;;; Inertly recovered online-help source contexts. ;;; Original System 46 file: nzwei/comf.25 ;;; Exact source bytes follow each generated provenance comment. ;;; Source bytes 144:4925; lines 4-109; sha256 5bdc4539a44d788939e0a4b01f3d1f19432a72eaeb2c9e439c195304f88b225b (DEFCOM COM-FROB-LISP-CONDITIONAL "Change CONDs to ANDs or ORs and vice versa. When changing to COND, point is left in such a place that LF will add another clause to this condition, and M-) will add another condition. Also in this case an argument specifies the number of clauses that are left in the consequent, the default is 1, i.e. all clauses but the last are assumed to be for value, and to belong in the antecedent." () (ATOM-WORD-SYNTAX-BIND (LET ((POINT (POINT)) FIXBP1 FIXBP2) (UNWIND-PROTECT (LET (COND-BP COND-TYPE UPCASE-P BP) (MULTIPLE-VALUE (COND-BP COND-TYPE) (FIND-CONTAINING-ATOM POINT '(COND AND OR IF))) ;Locate the COND or AND or OR (OR COND-BP (BARF)) (SETQ UPCASE-P (CHAR-UPPERCASE-P (BP-CHAR COND-BP))) ;Remember if have to lowercase (LET ((START-DEFUN-BP (FORWARD-DEFUN POINT -1 T)) (END-DEFUN-BP (FORWARD-DEFUN POINT 1 T)) DEPTH) ;; Parse it all once, then don't even bother checking. (LISP-PARSE-FROM-DEFUN (BP-LINE END-DEFUN-BP) START-DEFUN-BP) ;; Count how many levels down the next defun is from the start of this one. (LET ((*LISP-PARSE-PREPARSED-FLAG* T)) (DO ((I -1 (1+ I)) (BP3 END-DEFUN-BP (FORWARD-SEXP BP3 -1 NIL 1 START-DEFUN-BP))) ((NULL BP3) (SETQ DEPTH I)))) ;; Insert that many ")"'s just before point, so everything is balanced. ;; These ")"'s lie between FIXBP1 and FIXBP2. We use that to delete them later. (COND ((> DEPTH 0) (LET ((BP (LIKELY-UNBALANCED-POINT (FORWARD-LIST COND-BP -1 NIL 1) END-DEFUN-BP))) (SETQ FIXBP1 (COPY-BP BP ':NORMAL) FIXBP2 (COPY-BP BP ':MOVES))) (INSERT FIXBP2 #\CR) (DOTIMES (I DEPTH) (INSERT FIXBP2 #/))) (INSERT FIXBP2 #\CR)))) (COND ((EQ COND-TYPE 'COND) ;Changing COND to AND or OR (LET ((N (COUNT-LIST-ELEMENTS (FORWARD-LIST COND-BP -1 NIL 1)))) (AND (> N 3) (BARF "Too many clauses")) (AND (= N 3) (LET ((BP1 (FORWARD-SEXP COND-BP 2)) BP2 BP3) (SETQ BP2 (FORWARD-LIST BP1 1 NIL -1 T) BP3 (FORWARD-WORD BP2)) (OR (AND (EQ (BP-LINE BP2) (BP-LINE BP3)) (STRING-EQUAL (BP-LINE BP2) "T" (BP-INDEX BP2) 0 (BP-INDEX BP3))) (BARF "Too many clauses")) (SETQ BP1 (BACKWARD-OVER '(#\CR #\TAB #\SP) BP1)) (SETQ BP1 (FORWARD-CHAR BP1 -1)) (SETQ N (COUNT-LIST-ELEMENTS (FORWARD-SEXP COND-BP))) (DELETE-INTERVAL BP1 BP3 T) (SETQ COND-TYPE (IF (= N 1) "OR" "IF"))))) (DELETE-INTERVAL COND-BP (FORWARD-WORD COND-BP) T) (AND (EQ COND-TYPE 'COND) ;Still not determined ;; Check for (COND ((NOT ...))) (LET ((BP1 (FORWARD-LIST COND-BP 1 NIL -2 T))) (LET ((BP2 (FORWARD-WORD COND-BP 1 T))) (LET ((WORD (STRING-INTERVAL BP1 BP2))) (COND ((OR (STRING-EQUAL WORD "NULL") (STRING-EQUAL WORD "NOT")) (SETQ BP1 (FORWARD-LIST BP1 -1 NIL 1)) (LET ((BP3 (FORWARD-LIST BP1))) (DELETE-INTERVAL (FORWARD-CHAR BP3 -1) BP3 T)) (DELETE-INTERVAL BP1 (FORWARD-OVER *BLANKS* BP2) T) (SETQ COND-TYPE "OR")) (T (SETQ COND-TYPE "AND"))))))) (SETQ BP (FORWARD-OVER *BLANKS* (INSERT COND-BP COND-TYPE))) (LET ((BP1 (FORWARD-LIST BP))) ;Remove a level of parens (DELETE-INTERVAL (FORWARD-CHAR BP1 -1) BP1 T)) (DELETE-INTERVAL BP (FORWARD-CHAR BP) T)) (T (LET ((BP1 (FORWARD-LIST (FORWARD-LIST (FORWARD-CHAR COND-BP -1)) -1 NIL -1 T))) (INSERT BP1 #/)) (DO ((N -1 (1+ N)) (BP2 BP1 (FORWARD-SEXP BP2 -1)) (ARG (COND (*NUMERIC-ARG-P* (- 1 *NUMERIC-ARG*)) ((EQ COND-TYPE 'IF) -1) (T 0)))) ((BP-= BP2 COND-BP) (COND ((MINUSP (+ ARG N -3)) (DELETE-INTERVAL COND-BP (FORWARD-WORD COND-BP) T) (SETQ BP (FORWARD-OVER *WHITESPACE-CHARS* (INSERT COND-BP "COND"))) (INSERT-MOVING BP #/() (COND ((EQ COND-TYPE 'IF) (SETQ BP (FORWARD-SEXP BP 2)) (INSERT-MOVING BP ") (T")))) (T (SETQ BP (INSERT COND-BP "COND ((")) (LET ((BP1 (IF (PLUSP ARG) (FORWARD-LIST BP 1 NIL 1) (FORWARD-SEXP BP (+ ARG N))))) (INSERT BP1 #/))) (SETQ BP (FORWARD-CHAR BP -1)))) (COND ((EQ COND-TYPE 'OR) (INSERT (FORWARD-SEXP BP) #/)) (INSERT-MOVING BP "(NOT ")))))))) (OR UPCASE-P (DOWNCASE-INTERVAL COND-BP BP T)) (MOVE-BP POINT (FORWARD-LIST BP -1 NIL (IF (MEMQ COND-TYPE '(IF OR)) 2 1))) (COM-INDENT-SEXP) ;Regrind changed stuff (MOVE-BP POINT (FORWARD-LIST (FORWARD-SEXP POINT) -1 NIL -1 T))) (COND (FIXBP1 (DELETE-INTERVAL FIXBP1 FIXBP2 T) (FLUSH-BP FIXBP1) (FLUSH-BP FIXBP2)))))) DIS-TEXT) ;;; Source bytes 6048:8184; lines 142-192; sha256 4d8a27198a406dda854e9821cb3d3412e2c0691fabad6d1ffef2043c6ca25293 (DEFCOM COM-FROB-DO "Interchange old and new style DO's" () (ATOM-WORD-SYNTAX-BIND (LET (DO-BP DO-TYPE BP BP1 BP2 BP3) (MULTIPLE-VALUE (DO-BP DO-TYPE) (FIND-CONTAINING-ATOM (POINT) '(DO DOTIMES DOLIST))) (OR DO-BP (BARF)) (SETQ BP (FORWARD-OVER *WHITESPACE-CHARS* (FORWARD-WORD DO-BP))) (COND ((AND (EQ DO-TYPE 'DO) (= (LIST-SYNTAX (BP-CH-CHAR BP)) LIST-OPEN)) ;New style (OR (= (COUNT-LIST-ELEMENTS BP) 1) (BARF "Too many DO variables")) (OR (SETQ BP1 (FORWARD-SEXP BP)) (BARF)) (OR (= (COUNT-LIST-ELEMENTS BP1) 1) (BARF "Cannot have ending form")) (OR (SETQ BP2 (FORWARD-SEXP BP1)) (BARF)) (SETQ BP3 (FORWARD-SEXP BP2 -1)) (DELETE-INTERVAL (FORWARD-LIST BP2 -1 NIL -1 T) BP2 T) (MOVE-BP (POINT) (DELETE-INTERVAL (FORWARD-LIST BP1 -1 NIL -2 T) (FORWARD-LIST BP3 1 NIL -1 T) T)) (INSERT-MOVING (POINT) #\SP) (DELETE-INTERVAL BP (FORWARD-LIST BP 1 NIL -2 T) T)) (T ;Old style or special (COND ((NEQ DO-TYPE 'DO) (OR (SETQ BP1 (FORWARD-LIST BP 1 NIL -1 T)) (BARF)) (SETQ BP2 (FORWARD-SEXP BP1)) (LET ((VARNAME (STRING-INTERVAL BP1 BP2 T))) (DELETE-INTERVAL BP BP1 T) (COND ((EQ DO-TYPE 'DOTIMES) (SETQ BP2 (FORWARD-SEXP BP)) (INSERT-MOVING BP2 (IN-CURRENT-FONT " 0 (1+ ")) (INSERT-MOVING BP2 VARNAME) (INSERT-MOVING BP2 (IN-CURRENT-FONT ") ( "))) ((EQ DO-TYPE 'DOLIST) (SETQ BP2 (FORWARD-SEXP BP 2)) (INSERT-MOVING BP2 (IN-CURRENT-FONT " (CDR ")) (INSERT-MOVING BP2 VARNAME) (INSERT-MOVING BP2 (IN-CURRENT-FONT ") (NULL ")))) (INSERT-MOVING BP2 VARNAME)) (DELETE-INTERVAL DO-BP (FORWARD-WORD DO-BP) T) (SETQ BP (FORWARD-OVER *WHITESPACE-CHARS* (INSERT DO-BP (IN-CURRENT-FONT "DO")))))) (OR (SETQ BP1 (FORWARD-SEXP BP 3)) (BARF)) (DELETE-AROUND *WHITESPACE-CHARS* BP1) (MOVE-BP (POINT) (INSERT-MOVING BP1 (IN-CURRENT-FONT #/)))) (INSERT-MOVING BP1 (IN-CURRENT-FONT ") (")) (INSERT BP (IN-CURRENT-FONT "((")) (INSERT (FORWARD-SEXP BP1) (IN-CURRENT-FONT #/))) (INDENT-INTERVAL-FOR-LISP BP BP1 T))))) DIS-TEXT) ;;; Source bytes 8186:9147; lines 194-217; sha256 1ead3434bc1669f9020c20cdbfb854f2330fb94c7efe993494bd0ba8b5a02ff0 (DEFCOM COM-QUERY-REPLACE-LET-BINDING "Replace variable of LET with its value. Point must be after or within the binding to be modified." () (ATOM-WORD-SYNTAX-BIND (LET ((POINT (POINT)) LET-BP BINDING-BP BP1 BP2 FROM TO) (OR (SETQ LET-BP (FIND-CONTAINING-ATOM POINT '(LET))) (BARF)) (DO ((BP (FORWARD-LIST LET-BP 1 NIL -1 T) NBP) (NBP)) (NIL) (OR (SETQ NBP (FORWARD-SEXP BP 1 NIL 0 NIL NIL T)) (BARF)) (OR (BP-< NBP POINT) (RETURN (SETQ BINDING-BP BP)))) (SETQ BP1 (FORWARD-LIST BINDING-BP 1 NIL -1 T) BP2 (FORWARD-SEXP BP1) FROM (STRING-INTERVAL BP1 BP2 T)) (SETQ BP1 (FORWARD-OVER *WHITESPACE-CHARS* BP2) BP2 (FORWARD-SEXP BP1) TO (STRING-INTERVAL BP1 BP2 T)) (SETQ BP1 (FORWARD-SEXP LET-BP 2) BP2 (FORWARD-SEXP BP1 1 NIL 1)) (OR *NUMERIC-ARG-P* (PSETQ FROM TO TO FROM)) (MOVE-BP POINT BP1) (LET ((*INTERVAL* (CREATE-INTERVAL BP1 BP2 T))) (QUERY-REPLACE POINT FROM TO T)))) DIS-TEXT) ;;; Source bytes 9149:9370; lines 219-222; sha256 79aabdd2914f7a3e4e99f1f23379718fa19de08e89acbf653072bc2ec3dab7c5 (DEFCOM COM-QUERY-REPLACE-LAST-KILL "Replace top of kill ring with region." () (LET ((POINT (POINT)) (MARK (MARK))) (QUERY-REPLACE POINT (STRING-INTERVAL (CAR *KILL-RING*)) (STRING-INTERVAL MARK POINT))) DIS-TEXT) ;;; Source bytes 9373:9566; lines 224-228; sha256 2374a7f21891c7eb1ee88448b166a7345371ad2bcea318405eb1b28209682627 (DEFCOM COM-JUST-ONE-SPACE "Replace all whitespace around point with arg spaces" () (DELETE-AROUND *BLANKS* (POINT)) (DOTIMES (I *NUMERIC-ARG*) (INSERT-MOVING (POINT) #\SP)) DIS-TEXT) ;;; Source bytes 9568:11064; lines 230-261; sha256 23066d843466dca102600488962ee5501bc5ade1a1b15beeff3a29fda2115c51 (DEFCOM COM-CANONICALIZE-WHITESPACE "Try to fixup wrong spacing heuristically. If given an argument, or called just after a yank type command, operates at the mark, else at point." () (LET ((BP (IF (OR *NUMERIC-ARG-P* (EQ *LAST-COMMAND-TYPE* 'YANK)) (MARK) (POINT))) BP1 CH1 CH2 SYN1 SYN2) (SETQ BP (BACKWARD-OVER *BLANKS* BP) BP1 (FORWARD-OVER *BLANKS* BP) CH1 (BP-CH-CHAR (FORWARD-CHAR BP -1)) CH2 (BP-CH-CHAR BP1) SYN1 (LIST-SYNTAX CH1) SYN2 (LIST-SYNTAX CH2)) (COND ((OR (= CH2 #\CR) ;If at the end of the line, (MULTIPLE-VALUE-BIND (STRING SLASH COMMENT) (LISP-BP-SYNTACTIC-CONTEXT BP) (OR STRING SLASH COMMENT)))) ;or any funny syntax, leave it alone ((NOT (= CH1 #\CR)) ;If not at beginning of line, (DELETE-INTERVAL BP BP1 T) ;flush whitespace, and (AND ( SYN1 LIST-OPEN) ( SYN1 LIST-SINGLE-QUOTE) ( SYN2 LIST-CLOSE) (INSERT BP (IN-CURRENT-FONT #\SP)))) ;leave zero or one space in its place (( CH2 #/() ;If not start of defun (INDENT-INTERVAL-FOR-LISP BP (BEG-LINE BP 1 T) T NIL T)) ;run tab ((DO ((LINE (LINE-PREVIOUS (BP-LINE BP)) (LINE-PREVIOUS LINE)) (OLINE (BP-LINE BP) LINE) ;Flush blank lines, and (TYPE)) ;unless previous non-blank is a comment (NIL) (SETQ TYPE (AND LINE (LINE-TYPE LINE))) (COND ((NEQ TYPE ':BLANK) (DELETE-INTERVAL (CREATE-BP OLINE 0) BP T) (RETURN (NEQ TYPE ':COMMENT))))) (INSERT BP #\CR)))) ;leave just one in their place DIS-TEXT) ;;; Source bytes 11066:12095; lines 263-293; sha256 b3e5d1166043691460747129dcfbd27e9abe722a5aa9809d74e6d8f597ede4ab (DEFCOM COM-FIND-UNBALANCED-PARENTHESES "Find parenthesis error in buffer" () (LET ((BEG-BP (INTERVAL-FIRST-BP *INTERVAL*)) (END-BP (INTERVAL-LAST-BP *INTERVAL*)) (POINT (POINT)) (OLD-TICK (INTERVAL-TICK *INTERVAL*)) BEG-BP-1 END-BP-1 BP) (UNWIND-PROTECT (PROGN (SETQ BEG-BP-1 (COPY-BP BEG-BP ':MOVES) END-BP-1 (COPY-BP END-BP ':NORMAL)) (INSERT BEG-BP-1 "( ") (INSERT END-BP-1 " )") (IF (SETQ BP (FORWARD-SEXP BEG-BP)) (IF (BP-= BP END-BP) ;All ok (TYPEIN-LINE "All parens appear balanced.") (MOVE-BP POINT BP) (TYPEIN-LINE "Probably extra right-paren here.")) (OR (SETQ BP (FORWARD-SEXP END-BP -1)) (BARF "Cannot find unbalanced parenthesis")) (MOVE-BP POINT BP) (TYPEIN-LINE "Probably no right-paren for this left-paren."))) (COND (BEG-BP-1 (DELETE-INTERVAL BEG-BP BEG-BP-1 T) (FLUSH-BP BEG-BP-1))) (COND (END-BP-1 (DELETE-INTERVAL END-BP-1 END-BP T) (FLUSH-BP END-BP-1))) (SETF (INTERVAL-TICK *INTERVAL*) OLD-TICK))) DIS-BPS) ;;; Source bytes 12097:12551; lines 295-305; sha256 f789eb940bc95c820ac90f7a983f92fa4b27450e8a92767b2f32c9da55b9ad5c (DEFCOM COM-DESCRIBE-CLASS "Describe the specified class." () (LET ((CLASS (COMPLETING-READ-FROM-MINI-BUFFER "Describe class:" (MAPCAR #'(LAMBDA (X) (SETQ X (<- X ':CLASS-SYMBOL)) (CONS (FORMAT NIL "~S" X) X)) (CONS OBJECT-CLASS (SI:ALL-SUBCLASSES-OF-CLASS OBJECT-CLASS))) NIL NIL "You are typing the name of a class, to be described."))) (AND (ATOM CLASS) (BARF)) (DESCRIBE-CLASS-INTERNAL (CDR CLASS))) DIS-NONE) ;;; Source bytes 12553:13521; lines 307-333; sha256 3e0a2eddadec452efccc22312cccb966962c1f3fa0c9cf652e42f7c40b736db8 (DEFUN DESCRIBE-CLASS-INTERNAL (CLASS) (OR (AND (SYMBOLP CLASS) (BOUNDP CLASS) (ENTITYP (SETQ CLASS (SYMEVAL CLASS)))) (BARF "~S is not a class" CLASS)) (FORMAT *TYPEOUT-WINDOW* "~&Instance variables of ~A:~%" (SYMEVAL-IN-CLOSURE CLASS ':NAME)) (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST NIL (SYMEVAL-IN-CLOSURE CLASS 'SI:INSTANCE-PATTERN)) (DO ((SYM (SYMEVAL-IN-CLOSURE CLASS 'SI:CLASS-METHOD-SYMBOL)) (METHS NIL) (CL) (ML)) ((EQ SYM 'SI:UNCLAIMED-MESSAGE)) (SETQ CL (SYMEVAL SYM) ML (%MAKE-POINTER DTP-LIST (FSYMEVAL SYM))) (FORMAT *TYPEOUT-WINDOW* "~2%Methods~:[ as a subclass~] of ~A:~%" (EQ CL CLASS) (SYMEVAL-IN-CLOSURE CL ':NAME)) (DO ((L ML (CDR L)) (M) (LL NIL)) ((NLISTP L) (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST 'FUNCTION-NAME (NREVERSE LL)) (SETQ SYM L METHS (APPEND ML METHS)) (RPLACD (LAST METHS) NIL)) (OR (ASSQ (CAR (SETQ M (CAR L))) METHS) (PUSH M LL)))) NIL) ;;; Source bytes 13599:14159; lines 338-349; sha256 5f6e7a481434e00b255eeb8414fbe25d4ffa44e8cfdd6844bbc41d33fbf59b92 (DEFCOM COM-DESCRIBE-FLAVOR "Describe the specified flavor." () (AND (NEQ *LAST-ALL-FLAVOR-NAMES* SI:*ALL-FLAVOR-NAMES*) (SETQ *LAST-ALL-FLAVOR-NAMES* SI:*ALL-FLAVOR-NAMES* *ALL-FLAVOR-NAMES-ALIST* (MAPCAR #'(LAMBDA (X) (CONS (FORMAT NIL "~S" X) X)) *LAST-ALL-FLAVOR-NAMES*))) (LET ((FLAVOR (COMPLETING-READ-FROM-MINI-BUFFER "Describe flavor:" *ALL-FLAVOR-NAMES-ALIST* NIL NIL "You are typing the name of a flavor, to be described."))) (AND (ATOM FLAVOR) (BARF)) (DESCRIBE-FLAVOR-INTERNAL (CDR FLAVOR))) DIS-NONE) ;;; Source bytes 14161:16050; lines 351-392; sha256 4291cf5b120f87a61a89f95cb81568838cd9e1938c6e748c6e988c0e89539878 (DEFUN DESCRIBE-FLAVOR-INTERNAL (FLAVOR &AUX FL TEM) (OR (SETQ FL (GET FLAVOR 'SI:FLAVOR)) (BARF "~S is not the name of a flavor" FLAVOR)) (COND ((SETQ TEM (SI:FLAVOR-DEPENDS-ON FL)) (FORMAT *TYPEOUT-WINDOW* "~&Flavor ~S directly depends on flavor~P:~%" FLAVOR (LENGTH TEM)) (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST 'FLAVOR-NAME TEM)) (T (FORMAT *TYPEOUT-WINDOW* "~&Flavor ~S does not directly depend on any other flavors~%" FLAVOR))) (COND ((SETQ TEM (SI:FLAVOR-INCLUDES FL)) (FORMAT *TYPEOUT-WINDOW* "~& and directly includes flavor~P:~%" (LENGTH TEM)) (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST 'FLAVOR-NAME TEM))) (COND ((SETQ TEM (SI:FLAVOR-DEPENDED-ON-BY FL)) (FORMAT *TYPEOUT-WINDOW* "~& and is directly depended on by flavor~P:~%" (LENGTH TEM)) (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST 'FLAVOR-NAME TEM))) (LOCAL-DECLARE ((SPECIAL LIV)) ;For the REM-IF below (LET ((LIV (SI:FLAVOR-LOCAL-INSTANCE-VARIABLES FL))) (IF (NULL LIV) (FORMAT *TYPEOUT-WINDOW* "~&~S has no local instance variables~%" FLAVOR) (FORMAT *TYPEOUT-WINDOW* "~&Instance variable~P of ~S: ~{~S~^, ~}~%" (LENGTH LIV) FLAVOR LIV)) (AND (SETQ TEM (SI:FLAVOR-INSTANCE-SIZE FL)) (FORMAT *TYPEOUT-WINDOW* "Flavor ~S has instance size ~D, with inherited instance variables: ~{~S~^, ~}~%" FLAVOR TEM (REM-IF #'(LAMBDA (X) (MEMQ X LIV)) (SI:FLAVOR-ALL-INSTANCE-VARIABLES FL)))))) (SI:MAP-OVER-COMPONENT-FLAVORS 0 T NIL #'DESCRIBE-FLAVOR-1 FLAVOR (LIST NIL NIL) FLAVOR) (DO ((PLIST (SI:FLAVOR-PLIST FL) (CDDR PLIST)) (FLAG NIL)) ((NULL PLIST)) (COND ((NOT (MEMQ (CAR PLIST) '(:DEFAULT-INIT-PLIST :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES))) (COND ((NOT FLAG) (FORMAT *TYPEOUT-WINDOW* "Random properties:~%") (SETQ FLAG T))) (FORMAT *TYPEOUT-WINDOW* "~5X~S: ~S~%" (CAR PLIST) (CADR PLIST))))) NIL) ;;; Source bytes 16052:19125; lines 394-458; sha256 252fcff65c4ca58f7dee9c79d336f6052f6d8e97656a3279182afb2fae5c0139 (DEFUN DESCRIBE-FLAVOR-1 (FL STATE TOP-FLAVOR-NAME &AUX (FLAVOR-FLAG NIL)) (COND ((NOT (MEMQ FL (SECOND STATE))) (DO ((METHS (SI:FLAVOR-METHOD-TABLE FL) (CDR METHS)) (METH) (ELEM) (MSG) (MSG-FLAG NIL NIL) (TEM)) ((NULL METHS)) (SETQ METH (CAR METHS) MSG (FIRST METH) METH (CDDDR METH)) (OR (SETQ ELEM (ASSQ MSG (FIRST STATE))) (PUSH (SETQ ELEM (LIST MSG NIL NIL NIL NIL)) (FIRST STATE))) (COND ((AND (SETQ TEM (ASSQ ':BEFORE METH)) (NOT (MEMQ TEM (SECOND ELEM)))) (MULTIPLE-VALUE (FLAVOR-FLAG MSG-FLAG) (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (CADR TEM) "before" MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME)) (PUSH TEM (SECOND ELEM)))) (COND ((AND (SETQ TEM (ASSQ 'NIL METH)) (NULL (THIRD ELEM))) (MULTIPLE-VALUE (FLAVOR-FLAG MSG-FLAG) (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (CADR TEM) "primary" MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME)) (SETF (THIRD ELEM) TEM))) (COND ((AND (SETQ TEM (ASSQ ':AFTER METH)) (NOT (MEMQ TEM (FOURTH ELEM)))) (MULTIPLE-VALUE (FLAVOR-FLAG MSG-FLAG) (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (CADR TEM) "after" MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME)) (PUSH TEM (FOURTH ELEM)))) (COND ((AND (SETQ TEM (ASSQ ':WRAPPER METH)) (NOT (MEMQ TEM (FIFTH ELEM)))) (MULTIPLE-VALUE (FLAVOR-FLAG MSG-FLAG) (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (CADR TEM) "wrapper" MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME)) (PUSH TEM (FIFTH ELEM)))) (AND MSG-FLAG (TERPRI *TYPEOUT-WINDOW*))) (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST FL (SI:FLAVOR-GETTABLE-INSTANCE-VARIABLES FL) "automatically-generated methods to get instance variable" "" FLAVOR-FLAG TOP-FLAVOR-NAME)) (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST FL (SI:FLAVOR-SETTABLE-INSTANCE-VARIABLES FL) "automatically-generated methods to set instance variable" "" FLAVOR-FLAG TOP-FLAVOR-NAME)) (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST FL (SI:FLAVOR-INITABLE-INSTANCE-VARIABLES FL) "instance variable" " that may be set by initialization" FLAVOR-FLAG TOP-FLAVOR-NAME)) (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST FL (SI:FLAVOR-INIT-KEYWORDS FL) "keyword" " in the :INIT message" FLAVOR-FLAG TOP-FLAVOR-NAME)) (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST FL (GET (LOCF (SI:FLAVOR-PLIST FL)) ':OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES) "macros to access variable" "" FLAVOR-FLAG TOP-FLAVOR-NAME)) (LET ((DEFAULT-PLIST (GET (LOCF (SI:FLAVOR-PLIST FL)) ':DEFAULT-INIT-PLIST))) (COND (DEFAULT-PLIST (DESCRIBE-FLAVOR-PRINT-FLAVOR-NAME FL FLAVOR-FLAG TOP-FLAVOR-NAME) (FORMAT *TYPEOUT-WINDOW* " Plus default init plist: ") (DO ((L DEFAULT-PLIST (CDDR L)) (FLAG T NIL)) ((NULL L)) (FORMAT *TYPEOUT-WINDOW* "~:[, ~]~S ~S" FLAG (CAR L) (CADR L))) (TERPRI *TYPEOUT-WINDOW*)))) (PUSH FL (SECOND STATE)))) STATE) ;;; Source bytes 19127:19423; lines 460-465; sha256 7a60a743501eac887e175ebf1433139afa56db9542209faf0e3147c021352d94 (DEFUN DESCRIBE-FLAVOR-PRINT-FLAVOR-NAME (FL FLAG TOP-FLAVOR-NAME &AUX FLAVOR-NAME) (COND ((NOT FLAG) ;If not already printed (SETQ FLAVOR-NAME (SI:FLAVOR-NAME FL)) (FORMAT *TYPEOUT-WINDOW* "Method(s) ~:[inherited from~;of~] ~S:~%" (EQ FLAVOR-NAME TOP-FLAVOR-NAME) FLAVOR-NAME))) T) ;;; Source bytes 19449:19789; lines 467-472; sha256 93fa667ed02d740a0840d31ced2f2feb9d9ae2c6d1a5a1f85575d255ada18213 (DEFUN DESCRIBE-FLAVOR-PRINT-MSG (FL MSG FUNCTION TYPE MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME) (DESCRIBE-FLAVOR-PRINT-FLAVOR-NAME FL FLAVOR-FLAG TOP-FLAVOR-NAME) (OR MSG-FLAG (FORMAT *TYPEOUT-WINDOW* " :~A " MSG)) (FUNCALL *TYPEOUT-WINDOW* ':ITEM 'FUNCTION-NAME FUNCTION TYPE) (FUNCALL *TYPEOUT-WINDOW* ':TYO #\SP) (MVRETURN T T)) ;;; Source bytes 19820:20111; lines 474-478; sha256 6626dea313c8b5d260816892a22ee3eacfc20670159400ecbb2e55af9ace5c2b (DEFUN DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST (FL LIST STR1 STR2 FLAG TOP-FLAVOR-NAME) (COND (LIST ;If there is something there (DESCRIBE-FLAVOR-PRINT-FLAVOR-NAME FL FLAG TOP-FLAVOR-NAME) (FORMAT *TYPEOUT-WINDOW* " Plus ~A~P~A: ~{~:S~^, ~}~%" STR1 (LENGTH LIST) STR2 LIST) T))) ;;; Source bytes 20379:20644; lines 487-491; sha256 bc84ee0e69f8ea6a6add359ae08bd821ed378d641f83152a9705e687b8127b69 (DEFCOM COM-START-KBD-MACRO "Begin defining a keyboard macro" () (OR (MEMQ ':MACRO-PUSH (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS)) (BARF "This stream doesnt support macros")) (FUNCALL STANDARD-INPUT ':MACRO-PUSH (+ 2 *NUMERIC-ARG-N-DIGITS*)) DIS-NONE) ;;; Source bytes 20646:21057; lines 493-499; sha256 c205d877cc6001db986a68b55d150a104588edc444e2e5b8071795a28a09d374 (DEFCOM COM-END-KBD-MACRO "Terminate the definition of a keyboard macro" () (OR (MEMQ ':MACRO-POP (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS)) (BARF "This stream doesnt support macros")) (*CATCH 'MACRO-LOOP ;In case no macro running (FUNCALL STANDARD-INPUT ':MACRO-POP (+ 2 *NUMERIC-ARG-N-DIGITS*) (AND (NOT (ZEROP *NUMERIC-ARG*)) *NUMERIC-ARG*))) DIS-NONE) ;;; Source bytes 21059:21356; lines 501-505; sha256 123054040cff1290d47a0f89537f642f17dfa615d78e40825812ed8d16b8a876 (DEFCOM COM-CALL-LAST-KBD-MACRO "Repeat the last keyboard macro" () (OR (MEMQ ':MACRO-EXECUTE (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS)) (BARF "This stream doesnt support macros")) (FUNCALL STANDARD-INPUT ':MACRO-EXECUTE NIL (AND (NOT (ZEROP *NUMERIC-ARG*)) *NUMERIC-ARG*)) DIS-NONE) ;;; Source bytes 21358:21591; lines 507-511; sha256 3ea97490b3de5adc10c0c0e40e371917c98bca01c06e007a3c7b3bc40446953d (DEFCOM COM-KBD-MACRO-QUERY "Interactive keyboard macro" () (OR (MEMQ ':MACRO-QUERY (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS)) (BARF "This stream doesnt support macros")) (FUNCALL STANDARD-INPUT ':MACRO-QUERY) DIS-NONE) ;;; Source bytes 21593:22575; lines 513-537; sha256 c0ecbce004668314bae8559bad2411e0276e9749c295b3d37e98faec2953194d (DEFCOM COM-VIEW-KBD-MACRO "Typeout the specified keyboard macro. The macro should be a /"permanent/" macro, that has a name. The name of the macro is read from the mini-buffer, just cr means the last one defined, which can also be temporary." () (OR (MEMQ ':MACRO-PREVIOUS-ARRAY (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS)) (BARF "This stream does not support macros")) (LET ((PACKAGE SI:PKG-USER-PACKAGE) NAME MAC) (SETQ NAME (TYPEIN-LINE-READ "Name of macro to view (CR for last macro defined):")) (COND ((EQ NAME '*EOF*) (SETQ MAC (FUNCALL STANDARD-INPUT ':MACRO-PREVIOUS-ARRAY))) ((NOT (SETQ MAC (GET NAME 'MACRO-STREAM-MACRO))) (BARF "~A is not a defined macro." NAME))) (DO ((I 0 (1+ I)) (LEN (MACRO-LENGTH MAC)) (CH)) ((> I LEN)) (FORMAT T (SELECTQ (SETQ CH (AREF MAC I)) (*MOUSE* "Mouse command ~*") (*SPACE* "Macro query ~*") (*RUN* "Repeat ~*") (NIL "Input ~*") (OTHERWISE "~:C ")) CH))) DIS-NONE) ;;; Source bytes 22577:24327; lines 539-585; sha256 3d6876b8a9298f2423a58d7bb45d59de3da556c646a9bc611bc007885186108d (DEFCOM COM-DECLARE-SPECIAL "Add the nth previous word to the last special declaration" () (ATOM-WORD-SYNTAX-BIND (LET (WORD) (LET ((BP1 (FORWARD-WORD (POINT) (- *NUMERIC-ARG*))) BP2) (OR BP1 (BARF)) (SETQ BP2 (FORWARD-WORD BP1 1)) (OR BP2 (BARF)) (SETQ WORD (STRING-INTERVAL BP1 BP2 T))) (LET ((BP (DO-NAMED DECLARES ((LINE (BP-LINE (POINT)) (LINE-PREVIOUS LINE)) (LIMIT-LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)))) (NIL) (AND (STRING-EQUAL "(DECLARE " LINE 0 0 9 9) ;;Found a (DECLARE ...), look for SPECIAL in the CARs of the elements (DO ((BP1 (CREATE-BP LINE 9) (FORWARD-SEXP BP1)) (BP2) (BP3)) ((NULL BP1)) (OR (SETQ BP2 (FORWARD-LIST BP1 1 NIL 1 T)) (RETURN NIL)) (OR (SETQ BP3 (FORWARD-WORD BP2)) (RETURN NIL)) (AND (EQ (BP-LINE BP2) (BP-LINE BP3)) (STRING-EQUAL "SPECIAL" (BP-LINE BP2) 0 (BP-INDEX BP2) 7 (BP-INDEX BP3)) (SETQ BP2 (FORWARD-LIST BP1)) ;Found one (RETURN-FROM DECLARES (FORWARD-CHAR BP2 -1))))) ;;If there isnt a special declaration, make one at the start of the file (AND (EQ LINE LIMIT-LINE) (RETURN (FORWARD-CHAR (INSERT (SKIP-OVER-BLANK-LINES-AND-COMMENTS (INTERVAL-FIRST-BP *INTERVAL*) T) "(DECLARE (SPECIAL)) ") -3)))))) ;;Now put it in and try not to overflow the line (WITH-BP (PT (POINT) ':MOVES) ;Preserve point (MOVE-BP (POINT) BP) (INSERT-MOVING (POINT) (STRING-APPEND #\SP WORD)) (AUTO-FILL-HOOK #\SP) (COND ((END-LINE-P (POINT)) (MOVE-BP (POINT) (END-LINE (POINT) 1)) (INSERT (DELETE-BACKWARD-OVER *BLANKS* (POINT)) #\CR) (COM-INDENT-FOR-LISP))) (MOVE-BP (POINT) PT))))) DIS-TEXT) ;;; Source bytes 24454:25587; lines 592-616; sha256 bb6d0220cb89fac1b9a9a60ad4a03486c3200e79318440fc6cdfa57e838bc2d8 (DEFCOM COM-FIND-PATTERN "Move to next occurence of the given pattern. The pattern must be a list, ** matches any one thing, ... any number of things. A numeric argument repeats the last search." () (LET (FORM RESTART BP) (COND (*NUMERIC-ARG-P* (SETQ FORM (OR *LAST-PATTERN* (BARF "No previous pattern"))) (TYPEIN-LINE "Finding ~S" FORM) (AND (BP-= (POINT) *LAST-PATTERN-BP*) (SETQ RESTART *LAST-PATTERN-RESTART-LIST*))) (T (LET ((FORM-STRING (TYPEIN-LINE-READLINE "Pattern to search for:")) (EOF '(()))) (SETQ FORM (READ-FROM-STRING FORM-STRING EOF)) (AND (EQ FORM EOF) (BARF "Unbalanced parens")) (OR (LISTP FORM) (BARF "I only know how to search for lists")) ;; This is sort of a kludge (OR (EQ PACKAGE SI:PKG-USER-PACKAGE) (SETQ FORM (SUBLIS (LIST (CONS (INTERN "...") ':...) (CONS (INTERN "**") ':**)) FORM)))))) (MULTIPLE-VALUE (BP RESTART) (FIND-PATTERN (POINT) FORM RESTART)) (OR BP (BARF)) (MAYBE-PUSH-POINT BP) (MOVE-BP (POINT) BP) (SETQ *LAST-PATTERN* FORM *LAST-PATTERN-BP* BP *LAST-PATTERN-RESTART-LIST* RESTART)) DIS-BPS) ;;; Source bytes 28488:29105; lines 696-710; sha256 c8722436e3c83af69cb7c76808196fb15ce58bb47a91cf1c47573854ca058023 (DEFCOM COM-UNDO "Undo the last undoable command" () (OR (BOUNDP '*UNDO-START-BP*) (BARF "Nothing to undo")) (OR (EQ (BP-INTERVAL *UNDO-START-BP*) *INTERVAL*) (BARF "No longer in the same buffer")) (LET ((POINT (POINT)) (MARK (MARK)) (OLD *UNDO-OLD-INTERVAL*) (NAME *UNDO-TYPE*)) (TYPEIN-LINE "Undo ~A? " NAME) (COND ((TYPEIN-LINE-ACTIVATE (Y-OR-N-P NIL *TYPEIN-WINDOW*)) (MOVE-BP MARK *UNDO-START-BP*) (MOVE-BP POINT *UNDO-END-BP*) (UNDO-SAVE MARK POINT T "Undo") (DELETE-INTERVAL MARK POINT T) (INSERT-INTERVAL-MOVING POINT OLD) (TYPEIN-LINE "~A undone." NAME)))) DIS-TEXT)