;;; -*- Mode:LISP; Package:Zwei; Fonts:(CPTFONT); Base:10 -*- ;;; Copyright (C) Lisp Machine, Inc. 1984, 1985, 1986 ;;; See filename "Copyright" for ;;; licensing and release information. ;;; Miscellaneous low-level utility routines, in alphabetical order. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; BTRIM ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Trim blanks and strip fonts from a string. (defun BTRIM (string) (string-trim #/space (string-remove-fonts string))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; CREATE-HISTORY-FRAME-FROM-SCRIPT-FRAME ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Create a history frame, containing only the script-name and node-name of ;;; a script frame. History frames exist to make history information ;;; invariant of changes made in a script by the Gateway editor. (defun CREATE-HISTORY-FRAME-FROM-SCRIPT-FRAME (script-frame) (make-history-frame :script-name (script-frame-script-name script-frame) :node-name (script-frame-node-name script-frame))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; DISPLAY-MODE-P ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Predicate to determine whether we are in Display Mode. (defun DISPLAY-MODE-P () (eq *current-gateway-mode* 'display-mode)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; EDIT-MODE-P ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Predicate to determine whether we are in Edit Mode. (defun EDIT-MODE-P () (eq *current-gateway-mode* 'edit-mode)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; GATEWAY-P ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Predicate to determine whether the current application is Gateway. (defun GATEWAY-P () (eq *current-gateway-application* 'gateway)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; GET DEFAULTED TITLE AND FILE ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Get a node title and file name from the user, offering relevant defaults. (defun GET-DEFAULTED-TITLE-AND-FILE (&aux title-obtained pathname-obtained) (setq title-obtained (or (get-mini-buffer-string (string-append "Title: (default is " *current-node-title* ")")) *current-node-title*)) (setq pathname-obtained (read-defaulted-pathname "File:" (send *current-gateway-buffer* :pathname) "GATE" nil :new-ok)) (read-from-string (make-nodename pathname-obtained title-obtained))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; GET-MINI-BUFFER-STRING ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Prompt for and read in a string from the mini-buffer. (defun GET-MINI-BUFFER-STRING (statement &optional (prompt "") &aux prompt-length string-obtained) (setq prompt-length (string-length prompt)) (setq string-obtained (substring (string-interval (nth-value 2 (edit-in-mini-buffer *mini-buffer-comtab* prompt prompt-length (read-from-string (string-append "(/"" statement "/")"))))) prompt-length)) (if (not (string-equal string-obtained "")) string-obtained nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; GET-TITLE-FROM-HEADER ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Separate out a node title from a node header line (=NODE: line). (defun GET-TITLE-FROM-HEADER (line &aux idx1 idx2) (setq idx1 (string-search-not-set '(#/ ) line 7)) (setq idx2 (string-search-set '(#/;) line idx1)) (when (char-equal (aref line idx1) #/( ) (setq idx1 (1+ (string-search-set '(#/)) line idx1)))) (btrim (substring line idx1 idx2))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; GUIDE-P ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Predicate to determine whether the current application is Guide. (defun GUIDE-P () (eq *current-gateway-application* 'guide)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; LAND-P ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Predicate to determine whether the terminal is a landscape terminal. (defun LAND-P () (eq *terminal-type* 'landscape)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; MAKE-ABSOLUTE-PATHNAME ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Converts a logical pathname to a physical pathname, traversing as many indirection ;;; levels as necessary. Saves all results in a hash table to prevent redundant ;;; translations. ;;; Logical pathnames can equate to other logical pathnames. Some go deeper than ;;; others before a physical (absolute) pathname is reached. To prevent problems ;;; caused by pathnames at different levels meaning the same thing while seeming ;;; different, Gateway resolves all pathnames to the physical level and uses them ;;; only in that form. This is done by translating them until the translation process ;;; returns its input as its output, which happens only for a physical pathname. ;;; All the steps of the translation are saved in a hash table as keys to the absolute ;;; pathname, to prevent redundant translations of the same pathname. (defun MAKE-ABSOLUTE-PATHNAME (pathname &aux pathname-synonyms translated-pathname) (unless (setq translated-pathname (gethash pathname *pathname-hash-table*)) (when (stringp pathname) (setq pathname-synonyms (list pathname))) (setq pathname (fs:parse-pathname pathname)) (tagbody loop (setq pathname-synonyms (nconc (list pathname) pathname-synonyms)) (setq translated-pathname (send pathname :translated-pathname)) (unless (eq pathname translated-pathname) (setq pathname translated-pathname) (go loop))) (dolist (synonym pathname-synonyms) (puthash synonym translated-pathname *pathname-hash-table*))) translated-pathname) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; MAKE-NODENAME ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Create a nodename from a pathname and a title. The nodename is returned as ;;; a string; the calling routine can convert it to a list if desired. (defun MAKE-NODENAME (node-pathname node-id) (string-append "(/"" node-pathname "/" /"" (btrim node-id) "/" /"" node-id "/")" )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ODM-P ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Predicate to determine whether the current application is ODM. (defun ODM-P () (eq *current-gateway-application* 'odm)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; PARSE-SCRIPT-REFERENCE ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Convert a script reference, having the form TITLE or (FILENAME)TITLE ;;; into two values: a full pathname, and the title as a separate string. ;;; If (FILENAME) is not specified, it defaults to the filename of the ;;; file/buffer containing the script entry being parsed. (defun PARSE-SCRIPT-REFERENCE (string &optional (buffer *current-gateway-buffer*) &aux idx1 idx2) (setq idx1 (string-search-not-set '(#/@ #/ ) string)) (if (not idx1) (values nil nil) (cond ((char-equal (aref string idx1) #/( ) (setq idx2 (string-search-char #/) string)) (if (not idx2) (values nil nil) (values (send (make-absolute-pathname (string-append "GATEWAY: DATA; " (substring string (1+ idx1) idx2) ".GATE#>")) :string-for-printing) (substring string (1+ idx2))))) (t (values (send (send buffer :pathname) :string-for-printing) (substring string idx1)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; PORT-P ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Predicate to determine whether the terminal is a portrait terminal. (defun PORT-P () (eq *terminal-type* 'portrait)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; STANDARDIZE-NODENAME ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Filter out minor variations that could prevent identical nodenames ;;; differently derived from being detected as identical. (defun STANDARDIZE-NODENAME (nodename) (list (send (make-absolute-pathname (car nodename)) :string-for-printing) (btrim (cadr nodename)) (caddr nodename))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; STRING-REMOVE-EPSILON-FONTS ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Remove any literal epsilon-number font codes from a string. (defun STRING-REMOVE-EPSILON-FONTS (line) (do ((epsilon-position (string-search-set '(#/epsilon) line) (string-search-set '(#/epsilon) line epsilon-position))) ((null epsilon-position) t) (setq line (string-append (substring line 0 epsilon-position) (substring line (plus epsilon-position (if (lessp epsilon-position (1- (string-length line))) 2 1)))))) line) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; TYPE-TITLE-AND-FILE-THAT-DOES-EXIST ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Get a node title and file name from the user, being sure the node exists. (defun TYPE-TITLE-AND-FILE-THAT-DOES-EXIST (&aux nodename) (get-node (setq nodename (get-defaulted-title-and-file)) 'complain 'throw)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; TYPE-TITLE-AND-FILE-THAT-DOES-NOT-EXIST ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Get a node title and file name from the user, being sure the node does not exist. (defun TYPE-TITLE-AND-FILE-THAT-DOES-NOT-EXIST (&aux nodename) (if (get-node (setq nodename (get-defaulted-title-and-file)) 'quiet 'continue) (barf "~% ***** NODE ALREADY EXISTS *****") nodename))