;;; -*- Mode:LISP; Package:ZWEI; Fonts:(CPTFONT); Base:10; Readtable:ZL -*- ;;; Copyright (C) Lisp Machine, Inc. 1984, 1985, 1986 ;;; See filename "Copyright" for ;;; licensing and release information. ;;; Routines used to get Gateway going from Zmacs or a Listener. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; ;;; ;;; ENTRY AND STARTUP ;;; ;;; ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The way Gateway is entered and started is rather roundabout, but the ;;; natures of Zmacs, the Window System, and the System Key handler necessitate ;;; that. The order of events is: ;;; 1. When Gateway is loaded, TV:ADD-SYSTEM-KEY establishes the system ;;; keys that will invoke Gateway/Guide/ODM, and ZWEI:SET-COMTAB ;;; establishes the Zmacs extended commands that will start ;;; Gateway running under the Zmacs process associated with the ;;; GATEWAY-CONSTRAINT-FRAME's DISPLAY-PANE-1. ;;; 2. The user enters Gateway via the system key, which invokes TV:KBD-SYS ;;; and hands it the invoking keystroke, or via a Lisp Listener command, ;;; which invokes TV:KBD-SYS-1 and hands it the same keystroke that TV:KBD-SYS ;;; gives it when entry is made via system key. ;;; 3. TV:KBD-SYS-1 retrieves the form associated with the keystroke in ;;; TV:*SYSTEM-KEYS* (which association was created by TV:ADD-SYSTEM-KEY) ;;; and evaluates the form. The value of a form given TV:KBD-SYS-1 in ;;; this way must be the name of an instantiable window or constraint ;;; frame. ;;; 4. There is a different form for each of the three entries to Gateway. ;;; Each one sets the global *CURRENT-GATEWAY-APPLICATION* to indicate ;;; which entry point was used, then names 'GATEWAY-CONSTRAINT-FRAME ;;; as its returned value. Wherever Gateway must adapt to the application ;;; it is running, it polls *CURRENT-GATEWAY-APPLICATION* to determine ;;; what to do. ;;; 5. KBD-SYS-1 does a MAKE-INSTANCE on GATEWAY-CONSTRAINT-FRAME. ;;; 6. GATEWAY-CONSTRAINT-FRAME has an (:AFTER :INIT) method, which fires ;;; as soon as the frame has been instantiated. ;;; 7. The (:AFTER :INIT) method calls a routine to initialize the ;;; GATEWAY-CONSTRAINT-FRAME and its associated globals (this is ;;; the standard purpose of such a routine on the Lisp Machine). It ;;; then tells the Zmacs process of DISPLAY-PANE-1 to execute the ;;; extended command COM-GATE. It does this by putting into the ;;; process's io-buffer the character string that will cause COM-GATE ;;; to be executed as a META-X command. (The association of that string ;;; with COM-GATE was established via ZWEI:SET-COMTAB, as mentioned ;;; in Step 1.) COM-GATE cannot be called directly, because doing so ;;; would not cause Gateway to run under the Zmacs process (see next step). ;;; 8. COM-GATE calls routines to initialize Gateway's globals and utility ;;; buffers, and read in and display the initial data and script nodes. ;;; Being a Zmacs command, COM-GATE then returns to the Zmacs command ;;; loop that called it, the loop running under the display-pane-1 ;;; process. This is the action that starts the Zmacs process handling ;;; Gateway commands, so that Gateway runs under it. Additional commands, ;;; Gateway or Zmacs, can now be executed; Gateway is up and running. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; SYSTEM-KEY ENTRIES TO GATEWAY ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;(tv:add-system-key #/G '(standard-entry-to-gateway) "LMI-GATEWAY" t) ;(tv:add-system-key #/= '(guide-entry-to-gateway) "LMI-GUIDE" t) ;(tv:add-system-key #/D '(odm-entry-to-gateway) "LMI-ODM" t) (tv:add-system-key #/O '(odm-entry-to-gateway) "LMI-ODM" t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ZMACS META-X COMMANDS USED BY GATEWAY ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This form sets up com-gate as mentioned above. It also sets up #/h-s-m-c-greek-g, ;;; which is in *zmacs-comtab* rather than *mode-comtab* so mousing on the Gateway Herald ;;; can get you back to a Gateway buffer from a buffer of some other type; and com-gate-mode, ;;; which is useful whenever you want to throw a buffer into Gate mode for some reason. (eval-when (load compile) (set-comtab *zmacs-comtab* '(#/h-s-m-c-greek-g com-execute-gateway-command) '(("enter gateway via system key" . com-gate) ("gate mode" . com-gate-mode)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; LISP-LISTENER ENTRIES TO GATEWAY ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun USER:GATEWAY () (tv:kbd-sys-1 #/G)) (defun USER:GUIDE () (tv:kbd-sys-1 #/=)) (defun USER:ODM () (tv:kbd-sys-1 #/D)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; FORMS USED BY KBD-SYS AND KBD-SYS-1 TO INVOKE GATEWAY ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The pure-Gateway entry to Gateway. ;(defun STANDARD-ENTRY-TO-GATEWAY () ; (setq *terminal-type* (get-terminal-type)) ; (setq *current-gateway-application* 'gateway) ; 'gateway-constraint-frame) ;;; The Guide entry to Gateway. ;(defun GUIDE-ENTRY-TO-GATEWAY () ; (setq *current-gateway-application* 'guide) ; (setq *terminal-type* (get-terminal-type)) ; (if (land-p) ; 'gateway-constraint-frame ; (tv:beep) ; nil)) ;;; The ODM Entry to Gateway. (defun ODM-ENTRY-TO-GATEWAY () (setq *terminal-type* (get-terminal-type)) (setq *current-gateway-application* 'odm) 'gateway-constraint-frame) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; (GATEWAY-CONSTRAINT-FRAME :AFTER :INIT) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Initializes a newly instantiated Gateway Constraint Frame. (defmethod (GATEWAY-CONSTRAINT-FRAME :AFTER :INIT) (&rest ignore) (funcall-self :set-selection-substitute (funcall-self :get-pane 'display-pane-1)) (setq *gateway-constraint-frame* self) (initialize-gateway-constraint-frame) (force-meta-x-gate-command)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; FORCE-META-X-GATE-COMMAND ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Execute COM-GATE within a Zmacs process. (defun FORCE-META-X-GATE-COMMAND () (funcall *display-pane-1* :force-kbd-input #/m-x) (loop with string = (format nil "~A~%" "enter gateway via system key") for index from 0 to (1- (string-length string)) do (funcall *display-pane-1* :force-kbd-input (char string index)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; FORCE-META-X-GATE-MODE-COMMAND ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This is the routine to put a buffer into gate mode. Its a bit of an orphan ;;; wherever it goes, but the PRECEDING ROUTINE is its closest living relative. (defun FORCE-META-X-GATE-MODE-COMMAND () (funcall *display-pane-1* :force-kbd-input #/m-x) (loop with string = (format nil "~A~%" "gate mode") for index from 0 to (1- (string-length string)) do (funcall *display-pane-1* :force-kbd-input (char string index)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; COM-GATE ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Routine to fire up Gateway. (defcom COM-GATE "LMI INFORMATION MANAGEMENT SYSTEM" () (set-up-gateway) (establish-default-script-buffer) (make-gateway-closure) (setq *editor-closure* (dolist (pane (send *gateway-constraint-frame* :inferiors)) (when (typep pane 'zwei:zmacs-frame) (return (send pane :editor-closure))))) (read-in-initial-data) dis-all) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; SET-UP-GATEWAY ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Initialize Gateways global variables and first display. (defun SET-UP-GATEWAY () (initialize-global-variables) (send *herald-pane* :set-item-list (display-herald)) (send (cond ((gateway-p) *command-pane*) ((guide-p) *guide-command-pane*) ((odm-p) *command-pane*)) :set-item-list (gateway-menu)) (com-gate-mode)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ESTABLISH-DEFAULT-SCRIPT-BUFFER ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Grab the empty buffer Zmacs creates during Gateway startup (as a side effect of ;;; the instantiation of the Zmacs frame contained in a Gateway constraint frame) and ;;; use it as the Default Script Buffer. (defun ESTABLISH-DEFAULT-SCRIPT-BUFFER (&aux pathname) (move-bp (point) (insert (point) (format nil ";;; -*- Mode:gate; Fonts:(CPTFONTB); Base:10 -*-~2%"))) (move-bp (point) (insert (point) (format nil "=Node: ~A~2%~A~2%" "Default Script" "=Script:"))) (setq pathname (make-absolute-pathname (string-append "GATEWAY:DATA;DEFAULT-SCRIPT-" (generate-buffer-name) ".GATE#>"))) (move-bp (point) (insert (point) (format nil "@ (~A)~A~%" (send pathname :name) "Default Script"))) (set-buffer-pathname pathname) (send *interval* :set-file-id t) (reparse-buffer-attribute-list-or-mode-line *interval*) (send *interval* :sectionize) (setq *default-script-buffer* *interval*) (setq *default-script-nodename* (read-from-string (make-nodename (send (send *default-script-buffer* :pathname) :string-for-printing) "Default Script"))) (get-node *default-script-nodename* 'quiet 'continue)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; READ-IN-INITIAL-DATA ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Get the appropriate initial data and script nodes, and display them. (defun READ-IN-INITIAL-DATA (&aux script-name script data-node-name) (cond ((gateway-p) (setq data-node-name *initial-gateway-data-node*) (setq script-name *initial-gateway-script-node*)) ((guide-p) (setq data-node-name *initial-guide-data-node*) (setq script-name *initial-guide-script-node*)) ((odm-p) (setq data-node-name *initial-odm-data-node*) (setq script-name *initial-odm-script-node*))) (setq data-node-name (standardize-nodename data-node-name)) (setq script-name (standardize-nodename script-name)) (setq script (get-node script-name 'complain 'throw)) (setq *initial-script* script-name) (seek-data-node (get-script-frame-for-node data-node-name script-name)))