;;; -*- Mode:LISP; Package:Zwei; Fonts:(CPTFONT); Base:10 -*- ;;; Copyright (C) Lisp Machine, Inc. 1984, 1985, 1986 ;;; See filename "Copyright" for ;;; licensing and release information. ;;; Everything having to do with Gateway's interface to Zmacs. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; DEFINITION OF GATE-MODE ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; COM-GATE-MODE ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Establishes GATE mode as a major mode. Invoked by the "META-X GATE MODE" command. (defmajor COM-GATE-MODE gate-mode "GATE" "LMI Information Management System" () (set-comtab *mode-comtab* *gateway-comtab* *gateway-extended-comtab*)) ;;; Binds the Gateway section-p and get-section-name to GATE mode. (defprop GATE-MODE :gate editing-type) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; GATE-MODE SECTION-P ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Examines each line in a buffer being sectionized in GATE mode. Returns T for ;;; a line that is the beginning of a section. In GATE mode, a section is a Gateway ;;; attribute and its value. (defun (:GATE SECTION-P) (line) (cond ((attrib-start line) t) ((string-not-equal (substring line 0 (min (length line) 1)) "=") nil) ((node-start line) (setq *peeked-section-p-node-title* (node-name line)) t) ((or (text-start line) (script-start line) (index-start line) (see-also-start line) (function-start line)) t) (t nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; GATE-MODE GET-SECTION-NAME ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Assigns a name to each section whose first line has been flagged by (:GATE SECTION-P) ;;; as being the start of a section. It is called by Zmacs at the END of the section ;;; being named, which occurs when SECTION-P detects the start of the next section, or ;;; the last line has been processed. Thus SECTION-P and GET-SECTION-NAME are always ;;; out of sync by one section. This property is used to name any Attribute Section ;;; (a section that contains a per-node attribute line). The name of such a section ;;; is dependant on data in the =NODE: line that starts the next section. When ;;; GET-SECTION-NAME gets an attribute line, SECTION-P has already seen the next ;;; =NODE: line, and has put the name in the line into *PEEKED-SECTION-P-NODE-TITLE*, ;;; from which GET-SECTION-NAME can read it even though it lies in the "future" ;;; from GET-SECTION-NAME's viewpoint. (defun (:GATE GET-SECTION-NAME) (line ignore) (cond ((text-start line) (string-append *section-title* ".tex")) ((script-start line) (string-append *section-title* ".scr")) ((node-start line) (setq *section-title* (node-name line)) (string-append *section-title* ".hdr")) ((attrib-start line) (string-append *peeked-section-p-node-title* ".att")) ((index-start line) (string-append *section-title* ".ind")) ((see-also-start line) (string-append *section-title* ".see")) ((function-start line) (string-append *section-title* ".fun")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; PREDICATES FOR SECTION-P AND GET-SECTION-NAME ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Detect a line that is an Attribute line. (defun ATTRIB-START (line &aux mark1 mark2) (and (setq mark1 (string-search "-*-" line)) (setq mark2 (string-search "-*-" line (plus mark1 4))) (line-previous line))) ;;; Detect a line that begins a node. (defun NODE-START (line) (or (string-equal (substring line 0 (min (length line) 6)) "=Node:") (string-equal (substring line 0 (min (length line) 7)) "= Node:"))) ;;; Extract the title from a line that begins a node. (defun NODE-NAME (line) (cond ((string-equal (substring line 0 (min (length line) 6)) "=Node:") (btrim (substring line 6))) ((string-equal (substring line 0 (min (length line) 7)) "= Node:") (btrim (substring line 7))))) ;;; Detect a line that begins a text section. (defun TEXT-START (line) (or (string-equal (substring line 0 (min (length line) 6)) "=Text:") (string-equal (substring line 0 (min (length line) 7)) "= Text:"))) ;;; Detect a line that begins a script section. (defun SCRIPT-START (line) (or (string-equal (substring line 0 (min (length line) 8)) "=Script:") (string-equal (substring line 0 (min (length line) 9)) "= Script:"))) ;;; Detect a line that begins an index section. (defun INDEX-START (line) (or (string-equal (substring line 0 (min (length line) 7)) "=Index:") (string-equal (substring line 0 (min (length line) 8)) "= Index:"))) ;;; Detect a line that begins a related-information section. (defun SEE-ALSO-START (line) (or (string-equal (substring line 0 (min (length line) 10)) "=See-also:") (string-equal (substring line 0 (min (length line) 11)) "= See-also:") (string-equal (substring line 0 (min (length line) 9)) "=Seealso:") (string-equal (substring line 0 (min (length line) 10)) "= Seealso:"))) ;;; Detect a line that begins a function section. (defun FUNCTION-START (line) (cond ((string-equal (substring line 0 (min (length line) 10)) "=Function:") (values t (btrim (substring line 10)))) ((string-equal (substring line 0 (min (length line) 11)) "= Function:") (values t (btrim (substring line 11)))) (t (values nil nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; FILE-ACCESS ROUTINES ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; GATEWAY-FIND-FILE-BUFFER ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; An interface to ZWEI:FIND-FILE-BUFFER that returns immediately if the buffer ;;; requested is the same as it was on the last call. This allows various parts ;;; of Gateway to do find-file-buffer operations as needed without performance ;;; loss caused by redundant calls to find-file-buffer itself, which is fairly ;;; slow, especially over the network. (defun GATEWAY-FIND-FILE-BUFFER (pathname) (when (or (null *gateway-find-file-buffer-buffer*) (neq pathname *gateway-find-file-buffer-pathname*)) (setq *gateway-find-file-buffer-buffer* (find-file-buffer pathname)) (setq *gateway-find-file-buffer-pathname* pathname)) *gateway-find-file-buffer-buffer*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; FIND-A-FILE-THAT-DOES-EXIST ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Locate a file/buffer that is supposed to exist, but do not make it the ;;; current Gateway buffer. Return the file/buffer, or nil if it does not exist. (defun FIND-A-FILE-THAT-DOES-EXIST (pathname) (setq pathname (make-absolute-pathname pathname)) (when (or (gateway-find-file-buffer pathname) (fs:probe-file pathname)) (find-file pathname nil nil t nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; MAKE-CURRENT-A-FILE-THAT-DOES-EXIST ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Locate a file/buffer that is supposed to exist, and make it the current ;;; Gateway buffer. Return nil if the file/buffer does not exist. (defun MAKE-CURRENT-A-FILE-THAT-DOES-EXIST (pathname) (setq pathname (make-absolute-pathname pathname)) (when (or (gateway-find-file-buffer pathname) (fs:probe-file pathname)) (normalize-gateway-buffer *current-gateway-buffer*) (setq *current-gateway-buffer* (find-file pathname t nil t nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; MAKE-CURRENT-A-FILE-THAT-DOES-NOT-EXIST ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Create and make current a new file/buffer. Initialize its attribute line. ;;; Return nil if the file/buffer already exists. (defun MAKE-CURRENT-A-FILE-THAT-DOES-NOT-EXIST (pathname) (setq pathname (make-absolute-pathname pathname)) (unless (or (gateway-find-file-buffer pathname) (fs:probe-file pathname)) (normalize-gateway-buffer *current-gateway-buffer*) (setq *current-gateway-buffer* (find-file pathname t nil t nil)) (move-bp (point) (insert (point) (format nil ";;; -*- Mode:gate; Fonts:(CPTFONT); Base:10 -*-~2%"))) (reparse-buffer-attribute-list-or-mode-line *interval*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; MAKE-CURRENT-A-FILE-THAT-MIGHT-EXIST ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Takes a pathname argument. If the file/buffer designated by the argument ;;; exists, make it the current Gateway buffer. If not, create it, initialize ;;; its attribute line, and make it the current Gateway buffer. (defun MAKE-CURRENT-A-FILE-THAT-MIGHT-EXIST (pathname &aux new-file) (setq pathname (make-absolute-pathname pathname)) (setq new-file (not (or (gateway-find-file-buffer pathname) (fs:probe-file pathname)))) (normalize-gateway-buffer *current-gateway-buffer*) (setq *current-gateway-buffer* (find-file pathname t nil t nil)) (when new-file (move-bp (point) (insert (point) (format nil ";;; -*- Mode:gate; Fonts:(CPTFONT); Base:10 -*-~2%"))) (reparse-buffer-attribute-list-or-mode-line *interval*)) new-file) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; DATA DISPLAY ROUTINES ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; GATEWAY-DISPLAY-NODE ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Gateway's primary display handler and Zmacs interface. Called ;;; whenever a node must be displayed in either Display or Edit mode. ;;; If the node already on display is being edited, nil it in *NODE-HASH-TABLE*, ;;; nil its buffer in *RESECTIONIZE-P-HASH-TABLE*, then call GET-NODE on it to ;;; incorporate any changes into its state. This is an inefficient way to do ;;; things. It would be better to nil it and its buffer only if it has been ;;; changed, which could be done by keeping track of the ticks of its sections ;;; in global variables, and possibly by omitting the GET-NODE call, since there ;;; will be one made before it is redisplayed in any case. The latter would need ;;; some research before it could be done; there may be things that will blow up ;;; if editing changes have been made that are not immediately known everywhere. (defun GATEWAY-DISPLAY-NODE (node script-frame &key backtrack &aux display-the-script-buffer) (when *node-now-being-edited* (puthash *node-now-being-edited* nil *node-hash-table*) (puthash (make-absolute-pathname (car *node-now-being-edited*)) t *resectionize-p-hash-table*) (get-node *node-now-being-edited* 'quiet 'continue)) ;;; Set up the global the above will need on the next call to DISPLAY-NODE. (if (edit-mode-p) (setq *node-now-being-edited* (gnode-nodename node)) (setq *node-now-being-edited* nil)) ;;; Undo the equating of the buffer's first-bp and last-bp with the beginning ;;; and end of the node now on display. (when *current-gateway-buffer* (normalize-gateway-buffer *current-gateway-buffer*)) ;;; Set buffer currency to reflect the node to be displayed. (setq *current-gateway-buffer* (send (car (gnode-sections node)) :superior)) (make-buffer-current *current-gateway-buffer*) ;;; Select and call the appropriate display routine. (setq display-the-script-buffer nil) (cond ((and (display-mode-p) (gnode-script node)) (setq display-the-script-buffer t) (display-script-node-for-viewing node)) ((display-mode-p) (display-data-node-for-viewing node)) (t (display-node-for-editing node))) ;;; Set up various things to reflect the newly displayed node. (setf (point) nil) (setf (mark) nil) (setq *current-node-title* (third (gnode-nodename node))) (setq *current-script-frame* script-frame) (if display-the-script-buffer (send *window* :set-interval-internal *script-display-buffer*) (send *window* :set-interval-internal *current-gateway-buffer*)) ;;; Tell Zmacs it must (re)display the current interval. (must-redisplay *window* dis-all) ;;; Update the various history lists and environment display panes, ;;; and highlight the current script. (update-history-lists script-frame) (unless backtrack (update-backtrack-list script-frame)) (unless (guide-p) (redisplay-full-history-pane) (redisplay-current-script-pane)) (highlight-current-script) t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; FORMAT-NODE-FOR-PRINTING ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Take a node and format it into a buffer so that it can be printed. Most of ;;; this routine exists because the Zmacs print utility insists on parsing a ;;; buffer's attribute line directly, which is wrong: it should leave that to ;;; the routines whose job it is, and look at the buffer attributes themselves, ;;; the way the rest of Zmacs does. The problem is that a node with its own ;;; attribute line must be printed in the context of that line, and that a ;;; node without one must be printed in the context of the source buffer ;;; attribute line. Since we can't play games with the buffer attributes ;;; (as in DISPLAY-DATA-NODE-FOR-VIEWING) to make this happen we have to do ;;; things the hard way. (defun FORMAT-NODE-FOR-PRINTING (node-to-print &aux print-buffer-last-bp node-defun-line node-defun-line-bp node-has-attribute-line node-last-bp name-string name-suffix attribute-section display-section display-section-first-bp) ;;; Initialize the print buffer various data we will need. (delete-interval *print-node-buffer*) (setq print-buffer-last-bp (send *print-node-buffer* :last-bp)) (setq node-to-print (gnode-sections node-to-print)) (setq node-defun-line (send (car node-to-print) :defun-line)) (setq node-defun-line-bp (create-bp node-defun-line 0 :NORMAL)) (setq node-has-attribute-line (attrib-start node-defun-line)) (setq node-last-bp (copy-bp (send (car (last node-to-print)) :last-bp) :MOVES)) ;;; If there is a per-node attribute line and we're in edit mode, just print everything. (if (and node-has-attribute-line (edit-mode-p)) (insert-interval-moving print-buffer-last-bp node-defun-line-bp node-last-bp) ;;; Otherwise we'll need the attribute line and printable text separately. ;;; Get the attribute ;;; line if it's in the node, and the text. (dolist (sect node-to-print) (setq name-string (send sect :name)) (setq name-suffix (substring name-string (- (length name-string) 4))) (when (string-equal name-suffix ".att") (setq attribute-section sect)) (when (or (string-equal name-suffix ".tex") (string-equal name-suffix ".scr")) (setq display-section sect))) ;;; Set the bp we'll use to read the printable text into the print buffer. (setq display-section-first-bp (create-bp (line-next (send display-section :defun-line)) 0 :NORMAL)) ;;; If there is a per-node attribute line and we're in display mode, copy it to the ;;; print buffer, followed by the printable text. (if (and node-has-attribute-line (display-mode-p)) (progn (insert-interval-moving print-buffer-last-bp attribute-section) (insert-interval-moving print-buffer-last-bp display-section-first-bp (send display-section :last-bp))) ;;; Otherwise there is no per-node attribute line. Get the attribute line from ;;; the top of the source buffer, and copy it to the print buffer (insert-interval-moving print-buffer-last-bp (car (send (send (car node-to-print) :superior) :inferiors))) ;;; If we're in edit mode, copy edit-mode type text (the whole node) ;;; to the print buffer. (if (edit-mode-p) (insert-interval-moving print-buffer-last-bp node-defun-line-bp node-last-bp) ;;; We're in display mode. Copy display-mode type text (just the printable stuff) ;;; to the print buffer. (insert-interval-moving print-buffer-last-bp display-section-first-bp (send display-section :last-bp))))) ;;; Set print buffer attributes (for the parts of Zmacs that do things right.) (reparse-buffer-attribute-list-or-mode-line *print-node-buffer*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; DISPLAY-DATA-NODE-FOR-VIEWING ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Display a data node in display mode (defun DISPLAY-DATA-NODE-FOR-VIEWING (node &aux node-to-display node-defun-line node-defun-line-bp node-has-attribute-line name-string name-suffix section-to-display section-to-display-first-bp section-to-display-last-bp node-last-bp) (make-buffer-not-read-only *current-gateway-buffer*) ;;; Set up various data we will need. (setq node-to-display (gnode-sections node)) (setq node-defun-line (send (car node-to-display) :defun-line)) (setq node-defun-line-bp (create-bp node-defun-line 0 :NORMAL)) (setq node-has-attribute-line (attrib-start node-defun-line)) (setq node-last-bp (copy-bp (send (car (last node-to-display)) :last-bp) :MOVES)) ;;; Retrieve the displayable part of the node, and set bp's to its ;;; beginning and end. (setq section-to-display (dolist (sect node-to-display) (setq name-string (send sect :name)) (setq name-suffix (substring name-string (- (length name-string) 4))) (when (or (string-equal name-suffix ".tex") (string-equal name-suffix ".scr")) (return sect)))) (setq section-to-display-first-bp (create-bp (line-next (send section-to-display :defun-line)) 0 :NORMAL)) (setq section-to-display-last-bp (send section-to-display :last-bp)) ;;; If the node has an attribute line, parse the attributes into the buffer. ;;; If not, restore the global attributes if they are not already in effect. (cond (node-has-attribute-line (move-bp (send *current-gateway-buffer* :first-bp) node-defun-line-bp) (move-bp (send *current-gateway-buffer* :last-bp) node-last-bp) (reparse-buffer-attribute-list-or-mode-line *interval*) (setq *global-attribute-line-parsed* nil)) ((not *global-attribute-line-parsed*) (move-bp (send *current-gateway-buffer* :first-bp) (send (car (send *current-gateway-buffer* :inferiors)) :first-bp)) (move-bp (send *current-gateway-buffer* :last-bp) (send (car (last (send *current-gateway-buffer* :inferiors))) :last-bp)) (reparse-buffer-attribute-list-or-mode-line *interval*) (setq *global-attribute-line-parsed* t))) ;;; Set the buffer so that it effectively contains only the displayable section. (move-bp (send *current-gateway-buffer* :first-bp) section-to-display-first-bp) (move-bp (send *current-gateway-buffer* :saved-point) section-to-display-first-bp) (move-bp (send *current-gateway-buffer* :saved-mark) section-to-display-first-bp) (move-bp (send *current-gateway-buffer* :saved-window-start-bp)section-to-display-first-bp) (move-bp (send *current-gateway-buffer* :last-bp) section-to-display-last-bp) (make-buffer-read-only *current-gateway-buffer*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; DISPLAY-SCRIPT-NODE-FOR-VIEWING ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Display a script node in display mode. The node is displayed in the script ;;; display buffer. (defun DISPLAY-SCRIPT-NODE-FOR-VIEWING (node &aux node-to-display node-defun-line node-has-attribute-line name-string name-suffix section-to-display script-line done-line display-bp section-to-display-first-bp) (delete-interval *script-display-buffer*) ;;; Set up various data we will need. (setq node-to-display (gnode-sections node)) (setq node-defun-line (send (car node-to-display) :defun-line)) (setq node-has-attribute-line (attrib-start node-defun-line)) ;;; Retrieve the displayable part of the node, and set bp's to its ;;; beginning and end. (setq section-to-display (dolist (sect node-to-display) (setq name-string (send sect :name)) (setq name-suffix (substring name-string (- (length name-string) 4))) (when (string-equal name-suffix ".scr") (return sect)))) (setq script-line (bp-line (send section-to-display :first-bp))) (setq done-line (bp-line (send section-to-display :last-bp))) (setq display-bp (send *script-display-buffer* :last-bp)) ;;; Give the script display buffer an attribute line, either from the source node ;;; (if it has one) or the source buffer. (insert-moving display-bp (format nil "~A~%" (if node-has-attribute-line node-defun-line (bp-line (send (send (car node-to-display) :superior) :first-bp))))) ;;; Now format the script entries into the display buffer. (tagbody loop (cond ((script-start script-line) (insert-moving display-bp (format nil "~A~%" script-line))) ((string-equal (substring script-line 0 (min (length script-line) 1)) "@") (insert-moving display-bp (format nil "~A~%" (nth-value 1 (parse-script-reference script-line))))) (t (insert-moving display-bp (format nil "~%")))) (unless (eq script-line done-line) (setq script-line (line-next script-line)) (go loop))) ;;; Set up the script display buffer to know about its contents. (reparse-buffer-attribute-list-or-mode-line *script-display-buffer*) (send *script-display-buffer* :sectionize) (setq section-to-display-first-bp (create-bp (line-next (send (cadr (send *script-display-buffer* :inferiors)) :defun-line)) 0 :NORMAL)) (move-bp (send *script-display-buffer* :first-bp) section-to-display-first-bp) (move-bp (send *script-display-buffer* :saved-point) section-to-display-first-bp) (move-bp (send *script-display-buffer* :saved-mark) section-to-display-first-bp) (move-bp (send *script-display-buffer* :saved-window-start-bp)section-to-display-first-bp) ;;; Save the source script for use in resolving moused script choices to ;;; real script lines. (setq *script-source-section* section-to-display) ;;; Make the script display buffer the current Zmacs buffer, so it will ;;; be displayed on return to GATEWAY-DISPLAY-NODE. (make-buffer-current *script-display-buffer*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; DISPLAY-NODE-FOR-EDITING ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Display a data or script node in edit mode. (defun DISPLAY-NODE-FOR-EDITING (node &aux node-to-display node-defun-line node-defun-line-bp node-has-attribute-line node-last-bp) (make-buffer-not-read-only *current-gateway-buffer*) ;;; Set up various data we will need. (setq node-to-display (gnode-sections node)) (setq node-defun-line (send (car node-to-display) :defun-line)) (setq node-defun-line-bp (create-bp node-defun-line 0 :NORMAL)) (setq node-has-attribute-line (attrib-start node-defun-line)) (setq node-last-bp (copy-bp (send (car (last node-to-display)) :last-bp) :MOVES)) ;;; If the node has an attribute line, parse the attributes into the buffer. ;;; If not, restore the global attributes if they are not already in effect. (cond (node-has-attribute-line (move-bp (send *current-gateway-buffer* :first-bp) node-defun-line-bp) (move-bp (send *current-gateway-buffer* :last-bp) node-last-bp) (reparse-buffer-attribute-list-or-mode-line *interval*) (setq *global-attribute-line-parsed* nil)) ((not *global-attribute-line-parsed*) (move-bp (send *current-gateway-buffer* :first-bp) (send (car (send *current-gateway-buffer* :inferiors)) :first-bp)) (move-bp (send *current-gateway-buffer* :last-bp) (send (car (last (send *current-gateway-buffer* :inferiors))) :last-bp)) (reparse-buffer-attribute-list-or-mode-line *interval*) (setq *global-attribute-line-parsed* t))) ;;; Set the buffer so that it effectively contains only the displayable section. (move-bp (send *current-gateway-buffer* :first-bp) node-defun-line-bp) (move-bp (send *current-gateway-buffer* :saved-point) node-defun-line-bp) (move-bp (send *current-gateway-buffer* :saved-mark) node-defun-line-bp) (move-bp (send *current-gateway-buffer* :saved-window-start-bp) node-defun-line-bp) (move-bp (send *current-gateway-buffer* :last-bp) node-last-bp)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; ROUTINES TO MAKE UNDO/REDO WORK ON A PER-NODE BASIS ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The Zmacs facility for undoing and redoing editing changes works on a ;;; per-file/buffer or per-region basis. It was not designed to work on a ;;; subset of a file unless the subset is a region, and hence would not ;;; work per-node, as Gateway needs it to. When Gateway is active, the usual ;;; undo/redo routines are replaced by the following routines, which are the ;;; same as their namesakes except that they ignore changes that were made ;;; outside the current interval, which in Gateway means outside the current ;;; node. The replacement is done by shadowing the standard routines via entries ;;; in the *MODE-COMTAB* for GATE mode. Note however that when the current ;;; interval is a whole buffer, these routines behave identically to the ;;; originals. Hence they could safely replace the originals in a future ;;; system release. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ODM-QUICK-UNDO ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Undo the last undoable command in *interval*, no query. If there is a region, ;;; undo the last batch of changes that occurred within the current region. ;;; The region remains so that you can repeat the command on the same region. (defun ODM-QUICK-UNDO () (let ((undo-item (find-undo-item))) (if (or (not (bp-in-interval-p (undo-item-start-bp undo-item) *interval*)) (not (bp-in-interval-p (undo-item-end-bp undo-item) *interval*))) (barf "There is nothing to undo.") (odm-undo-undo-item undo-item (not (window-mark-p *window*))))) (must-redisplay *window* dis-text)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ODM-UNDO ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Undo the last undoable command done in *interval*. If there is a region, ;;; undo the last batch of changes that occurred within the current region. ;;; The region remains so that you can repeat the command on the same region. (defun ODM-UNDO () (let ((undo-item (find-undo-item))) (if (or (not (bp-in-interval-p (undo-item-start-bp undo-item) *interval*)) (not (bp-in-interval-p (undo-item-end-bp undo-item) *interval*))) (barf "There is nothing to undo.") (fresh-line *query-io*) (if (y-or-n-p "Undo ~A (~A)? " (string-downcase (undo-item-type undo-item)) (summarize-undo-item undo-item)) (odm-undo-undo-item undo-item (not (window-mark-p *window*)))))) (must-redisplay *window* dis-text)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ODM-UNDO-UNDO-ITEM ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Subroutine of ODM-UNDO. Undoes the undo item, moving point if desired, ;;; and notifying user. (defun ODM-UNDO-UNDO-ITEM (undo-item &optional move-point-and-mark &aux (undo-status (node-undo-status (node-top-level-node *interval*))) (name (undo-item-type undo-item))) (when move-point-and-mark (move-bp (point) (undo-item-start-bp undo-item)) (move-bp (mark) (undo-item-end-bp undo-item))) (unless (eq undo-status ':dont) (setf (undo-status-undo-list undo-status) (delq undo-item (undo-status-undo-list undo-status))) (push (undo-saved-change undo-item undo-status) (undo-status-redo-list undo-status)) (if (undo-status-undo-list undo-status) (format *query-io* "~&~A undone. Control-Shift-U to undo more, Control-Shift-R to undo the Undo." name) (format *query-io* "~&~A undone. Type Control-Shift-R to undo the Undo." name)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ODM-QUICK-REDO ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Redo the last command undone in *interval*, no query. (defun ODM-QUICK-REDO () (undo-save-current-range) (let ((undo-status (node-undo-status (node-top-level-node *interval*)))) (if (eq undo-status ':dont) (barf "There is nothing redoable.") (when (or (neq 'editing (car (undo-status-redo-list undo-status))) (redo-query undo-status)) (let* ((undo-item (car (undo-status-redo-list undo-status)))) (or undo-item (barf "There is nothing to redo.")) (if (or (not (bp-in-interval-p (undo-item-start-bp undo-item) *interval*)) (not (bp-in-interval-p (undo-item-end-bp undo-item) *interval*))) (barf "There is nothing to redo.") (undo-item-redo undo-status undo-item)))))) (must-redisplay *window* dis-text)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ODM-REDO ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Redo the last command undone in *interval* (defun ODM-REDO () (undo-save-current-range) (let* ((undo-status (node-undo-status (node-top-level-node *interval*)))) (if (eq undo-status ':dont) (barf "There is nothing redoable.") (when (or (neq 'editing (car (undo-status-redo-list undo-status))) (redo-query undo-status)) (let* ((undo-item (car (undo-status-redo-list undo-status))) (name (undo-item-type undo-item)) summary) (or undo-item (barf "There is nothing to redo.")) (if (or (not (bp-in-interval-p (undo-item-start-bp undo-item) *interval*)) (not (bp-in-interval-p (undo-item-end-bp undo-item) *interval*))) (barf "There is nothing to redo.") (fresh-line *query-io*) (setq summary (summarize-undo-item undo-item)) (if (y-or-n-p "Redo ~A (~A)? " (string-downcase name) summary) (undo-item-redo undo-status undo-item))))))) (must-redisplay *window* dis-text)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; MISCELLANEOUS ZMACS ROUTINES ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; NORMALIZE-GATEWAY-BUFFER ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Take a buffer that has been subsetted to effectively contain only a ;;; part of itself, and restore its bp's to reflect its complete contents. (defun NORMALIZE-GATEWAY-BUFFER (buffer) (when buffer (make-buffer-not-read-only buffer) (let ;;; Set up various data we will need ((buffer-first-bp (send buffer :first-bp)) (buffer-last-bp (send buffer :last-bp)) (buffer-inferiors (send buffer :inferiors)) (line)) ;;; If there are known inferiors, expand the buffer to include them. (when buffer-inferiors (let ((inferior-first-bp (send (car buffer-inferiors) :first-bp)) (inferior-last-bp (send (car (last buffer-inferiors)) :last-bp))) (move-bp buffer-first-bp inferior-first-bp) (move-bp (send buffer :saved-point) inferior-first-bp) (move-bp (send buffer :saved-mark) inferior-first-bp) (move-bp (send buffer :saved-window-start-bp) inferior-first-bp) (move-bp buffer-last-bp inferior-last-bp))) ;;; If for whatever reason there were lines before the first or after ;;; the last inferior (if any), expand the buffer to include them. (tagbody up-loop (when (setq line (line-previous (car buffer-first-bp))) (move-bp buffer-first-bp line 0) (go up-loop))) (tagbody down-loop (when (setq line (line-next (car buffer-last-bp))) (move-bp buffer-last-bp line 0) (go down-loop)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ADD-ENTRY-TO-DEFAULT-SCRIPT ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Add an entry to the default script, redisplaying it if necessary. Does ;;; nothing if the entry already exists. (defun ADD-ENTRY-TO-DEFAULT-SCRIPT (nodename &aux name-string) (get-node *default-script-nodename* 'complain 'throw) (unless (get-script-frame-for-node nodename *default-script-nodename*) (setq name-string (send (make-absolute-pathname (car nodename)) :name)) (with-read-only-suppressed (*default-script-buffer*) (insert-moving (send *default-script-buffer* :last-bp) (format nil "@ (~A)~A~%" name-string (cadr nodename)))) (puthash *default-script-nodename* nil *node-hash-table*) (get-node *default-script-nodename* 'complain 'throw) (when (eq *default-script-buffer* *current-gateway-buffer*) (must-redisplay *window* dis-all)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; REPARSE-BUFFER-ATTRIBUTE-LIST-OR-MODE-LINE ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Reparse an attribute line under Release-2 or Release-3 despite the ;;; inconsistancy in the name of the routine. Insure a return value of T ;;; no matter which routine is used. The Release-2 routine is ;;; REPARSE-BUFFER-MODE-LINE, which returns T. The Release-3 routine ;;; is REPARSE-BUFFER-ATTRIBUTE-LIST, which returns nil. ;;; This routine should be replaced once there is no possibility of Gateway having ;;; to run under Release-2. Calls to (REPARSE-BUFFER-ATTRIBUTE-LIST-OR-MODE-LINE) ;;; should then be replaced by calls to (NOT (REPARSE-BUFFER-ATTRIBUTE LIST)). (defun REPARSE-BUFFER-ATTRIBUTE-LIST-OR-MODE-LINE (interval) (if (fboundp 'reparse-buffer-attribute-list) (reparse-buffer-attribute-list interval) (reparse-buffer-mode-line interval)) t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; WRITE-FILE-INTERNAL-ODM ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (DEFUN WRITE-FILE-INTERNAL-ODM (PATHNAME &OPTIONAL (BUFFER *INTERVAL*) &aux node-first-bp node-last-bp) "SAVE BUFFER IN FILE PATHNAME AND MARK IT AS VISITING THAT FILE." (setq node-first-bp (copy-bp (send buffer :first-bp))) (setq node-last-bp (copy-bp (send buffer :last-bp))) (normalize-gateway-buffer buffer) (SEND BUFFER :WRITE-FILE-INTERNAL PATHNAME) (move-bp (send buffer :first-bp) node-first-bp) (move-bp (send buffer :last-bp) node-last-bp))