;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*- ;;; Patch file for System version 78.19 ;;; Reason: Finish 78.18, ITS patch pathname fix ;;; Written 12/17/81 14:10:21 by MMcM, ;;; while running on Lisp Machine Sixteen from band 6 ;;; with System 78.18, ZMail 38.2, Experimental Macsyma 22.0, microcode 836. ; From file MOUSE > ZWEI; AI: #8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI"))) ;;; This returns the name of a function, either from the buffer with the mouse, or the ;;; mini-buffer. ;;; STRINGP of T means return a string if one is typed, don't intern it now. ;;; STRINGP of ALWAYS-READ means always return a newly read symbol, even if a completion ;;; was typed. (DEFUN READ-FUNCTION-NAME (PROMPT &OPTIONAL DEFAULT MUST-BE-DEFINED STRINGP &AUX TEM CH STR) (AND (EQ MUST-BE-DEFINED T) (SETQ STRINGP 'ALWAYS-READ)) (SETQ PROMPT (FORMAT NIL "~A~:[:~; (Default: ~S)~]" PROMPT DEFAULT DEFAULT)) (COND ((OR *MINI-BUFFER-REPEATED-COMMAND* (FUNCALL STANDARD-INPUT ':LISTEN)) (SETQ TEM 0 CH NIL)) ;C-X , no opportunity for mouse (T (LET ((*MODE-LINE-LIST* (LIST PROMPT '(:RIGHT-FLUSH " (Completion)")))) (REDISPLAY-MODE-LINE)) ;Make correct for later (DELETE-INTERVAL (WINDOW-INTERVAL *MINI-BUFFER-WINDOW*)) (MUST-REDISPLAY *MINI-BUFFER-WINDOW* DIS-ALL) (SELECT-WINDOW *MINI-BUFFER-WINDOW*) ;;KLUDGE, position blinker (DO L (WINDOW-SPECIAL-BLINKER-LIST *MINI-BUFFER-WINDOW*) (CDR L) (NULL L) (TV:BLINKER-SET-VISIBILITY (CDAR L) NIL)) (LET ((BL (WINDOW-POINT-BLINKER *MINI-BUFFER-WINDOW*))) (TV:BLINKER-SET-CURSORPOS BL 0 0) (TV:BLINKER-SET-VISIBILITY BL ':BLINK)) (UNWIND-PROTECT (LET-GLOBALLY ((*GLOBAL-MOUSE-CHAR-BLINKER-HANDLER* (IF MUST-BE-DEFINED #'BLINK-FUNCTION #'BLINK-ATOM)) (*GLOBAL-MOUSE-CHAR-BLINKER-DOCUMENTATION-STRING* "Click left on highlighted name to select it.") (*MOUSE-FONT-CHAR* 0) (*MOUSE-X-OFFSET* 4) (*MOUSE-Y-OFFSET* 0)) (SETQ TV:MOUSE-RECONSIDER T) (WITHOUT-IO-BUFFER-OUTPUT-FUNCTION (MULTIPLE-VALUE (TEM CH) (FUNCALL STANDARD-INPUT ':MOUSE-OR-KBD-TYI)))) (TV:BLINKER-SET-VISIBILITY *GLOBAL-MOUSE-CHAR-BLINKER* NIL) (SETQ TV:MOUSE-RECONSIDER T)))) (COND ((AND (= TEM #\MOUSE-1-1) (MULTIPLE-VALUE-BIND (FCTN LINE START END) (ATOM-UNDER-MOUSE (CADR CH)) (COND ((OR (FBOUNDP (SETQ TEM FCTN)) (STRING-IN-AARRAY-P TEM *ZMACS-COMPLETION-AARRAY*) (GET TEM ':SOURCE-FILE-NAME) (AND (NOT MUST-BE-DEFINED) TEM)) (SETQ STR (SUBSTRING LINE START END)) T)))) (SELECT-WINDOW *WINDOW*) (DISAPPEAR-MINI-BUFFER-WINDOW) (OR *MINI-BUFFER-COMMAND* (MINI-BUFFER-RING-PUSH (SETQ *MINI-BUFFER-COMMAND* `((,*CURRENT-COMMAND* ,*NUMERIC-ARG-P* ,*NUMERIC-ARG*))))) (RPLACD (LAST *MINI-BUFFER-COMMAND*) (NCONS STR)) TEM) (T (FUNCALL STANDARD-INPUT ':UNTYI CH) (LET ((NAME (COMPLETING-READ-FROM-MINI-BUFFER PROMPT *ZMACS-COMPLETION-AARRAY* (OR (NEQ STRINGP 'ALWAYS-READ) 'ALWAYS-STRING))) SYM ERROR-P) (COND ((EQUAL NAME "") (OR DEFAULT (BARF)) (SETQ SYM DEFAULT NAME (STRING DEFAULT))) ((LISTP NAME) (SETQ SYM (CDR NAME) NAME (CAR NAME)) (AND (LISTP SYM) (NEQ STRINGP 'MULTIPLE-OK) (SETQ SYM (CAR SYM)))) ((EQ STRINGP T) ;If returning a string, don't intern it (SETQ SYM NAME)) (T (MULTIPLE-VALUE (SYM NAME ERROR-P) (SYMBOL-FROM-STRING NAME NIL T)) (AND (LISTP SYM) (EQ STRINGP 'MULTIPLE-OK) (SETQ SYM (NCONS SYM))) (AND ERROR-P (BARF "Read error")))) (AND (EQ MUST-BE-DEFINED T) (NOT (FDEFINEDP SYM)) (BARF "~S is not defined" SYM)) (VALUES SYM NAME))))) ) ; From file PATHNM > LMIO; AI: #8R FILE-SYSTEM:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (DEFMETHOD (TOPS20-PATHNAME-MIXIN :STRING-FOR-DIRECTORY) () (LET ((DIR-DELIM (CAR (FUNCALL-SELF ':DIRECTORY-DELIMITERS)))) (FORMAT NIL "~:[~A:~;~*~]~@[~C~A~C~]" (MEMBER DEVICE (FUNCALL-SELF ':SUPPRESSED-DEVICE-NAMES)) (STRING-OR-WILD DEVICE) (CAR DIR-DELIM) (TOPS20-DIRECTORY-NAME) (CDR DIR-DELIM)))) ) ; From file PATHNM > LMIO; AI: #8R FILE-SYSTEM:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (DEFUN ADD-LOGICAL-PATHNAME-HOST (LOGICAL-HOST PHYSICAL-HOST TRANSLATIONS &AUX LOG DEFDEV) (OR (SETQ LOG (GET-PATHNAME-HOST LOGICAL-HOST)) (PUSH (SETQ LOG (MAKE-INSTANCE 'LOGICAL-HOST ':NAME LOGICAL-HOST)) *PATHNAME-HOST-LIST*)) (SETQ PHYSICAL-HOST (OR (GET-PATHNAME-HOST PHYSICAL-HOST) (FERROR NIL "There is no host named ~S" PHYSICAL-HOST))) (FUNCALL LOG ':SET-HOST PHYSICAL-HOST) (FUNCALL LOG ':SET-TRANSLATIONS (LOOP FOR (LOGICAL-DIRECTORY PHYSICAL-DIRECTORY) IN TRANSLATIONS WITH HOST = (DEFAULT-PATHNAME NIL PHYSICAL-HOST NIL NIL T) AND DEVICE AND DIRECTORY DO (MULTIPLE-VALUE (DEVICE DIRECTORY) (FUNCALL HOST ':PARSE-NAMESTRING T PHYSICAL-DIRECTORY)) WHEN (MEMQ DIRECTORY '(NIL :UNSPECIFIC)) DO (FERROR NIL "No directory specified in ~A, you probably forgot some delimiter characters." PHYSICAL-DIRECTORY) WHEN (NULL DEFDEV) DO (SETQ DEFDEV DEVICE) COLLECT (MAKE-LOGICAL-PATHNAME-TRANSLATION LOGICAL-DIRECTORY LOGICAL-DIRECTORY PHYSICAL-DEVICE DEVICE PHYSICAL-DIRECTORY DIRECTORY))) (FUNCALL LOG ':SET-DEFAULT-DEVICE DEFDEV)) ) ; From file PATHNM > LMIO; AI: #8R FILE-SYSTEM:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "FILE-SYSTEM"))) ;;; Patch system interface, more kludges for only six character filenames (DEFMETHOD (ITS-PATHNAME-MIXIN :PATCH-FILE-PATHNAME) (NAM SAME-DIRECTORY-P PATOM TYP &REST ARGS) (SELECTQ TYP (:SYSTEM-DIRECTORY (FUNCALL-SELF ':NEW-PATHNAME ':NAME (IF SAME-DIRECTORY-P PATOM NAM) ':TYPE "(PDIR)" ':VERSION ':NEWEST)) (:VERSION-DIRECTORY (FUNCALL-SELF ':NEW-PATHNAME ':NAME (WITH-OUTPUT-TO-STRING (STREAM) (LET ((SNAME (IF SAME-DIRECTORY-P PATOM (SI:SYSTEM-SHORT-NAME NAM)))) (DOTIMES (I (MIN (STRING-LENGTH SNAME) 3)) (FUNCALL STREAM ':TYO (AREF SNAME I)))) (LET ((BASE 10.) (*NOPOINT T)) (PRIN1 (\ (CAR ARGS) 1000.) STREAM))) ':TYPE "(PDIR)" ':VERSION ':NEWEST)) (:PATCH-FILE (FUNCALL-SELF ':NEW-PATHNAME ':NAME (FORMAT NIL "~:[~*~;~C~]~D.~D" SAME-DIRECTORY-P PATOM (\ (CAR ARGS) 100.) (\ (CADR ARGS) (IF SAME-DIRECTORY-P 100. 1000.))) ':TYPE (CADDR ARGS) ':VERSION ':NEWEST)))) ) ; From file PATHNM > LMIO; AI: #8R FILE-SYSTEM:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (DEFUN FILE-READ-PROPERTY-LIST (PATHNAME STREAM &AUX WO PLIST PATH MODE) (SETQ WO (FUNCALL STREAM ':WHICH-OPERATIONS)) (COND ((MEMQ ':SYNTAX-PLIST WO) (SETQ PLIST (FUNCALL STREAM ':SYNTAX-PLIST))) ((AND (MEMQ ':READ-INPUT-BUFFER WO) (MULTIPLE-VALUE-BIND (BUFFER START END) (FUNCALL STREAM ':READ-INPUT-BUFFER) (AND BUFFER (SETQ PLIST (FILE-PARSE-PROPERTY-LIST BUFFER START END))) PLIST))) ;Try :LINE-IN if this fails (T (DO ((LINE) (EOF)) (NIL) (MULTIPLE-VALUE (LINE EOF) (FUNCALL STREAM ':LINE-IN NIL)) (COND ((STRING-SEARCH "-*-" LINE) (SETQ PLIST (FILE-PARSE-PROPERTY-LIST LINE)) (FUNCALL STREAM ':SET-POINTER 0) (RETURN NIL)) ((OR EOF (STRING-SEARCH-NOT-SET '(#\SP #\TAB) LINE)) (FUNCALL STREAM ':SET-POINTER 0) (RETURN NIL)))))) (AND (NOT (GET (LOCF PLIST) ':MODE)) (MEMQ ':PATHNAME WO) (SETQ PATH (FUNCALL STREAM ':PATHNAME)) (SETQ MODE (CDR (ASSOC (FUNCALL PATH ':TYPE) *FILE-TYPE-MODE-ALIST*))) (PUTPROP (LOCF PLIST) MODE ':MODE)) (AND PATHNAME (DO ((L PLIST (CDDR L))) ((NULL L)) (FUNCALL PATHNAME ':PUTPROP (SECOND L) (FIRST L)))) PLIST) ) ; From file FLAVOR > LISPM2; AI: #8R SYSTEM-INTERNALS:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (DEFUN GET-HANDLER-FOR (FUNCTION OPERATION &OPTIONAL (SUPERIORS-P T) &AUX TEM) "Given a functional object, return its subfunction to do the given operation or NIL. Returns NIL if it does not reduce to a select-method or if it does not handle that." (DO-NAMED GET-HANDLER-FOR () (NIL) ;Repeat until reduced to a select-method (if possible) (SELECT (%DATA-TYPE FUNCTION) (DTP-ARRAY-POINTER (OR (AND (NAMED-STRUCTURE-P FUNCTION) ;This is a crock (why?) (SETQ FUNCTION (GET (NAMED-STRUCTURE-SYMBOL FUNCTION) 'NAMED-STRUCTURE-INVOKE))) (RETURN NIL))) (DTP-SYMBOL (OR (FBOUNDP FUNCTION) (RETURN NIL)) (SETQ FUNCTION (FSYMEVAL FUNCTION))) ((DTP-ENTITY DTP-CLOSURE) (SETQ FUNCTION (CAR (%MAKE-POINTER DTP-LIST FUNCTION)))) (DTP-SELECT-METHOD (SETQ FUNCTION (%MAKE-POINTER DTP-LIST FUNCTION)) (DO () (NIL) ;Iterate down select-method, then continue with tail (COND ((SYMBOLP (CAR FUNCTION)) ;One level subroutine call (AND SUPERIORS-P (SETQ TEM (GET-HANDLER-FOR FUNCTION OPERATION NIL)) (RETURN-FROM GET-HANDLER-FOR TEM))) ((IF (LISTP (CAAR FUNCTION)) (MEMQ OPERATION (CAAR FUNCTION)) (EQ OPERATION (CAAR FUNCTION))) (RETURN-FROM GET-HANDLER-FOR (CDAR FUNCTION)))) (SETQ FUNCTION (CDR FUNCTION)) (OR (LISTP FUNCTION) (RETURN NIL)))) (DTP-INSTANCE (SETQ FUNCTION (%P-CONTENTS-OFFSET (%P-CONTENTS-AS-LOCATIVE-OFFSET FUNCTION 0) %INSTANCE-DESCRIPTOR-FUNCTION))) (OTHERWISE (RETURN-FROM GET-HANDLER-FOR NIL))))) ) ; From file SHEET > LMWIN; AI: #8R TV:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TV"))) ;;; This function should get called by the clock about every 60th of a second. ;;; Any blinkers which are supposed to be on but are off are turned on. ;;; Any blinkers which are supposed to be flashed are flashed if it is time. ;;; Note: we depend on the fact that blinkers temporarily turned off ;;; have their BLINKER-TIME-UNTIL-BLINK fields set to 0. (LOCAL-DECLARE ((SPECIAL BLINKER-DELTA-TIME)) (DEFUN BLINKER-CLOCK-INTERNAL (SHEET) (COND ((AND (SHEET-EXPOSED-P SHEET) (ZEROP (SHEET-DONT-BLINK-BLINKERS-FLAG SHEET))) (DOLIST (BLINKER (SHEET-BLINKER-LIST SHEET)) (AND (SELECTQ (BLINKER-VISIBILITY BLINKER) ((NIL :OFF) (BLINKER-PHASE BLINKER)) ((T :ON) (NULL (BLINKER-PHASE BLINKER))) (:BLINK (LET ((NEW-TIME (- (BLINKER-TIME-UNTIL-BLINK BLINKER) BLINKER-DELTA-TIME))) (SETF (BLINKER-TIME-UNTIL-BLINK BLINKER) NEW-TIME) ( NEW-TIME 0)))) (NOT (SHEET-OUTPUT-HELD-P SHEET)) (LET ((LV (SHEET-LOCK SHEET))) (OR (NULL LV) (LISTP LV))) (CATCH-ERROR (BLINK BLINKER) NIL))) (AND (EQ SHEET MOUSE-SHEET) (= MOUSE-CURSOR-STATE 1) (= MOUSE-CURSOR-CLOSED-STATE 2) (NEQ WINDOW-OWNING-MOUSE 'STOP) (NOT (SHEET-OUTPUT-HELD-P SHEET)) (LET ((LV (SHEET-LOCK SHEET))) (OR (NULL LV) (LISTP LV))) (SETQ MOUSE-CURSOR-STATE MOUSE-CURSOR-CLOSED-STATE PREPARED-SHEET NIL)) (DOLIST (S (SHEET-EXPOSED-INFERIORS SHEET)) (BLINKER-CLOCK-INTERNAL S)))))) )