LMFL#!C(:PADDED T :HOST "SYS" :BACKUP-DATE 2773684070. :SYSTEM-TYPE :LOGICAL :VERSION 125. :TYPE "LISP" :NAME "METHODS" :DIRECTORY ("REL3-2" "VISIDOC") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-2\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2771957198. :AUTHOR "REL3-2" :LENGTH-IN-BYTES 15984. :LENGTH-IN-BLOCKS 16. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           ;;; -*- Mode:Common-Lisp; Package:ZWEI; Fonts:(CPTFONT CPTFONTB CPTFONTI); Base:10 -*-;;;The data, information, methods, and concepts contained herein are;;;a valuable trade secret of Texas Instruments.   They are licensed;;;in  confidence  by  Texas  Instruments  and  may  only be used as;;;permitted  under the terms of the  definitive  license  agreement;;;under which such use is licensed.;;;;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;;;;; Copyright (C) 1987, Texas Instruments Incorporated. All rights reserved.;;; CHANGE HISTORY started on 10/22/87;;; 10/31/87   slm  Add loops within :LINK-AND-EXPOSE to get to the last physical diagram;;;                 line of the preceding node when obtaining the surrounding lines to use.;;;                 This is part of the fix to keep from "losing" the chapter's number diagram;;;                 during expansion/contraction of superior references.;;; 10/31/87   slm  Change case of VISIDOC to Visidoc in the message that gets printed in the;;;                 minibuffer during a REVERT.;================================================================================;  ZWEI:ZMACS-FRAME METHODS(DEFMETHOD (zmacs-frame :suggestions-on-message) ()  (WHEN (AND tv:exposed-p     (MEMBER 'zwei:doc-viewer-command-menu tv:inferiors     :test #'(lambda (x y) (TYPEP y x))))    (DOLIST (wind tv:inferiors)      (SEND editor-closure #'EVAL    `(SEND ,wind :send-if-handles :suggestions-on-message self)))    (SEND (SEND editor-closure #'EVAL '*window*) :select)))(DEFMETHOD (zmacs-frame :suggestions-off-message) ()  (WHEN (AND tv:exposed-p     (MEMBER 'zwei:doc-viewer-command-menu tv:inferiors     :test #'(lambda (x y) (TYPEP y x))))    (DOLIST (wind tv:inferiors)      (SEND editor-closure #'EVAL    `(SEND ,wind :send-if-handles :suggestions-off-message self)))    (SEND (SEND editor-closure #'EVAL '*window*) :select)));================================================================================;  ZWEI:ZMACS-WINDOW-PANE METHODS(DEFMETHOD (zmacs-window-pane :suggestions-on-message) (&rest ignore)  (WHEN tv:exposed-p    (SEND (window-interval self) :send-if-handles :suggestions-on-message self)))(DEFMETHOD (zmacs-window-pane :suggestions-off-message) (&rest ignore)  (WHEN tv:exposed-p    (SEND (window-interval self) :send-if-handles :suggestions-off-message self)));================================================================================;  BUFFER METHODS(defmethod (zwei-doc-viewer-buffer :after :init) (&rest ignore)  (setf pathname nil)  (setf saved-major-mode 'doc-viewer-mode)  (setf read-only-p t)  (setf plist nil)  (setf undo-status :dont)  (setf (node-inferiors self) nil))(defmethod (zwei-doc-viewer-buffer :exit-special-buffer)   (&optional mark-clean buffer-being-exited)  (declare (special *zmacs-doc-viewer-list*))  (let ((special-buffer (or buffer-being-exited *interval*)))    (and mark-clean (not-modified special-buffer))    (if (eq special-buffer *interval*)(send   (or (car (member special-buffer (history-list (send *window* :buffer-history))   :test #'neq))      *interval*) :select))    (without-interrupts      (setq *zmacs-doc-viewer-list*     (append (remove special-buffer *zmacs-doc-viewer-list* :test #'eq)    (list special-buffer))))    (point-pdl-purge special-buffer))  dis-text)(DEFMETHOD (zwei-doc-viewer-buffer :suggestions-off-message) (window)  (SEND self :remprop :leave-menus-up)  (configure-window-pane-with-menus window)  nil)(DEFMETHOD (zwei-doc-viewer-buffer :suggestions-on-message) (window)  (send self :putprop :leave-menus-up t)  (configure-window-pane-WITHOUT-menus window)  nil)(defmethod (zwei-doc-viewer-buffer :after :select) (&rest ignore)  "Make SELF the current ZMACS buffer in the selected window.PRESERVE-BUFFER-HISTORY non-NIL says do not reorder the buffers for C-M-L, etc."  ;;Don't do anything to the windows if Suggestions are on!!!  (UNLESS (sugg:suggestions-on-for-this-window?    (type-of (sugg:climb-to-recognized-window w:selected-window)))    ;; Make the window pane be the constraint frame    (SEND self :remprop :Leave-Menus-Up)      (Configure-Window-Pane-with-Menus *window*))  (SEND *INTERVAL* :SET-ATTRIBUTE :TAB-WIDTH 8 nil)  (SEND self :putprop (SEND *window* :tab-nchars) :old-tab-nchars)  (REDEFINE-WINDOW-TAB-NCHARS *WINDOW* 8)  nil)(DEFMETHOD (zwei-doc-viewer-buffer :after :deselect) (&rest ignore &aux n)  (WHEN (SETQ n (SEND self :get-attribute :old-tab-nchars))    (redefine-window-tab-nchars *window* n))  (UNLESS (SEND self :get-attribute :Leave-Menus-Up)    (Configure-Window-Pane-WITHOUT-Menus *window*)))(defmethod (zwei-doc-viewer-buffer :before :kill) (&rest ignore)  (point-pdl-purge self)  (without-interrupts    (let ((element (rassoc self *zmacs-doc-viewer-buffer-name-alist* :test #'equal)))      (and element   (setq *zmacs-doc-viewer-buffer-name-alist* ;; Make a new list so old buffers get gc'd. (COPY-LIST (delete element  *zmacs-doc-viewer-buffer-name-alist* :test #'equal)))))    (setq *zmacs-doc-viewer-list* (remove self *zmacs-doc-viewer-list* :test #'equal)))  (FORMAT *query-io* "~&Killing Visidoc buffer for ~a manual" namespace-name)  (dolist (node inferiors)    (FORMAT *query-io* "..")    (send node :remove-from-namespace-and-unlink-all self))  (setf inferiors nil)  t)(defmethod (zwei-doc-viewer-buffer :activate) (&optional ask-for-new-name)  (without-interrupts    ;; First, if buffer is not already on name alist, put it on,    ;; getting a new name if necessary and appropriate.    (unless (rassoc self *zmacs-doc-viewer-buffer-name-alist* :test #'eq)      (do () ((not (assoc name *zmacs-doc-viewer-buffer-name-alist* :test #'equalp)))(if ask-for-new-name    (let ((inhibit-scheduling-flag nil))      (if (and pathname       (not (buffer-pathname      (cdr (assoc name *zmacs-doc-viewer-buffer-name-alist*  :test #'equalp)))))  ;; This is visiting a file and the other is not.  (send (cdr (assoc name *zmacs-doc-viewer-buffer-name-alist* :test #'equalp)):rename(do ((name1 (typein-line-readline      "There is a non-file buffer ~A.  Rename it to: "      name)    (typein-line-readline      "~A is in use too.  Try again." name1)))    (())  (unless    (assoc name1 *zmacs-doc-viewer-buffer-name-alist* :test #'equalp)    (return name1))))  (setq name(typein-line-readline  "There is already a buffer named ~A.  Specify another name:"  name))))    (barf "There is already a buffer named ~A." name)))      (push (cons name self) *zmacs-doc-viewer-buffer-name-alist*)      (setq *zmacs-doc-viewer-buffer-name-alist*    (copy-alist *zmacs-doc-viewer-buffer-name-alist*))      (dolist (elt *zmacs-doc-viewer-buffer-name-alist*)(setf (car elt) (si:copy-object (car elt)))))    ;; Put the buffer on the other lists, if not already there.    (unless (member self *zmacs-doc-viewer-list* :test #'eq)      (setq *zmacs-doc-viewer-list* (append *zmacs-doc-viewer-list* (list self))))))(defmethod (zwei-doc-viewer-buffer :revert) (&rest ignore)   "Re-calculate doc-viewer information and format Doc-viewer buffer."  (setf read-only-p t)  (FORMAT *query-io* "~&Reverting buffer for ~a manual" namespace-name)  (DOLIST (node inferiors)    (FORMAT *query-io* "..")    (SEND node :revert namespace-name))  (WHEN (EQ (window-interval *window*) self)    (move-bp (point) first-bp)    (SETF (window-redisplay-degree *window*) DIS-TEXT)    (SEND *window* :redisplay :START (point) nil nil)))(DEFMETHOD (zwei-doc-viewer-buffer :window) ()  (DOLIST (window (SEND self ':windows) nil)    (AND (EQ (window-interval window) self) (RETURN window))))(DEFMETHOD (zwei-doc-viewer-buffer :find-last-exposed-inferior) ()  (WHEN inferiors    (SEND (CAR (LAST inferiors)) :find-last-exposed-inferior)))(DEFMETHOD (zwei-doc-viewer-buffer :find-first-exposed-inferior) ()  (WHEN inferiors    (SEND (CAR inferiors) :find-first-exposed-inferior)))(defmethod (zwei-doc-viewer-buffer :change-superiors-first-bp) (bp &optional (inf nil given?))  (and given? (OR (eq (CAR inferiors) inf) (EQ inf (SEND self :find-first-exposed-inferior)))    (move-bp first-bp bp)))(defmethod (zwei-doc-viewer-buffer :change-superiors-last-bp)  (&rest ignore) ;;(bp &optional (inf nil given?))  nil)(defmethod (zwei-doc-viewer-buffer :step-up-to-superior) (&rest ignore)  nil)(defmethod (zwei-doc-viewer-buffer :set-superiors-first-bp-type) (&rest ignore)  ())(defmethod (zwei-doc-viewer-buffer :set-superiors-last-bp-type) (&rest ignore)  ())(defmethod (zwei-doc-viewer-buffer :climb-to-buffer) ()  self)(DEFMETHOD (zwei-doc-viewer-buffer :climb-to-superior) (&rest ignore)  nil)(DEFMETHOD (zwei-doc-viewer-buffer :climb-up-node-hierarchy) (&rest ignore)  nil);================================================================================;  REFERENCE-NODE METHODS(defmethod (reference-node :change-superiors-first-bp) (bp &optional (inf nil given?))  (when (or (not given?)    (EQ (CAR inferiors) inf)    (eq (SEND self :find-first-exposed-inferior) inf))    (move-bp first-bp bp)    (send superior :change-superiors-first-bp bp (OR inf self))))(defmethod (reference-node :change-superiors-last-bp) (bp &optional (inf nil given?))  (when (or (not given?)    (EQ (CAR (LAST inferiors)) inf)    (eq (SEND self :find-last-exposed-inferior) inf))    (move-bp last-bp bp)    (send superior :change-superiors-last-bp bp (OR inf self))))(defmethod (reference-node :mark-inferiors-as-deexposed) ()  (dolist (node inferiors)    (send node :mark-as-deexposed)))(defmethod (reference-node :mark-as-deexposed) ()  (when inferiors    (dolist (node inferiors)      (SEND node :mark-as-deexposed)))  (setf exposed-p nil))(defmethod (reference-node :link-and-expose) ()  ;;Move this reference-node from its unexposed neighbors and hook it up  ;;to it's exposeded/visible neighbors.  ;;Notice that we want to leave the unexposed neighbors' lines pointing to   ;;the lines of this newly exposed node.  (COND ((memeq (ht-node-type self) '(:contents :header)) (let* ((fline (find-real-line self))(exposed-prev (send self :exposed-previous-leaf-node))(lline-exp-prev (when exposed-prev (find-real-line exposed-prev t)))(lline (find-real-line self t))(exposed-nxt (send self :exposed-next-leaf-node))(fline-exp-nxt (if exposed-nxt (find-real-line exposed-nxt)   (bp-line (interval-last-bp *interval*)))))   (setf exposed-p t)   (without-interrupts     ;;relink lines of unexposed previous and exposed-prev nodes if necessary     (when lline-exp-prev       (setf (line-next lline-exp-prev) fline))     (setf (line-previous fline) lline-exp-prev)     ;;relink lines of unexposed next and exposed-nxt nodes if necessary     (when fline-exp-nxt       (setf (line-previous fline-exp-nxt) lline))     (setf (line-next lline) fline-exp-nxt))) (update-surrounding-bps self))((and inferiors (node-expandedp self)) (dolist (inf inferiors)   (UNLESS (EQ :header (ht-node-type inf))     (send inf :link-and-expose))) (SETF exposed-p t))(inferiors (DOLIST (inf inferiors)   (WHEN (EQ :header (ht-node-type inf))     (SEND inf :link-and-expose)     (RETURN))) (SETF exposed-p t))))(DEFMETHOD (reference-node :revert) (manual)  (IF (EQ type :unbound)      (DOLIST (node inferiors)(SEND node :revert manual))       (contract-reference self))) ;;)cc(defmethod (reference-node :remove-from-namespace) ()  (remove-node-from-namespace self))(DEFMETHOD (reference-node :remove-from-namespace-and-unlink-all) (buffer)  (DOLIST (node inferiors)    (SEND node :remove-from-namespace-and-unlink-all buffer))    (remove-node-from-namespace self)    (remove-node-from-history self)  )(defmethod (reference-node :remove-all-from-namespace) (buffer)  (dolist (node inferiors)    (send node :remove-all-from-namespace buffer))   (remove-node-from-namespace self)  (remove-node-from-history self)  (with-read-only-suppressed (buffer)    (delete-interval self)))(defmethod (reference-node :climb-to-buffer) ()  (send superior :climb-to-buffer))(DEFMETHOD (reference-node :climb-to-superior) (sup)  (IF (EQ superior sup)      self      (SEND superior :climb-to-superior sup)))(DEFMETHOD (reference-node :find-last-exposed-inferior) ()      (IF inferiors(SEND (CAR (LAST inferiors)) :find-last-exposed-inferior)        (OR (AND exposed-p self)    (SEND self :exposed-previous-leaf-node))))(DEFMETHOD (reference-node :find-first-exposed-inferior) ()      (IF inferiors(SEND (CAR inferiors) :find-first-exposed-inferior)        (OR (AND exposed-p self)    (SEND self :exposed-next-leaf-node))))(defmethod (reference-node :after :init) (&rest ignore)  (setf expanded-p nilexposed-p nilstart :unboundend :unboundref-type :unboundnth :unboundmax-nth 0)  (unless superior (setf superior *interval*)));================================================================================;  HT-NODE METHODS(DEFMETHOD (ht-node :print-self) (stream depth slashify)  depth  (IF slashify (FORMAT stream "#<~A ~S ~O>" (SEND self :type) name (sys:%POINTER self))      (PRINC name stream)))(DEFVAR s-delim1 (make-fat-string "<S|" 3))(DEFVAR s-delim2 (make-fat-string "|S>" 3))(DEFVAR h-delim1 (make-fat-string "<H|" 3))(DEFVAR h-delim2 (make-fat-string "|H>" 3))(DEFVAR h-remain 'YES)(DEFVAR d-remain 'YES)(DEFMETHOD (ht-node :exposed-previous-node) ()  (LOOP for node first self then (node-previous node)until (NULL node)when (ht-node-exposed-p node)return nodefinally (RETURN nil)))(DEFMETHOD (ht-node :exposed-next-node) ()  (LOOP for node first self then (node-next node)until (NULL node)when (ht-node-exposed-p node)return nodefinally (RETURN nil)))(DEFMETHOD (ht-node :exposed-previous-leaf-node) ()  (DO ((prev-node (SEND self :previous-leaf-node) (SEND prev-node :previous-leaf-node)))      ((OR (NULL prev-node)   (ht-node-exposed-p prev-node))       prev-node)))(DEFMETHOD (ht-node :exposed-next-leaf-node) ()  (DO ((next-node (SEND self :next-leaf-node) (SEND next-node :next-leaf-node)))      ((OR (NULL next-node)   (ht-node-exposed-p next-node))       next-node)))(DEFMETHOD (ht-node :previous-leaf-node) (&aux top-node)  (SETQ top-node (SEND self :climb-up-node-hierarchy t))  (IF top-node      (SEND top-node :step-down-node-hierarchy t)      nil))(DEFMETHOD (ht-node :next-leaf-node) (&aux top-node)  (SETQ top-node (SEND self :climb-up-node-hierarchy nil))  (IF top-node      (SEND top-node :step-down-node-hierarchy nil)      nil))(DEFMETHOD (ht-node :climb-up-node-hierarchy)  (prev &aux siblings pos bound switch)  (SETQ siblings (node-inferiors superior))  (COND (prev (SETQ bound 0       switch #'1-))(t (SETQ bound (1- (LENGTH siblings))       switch #'1+)))  (COND ((= bound (SETQ pos (OR (POSITION self siblings) bound))) (SEND superior :climb-up-node-hierarchy prev))(t (NTH (FUNCALL switch pos) siblings))))(DEFMETHOD (ht-node :step-down-node-hierarchy)  (prev &aux index)  (COND (inferiors  (SETQ index (IF prev (1- (LENGTH inferiors)) 0)) (SEND (NTH index inferiors) :step-down-node-hierarchy prev))(t self)));================================================================================(compile-flavor-methods zwei-doc-viewer-buffer ht-node doc-viewer-interval reference-node)