Changeset 273


Ignore:
Timestamp:
08/18/11 17:35:01 (3 years ago)
Author:
rjs
Message:

Update from System 78.

Location:
trunk/lisp/zwei
Files:
8 added
6 deleted
25 edited

Legend:

Unmodified
Added
Removed
  • trunk/lisp/zwei/coma.lisp

    r258 r273  
    5050;;;    A larger, menu-like window for random stream output.
    5151
    52 (ENDF HEAD)
    53 
    5452(DEFCOM COM-SELF-INSERT "Inserts itself." (NM)
    5553  (LET ((CHAR (IN-CURRENT-FONT *LAST-COMMAND-CHAR*))
     
    5957           (INSERT-MOVING POINT CHAR))
    6058         (SETQ *CURRENT-COMMAND-TYPE* 'SELF-INSERT)
    61          (MVRETURN DIS-LINE LINE INDEX))))
     59         (VALUES DIS-LINE LINE INDEX))))
    6260
    6361(DEFCOM COM-QUOTED-INSERT "Insert a quoted character" (NM)
     
    9290count the characters the way ITS would count them, namely,
    9391count newlines as two characters rather than one.  This is useful for interpreting
    94 character counts returned by R and BOLIO." (KM)
     92character counts returned by R and BOLIO.
     93With no argument, just feep; the user was probably in Bolio mode and confused." (KM)
     94  (IF (NOT *NUMERIC-ARG-P*)
     95      (BARF))
    9596  (LET ((DEST (FUNCALL (IF (MINUSP *NUMERIC-ARG*) #'FORWARD-ITS-CHAR #'FORWARD-CHAR)
    9697                       (INTERVAL-FIRST-BP *INTERVAL*) (ABS *NUMERIC-ARG*))))
     
    125126                    ;; No argument give, going down.  Create a line.
    126127                    (SETQ RET DIS-TEXT)
    127                     (MOVE-BP POINT (INSERT (INTERVAL-LAST-BP *INTERVAL*) #\CR))
    128                     (SETQ *REAL-LINE-GOAL-XPOS* 0))
     128                    (MOVE-BP POINT (INSERT (INTERVAL-LAST-BP *INTERVAL*) #\CR)))
    129129                   (T
    130130                    ;; He was going forwards, go to end.
     
    139139                         (T (BP-INDENTATION POINT))))
    140140             (LET ((INDEX (INDENTATION-INDEX DEST *REAL-LINE-GOAL-XPOS*)))
    141                (MOVE-BP POINT DEST (OR INDEX (LINE-LENGTH DEST)))))))
     141               (MOVE-BP POINT DEST
     142                        (COND (INDEX)
     143                              ((NEQ DEST (BP-LINE (INTERVAL-LAST-BP *INTERVAL*)))
     144                               (LINE-LENGTH DEST))
     145                              (T (BP-INDEX (INTERVAL-LAST-BP *INTERVAL*)))))))))
    142146    RET))
    143147
    144148(DEFCOM COM-SET-GOAL-COLUMN "Sets the goal column for Up Real Line and Down Real Line." (KM)
    145   (SETQ *PERMANENT-REAL-LINE-GOAL-XPOS*
    146         (COND ((> *NUMERIC-ARG* 1) NIL)
    147               (T (BP-INDENTATION (POINT)))))
     149  (REPORT-COLUMN-SETTING "c-N//c-P goal column"
     150                         (SETQ *PERMANENT-REAL-LINE-GOAL-XPOS* (IF (> *NUMERIC-ARG* 1) NIL
     151                                                                  (BP-INDENTATION (POINT)))))
    148152  DIS-NONE)
    149153
     
    195199  DIS-NONE)
    196200
    197 (DEFCOM COM-BEGINNING-OF-LINE "Move to the beginning of the line." (KM)
    198   (MOVE-BP (POINT) (BEG-LINE (POINT) (1- *NUMERIC-ARG*)))
    199   DIS-BPS)
    200 
    201 (DEFCOM COM-END-OF-LINE "Move to the end of the line." (KM)
    202   (MOVE-BP (POINT) (END-LINE (POINT) (1- *NUMERIC-ARG*)))
     201(DEFCOM COM-BEGINNING-OF-LINE "Move to the beginning of the line.
     202With a numeric argument, also moves forward by a number of lines
     203one less than the argument." (KM)
     204  (MOVE-BP (POINT) (BEG-LINE (POINT) (1- *NUMERIC-ARG*) T))
     205  DIS-BPS)
     206
     207(DEFCOM COM-END-OF-LINE "Move to the end of the line.
     208With a numeric argument, also moves forward by a number of lines
     209one less than the argument." (KM)
     210  (MOVE-BP (POINT) (END-LINE (POINT) (1- *NUMERIC-ARG*) T))
    203211  DIS-BPS)
    204212
     
    257265
    258266(DEFCOM COM-SWAP-POINT-AND-MARK "Exchange point and the mark." (SM)
    259   (OR (EQ (BP-INTERVAL (POINT)) (BP-INTERVAL (MARK)))
     267  (OR (EQ (BP-TOP-LEVEL-NODE (POINT)) (BP-TOP-LEVEL-NODE (MARK)))
    260268      (BARF "Point and mark not in same buffer"))
    261269  (SWAP-BPS (POINT) (MARK))
     
    301309numeric argument is 2).  An argument of 1 rotates the whole point pdl
    302310and a negative argument rotates the other way." ()
    303   (ROTATE-POINT-PDL *WINDOW* (IF *NUMERIC-ARG-P* *NUMERIC-ARG* 2)))
     311  (ROTATE-POINT-PDL *WINDOW* (IF (MEMQ *NUMERIC-ARG-P* '(:SIGN NIL))
     312                                 (* 2 *NUMERIC-ARG*) *NUMERIC-ARG*)))
    304313
    305314(DEFVAR *DEFAULT-PREVIOUS-POINT-ARG* 3)
    306315(DEFCOM COM-MOVE-TO-DEFAULT-PREVIOUS-POINT "Rotate the point pdl.
    307316A numeric argument specifies the number of entries to rotate, and sets the new default." ()
    308   (AND *NUMERIC-ARG-P*
    309        (SETQ *DEFAULT-PREVIOUS-POINT-ARG* *NUMERIC-ARG*))
    310   (ROTATE-POINT-PDL *WINDOW* *DEFAULT-PREVIOUS-POINT-ARG*))
     317  (OR (MEMQ *NUMERIC-ARG-P* '(:SIGN NIL))
     318      (SETQ *DEFAULT-PREVIOUS-POINT-ARG* *NUMERIC-ARG*))
     319  (ROTATE-POINT-PDL *WINDOW* (IF (EQ *NUMERIC-ARG-P* ':SIGN)
     320                                 (* *NUMERIC-ARG* *DEFAULT-PREVIOUS-POINT-ARG*)
     321                                 *DEFAULT-PREVIOUS-POINT-ARG*)))
    311322
    312323(DEFCOM COM-INSERT-CRS "Insert one or more newlines into the buffer." ()
     
    374385(DEFCOM COM-DELETE-FORWARD "Delete one or more characters forward." ()
    375386  (LET ((POINT (POINT)))
    376     (LET ((BP (FORWARD-CHAR POINT *NUMERIC-ARG* T)))
    377       (COND ((EQ (BP-LINE POINT) (BP-LINE BP))
     387    (LET ((BP (FORWARD-CHAR POINT *NUMERIC-ARG*)))
     388      (COND ((NULL BP) (BARF))
     389            ((EQ (BP-LINE POINT) (BP-LINE BP))
    378390             (MUST-REDISPLAY *WINDOW*
    379391                             DIS-LINE
     
    414426                 (T
    415427                  (KILL-INTERVAL POINT (END-LINE POINT) T T)
    416                   (MVRETURN DIS-LINE (BP-LINE POINT) (BP-INDEX POINT))))))))
     428                  (VALUES DIS-LINE (BP-LINE POINT) (BP-INDEX POINT))))))))
    417429
    418430(DEFCOM COM-CLEAR "Kill to the start of the current line." ()
     
    436448  (SETQ *CURRENT-COMMAND-TYPE* 'KILL)
    437449  (REGION (BP1 BP2)
    438      (KILL-INTERVAL BP1 BP2 T T))
     450    (KILL-INTERVAL BP1 BP2 T T T))
    439451  (CLEAN-POINT-PDL *WINDOW*)
    440452  (LET ((PDL (WINDOW-POINT-PDL *WINDOW*)))
     
    450462n'th most recent kill from the ring." ()
    451463  (OR *KILL-RING* (BARF))
    452   (LET ((ARG (IF (EQ *NUMERIC-ARG-P* ':CONTROL-U) 0 (1- *NUMERIC-ARG*))))
     464  (LET ((ARG (COND ((EQ *NUMERIC-ARG-P* ':CONTROL-U)  0)
     465                   ((MINUSP *NUMERIC-ARG*) (+ (LENGTH *KILL-RING*) *NUMERIC-ARG*))
     466                   (T (1- *NUMERIC-ARG*)))))
    453467    (AND (
    454468 ARG (LENGTH *KILL-RING*)) (BARF))
    455469    (SETQ *CURRENT-COMMAND-TYPE* 'YANK)
    456470    (POINT-PDL-PUSH (POINT) *WINDOW* NIL NIL)
    457     (LET ((BP (INSERT-THING (POINT) (NTH ARG *KILL-RING*))))
     471    (LET ((BP (INSERT-KILL-RING-THING (POINT) (NTH ARG *KILL-RING*))))
    458472      (COND ((EQ *NUMERIC-ARG-P* ':CONTROL-U)
    459473             (MOVE-BP (MARK) BP))
     
    470484  (OR (EQ *LAST-COMMAND-TYPE* 'YANK) (BARF))
    471485  (SETQ *CURRENT-COMMAND-TYPE* 'YANK)
    472   (DELETE-INTERVAL (POINT) (MARK))
    473   (OR (ZEROP *NUMERIC-ARG*)
    474       (MOVE-BP (POINT) (INSERT-THING (POINT) (KILL-RING-POP (1- *NUMERIC-ARG*)))))
     486  (LET ((SWAP-P (BP-< (POINT) (MARK))))
     487    (DELETE-INTERVAL (POINT) (MARK))
     488    (OR (ZEROP *NUMERIC-ARG*)
     489        (MOVE-BP (POINT) (INSERT-KILL-RING-THING (POINT) (KILL-RING-POP (1- *NUMERIC-ARG*)))))
     490    (AND SWAP-P (SWAP-BPS (POINT) (MARK))))
    475491  DIS-TEXT)
    476492
     
    635651    (LET ((LIST (LIST BP1 BP2 BP3 BP4)))
    636652      (SETQ LIST (SORT LIST #'(LAMBDA (BP1 BP2)
    637                                 (AND (EQ (BP-INTERVAL BP1) (BP-INTERVAL BP2))
     653                                (AND (EQ (BP-TOP-LEVEL-NODE BP1) (BP-TOP-LEVEL-NODE BP2))
    638654                                     (BP-< BP1 BP2)))))
    639655      (SETQ BP1 (FIRST LIST)
     
    641657            BP3 (THIRD LIST)
    642658            BP4 (FOURTH LIST)))
    643     (OR (AND (EQ (BP-INTERVAL BP1) (BP-INTERVAL BP2))
    644              (EQ (BP-INTERVAL BP3) (BP-INTERVAL BP4)))
     659    (OR (AND (EQ (BP-TOP-LEVEL-NODE BP1) (BP-TOP-LEVEL-NODE BP2))
     660             (EQ (BP-TOP-LEVEL-NODE BP3) (BP-TOP-LEVEL-NODE BP4)))
    645661        (BARF "Regions are not both within single buffers"))
    646662    (WITH-BP (NBP2 (INSERT-INTERVAL BP2 BP3 BP4 T) ':NORMAL)
     
    655671  DIS-TEXT)
    656672
    657 (DEFUN REVERSE-SUBR (FN N &AUX (POINT (POINT)) BP-LIST)
     673(DEFUN REVERSE-SUBR (FN N &OPTIONAL (BP (POINT)) BP-LIST)
    658674  (AND (MINUSP N)
    659        (SETQ POINT (FUNCALL FN POINT N)
     675       (SETQ BP (FUNCALL FN BP N)
    660676             N (- N)))
    661677  (UNWIND-PROTECT
    662678    (PROGN
    663679      (DO ((I 0 (1+ I))
    664            (START-BP POINT END-BP)
     680           (START-BP BP END-BP)
    665681           (END-BP))
    666682          ((
    667683 I N)
    668            (UNDO-SAVE POINT END-BP T "Reverse"))
     684           (UNDO-SAVE BP END-BP T "Reverse"))
    669685        (SETQ END-BP (OR (FUNCALL FN START-BP 1) (BARF))
    670686              START-BP (OR (FUNCALL FN END-BP -1) (BARF)))
     
    682698        (SETQ RIGHT-START-BP (CAAR LIST-FROM-THE-RIGHT)
    683699              RIGHT-END-BP (CADAR LIST-FROM-THE-RIGHT))
    684         (INSERT-INTERVAL LEFT-START-BP RIGHT-START-BP RIGHT-END-BP T)
    685         (DELETE-INTERVAL RIGHT-START-BP RIGHT-END-BP T)
    686         (INSERT-INTERVAL RIGHT-START-BP LEFT-START-BP LEFT-END-BP T)
    687         (DELETE-INTERVAL LEFT-START-BP LEFT-END-BP T)))
     700        (INSERT-INTERVAL LEFT-START-BP
     701                         (PROG1 (COPY-INTERVAL RIGHT-START-BP RIGHT-END-BP T)
     702                                (DELETE-INTERVAL RIGHT-START-BP RIGHT-END-BP T)))
     703        (INSERT-INTERVAL RIGHT-START-BP
     704                         (PROG1 (COPY-INTERVAL LEFT-START-BP LEFT-END-BP T)
     705                                (DELETE-INTERVAL LEFT-START-BP LEFT-END-BP T)))))
    688706    (DO ((BPS BP-LIST (CDR BPS)))
    689707        ((NULL BPS))
     
    695713  DIS-TEXT)
    696714
     715(DEFCOM COM-REVERSE-FOLLOWING-LIST "Reverse the elements of the list after point" ()
     716  (LET* ((BP (POINT))
     717         (COUNT (OR (COUNT-LIST-ELEMENTS BP) (BARF))))
     718    (REVERSE-SUBR #'FORWARD-SEXP COUNT (FORWARD-LIST BP 1 NIL -1 T)))
     719  DIS-TEXT)
     720
    697721(DEFUN KILL-COMMAND-INTERNAL (FUNCTION ARG &AUX (POINT (POINT)))
    698   (KILL-INTERVAL-ARG POINT
    699                      (OR (FUNCALL FUNCTION POINT ARG) (BARF))
    700                      ARG)
    701   (SETQ *CURRENT-COMMAND-TYPE* 'KILL)
    702   (MOVE-BP (MARK) POINT)
    703   DIS-TEXT)
     722  (LET* ((OTHER-END (OR (FUNCALL FUNCTION POINT ARG) (BARF)))
     723         (SAME-LINE-P (EQ (BP-LINE POINT) (BP-LINE OTHER-END))))
     724    (KILL-INTERVAL-ARG POINT OTHER-END ARG)
     725    (SETQ *CURRENT-COMMAND-TYPE* 'KILL)
     726    (MOVE-BP (MARK) POINT)
     727    (COND ((AND SAME-LINE-P
     728                (= (BP-INDEX POINT) (LINE-LENGTH (BP-LINE POINT))))
     729           (VALUES DIS-LINE (BP-LINE POINT) (BP-INDEX POINT)))
     730          (T DIS-TEXT))))
    704731
    705732(DEFCOM COM-FORWARD-WORD "Move one or more words forward." (KM)
     
    773800(DEFCOM COM-FORWARD-UP-LIST "Move up one level of list structure, forward.
    774801Also, if called inside of a string, moves up out of that string." (KM)
    775   (LET ((BP (IF (LISP-BP-SYNTACTIC-CONTEXT (POINT))
    776                 (FORWARD-UP-STRING (POINT) (MINUSP *NUMERIC-ARG*))
    777                 (FORWARD-SEXP (POINT) *NUMERIC-ARG* NIL 1))))
     802  (LET ((BP (FORWARD-UP-LIST-OR-STRING (POINT) *NUMERIC-ARG*)))
    778803    (OR BP (BARF))
    779804    (MOVE-BP (POINT) BP))
     
    782807(DEFCOM COM-BACKWARD-UP-LIST "Move up one level of list structure, backward.
    783808Also, if called inside of a string, moves back up out of that string." (KM)
    784   (LET ((BP (IF (LISP-BP-SYNTACTIC-CONTEXT (POINT))
    785                 (FORWARD-UP-STRING (POINT) (NOT (MINUSP *NUMERIC-ARG*)))
    786                 (FORWARD-SEXP (POINT) (- *NUMERIC-ARG*) NIL 1))))
     809  (LET ((BP (FORWARD-UP-LIST-OR-STRING (POINT) (- *NUMERIC-ARG*))))
    787810    (OR BP (BARF))
    788811    (MOVE-BP (POINT) BP))
     
    797820(DEFCOM COM-END-OF-DEFUN "Go to the end of the current defun." (KM)
    798821  (LET ((BP (FORWARD-DEFUN (POINT) -1 T)))              ;Go to front of defun.
    799     (OR (SETQ BP (FORWARD-LIST BP)) (BARF))             ; and forward over it.
     822    (OR (SETQ BP (FORWARD-SEXP BP)) (BARF))             ; and forward over it.
    800823    (SETQ BP (BEG-LINE BP 1 T))
    801824    (COND ((OR (BP-< BP (POINT))                      ;If we were between defuns,
    802825               (AND (PLUSP *NUMERIC-ARG*) (BP-= BP (POINT))))
    803826           (SETQ BP (END-LINE BP -1 T))
    804            (OR (SETQ BP (FORWARD-LIST (FORWARD-DEFUN BP 1 T)))
     827           (OR (SETQ BP (FORWARD-SEXP (FORWARD-DEFUN BP 1 T)))
    805828               (BARF))
    806829           (SETQ BP (BEG-LINE BP 1 T))))              ; then move ahead another.
    807830    (POINT-PDL-PUSH (POINT) *WINDOW*)
    808831    (OR (= *NUMERIC-ARG* 1)
    809         (SETQ BP (BEG-LINE (FORWARD-LIST (FORWARD-DEFUN BP (1- *NUMERIC-ARG*) T) 1 T) 1 T)))
     832        (SETQ BP (BEG-LINE (FORWARD-SEXP (FORWARD-DEFUN BP (1- *NUMERIC-ARG*) T) 1 T) 1 T)))
    810833    (MOVE-BP (POINT) BP))
    811834  DIS-BPS)
  • trunk/lisp/zwei/comb.lisp

    r258 r273  
    2121         (DOTIMES (I ARG)
    2222           (SETQ BP (FORWARD-PAGE BP 1 T)))))
    23   (MVRETURN BP (FORWARD-PAGE BP)))
    24 
    25 ;;; Make this a variable just in case someone wants to modify it
    26 (DEFVAR *MATCHING-DELIMITER-LIST*
    27         '((#/( #/) FORWARD-SEXP) (#/" #/" FORWARD-WORD) (#/[ #/] FORWARD-SEXP)
    28           (#/{ #/} FORWARD-SEXP) (#/< #/> FORWARD-WORD) (#/* #/* FORWARD-WORD)
    29           (#/ #/ FORWARD-WORD)))
     23  (VALUES BP (FORWARD-PAGE BP)))
     24
     25(DEFCOM COM-FORWARD-OVER-MATCHING-DELIMITERS "Move over matching delimiters" (KM)
     26  (LET ((POINT (POINT))
     27        (CLOSE) (OPEN))
     28    (DO ((L *MATCHING-DELIMITER-LIST* (CDR L))
     29         (CH (LDB %%KBD-CHAR *LAST-COMMAND-CHAR*)))
     30        ((NULL L))
     31      (COND ((= CH (CADAR L))
     32             (SETQ CLOSE CH
     33                   OPEN (CAAR L))
     34             (RETURN))))
     35    (MOVE-BP POINT (OR (FORWARD-OVER-MATCHING-DELIMITERS POINT *NUMERIC-ARG* NIL 0 OPEN CLOSE)
     36                       (BARF))))
     37  DIS-BPS)
     38
     39(DEFCOM COM-BACKWARD-OVER-MATCHING-DELIMITERS "Move over matching delimiters" (KM)
     40  (LET ((POINT (POINT))
     41        (CLOSE) (OPEN))
     42    (DO ((L *MATCHING-DELIMITER-LIST* (CDR L))
     43         (CH (LDB %%KBD-CHAR *LAST-COMMAND-CHAR*)))
     44        ((NULL L))
     45      (COND ((= CH (CAAR L))
     46             (SETQ OPEN CH
     47                   CLOSE (CADAR L))
     48             (RETURN))))
     49    (MOVE-BP POINT (OR (FORWARD-OVER-MATCHING-DELIMITERS POINT (- *NUMERIC-ARG*)
     50                                                         NIL 0 OPEN CLOSE)
     51                       (BARF))))
     52  DIS-BPS)
    3053
    3154(DEFCOM COM-MAKE-/(/) "Insert matching delimiters, putting point between them.
     
    5679(DEFCOM COM-DELETE-/(/) "Delete both of the nth innermost pair of parens enclosing point." ()
    5780  (LET ((POINT (POINT)))
    58     (LET ((BP1 (OR (FORWARD-LIST POINT *NUMERIC-ARG* NIL 1) (BARF)))
    59           (BP2 (OR (FORWARD-LIST POINT (- *NUMERIC-ARG*) NIL 1) (BARF))))
     81    (LET ((BP1 (OR (FORWARD-UP-LIST-OR-STRING POINT *NUMERIC-ARG*) (BARF)))
     82          (BP2 (OR (FORWARD-UP-LIST-OR-STRING POINT (- *NUMERIC-ARG*) NIL NIL) (BARF))))
    6083      (DELETE-INTERVAL (FORWARD-CHAR BP1 -1) BP1)
    6184      (DELETE-INTERVAL BP2 (FORWARD-CHAR BP2 1))
     
    7598    (LET ((BP (OR (IF CHAR (SEARCH (POINT) CHAR) (FORWARD-LIST POINT 1 NIL 1)) (BARF))))
    7699      (MOVE-BP (POINT) BP)
    77       (DELETE-BACKWARD-OVER *WHITESPACE-CHARS* (FORWARD-CHAR BP -1))
     100      (LET* ((BP1 (FORWARD-CHAR BP -1))
     101             (BP2 (BACKWARD-OVER *WHITESPACE-CHARS* BP1)))
     102        ;; Flush whitespace before this point,
     103        ;; unless that would move us to the end of a comment.
     104        (OR (MULTIPLE-VALUE-BIND (NIL NIL X) (LISP-BP-SYNTACTIC-CONTEXT BP2) X)
     105            (DELETE-INTERVAL BP2 BP1 T)))
    78106      (LET ((ARG (1- *NUMERIC-ARG*)))
    79107        (AND (> ARG 0)
     
    253281  DIS-TEXT)
    254282
    255 (DEFUN INDENT-FOR-COMMENT (BP &OPTIONAL (TIMES 1) CREATE-P MOVE-TO-NEXT-P &AUX (UP-P 1))
     283(DEFUN INDENT-FOR-COMMENT (BP &OPTIONAL (TIMES 1) CREATE-P MOVE-TO-NEXT-P BEG-LINE-NOT-SPECIAL
     284                              &AUX (UP-P 1))
    256285  (SETQ BP (COPY-BP BP ':MOVES))
    257286  (AND (MINUSP TIMES)
     
    273302           (MOVE-BP BP LINE START-START-INDEX)
    274303           ;; Distinguish between ";", ";;" and ";;;" type comments.
    275            (COND ((AND (> LEN (1+ START-START-INDEX))
     304           (COND ((AND (ZEROP START-START-INDEX)        ;At the beginning of the line stays
     305                       (NOT BEG-LINE-NOT-SPECIAL)))
     306                 ((AND (> LEN (1+ START-START-INDEX))
    276307                       (CHAR-EQUAL (AREF LINE (1+ START-START-INDEX))
    277308                                   (SETQ CH (AREF LINE START-START-INDEX))))
    278309                  (COND ((OR (
    279  LEN (+ START-START-INDEX 2))   ; ";;;" doesnt move
     310 LEN (+ START-START-INDEX 2))   ; ";;;" doesn't move
    280311                             (NOT (CHAR-EQUAL CH (AREF LINE (+ START-START-INDEX 2)))))
    281312                         ;; It is a double semicolon, indent as code.
     
    298329;; Internal function of above.
    299330(DEFUN INDENT-TO-COMMENT-COLUMN (BP)
    300   (LET ((HERE (BP-INDENTATION BP))
     331  (LET ((HERE (BP-VIRTUAL-INDENTATION BP))
    301332        (GOAL *COMMENT-COLUMN*))
    302333    (COND ((
     
    331362(DEFCOM COM-KILL-COMMENT "Delete any comment on the current line." ()
    332363  (LET ((LEN (LINE-LENGTH (BP-LINE (POINT)))))
    333     (KILL-COMMENT (BP-LINE (POINT)) NIL)
     364    (KILL-COMMENT (BP-LINE (POINT)))
    334365    (OR (= LEN (LINE-LENGTH (BP-LINE (POINT))))
    335366        (MOVE-BP (POINT) (END-LINE (POINT)))))
     
    337368
    338369(DEFCOM COM-UNCOMMENT-REGION "Delete any comments within the region." ()
     370  (REGION (BP1 BP2)
     371    (UNDO-SAVE BP1 BP2 T "Uncomment region"))
    339372  (REGION-LINES (START-LINE STOP-LINE)
    340373    (DO ((LINE START-LINE (LINE-NEXT LINE)))
    341374        ((EQ LINE STOP-LINE))
    342       (KILL-COMMENT LINE T)
    343       (SETQ *LAST-COMMAND-TYPE* 'KILL)))
    344   DIS-TEXT)
    345 
    346 ;; Kill the comment on the line with BP.  APPEND-P = NIL means don't append to
    347 ;; a previous kill.  T means do append, and append an additional CR.
    348 (DEFUN KILL-COMMENT (LINE APPEND-P &AUX START-INDEX)
    349   (OR APPEND-P (SETQ *LAST-COMMAND-TYPE* NIL))
     375      (KILL-COMMENT LINE)))
     376  DIS-TEXT)
     377
     378;; Kill the comment on the line with BP.
     379(DEFUN KILL-COMMENT (LINE &AUX START-INDEX)
    350380  (AND (SETQ START-INDEX (FIND-COMMENT-START LINE T))
    351381       (LET ((BP (CREATE-BP LINE START-INDEX)))
    352          (KILL-INTERVAL (BACKWARD-OVER *BLANKS* BP) (END-LINE BP) T)
    353          (AND APPEND-P (INSERT (INTERVAL-LAST-BP (CAR *KILL-RING*)) #\CR))))
     382         (KILL-INTERVAL (BACKWARD-OVER *BLANKS* BP) (END-LINE BP) T)))
    354383  (SETQ *CURRENT-COMMAND-TYPE* 'KILL))
    355384
     
    394423               (*NUMERIC-ARG* 1))
    395424           (COM-INDENT-COMMENT-RELATIVE)))
    396         (T
    397          (TYPEIN-LINE "Comment column = ~D"
    398                       (SETQ *COMMENT-COLUMN* (BP-INDENTATION (POINT))))
    399          DIS-NONE)))
     425        (T (REPORT-COLUMN-SETTING "Comment column"
     426                                  (SETQ *COMMENT-COLUMN* (BP-INDENTATION (POINT))))
     427           DIS-NONE)))
     428
     429(DEFUN REPORT-COLUMN-SETTING (NAME NPIXELS)
     430  (COND ((NUMBERP NPIXELS)
     431         (TYPEIN-LINE "~A = ~D pixels" NAME NPIXELS)
     432         (LET ((FONT (CURRENT-FONT *WINDOW*)))
     433           (IF (NULL (FONT-CHAR-WIDTH-TABLE FONT))
     434               (TYPEIN-LINE-MORE " (~D characters)" (// NPIXELS (FONT-CHAR-WIDTH FONT))))))
     435        (T (TYPEIN-LINE "~A disabled" NAME)))
     436  NPIXELS)
    400437
    401438(DEFCOM COM-INDENT-NEW-COMMENT-LINE "Insert newline, then start new comment.
     
    409446    (COND ((OR (NOT START) (< (BP-INDEX PT) START))
    410447           (MUST-REDISPLAY *WINDOW* (KEY-EXECUTE #\CR))
    411            (IF *SPACE-INDENT-FLAG* (KEY-EXECUTE #\TAB) DIS-NONE))
     448           (COND ((PLUSP (STRING-LENGTH *FILL-PREFIX*))
     449                  (INSERT-MOVING (POINT) *FILL-PREFIX*)
     450                  DIS-TEXT)
     451                 (*SPACE-INDENT-FLAG*
     452                  (KEY-EXECUTE #\TAB))
     453                 (T
     454                  (DELETE-OVER *BLANKS* (POINT))
     455                  DIS-TEXT)))
    412456          (T
    413457           (INSERT-MOVING PT *COMMENT-END*)
    414458           (INSERT PT (SUBSTRING (BP-LINE PT) START END))
    415459           (MUST-REDISPLAY *WINDOW* (KEY-EXECUTE #\CR))
    416            (COM-INDENT-FOR-COMMENT)))))
     460           (MOVE-BP PT (INDENT-FOR-COMMENT PT 1 NIL NIL T))
     461           DIS-TEXT))))
    417462
    418463(DEFCOM COM-END-COMMENT "Terminate comment on this line and move to the next.
     
    432477(DEFCOM COM-SET-FILL-COLUMN "Set the fill column from point's current hpos.
    433478With an argument, if it is less than 200., set fill column to that many characters;
    434 otherwise set it to that many pixels." ()
    435   (LET ((COL (COND (*NUMERIC-ARG-P*
    436                     (COND ((< *NUMERIC-ARG* 200.)
    437                            (* *NUMERIC-ARG* (FONT-SPACE-WIDTH)))
    438                           (T *NUMERIC-ARG*)))
    439                    (T (BP-INDENTATION (POINT))))))
    440     (TYPEIN-LINE "Fill Column = ~D. pixels." COL)
    441     (SETQ *FILL-COLUMN* COL))
     479otherwise set it to that many pixels." (KM)
     480  (SETQ *FILL-COLUMN*
     481        (REPORT-COLUMN-SETTING "Fill column"
     482                               (COND (*NUMERIC-ARG-P*
     483                                      (COND ((< *NUMERIC-ARG* 200.)
     484                                             (* *NUMERIC-ARG* (FONT-SPACE-WIDTH)))
     485                                            (T *NUMERIC-ARG*)))
     486                                     (T (BP-INDENTATION (POINT))))))
    442487  DIS-NONE)
    443488
     
    459504a Set Fill Prefix at the beginning of a line." ()
    460505  (SETQ *FILL-PREFIX* (SUBSTRING (BP-LINE (POINT)) 0 (BP-INDEX (POINT))))
     506  (TYPEIN-LINE "Fill prefix = ~S" *FILL-PREFIX*)
    461507  DIS-NONE)
    462508
     
    464510Comment must begin at the start of the line" (KM)
    465511  (LET ((BP1 (BACKWARD-OVER-COMMENT-LINES (POINT)))
    466         BP2 LINE1 LINE2 (MINEND 177777) LINE3 NON-COMMENT-LINES)
     512        BP2 LINE1 LINE2 (MINEND 177777) LINE3)
     513    (SETQ BP1 (FORWARD-OVER-BLANK-OR-PAGE-LINES BP1))
    467514    (SETQ BP2 (SKIP-OVER-BLANK-LINES-AND-COMMENTS BP1 T)
    468515          LINE1 (BP-LINE BP1) LINE2 (BP-LINE BP2))
     
    475522      (IF START
    476523          (SETQ LINE3 LINE                      ;Remember a non-blank line
    477                 MINEND (MIN MINEND END))
    478           (PUSH LINE NON-COMMENT-LINES)))
     524                MINEND (MIN MINEND END))))
    479525    (OR LINE3 (BARF "No comment starting at beginning of line"))
    480526    (LET ((*FILL-PREFIX* (SUBSTRING LINE3 0 MINEND)))
    481       (FILL-INTERVAL BP1 (END-LINE BP2 -1) T)
    482       (DOLIST (LINE NON-COMMENT-LINES)          ;Now remove excess comments
    483         (AND (STRING-EQUAL LINE *FILL-PREFIX*)
    484              (SETF (LINE-LENGTH LINE) 0)))))
     527      (FILL-INTERVAL BP1 (END-LINE BP2 -1) T)))
    485528  DIS-TEXT)
    486529
     
    625668      (LET ((POS (BP-INDENTATION PT))
    626669            (X (* 10 FONT-SPACE-WIDTH))
    627             (SPACE (DPB *FONT* %%CH-FONT #\SP)))
     670            (SPACE (IN-CURRENT-FONT #\SP)))
    628671        (DO L (// (- (* X (1+ (// POS X))) POS) FONT-SPACE-WIDTH) (1- L) (
    629672 L 0)
    630673            (INSERT-MOVING PT SPACE)))))
    631     DIS-TEXT)
     674  DIS-TEXT)
    632675
    633676(DEFCOM COM-INSERT-TAB "Insert a Tab in the buffer at point." ()
     
    755798    (OR (FIND-BP-IN-WINDOW *WINDOW* LINE 0)
    756799        (FUNCALL *TYPEIN-WINDOW* ':LINE-OUT LINE))
    757     (MOVE-BP PT (INDENT-LINE PT INDENTATION)))
     800    (INDENT-TO PT INDENTATION))
    758801  DIS-TEXT)
    759802
     
    771814             (NULL (SETQ IND (INDENT-RELATIVE PT))))
    772815         (COM-TAB-TO-TAB-STOP)
    773          (DELETE-BACKWARD-OVER *BLANKS* PT)
     816         (DELETE-AROUND *BLANKS* PT)
    774817         (MOVE-BP PT (INDENT-TO PT IND))
    775818         DIS-TEXT)))
     
    777820(DEFUN INDENT-RELATIVE (BP &OPTIONAL (RESTART-OK T) INDENT-TO-WORDS &AUX START DEST BP1 L)
    778821  (SETQ BP1 (BACKWARD-OVER *BLANKS* BP)
     822        BP (FORWARD-OVER *BLANKS* BP)
    779823        L (DO ((L (BP-LINE BP))
    780824               (FIRST (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*))))
     
    786830        ;; L is the previous non-blank line.
    787831        ;; BP1 is at the beginning of the current line whitespace.
    788         ((OR (AND (SETQ START (INDENTATION-INDEX L (BP-INDENTATION BP)))
     832        ((OR (AND (SETQ START (INDENTATION-INDEX L (BP-INDENTATION BP) NIL NIL T))
    789833                  (< START (LINE-LENGTH L)))
    790834             (AND RESTART-OK
    791                   (SETQ START (INDENTATION-INDEX L (BP-INDENTATION BP1)))))
     835                  (SETQ START (INDENTATION-INDEX L (BP-INDENTATION BP1) NIL NIL T))))
    792836         (SETQ DEST (IF (AND INDENT-TO-WORDS (ZEROP START)) START
    793837                        (STRING-SEARCH-SET *BLANKS* L START)))
     
    822866If called repeatedly, makes multiple attempts." ()
    823867  (LET ((POINT (POINT)) IND)
     868    (SETQ POINT (FORWARD-OVER *BLANKS* (BEG-LINE POINT)))
    824869    (OR (EQ *LAST-COMMAND-TYPE* 'INDENT-DIFFERENTLY)
    825870        (SETQ *INDENT-DIFFERENTLY-REPETITION-LEVEL* 0
     
    878923             (OR (PLUSP (SETQ TIMES (1- TIMES))) (RETURN T)))))
    879924    (INDENT-LINE POINT IND)
    880     (INDENT-BP-ADJUSTMENT POINT))
    881   DIS-TEXT)
     925    (INDENT-BP-ADJUSTMENT (POINT)))
     926  DIS-TEXT)
  • trunk/lisp/zwei/comc.lisp

    r258 r273  
    1 ;;; Zwei commands, see ZWEI;COMA for comments -*-Mode:LISP; Package:ZWEI-*-
     1;;; Zwei compiler commands, see ZWEI;COMA for comments -*-Mode:LISP; Package:ZWEI-*-
    22;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
    3 
    4 (DEFUN MAYBE-PUSH-POINT (BP)
    5   (AND *AUTO-PUSH-POINT-OPTION*
    6        (BPS-FAR-APART BP (POINT) *AUTO-PUSH-POINT-OPTION*)
    7        (POINT-PDL-PUSH BP *WINDOW*)))
    8 
    9 (DEFCOM COM-INSTALL-COMMAND "Install a specified function on a specified key.
    10 The name of the function is read from the mini-buffer (the top of the kill ring
    11 contains the name of the current defun), and a character from the echo area.
    12 If the key is currently holding a command prefix (like Control-X), it will ask
    13 you for another character, so that you can redefine Control-X commands.  However,
    14 with a numeric argument, it will assume you want to redefine Control-X itself,
    15 and will not ask for another character." ()
    16     (DO (NAME) (NIL)
    17       (SETQ NAME (READ-FUNCTION-NAME "Name of function to install"
    18                                      (RELEVANT-FUNCTION-NAME (POINT)) NIL 'ALWAYS-READ))
    19       (AND (OR (FBOUNDP NAME)
    20                (TYPEIN-LINE-ACTIVATE
    21                  (TYPEIN-LINE "~A is not defined, ok to install anyway? " NAME)
    22                  (Y-OR-N-P NIL *TYPEIN-WINDOW*)))
    23            (RETURN (INSTALL-COMMAND-INTERNAL NAME)))))
    24 
    25 (DEFCOM COM-INSTALL-MACRO "Install a specified user macro on a specifed key.
    26 The macro should be a /"permanent/" macro, that has a name.
    27 The name of the macro is read from the mini-buffer, and the keystroke on which
    28 to install it is read in the echo area.
    29 If the key is currently holding a command prefix (like Control-X), it will ask
    30 you for another character, so that you can redefine Control-X commands.  However,
    31 with a numeric argument, it will assume you want to redefine Control-X itself,
    32 and will not ask for another character." ()
    33   (OR (MEMQ ':MACRO-PREVIOUS-ARRAY (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))
    34       (BARF "This stream does not support macros"))
    35   (LET ((PACKAGE SI:PKG-USER-PACKAGE)
    36         NAME MAC)
    37     (SETQ NAME (TYPEIN-LINE-READ "Name of macro to install (CR for last macro defined):"))
    38     (COND ((EQ NAME '*EOF*)
    39            (SETQ MAC (FUNCALL STANDARD-INPUT ':MACRO-PREVIOUS-ARRAY)
    40                  NAME (GENSYM))
    41            (PUTPROP NAME MAC 'MACRO-STREAM-MACRO))
    42           ((NOT (SETQ MAC (GET NAME 'MACRO-STREAM-MACRO)))
    43            (BARF "~A is not a defined macro." NAME)))
    44     (INSTALL-COMMAND-INTERNAL (MAKE-MACRO-COMMAND NAME))))
    45 
    46 (DEFUN INSTALL-COMMAND-INTERNAL (COMMAND)
    47   (PROMPT-LINE "Key to get it:")
    48   (PROMPT-LINE-ACTIVATE
    49     (WITHOUT-IO-BUFFER-OUTPUT-FUNCTION
    50       (DO ((COMTAB *COMTAB*)
    51            (KEY (FUNCALL STANDARD-INPUT ':MOUSE-OR-KBD-TYI)
    52                 (FUNCALL STANDARD-INPUT ':TYI)))
    53           (NIL)
    54         (PROMPT-LINE-MORE " ~:@C" KEY)
    55         (LET ((OLD-COMMAND (COMMAND-LOOKUP KEY COMTAB)))
    56           (COND ((AND (PREFIX-COMMAND-P OLD-COMMAND)
    57                       (NOT *NUMERIC-ARG-P*))
    58                  (SETQ COMTAB (SYMEVAL-IN-CLOSURE OLD-COMMAND 'COMTAB)))
    59                 (T (COMMAND-STORE COMMAND KEY COMTAB)
    60                    (RETURN NIL)))))))
    61   DIS-NONE)
    62 
    63 (DEFCOM COM-COUNT-LINES-REGION "Print the number of lines in the region in the echo area." ()
    64   (REGION (BP1 BP2)
    65     (TYPEIN-LINE "~D line~:P.  " (1- (COUNT-LINES BP1 BP2 T))))
    66   DIS-NONE)
    67 
    68 (DEFCOM COM-WHERE-AM-I "Print various things about where the point is.
    69 Print the X and Y positions, the octal code for the following character,
    70 the current line number and its percentage of the total file size.
    71 If there is a region, the number of lines in it is printed.
    72 Fast Where Am I prints a subset of this information faster." ()
    73   (REDISPLAY *WINDOW* ':POINT NIL NIL T)
    74   (LET ((POINT (POINT))
    75         (FIRST-BP (INTERVAL-FIRST-BP *INTERVAL*))
    76         (LAST-BP (INTERVAL-LAST-BP *INTERVAL*)))
    77     (LET ((POINT-LINES (1- (COUNT-LINES FIRST-BP POINT)))
    78           (INTERVAL-LINES (1- (COUNT-LINES FIRST-BP LAST-BP)))
    79           (AT-END-P (BP-= (INTERVAL-LAST-BP *INTERVAL*) POINT))
    80           (BP-IND (BP-INDENTATION POINT))
    81           (SW (FONT-SPACE-WIDTH)))
    82       (TYPEIN-LINE "X=[~D. chars|~D. pixels|~:[~S~;~D.~] columns] ~
    83                         Y=~D.~@[ Char=~O~] Line=~D.(~D%)"
    84                    (BP-INDEX POINT)
    85                    BP-IND
    86                    (ZEROP (\ BP-IND SW))
    87                    (IF (ZEROP (\ BP-IND SW))
    88                        (// BP-IND SW)
    89                        (// (FLOAT BP-IND) SW))
    90                    (FIND-BP-IN-WINDOW *WINDOW* POINT)
    91                    (AND (NOT AT-END-P) (BP-CHAR POINT))
    92                    POINT-LINES
    93                    (IF (ZEROP INTERVAL-LINES)
    94                        0
    95                        (// (* 100. POINT-LINES) INTERVAL-LINES)))))
    96   (AND (WINDOW-MARK-P *WINDOW*)
    97        (REGION (BP1 BP2)
    98          (TYPEIN-LINE-MORE ", Region has ~D line~:P.  " (1- (COUNT-LINES BP1 BP2 T)))))
    99   DIS-NONE)
    100 
    101 (DEFCOM COM-FAST-WHERE-AM-I "Quickly print various things about where the point is.
    102 Print the X and Y positions, and the octal code for the following character.
    103 Where Am I prints the same things and more." ()
    104   (REDISPLAY *WINDOW* ':POINT NIL NIL T)
    105   (LET ((POINT (POINT)))
    106     (LET ((AT-END-P (BP-= (INTERVAL-LAST-BP *INTERVAL*) POINT))
    107           (BP-IND (BP-INDENTATION POINT))
    108           (SW (FONT-SPACE-WIDTH)))
    109       (TYPEIN-LINE "X=[~D. chars|~D. pixels|~:[~S~;~D.~] columns] Y=~D.~@[ Char=~O~]"
    110                    (BP-INDEX POINT)
    111                    BP-IND
    112                    (ZEROP (\ BP-IND SW))
    113                    (IF (ZEROP (\ BP-IND SW))
    114                        (// BP-IND SW)
    115                        (// (FLOAT BP-IND) SW))
    116                    (FIND-BP-IN-WINDOW *WINDOW* POINT)
    117                    (AND (NOT AT-END-P) (BP-CHAR POINT)))))
    118   DIS-NONE)
    119 
    120 (DEFCOM COM-ARGLIST "Print the argument list of the specified function.
    121 Reads the name of the function from the mini-buffer (the top of the kill
    122 ring has the /"current/" function from the buffer) and prints the arglist
    123 in the echo area." ()
    124   (LET ((NAME (READ-FUNCTION-NAME "Arglist" (RELEVANT-FUNCTION-NAME (POINT)) T)))
    125     (PRINT-ARGLIST NAME))
    126   DIS-NONE)
    127 
    128 (DEFCOM COM-QUICK-ARGLIST "Print the argument list of the function to left of cursor." ()
    129   (IF *NUMERIC-ARG-P*
    130       (COM-ARGLIST)
    131       (LET ((SYMBOL (RELEVANT-FUNCTION-NAME (POINT))))
    132         (COND ((AND (MEMQ SYMBOL '(FUNCALL FUNCALL-SELF <-))
    133                     (SETQ SYMBOL (RELEVANT-METHOD-NAME (POINT)
    134                                                        (IF (EQ SYMBOL 'FUNCALL-SELF) 1 2))))
    135                (MULTIPLE-VALUE-BIND (ARGLIST NAME RETLIST)
    136                    (METHOD-ARGLIST SYMBOL)
    137                  (TYPEIN-LINE "~S: ~:A~@[ ~:A~]"
    138                               (OR NAME SYMBOL) ARGLIST RETLIST)))
    139               ((FDEFINEDP SYMBOL)
    140                (PRINT-ARGLIST SYMBOL))
    141               ((BARF))))        ;Looked hard but couldn't find a defined function
    142       DIS-NONE))
    143 
    144 (DEFUN PRINT-ARGLIST (SYMBOL)
    145   (MULTIPLE-VALUE-BIND (ARGLIST RETURNS)
    146       (ARGLIST SYMBOL)
    147     (TYPEIN-LINE "~S: ~:A~@[ ~:A~]" SYMBOL ARGLIST RETURNS)))
    148 
    149 (DEFCOM COM-BRIEF-DOCUMENTATION "Print brief documentation for the specified function.
    150 Reads the name of the function from the mini-buffer (the top of the kill
    151 ring has the /"current/" function from the buffer) and prints the first
    152 line of its documentation in the echo area." ()
    153     (LET ((NAME (READ-FUNCTION-NAME "Brief Document" (RELEVANT-FUNCTION-NAME (POINT)) T)))
    154       (LET ((DOC (FUNCTION-DOCUMENTATION NAME)))
    155         (COND ((NULL DOC) (TYPEIN-LINE "~S is not documented" NAME))
    156               (T (TYPEIN-LINE "~S: ~A" NAME
    157                               (NSUBSTRING DOC 0 (STRING-SEARCH-CHAR #\CR DOC)))))))
    158     DIS-NONE)
    159 
    160 (DEFCOM COM-LONG-DOCUMENTATION "Print long documentation for the specified function.
    161 Reads the name of the function from the mini-buffer (the top of the kill
    162 ring has the /"current/" function from the buffer) and displays the
    163 function's arguments and documentation" ()
    164     (LET ((NAME (READ-FUNCTION-NAME "Document" (RELEVANT-FUNCTION-NAME (POINT)) T)))
    165       (LET ((DOC (FUNCTION-DOCUMENTATION NAME)))
    166         (COND ((NULL DOC) (TYPEIN-LINE "~S is not documented" NAME))
    167               (T (PRINT-ARGLIST NAME)
    168                  (FORMAT T "~%~A" DOC)))))
    169     DIS-NONE)
    170 
    171 (DEFCOM COM-TRACE "Trace or untrace a function.
    172 Reads the name of the function from the mini-buffer (the top of the kill
    173 ring has the /"current/" function from the buffer) then pops up a menu
    174 of trace options." ()
    175   (TV:TRACE-VIA-MENUS (READ-FUNCTION-NAME "Trace" (RELEVANT-FUNCTION-NAME (POINT)) T))
    176   DIS-NONE)
    177 
    178 (DEFCOM COM-WHERE-IS-SYMBOL "Show which packages contain the specified symbol." ()
    179   (MULTIPLE-VALUE-BIND (SYMBOL NAME)
    180       (READ-FUNCTION-NAME "Where is symbol" NIL NIL T)
    181     (WHERE-IS (OR NAME SYMBOL)))
    182   DIS-NONE)
    183 
    184 (DEFCOM COM-COUNT-LINES-PAGE "Type number of lines on this page.
    185 Also add, in parentheses, the number of lines on the page
    186 before point, and the number of lines after point." ()
    187    (LET ((POINT (POINT)))
    188      (LET ((N1 (1- (COUNT-LINES (FORWARD-PAGE POINT -1 T) POINT)))
    189            (N2 (1- (COUNT-LINES POINT (FORWARD-PAGE POINT 1 T)))))
    190        (TYPEIN-LINE "Page has ~D (~D + ~D) lines" (+ N1 N2) N1 N2)))
    191    DIS-NONE)
    192 
    193 
    194 (DEFCOM COM-LIST-ALL-DIRECTORY-NAMES "List names of all disk directories." ()
    195    (LOCAL-DECLARE ((SPECIAL *MFD-ARRAY*))
    196      (OR (BOUNDP '*MFD-ARRAY*)
    197        (SETQ *MFD-ARRAY* (MAKE-ARRAY NIL 'ART-Q 350. NIL '(0))))
    198      (STORE-ARRAY-LEADER 0 *MFD-ARRAY* 0)
    199      (OPEN-FILE (STREAM "DSK: M.F.D. (FILE)" '(IN))
    200        (DO ((STRING) (ENDP))
    201            (NIL)
    202          (MULTIPLE-VALUE (STRING ENDP)
    203             (FUNCALL STREAM ':LINE-IN NIL))
    204          (IF ENDP (RETURN NIL))
    205          (ARRAY-PUSH-EXTEND *MFD-ARRAY* STRING)))
    206      (SORT *MFD-ARRAY* #'STRING-LESSP)
    207      (LET ((IDX 0)
    208            (N (ARRAY-LEADER *MFD-ARRAY* 0)))
    209        (DO ((I 0 (1+ I))
    210             (TO (// N 10.)))
    211            ((
    212  I TO))
    213         (DO J 0 (1+ J) (
    214  J 10.)
    215           (FORMAT T "~A  " (AREF *MFD-ARRAY* IDX))
    216           (SETQ IDX (1+ IDX)))
    217         (FORMAT T "~%"))
    218        (DO () (NIL)
    219          (AND (
    220  IDX N) (RETURN NIL))
    221          (FORMAT T "~A  " (AREF *MFD-ARRAY* IDX))
    222          (SETQ IDX (1+ IDX)))))
    223    DIS-NONE)
    224 
    225 (DEFCOM COM-VIEW-DIRECTORY "List an ITS file directory." ()
    226   (LET ((FILENAME (DEFAULT-FILE-NAME))
    227         DIRECTORY DEFAULT)
    228     (SETQ DEFAULT (FORMAT NIL "~A: ~A;"
    229                           (FUNCALL FILENAME ':DEVICE) (FUNCALL FILENAME ':DIRECTORY)))
    230     (SETQ DIRECTORY (TYPEIN-LINE-READLINE "Directory name (Default: ~A)" DEFAULT))
    231     (AND (EQUAL DIRECTORY "") (SETQ DIRECTORY DEFAULT))
    232     (VIEW-DIRECTORY DIRECTORY)))
    233 
    234 (LOCAL-DECLARE ((SPECIAL VIEWED-DIRECTORY))
    235 (DEFUN VIEW-DIRECTORY (VIEWED-DIRECTORY)
    236   (SETQ VIEWED-DIRECTORY (STRING-TRIM '(#/; #\SP #\TAB) (STRING-UPCASE VIEWED-DIRECTORY)))
    237   (BIND-MODE-LINE ("Viewing Directory " VIEWED-DIRECTORY)
    238     (VIEW-FILE (STRING-APPEND VIEWED-DIRECTORY "; .FILE. (DIR)")))
    239    DIS-NONE)
    240 )
    241 
    242 (DEFCOM COM-VIEW-LOGIN-DIRECTORY "List files in user's directory." ()
    243   (VIEW-DIRECTORY (FS:FILE-USER-ID-HSNAME)))
    244 
    245 (DEFCOM COM-VIEW-XGP-QUEUE "List XGP queue." ()
    246   (VIEW-DIRECTORY "XGP:FOO"))
    247 
    248 (DEFCOM COM-VIEW-TTY-USERS "TTY
    249 F" ()
    250   (VIEW-DIRECTORY "TTY:FOO"))
    251 
    252 (DEFCOM COM-VIEW-MAIL "View any new mail." ()
    253   (LET ((FILE-NAME (STRING-APPEND (FS:FILE-USER-ID-HSNAME) USER-ID " MAIL")))
    254     (COND ((FILE-EXISTS-P FILE-NAME)
    255            (VIEW-FILE FILE-NAME))
    256           (T
    257            (TYPEIN-LINE "No new mail"))))
    258   DIS-NONE)
    259 
    260 ;;; Evaluation and Compilation commands.
    2613
    2624(DEFCOM COM-EVALUATE-MINI-BUFFER "Evaluate a form from the mini-buffer." (KM)
     
    29032        "Evaluate a form from the mini-buffer and insert the result into the buffer.
    29133If given an argument, things printed by the evaluation go there as well." (KM)
    292   (LET ((FORM (TYPEIN-LINE-READ "Lisp form:"))
    293         (STREAM (INTERVAL-STREAM (POINT) (POINT) T)))
     34  (LET ((FORM (TYPEIN-LINE-READ "Lisp form: (end with END)"))
     35        (STREAM (INTERVAL-STREAM-INTO-BP (POINT))))
    29436    (FORMAT STREAM "~&~S"
    29537            (LET ((STANDARD-OUTPUT (IF *NUMERIC-ARG-P* STREAM STANDARD-OUTPUT)))
    29638              (EVAL FORM)))
    297     (MOVE-BP (POINT) (FUNCALL STREAM ':READ-BP))
    298     (MUNG-BP-INTERVAL (POINT)))
     39    (MOVE-BP (POINT) (FUNCALL STREAM ':READ-BP)))
    29940  DIS-TEXT)
    30041
    30142(DEFCOM COM-EVALUATE-AND-REPLACE-INTO-BUFFER
    30243        "Evaluate the next s-expression and replace the result into the buffer" ()
    303   (LET ((STREAM (INTERVAL-STREAM (POINT) (INTERVAL-LAST-BP *INTERVAL*) T))
    304         (POINT (POINT)) (MARK (MARK))
    305         FORM)
    306     (SETQ FORM (READ STREAM '*EOF*))
     44  (LET* ((POINT (POINT)) (MARK (MARK))
     45         (STREAM (REST-OF-INTERVAL-STREAM POINT))
     46         (FORM (READ STREAM '*EOF*)))
    30747    (AND (EQ FORM '*EOF*) (BARF))
    30848    (SETQ FORM (EVAL FORM))
     
    31555  DIS-TEXT)
    31656
     57(DEFCOM COM-MICROCOMPILE-DEFUN "Microcompile the current defun." ()
     58  (COMPILE-DEFUN-INTERNAL T "Microcompiling" "microcompiled."
     59                          NIL    ;USE-TYPEOUT
     60                          NIL    ;DEFVAR-HACK
     61                          'COMPILER:MICRO-COMPILE)
     62  DIS-NONE)
     63
    31764(DEFCOM COM-COMPILE-DEFUN "Compile the current defun." ()
    318    (COMPILE-DEFUN-INTERNAL T "Compiling" "compiled.")
    319    DIS-NONE)
     65  (COMPILE-DEFUN-INTERNAL T "Compiling" "compiled.")
     66  DIS-NONE)
    32067
    32168(DEFCOM COM-EVALUATE-DEFUN "Evaluate the current defun.
    32269Result is typed out in the echo area." ()
    323    (COMPILE-DEFUN-INTERNAL  (GET-BUFFER-EVALUATOR *INTERVAL*)
    324                             "Evaluating"
    325                             "evaluated."
    326                             ':PROMPT)
    327    DIS-NONE)
     70  (COMPILE-DEFUN-INTERNAL  (GET-BUFFER-EVALUATOR *INTERVAL*)
     71                           "Evaluating"
     72                           "evaluated."
     73                           ':PROMPT)
     74  DIS-NONE)
    32875
    32976(DEFCOM COM-EVALUATE-DEFUN-VERBOSE "Evaluate the current defun.
    33077Result is typed out in the typeout window." ()
    331    (COMPILE-DEFUN-INTERNAL  (GET-BUFFER-EVALUATOR *INTERVAL*)
    332                             "Evaluating"
    333                             "evaluated."
    334                             T)
    335    DIS-NONE)
     78  (COMPILE-DEFUN-INTERNAL  (GET-BUFFER-EVALUATOR *INTERVAL*)
     79                           "Evaluating"
     80                           "evaluated."
     81                           T)
     82  DIS-NONE)
    33683
    33784(DEFCOM COM-EVALUATE-DEFUN-HACK "Evaluate the current defun.
    33885DEFVAR's are turned into SETQ's" ()
    339    (COMPILE-DEFUN-INTERNAL  (GET-BUFFER-EVALUATOR *INTERVAL*)
    340                             "Evaluating"
    341                             "evaluated."
    342                             ':PROMPT T)
    343    DIS-NONE)
    344 
    345 (DEFUN COMPILE-DEFUN-INTERNAL (COMPILE-P MODE-NAME ECHO-NAME &OPTIONAL USE-TYPEOUT DEFVAR-HACK
    346                                                              &AUX BP1 BP2 DEFUN-NAME)
     86  (COMPILE-DEFUN-INTERNAL  (GET-BUFFER-EVALUATOR *INTERVAL*)
     87                           "Evaluating"
     88                           "evaluated."
     89                           ':PROMPT T)
     90  DIS-NONE)
     91
     92(DEFUN COMPILE-DEFUN-INTERNAL (COMPILE-P MODE-NAME ECHO-NAME
     93                               &OPTIONAL USE-TYPEOUT DEFVAR-HACK
     94                               (COMPILER-PROCESSING-MODE 'COMPILER:MACRO-COMPILE)
     95                               &AUX BP1 BP2 DEFUN-NAME)
    34796  (COND ((WINDOW-MARK-P *WINDOW*)
    34897         (SETQ BP1 (MARK) BP2 (POINT))
     
    352101         (SETQ BP2 (INTERVAL-LAST-BP BP1) BP1 (INTERVAL-FIRST-BP BP1))
    353102         (SETQ DEFUN-NAME (GET-DEFUN-NAME DEFUN-NAME)
    354                DEFVAR-HACK T))
     103               DEFVAR-HACK T)
     104         (OR (EQ (ARRAY-TYPE DEFUN-NAME) 'ART-STRING)
     105             (SETQ DEFUN-NAME (STRING-APPEND "" DEFUN-NAME))))  ;Make printable
    355106        (T
    356107         (BARF "Unbalanced parentheses")))
    357   (PROMPT-LINE "~A ~A" MODE-NAME DEFUN-NAME)
     108  (COMPILE-PRINT-INTERVAL BP1 BP2 T COMPILE-P
     109                          DEFUN-NAME MODE-NAME ECHO-NAME USE-TYPEOUT DEFVAR-HACK
     110                          COMPILER-PROCESSING-MODE))
     111
     112
     113(DEFUN COMPILE-PRINT-INTERVAL (BP1 BP2 IN-ORDER-P COMPILE-P DEFUN-NAME MODE-NAME ECHO-NAME
     114                               &OPTIONAL USE-TYPEOUT DEFVAR-HACK
     115                               (COMPILER-PROCESSING-MODE  'COMPILER:MACRO-COMPILE)
     116                               &AUX FORMAT-FUNCTION)
     117  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
     118  (SETQ FORMAT-FUNCTION (SELECTQ USE-TYPEOUT
     119                          (:TYPEOUT #'(LAMBDA (STRING &REST ARGS)
     120                                        (LEXPR-FUNCALL #'FORMAT *TYPEOUT-WINDOW*
     121                                                       STRING ARGS)))
     122                          (:PROMPT #'PROMPT-LINE)
     123                          (OTHERWISE #'TYPEIN-LINE)))
     124  (FUNCALL FORMAT-FUNCTION "~&~A ~A" MODE-NAME DEFUN-NAME)
    358125  (COMPILE-INTERVAL COMPILE-P (EQ USE-TYPEOUT T) DEFVAR-HACK BP1 BP2 T
    359           (COND ((> *NUMERIC-ARG* 3)
    360                  'COMPILER:MICRO-COMPILE)
    361                 (T 'COMPILER:MACRO-COMPILE)))
    362   (FUNCALL (IF (EQ USE-TYPEOUT ':PROMPT) #'PROMPT-LINE #'TYPEIN-LINE)
    363            "~A ~A" DEFUN-NAME ECHO-NAME))
     126                    COMPILER-PROCESSING-MODE
     127                    (IF *NUMERIC-ARG-P* T))  ;do read followed by processing.
     128  (UPDATE-INTERVAL-COMPILE-TICK BP1 BP2 T)
     129  (OR (EQ USE-TYPEOUT ':TYPEOUT)                ;Unless being preserved
     130      (FUNCALL FORMAT-FUNCTION "~&~A ~A" DEFUN-NAME ECHO-NAME)))
    364131
    365132;;; Given a BP to the beginning of a DEFUN (as returned by BACKWARD-DEFUN,
     
    374141
    375142(DEFUN GET-BUFFER-EVALUATOR (BUFFER)
    376   (AND (ZMACS-BUFFER-P BUFFER BUFFER-FILE-GROUP-SYMBOL)
    377        (GET (BUFFER-FILE-GROUP-SYMBOL BUFFER) ':EVALUATOR)))
     143  (AND (TYPEP BUFFER 'FILE-BUFFER)
     144       (FUNCALL (BUFFER-GENERIC-PATHNAME BUFFER) ':GET ':EVALUATOR)))
    378145
    379146(DEFCOM COM-EVALUATE-BUFFER "Evaluate the entire buffer." ()
    380   (COMPILE-BUFFER "Evaluating" (GET-BUFFER-EVALUATOR *INTERVAL*)))
     147  (COMPILE-BUFFER (GET-BUFFER-EVALUATOR *INTERVAL*) "Evaluating" "evaluated."))
    381148
    382149(DEFCOM COM-COMPILE-BUFFER "Compile the entire buffer." ()
    383   (COMPILE-BUFFER "Compiling" T))
    384 
    385 (DEFUN COMPILE-BUFFER (TYPE COMPILE-P)
    386   (PROMPT-LINE "~A ~:[rest of ~]buffer." TYPE (NOT *NUMERIC-ARG-P*))
    387   (LET (BP1 BP2)
    388     (IF *NUMERIC-ARG-P*
    389         (SETQ BP1 (POINT) BP2 (INTERVAL-LAST-BP *INTERVAL*))
    390         (SETQ BP1 *INTERVAL*))
    391     (COMPILE-INTERVAL COMPILE-P T NIL BP1 BP2 T))
     150  (COMPILE-BUFFER T "Compiling" "compiled."))
     151
     152(DEFCOM COM-MICROCOMPILE-BUFFER "Microcompile the entire buffer." ()
     153  (COMPILE-BUFFER T "Microcompiling" "microcompiled." 'COMPILER:MICRO-COMPILE))
     154
     155(DEFUN COMPILE-BUFFER (COMPILE-P MODE-NAME ECHO-NAME
     156                       &OPTIONAL (COMPILER-PROCESSING-MODE 'COMPILER:MACRO-COMPILE)
     157                       &AUX BP1 BP2 NAME)
     158  (IF *NUMERIC-ARG-P*
     159      (SETQ BP1 (POINT) BP2 (INTERVAL-LAST-BP *INTERVAL*) NAME "Rest of buffer")
     160      (SETQ BP1 *INTERVAL* NAME "Buffer"))
     161  (COMPILE-PRINT-INTERVAL BP1 BP2 T COMPILE-P NAME MODE-NAME ECHO-NAME
     162                          NIL ;USE-TYPEOUT
     163                          NIL ;DEFVAR-HACK
     164                          COMPILER-PROCESSING-MODE)
    392165  DIS-NONE)
    393166
    394167(DEFCOM COM-EVALUATE-REGION "Evaluate just between point and the mark." ()
    395   (PROMPT-LINE "Evaluating region.")
    396168  (REGION (BP1 BP2)
    397     (COMPILE-INTERVAL (GET (BUFFER-FILE-GROUP-SYMBOL *INTERVAL*)        ;NIL if no special
    398                            ':EVALUATOR) ;evaluator
    399                       NIL NIL
    400                       BP1
    401                       BP2))
     169    (COMPILE-PRINT-INTERVAL BP1 BP2 T (GET-BUFFER-EVALUATOR *INTERVAL*)
     170                            "Region" "Evaluating" "evaluated."))
    402171  DIS-NONE)
    403172
    404173(DEFCOM COM-COMPILE-REGION "Compile just between point and the mark." ()
    405   (PROMPT-LINE "Compiling region.")
    406174  (REGION (BP1 BP2)
    407           (COMPILE-INTERVAL T T NIL BP1 BP2))
     175    (COMPILE-PRINT-INTERVAL BP1 BP2 T T
     176                            "Region" "Compiling" "compiled."))
     177  DIS-NONE)
     178
     179(DEFCOM COM-MICROCOMPILE-REGION "Microcompile just between point and the mark." ()
     180  (REGION (BP1 BP2)
     181    (COMPILE-PRINT-INTERVAL BP1 BP2 T T
     182                            "Region" "Microcompiling" "microcompiled."
     183                            NIL ;USE-TYPEOUT
     184                            NIL ;DEFVAR-HACK
     185                            'COMPILER:MICRO-COMPILE))
    408186  DIS-NONE)
    409187
     
    411189(LOCAL-DECLARE ((SPECIAL COMPILE-P USE-TYPEOUT DEFVAR-HACK COMPILE-PROCESSING-MODE))
    412190(DEFUN COMPILE-INTERVAL (COMPILE-P USE-TYPEOUT DEFVAR-HACK BP1 &OPTIONAL BP2 IN-ORDER-P
    413                            (COMPILE-PROCESSING-MODE 'COMPILER:MACRO-COMPILE)
     191                         (COMPILE-PROCESSING-MODE 'COMPILER:MACRO-COMPILE)
     192                         (READ-THEN-PROCESS-FLAG NIL)
    414193                         &AUX (STANDARD-OUTPUT *TYPEOUT-WINDOW*)
    415                               FILE-GROUP-SYMBOL)
    416     (SETQ FILE-GROUP-SYMBOL
    417           (IF (ZMACS-BUFFER-P *INTERVAL* BUFFER-FILE-GROUP-SYMBOL)
    418               (BUFFER-FILE-GROUP-SYMBOL *INTERVAL*)
    419               (GENSYM)))
    420     ;; Should re-read the mode line at the front of the file in case it has changed
    421     ;; Unfortunately SI:FILE-READ-PROPERTY-LIST doesn't work on interval streams.
    422     (GET-INTERVAL BP1 BP2 IN-ORDER-P)
    423     (COMPILER:COMPILE-STREAM (INTERVAL-STREAM BP1 BP2 T) FILE-GROUP-SYMBOL NIL
    424                     #'(LAMBDA (FORM)
    425                         (COND ((AND DEFVAR-HACK
    426                                     (LISTP FORM)
    427                                     (= (LENGTH FORM) 3)
    428                                     (MEMQ (CAR FORM) '(DEFVAR DEFCONST)))
    429                                (OR (SYMBOLP (CADR FORM))
    430                                    (FERROR NIL "~S not a recignized form" FORM))
    431                                (PUTPROP (CADR FORM) T 'SPECIAL) ;Declare it
    432                                (SETF (CAR FORM) 'SETQ)))        ;then always SETQ
    433                         (COND ((EQ COMPILE-P T)
    434                                (COMPILER:COMPILE-DRIVER FORM #'COMPILE-BUFFER-FORM NIL))
    435                               (COMPILE-P (FUNCALL COMPILE-P FORM))
    436                               (T (RECORD-DEFUN FORM *INTERVAL*)
    437                                  (EVAL-PRINT FORM USE-TYPEOUT))))
    438                     T NIL NIL)))
     194                              GENERIC-PATHNAME)
     195  (SETQ GENERIC-PATHNAME (IF (TYPEP *INTERVAL* 'FILE-BUFFER)
     196                             (BUFFER-GENERIC-PATHNAME *INTERVAL*)
     197                             (FS:MAKE-DUMMY-PATHNAME "Unknown")))
     198  ;; Should re-read the mode line at the front of the file in case it has changed
     199  ;; Unfortunately SI:FILE-READ-PROPERTY-LIST doesn't work on interval streams.
     200  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
     201  (CHECK-INTERVAL-SECTIONS BP1 BP2 T)
     202  (COMPILER:COMPILE-STREAM
     203    (INTERVAL-STREAM BP1 BP2 T)
     204    GENERIC-PATHNAME
     205    NIL         ;FASD-FLAG
     206    #'(LAMBDA (FORM)            ;PROCESS-FN
     207        (COND ((AND DEFVAR-HACK
     208                    (LISTP FORM)
     209                    (> (LENGTH FORM) 2)
     210                    (MEMQ (CAR FORM) '(DEFVAR DEFCONST)))
     211               (OR (SYMBOLP (CADR FORM))
     212                   (FERROR NIL "~S not a recognized form" FORM))
     213               (PUTPROP (CADR FORM) T 'SPECIAL) ;Declare it
     214               (COND ((> (LENGTH FORM) 3)       ;in case there is a documentation string.
     215                      (PUTPROP (SECOND FORM) (EVAL (FOURTH FORM)) ':VALUE-DOCUMENTATION)
     216                      (SETQ FORM (NBUTLAST FORM))))     ;remove documentation so that
     217                                                ;hack into SETQ works properly.
     218               (SETF (CAR FORM) 'SETQ)))        ;then always SETQ
     219        (COND ((EQ COMPILE-P T)
     220               (COMPILER:COMPILE-DRIVER FORM
     221                                        #'COMPILE-BUFFER-FORM NIL))
     222              (COMPILE-P
     223               (FUNCALL COMPILE-P FORM))
     224              (T
     225               (RECORD-DEFUN FORM *INTERVAL*)
     226               (EVAL-PRINT FORM USE-TYPEOUT))))
     227    T   ;QC-FILE-LOAD-FLAG
     228    NIL ;QC-FILE-IN-CORE-FLAG
     229    NIL ;PACKAGE-SPEC
     230    NIL ;FILE-LOCAL-DECLARATIONS
     231    READ-THEN-PROCESS-FLAG     ;READ-THEN-PROCESS-FLAG
     232    )))
    439233
    440234(DEFUN EVAL-PRINT (OBJECT USE-TYPEOUT)
    441     (LET ((LIST (MULTIPLE-VALUE-LIST (EVAL OBJECT))))
    442        (DOLIST (VAL LIST)
    443          (IF USE-TYPEOUT (PRINT VAL) (LET ((PRINLENGTH 5) (PRINLEVEL 2))
    444                                        (TYPEIN-LINE "~&~S" VAL))))
    445        (MVRETURN (CAR LIST) OBJECT)))
    446 
    447 ;Functional to be passed to COMPILE-DRIVER.
    448 (LOCAL-DECLARE ((SPECIAL COMPILE-PROCESSING-MODE))
    449 (DEFUN COMPILE-BUFFER-FORM (FORM TYPE)
    450   (SELECTQ TYPE
    451     ((DECLARE) (EVAL FORM))
    452     ((RANDOM SPECIAL) (EVAL FORM))
    453     (DEFUN
    454      (RECORD-DEFUN FORM *INTERVAL*)
    455      (COMPILER:COMPILE-1 (CADR FORM) (CONS 'LAMBDA (CDDR FORM)) COMPILE-PROCESSING-MODE))
    456     (MACRO
    457      (RECORD-DEFUN FORM *INTERVAL*)
    458      (COMPILER:COMPILE-1 (CADR FORM) (CONS 'MACRO (CONS 'LAMBDA (CDDR FORM))))))))
     235  (LET ((LIST (MULTIPLE-VALUE-LIST (EVAL OBJECT))))
     236    (DOLIST (VAL LIST)
     237      (IF USE-TYPEOUT (PRINT VAL) (LET ((PRINLENGTH 5) (PRINLEVEL 2))
     238                                    (TYPEIN-LINE "~S" VAL))))
     239    (VALUES (CAR LIST) OBJECT)))
     240
     241;;; Functional to be passed to COMPILE-DRIVER.
     242(DEFUN COMPILE-BUFFER-FORM (FORM TYPE &AUX NAME LAMBDA)
     243  (DECLARE (SPECIAL COMPILE-PROCESSING-MODE))
     244  (IF (MEMQ TYPE '(DECLARE RANDOM SPECIAL))
     245      (EVAL FORM)
     246      (RECORD-DEFUN FORM *INTERVAL*)
     247      (SETQ NAME (CADR FORM)
     248            LAMBDA (CONS 'LAMBDA (CDDR FORM)))
     249      (IF (EQ TYPE 'MACRO)
     250          (COMPILER:COMPILE-1 NAME (CONS 'MACRO LAMBDA))
     251          (COMPILER:COMPILE-1 NAME LAMBDA COMPILE-PROCESSING-MODE))))
    459252
    460253;;; This does not really get the right arguments, but can at least make it so that M-.
    461254;;; knows what buffer to sectionize to find the thing
    462255(DEFUN RECORD-DEFUN (FORM INTERVAL)
    463   (AND (LISTP FORM) (EQ (CAR FORM) 'DEFUN)
     256  (AND (LISTP FORM) (MEMQ (CAR FORM) '(DEFUN MACRO))
     257       (TYPEP INTERVAL 'FILE-BUFFER)
    464258       (LET ((SYM (SYMBOL-FROM-STRING (CADR FORM))))
    465          (COND ((NOT (ASSQ INTERVAL (GET SYM 'ZMACS-BUFFERS)))
     259         (COND ((NOT (ASSQ INTERVAL (SI:FUNCTION-SPEC-GET SYM 'ZMACS-BUFFERS)))
    466260                ;; NIL for a LINE will never be believed to be valid, forcing sectionization.
    467                 (PUSH (CONS INTERVAL NIL) (GET SYM 'ZMACS-BUFFERS))
     261                (PUSH (CONS INTERVAL NIL) (SI:FUNCTION-SPEC-GET SYM 'ZMACS-BUFFERS))
    468262                ;; This will make sectionizing forget the bogus entry above.
    469                 (PUSH SYM (GET (BUFFER-FILE-GROUP-SYMBOL INTERVAL) 'ZMACS-SECTION-LIST)))))))
     263                (LET ((GENERIC-PATHNAME (BUFFER-GENERIC-PATHNAME INTERVAL) ))
     264                  (PUSH SYM (FUNCALL GENERIC-PATHNAME ':GET 'ZMACS-SECTION-LIST))))))))
    470265
    471266(DEFCOM COM-MACRO-EXPAND-SEXP "Macroexpand the next s-expression" ()
    472   (LET ((STREAM (INTERVAL-STREAM *INTERVAL*)))
    473     (FUNCALL STREAM ':SET-BP (POINT))
     267  (LET ((STREAM (REST-OF-INTERVAL-STREAM (POINT))))
    474268    (LET ((FORM (READ STREAM '*EOF*)))
    475       (AND (EQ FORM '*EOF) (BARF))
     269      (AND (EQ FORM '*EOF*) (BARF))
    476270      (GRIND-TOP-LEVEL (MACRO-EXPAND-ALL FORM))))
    477271  DIS-NONE)
     
    480274  (SETQ FORM (MACROEXPAND FORM))
    481275  (AND (LISTP FORM)
    482        (DO L FORM (CDR L) (NULL L)
    483            (SETF (CAR L) (MACRO-EXPAND-ALL (CAR L)))))
     276       (DO ((L FORM (CDR L)))
     277           ((OR (NULL L)
     278                (ATOM L)))
     279           (COND ((ATOM (CDR L))                ;L may be a dotted pair therefore CDR'ing down
     280                                                ;list won't do quite the expected thing.
     281                  (SETF (CAR L)(MACRO-EXPAND-ALL (CAR L)))
     282                  (SETF (CDR L)(MACRO-EXPAND-ALL (CDR L))))
     283                 (T (SETF (CAR L) (MACRO-EXPAND-ALL (CAR L)))))))
    484284  FORM)
    485285
     
    491291;; in case the function text and expr definition don't actually match.
    492292(DEFUN FUNCTION-CORRESPONDENCE (FUNCTION)
    493     (PROG* ((LOCATION (CAR (DEFINITION-TEXT-LOCATION FUNCTION)))
    494             (BUFFER (CAR LOCATION))
    495             (LINE (CDR LOCATION))
    496             (INT (DEFUN-INTERVAL (CREATE-BP LINE 0) 1 NIL NIL))
    497             (DEFINITION (FDEFINITION FUNCTION))
    498             NEWSEXP TEM
    499             (CORRESPONDENCE (GET FUNCTION 'ZMACS-CORRESPONDENCE)))
    500           (COND ((OR (NULL CORRESPONDENCE)
    501                      (NEQ (CAR CORRESPONDENCE) DEFINITION)
    502                      (> (INTERVAL-REAL-TICK INT)
    503                         (CADDR CORRESPONDENCE)))
    504                  ;; Read in the text.  Get a new sexp for the function,
    505                  ;; together with a correspondence between it and the text.
    506                  (MULTIPLE-VALUE (NEWSEXP CORRESPONDENCE)
    507                    (ESTABLISH-CORRESPONDENCE DEFINITION BUFFER INT))
    508                  ;; If function is traced, find original definition.
    509                  (COND ((AND (EQ (CAR DEFINITION) 'NAMED-LAMBDA)
    510                              (NOT (ATOM (CADR DEFINITION)))
    511                              (SETQ TEM (ASSQ 'TRACE (CDADR DEFINITION))))
    512                         (SETQ DEFINITION (FDEFINITION (CADR TEM)))))
    513                  (SETQ TEM (MEMQ NEWSEXP CORRESPONDENCE))
    514                  (AND TEM (RPLACA TEM DEFINITION))
    515                  (SETQ NEWSEXP (CDDR NEWSEXP))  ;Flush DEFUN or DEFMETHOD, and fn name.
    516                  (SELECTQ (CAR DEFINITION)      ;Flush LAMBDA, or NAMED-LAMBDA and name.
    517                    (LAMBDA (SETQ DEFINITION (CDR DEFINITION)))
    518                    (NAMED-LAMBDA
    519                      (SETQ DEFINITION (CDDR DEFINITION))))
    520                  ;; Now the new sexp should look like the definition.
    521                  ;; Move the correspondence to the definition.
    522                  (TRANSFER-CORRESPONDENCE FUNCTION CORRESPONDENCE NEWSEXP DEFINITION)
    523                  (PUTPROP FUNCTION CORRESPONDENCE 'ZMACS-CORRESPONDENCE)))
    524           (RETURN CORRESPONDENCE)))
    525 
     293  (LET* ((LOCATION (CAR (DEFINITION-TEXT-LOCATION FUNCTION)))
     294         (BUFFER (CAR LOCATION))
     295         (LINE (CDR LOCATION))
     296         (INT (DEFUN-INTERVAL (CREATE-BP LINE 0) 1 NIL NIL))
     297         (DEFINITION (FDEFINITION FUNCTION))
     298         NEWSEXP TEM
     299         (CORRESPONDENCE (GET FUNCTION 'ZMACS-CORRESPONDENCE)))
     300    (COND ((OR (NULL CORRESPONDENCE)
     301               (NEQ (CAR CORRESPONDENCE) DEFINITION)
     302               (> (INTERVAL-REAL-TICK INT) (CADDR CORRESPONDENCE)))
     303           ;; Read in the text.  Get a new sexp for the function,
     304           ;; together with a correspondence between it and the text.
     305           (MULTIPLE-VALUE (NEWSEXP CORRESPONDENCE)
     306             (ESTABLISH-CORRESPONDENCE DEFINITION BUFFER INT))
     307           ;; If function is traced, find original definition.
     308           (COND ((AND (EQ (CAR DEFINITION) 'NAMED-LAMBDA)
     309                       (NOT (ATOM (CADR DEFINITION)))
     310                       (SETQ TEM (ASSQ 'TRACE (CDADR DEFINITION))))
     311                  (SETQ DEFINITION (FDEFINITION (CADR TEM)))))
     312           (SETQ TEM (MEMQ NEWSEXP CORRESPONDENCE))
     313           (AND TEM (RPLACA TEM DEFINITION))
     314           (SETQ NEWSEXP (CDDR NEWSEXP))        ;Flush DEFUN or DEFMETHOD, and fn name.
     315           (SELECTQ (CAR DEFINITION)            ;Flush LAMBDA, or NAMED-LAMBDA and name.
     316             (LAMBDA (SETQ DEFINITION (CDR DEFINITION)))
     317             (NAMED-LAMBDA (SETQ DEFINITION (CDDR DEFINITION))))
     318           ;; Now the new sexp should look like the definition.
     319           ;; Move the correspondence to the definition.
     320           (TRANSFER-CORRESPONDENCE FUNCTION CORRESPONDENCE NEWSEXP DEFINITION)
     321           (PUTPROP FUNCTION CORRESPONDENCE 'ZMACS-CORRESPONDENCE)))
     322    CORRESPONDENCE))
    526323
    527324(DEFUN ESTABLISH-CORRESPONDENCE (DEFINITION BUFFER BP1 &OPTIONAL BP2 IN-ORDER-P)
    528     (GET-INTERVAL BP1 BP2 IN-ORDER-P)
    529     (PROG ((STREAM (INTERVAL-STREAM BP1 BP2 T))
    530            (SI:XR-CORRESPONDENCE-FLAG T)
    531            SI:XR-CORRESPONDENCE)
    532       (RETURN (READ STREAM)
    533               `(,DEFINITION ,BUFFER ,(INTERVAL-TICK BUFFER)
    534                 ,BP1 ,BP2 . ,SI:XR-CORRESPONDENCE))))
     325  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
     326  (LET ((STREAM (INTERVAL-STREAM BP1 BP2 T))
     327        (SI:XR-CORRESPONDENCE-FLAG T)
     328        SI:XR-CORRESPONDENCE)
     329    (VALUES (READ STREAM)
     330            `(,DEFINITION ,BUFFER ,(NODE-TICK BUFFER)
     331              ,BP1 ,BP2 . ,SI:XR-CORRESPONDENCE))))
    535332
    536333;When's the latest any line between BP1 and BP2 was modified?
    537334(DEFUN INTERVAL-REAL-TICK (BP1 &OPTIONAL BP2 IN-ORDER-P)
    538     (GET-INTERVAL BP1 BP2 IN-ORDER-P)
    539     (DO ((LINE (BP-LINE BP1) (LINE-NEXT LINE))
    540         (END-LINE (BP-LINE BP2))
    541         (MAX-TICK 0))
    542         (())
    543       (SETQ MAX-TICK (MAX MAX-TICK (LINE-TICK LINE)))
    544       (AND (EQ LINE END-LINE)
    545            (RETURN MAX-TICK))))
     335  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
     336  (DO ((LINE (BP-LINE BP1) (LINE-NEXT LINE))
     337      (END-LINE (BP-LINE BP2))
     338      (MAX-TICK 0))
     339      (NIL)
     340    (SETQ MAX-TICK (MAX MAX-TICK (LINE-TICK LINE)))
     341    (AND (EQ LINE END-LINE)
     342         (RETURN MAX-TICK))))
    546343
    547344;; Given a correspondence from the sexp TEMPDEF, matches up TEMPDEF
     
    550347;; We throw to TRANSFER-CORRESPONDENCE-LOSSAGE if the two sexps don't match.
    551348(DEFUN TRANSFER-CORRESPONDENCE (FUNCTION CORRESPONDENCE TEMPDEF REALDEF)
    552     (LET ((TEM (MEMQ TEMPDEF CORRESPONDENCE)))
    553       (AND TEM (RPLACA TEM REALDEF)))
    554     ;; In the real definition, some displacing macros may have gone off.
    555     (AND (EQ (CAR REALDEF) 'SI:DISPLACED)
    556          (SETQ REALDEF (CADR REALDEF)))
    557     (OR (= (LENGTH TEMPDEF) (LENGTH REALDEF))
    558         (THROW NIL TRANSFER-CORRESPONDENCE-LOSSAGE))
    559     (DO ((TD TEMPDEF (CDR TD))
    560          (RD REALDEF (CDR RD)))
    561         ((NULL TD))
    562       (AND (COND ((ATOM (CAR TD)) (NEQ (CAR TD) (CAR RD)))
    563                  (T (ATOM (CAR RD))))
    564            (THROW NIL TRANSFER-CORRESPONDENCE-LOSSAGE))
    565       (OR (ATOM (CAR TD))
    566           (TRANSFER-CORRESPONDENCE FUNCTION CORRESPONDENCE (CAR TD) (CAR RD)))))
    567 
    568 
    569 ;;; Sorting commands
    570 (DEFCOM COM-SORT-LINES "Sort the region alphabetically by lines" ()
    571   (REGION (BP1 BP2)
    572     (SORT-LINES-INTERVAL #'STRING-LESSP BP1 BP2 T))
    573   DIS-TEXT)
    574 
    575 (DEFCOM COM-SORT-PARAGRAPHS "Sort the region alphabetically by paragraphs" ()
    576   (REGION (BP1 BP2)
    577     (SORT-INTERVAL-FUNCTIONS #'FORWARD-OVER-BLANK-OR-TEXT-JUSTIFIER-LINES
    578                              #'(LAMBDA (BP) (FORWARD-PARAGRAPH BP 1 T))
    579                              #'(LAMBDA (BP) BP)
    580                              #'INTERVAL-WITH-SORT-INTERVAL-LESSP
    581                              BP1 BP2 T))
    582   DIS-TEXT)
    583 
    584 (DEFVAR *MAKE-KBD-MACRO-MOVER-COMTAB*)
    585 
    586 ;;; This returns a function which takes a BP and returns a resultant BP after performing
    587 ;;; the given kbd-macro operation.
    588 (DEFUN MAKE-KBD-MACRO-MOVER (PROMPT)
    589   (COM-START-KBD-MACRO)
    590   (TYPEIN-LINE "Defining a keyboard macro to ~A~@[; type ~A to finish it~]"
    591                PROMPT (KEY-FOR-COMMAND 'COM-END-KBD-MACRO))
    592   (LET ((STANDARD-INPUT (LET-CLOSED ((OLD-STANDARD-INPUT STANDARD-INPUT))
    593                           #'(LAMBDA (OP &REST REST)
    594                               (PROG1 (LEXPR-FUNCALL OLD-STANDARD-INPUT OP REST)
    595                                      (COND ;;When done recording, exit the recursive edit.
    596                                            ((EQ OP ':MACRO-POP)
    597                                             (*THROW 'EXIT-MAKE-KBD-MACRO-MOVER T))
    598                                            ;;If there is an error, exit, it will throw up
    599                                            ;;further.
    600                                            ((EQ OP ':MACRO-ERROR)
    601                                             (*THROW 'EXIT-MAKE-KBD-MACRO-MOVER
    602                                                     ':MACRO-ERROR))))))))
    603     (AND (EQ (*CATCH 'EXIT-MAKE-KBD-MACRO-MOVER
    604                (FUNCALL-SELF ':EDIT))
    605              ':MACRO-ERROR)
    606          (*THROW 'ZWEI-COMMAND-LOOP T)))
    607   (COND ((NOT (BOUNDP '*MAKE-KBD-MACRO-MOVER-COMTAB*))
    608          (SETQ *MAKE-KBD-MACRO-MOVER-COMTAB* (CREATE-SPARSE-COMTAB))
    609          (SETF (COMTAB-KEYBOARD-ARRAY *MAKE-KBD-MACRO-MOVER-COMTAB*)
    610                '((-1 . COM-EXIT-KBD-MACRO-MOVER)))))
    611   (SET-COMTAB-INDIRECTION *MAKE-KBD-MACRO-MOVER-COMTAB* *COMTAB*)
    612   (LET-CLOSED ((OLD-MACRO-PREVIOUS-ARRAY (FUNCALL STANDARD-INPUT ':MACRO-PREVIOUS-ARRAY))
    613                (STANDARD-INPUT (LET-CLOSED ((OLD-STANDARD-INPUT STANDARD-INPUT))
    614                                  #'(LAMBDA (OP &REST REST)
    615                                      (PROG1 (LEXPR-FUNCALL OLD-STANDARD-INPUT OP REST)
    616                                             (COND ((EQ OP ':MACRO-ERROR)
    617                                                    (*THROW 'EXIT-KBD-MACRO-MOVER
    618                                                            ':MACRO-ERROR))))))))
    619     (ARRAY-PUSH-EXTEND OLD-MACRO-PREVIOUS-ARRAY -1)
    620     (SETF (MACRO-LENGTH OLD-MACRO-PREVIOUS-ARRAY)
    621           (1- (MACRO-POSITION OLD-MACRO-PREVIOUS-ARRAY)))
    622     #'(LAMBDA (BP &AUX (POINT (POINT)) OLD-POINT)
    623         (SETQ OLD-POINT (COPY-BP POINT ':NORMAL))
    624         (MOVE-BP (POINT) BP)
    625         (UNWIND-PROTECT
    626           (LET ((*COMTAB* *MAKE-KBD-MACRO-MOVER-COMTAB*))
    627             (FUNCALL STANDARD-INPUT ':MACRO-EXECUTE OLD-MACRO-PREVIOUS-ARRAY 1)
    628             (AND (EQ (*CATCH 'EXIT-KBD-MACRO-MOVER
    629                        (FUNCALL-SELF ':EDIT))
    630                      ':MACRO-ERROR)
    631                  (*THROW 'ZWEI-COMMAND-LOOP T))
    632             (COPY-BP POINT))
    633           (MOVE-BP (POINT) OLD-POINT)
    634           (FLUSH-BP OLD-POINT)))))
    635 
    636 (DEFUN COM-EXIT-KBD-MACRO-MOVER ()
    637   (*THROW 'EXIT-KBD-MACRO-MOVER T))
    638 
    639 (DEFCOM COM-SORT-VIA-KEYBOARD-MACROS "Sort the region alphabetically.
    640 Keyboard macros are read to move to the various part of the region to be sorted." ()
    641   (REGION (BP1 BP2)
    642     (WITH-BP (FIRST-BP BP1 ':NORMAL)
    643       (WITH-BP (LAST-BP BP2 ':MOVES)
    644         (SETF (WINDOW-MARK-P *WINDOW*) NIL)
    645         (MOVE-BP (POINT) FIRST-BP)
    646         (MUST-REDISPLAY *WINDOW* DIS-BPS)
    647         (LET ((MOVE-TO-KEY-MACRO (MAKE-KBD-MACRO-MOVER "move to the start of the sort key"))
    648               (MOVE-OVER-KEY-MACRO (MAKE-KBD-MACRO-MOVER "move over the sort key"))
    649               (MOVE-TO-NEXT-MACRO (MAKE-KBD-MACRO-MOVER "move to the end of the record")))
    650           (SORT-INTERVAL-FUNCTIONS MOVE-TO-KEY-MACRO MOVE-OVER-KEY-MACRO MOVE-TO-NEXT-MACRO
    651                                    #'INTERVAL-WITH-SORT-INTERVAL-LESSP FIRST-BP LAST-BP T)))))
    652   DIS-TEXT)
     349  (LET ((TEM (MEMQ TEMPDEF CORRESPONDENCE)))
     350    (AND TEM (RPLACA TEM REALDEF)))
     351  ;; In the real definition, some displacing macros may have gone off.
     352  (AND (EQ (CAR REALDEF) 'SI:DISPLACED)
     353       (SETQ REALDEF (CADR REALDEF)))
     354  (OR (= (LENGTH TEMPDEF) (LENGTH REALDEF))
     355      (THROW NIL TRANSFER-CORRESPONDENCE-LOSSAGE))
     356  (DO ((TD TEMPDEF (CDR TD))
     357       (RD REALDEF (CDR RD)))
     358      ((NULL TD))
     359    (AND (COND ((ATOM (CAR TD)) (NEQ (CAR TD) (CAR RD)))
     360               (T (ATOM (CAR RD))))
     361         (THROW NIL TRANSFER-CORRESPONDENCE-LOSSAGE))
     362    (OR (ATOM (CAR TD))
     363        (TRANSFER-CORRESPONDENCE FUNCTION CORRESPONDENCE (CAR TD) (CAR RD)))))
     364
     365
     366;;; These functions know about zmacs buffers and nodes
     367(DEFUN UPDATE-INTERVAL-COMPILE-TICK (BP1 &OPTIONAL BP2 IN-ORDER-P)
     368  (TICK)
     369  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
     370  (DO ((NODE (BP-NODE BP1) (NODE-NEXT NODE)))
     371      ((OR (NULL NODE)
     372           (NOT (BP-< (INTERVAL-FIRST-BP NODE) BP2))))
     373    (AND (TYPEP NODE 'SECTION-NODE)
     374         (SETF (SECTION-NODE-COMPILE-TICK NODE) *TICK*))))
     375
     376(DEFCOM COM-COMPILE-BUFFER-CHANGED-FUNCTIONS "Compile any sections which have been edited"
     377        ()
     378  (COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
     379    (COMPILE-BUFFER-CHANGED-FUNCTIONS *INTERVAL* *NUMERIC-ARG-P*))
     380  (FORMAT T "~&Done.~%")
     381  DIS-NONE)
     382
     383(DEFCOM COM-COMPILE-CHANGED-FUNCTIONS "Compile any sections which have been edited" ()
     384  (COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
     385    (DOLIST (BUFFER *ZMACS-BUFFER-LIST*)
     386      (AND (EQ (IF (EQ BUFFER *INTERVAL*) *MAJOR-MODE*
     387                   (BUFFER-SAVED-MAJOR-MODE BUFFER))
     388               'LISP-MODE)
     389           (COMPILE-BUFFER-CHANGED-FUNCTIONS BUFFER *NUMERIC-ARG-P*))))
     390  (FORMAT T "~&Done.~%")
     391  DIS-NONE)
     392
     393(DEFCOM COM-EVALUATE-BUFFER-CHANGED-FUNCTIONS "Evaluate any sections which have been edited"
     394        ()
     395  (COMPILE-BUFFER-CHANGED-FUNCTIONS *INTERVAL* *NUMERIC-ARG-P* NIL
     396                                    '("Evaluate" "Evaluating" "evaluated."))
     397  (FORMAT T "~&Done.~%")
     398  DIS-NONE)
     399
     400(DEFCOM COM-EVALUATE-CHANGED-FUNCTIONS "Evaluate any sections which have been edited" ()
     401  (DOLIST (BUFFER *ZMACS-BUFFER-LIST*)
     402    (AND (EQ (IF (EQ BUFFER *INTERVAL*) *MAJOR-MODE*
     403                 (BUFFER-SAVED-MAJOR-MODE BUFFER))
     404             'LISP-MODE)
     405         (COMPILE-BUFFER-CHANGED-FUNCTIONS BUFFER *NUMERIC-ARG-P*
     406                                           NIL '("Evaluate" "Evaluating" "evaluated.") )))
     407  (FORMAT T "~&Done.~%")
     408  DIS-NONE)
     409
     410(DEFUN COMPILE-BUFFER-CHANGED-FUNCTIONS (*INTERVAL* ASK-P
     411                                         &OPTIONAL (COMPILE-P T)
     412                                         (NAMES '("Compile" "Compiling" "compiled."))
     413                                         &AUX (QUERY-IO *TYPEOUT-WINDOW*))
     414  (DOLIST (SECTION (NODE-INFERIORS *INTERVAL*))
     415    (AND (TYPEP SECTION 'SECTION-NODE)
     416         (> (NODE-TICK SECTION) (SECTION-NODE-COMPILE-TICK SECTION))
     417         (LET ((NAME (GET-SECTION-NODE-NAME SECTION)))
     418           (AND (OR (NOT ASK-P)
     419                    (FQUERY '(:SELECT T) "~A ~A? " (FIRST NAMES) NAME))
     420                (COMPILE-PRINT-INTERVAL SECTION NIL T COMPILE-P NAME
     421                                        (SECOND NAMES) (THIRD NAMES) ':TYPEOUT T))))))
     422
     423(DEFUN GET-SECTION-NODE-NAME (SECTION-NODE &AUX DEFUN-LINE)
     424  (IF (SETQ DEFUN-LINE (SECTION-NODE-DEFUN-LINE SECTION-NODE))
     425      (GET-DEFUN-NAME (CREATE-BP DEFUN-LINE 0))
     426      (SECTION-NODE-NAME SECTION-NODE)))
     427
     428(DEFCOM COM-LIST-CHANGED-FUNCTIONS "List any sections which have been edited" ()
     429  (LET ((ITEM-LIST (LIST-CHANGED-FUNCTIONS-INTERNAL NIL)))
     430    (EDIT-FUNCTIONS-DISPLAY ITEM-LIST "~A:" "No ~A found." "Changed functions"))
     431  DIS-NONE)
     432
     433(DEFCOM COM-EDIT-CHANGED-FUNCTIONS "Edit any sections which have been edited" ()
     434  (LIST-CHANGED-FUNCTIONS-INTERNAL NIL)
     435  (COM-NEXT-CALLER))
     436
     437(DEFCOM COM-LIST-BUFFER-CHANGED-FUNCTIONS "List any sections which have been edited" ()
     438  (LET ((ITEM-LIST (LIST-CHANGED-FUNCTIONS-INTERNAL T)))
     439    (EDIT-FUNCTIONS-DISPLAY ITEM-LIST "~A:" "No ~A found." "Changed functions"))
     440  DIS-NONE)
     441
     442(DEFCOM COM-EDIT-BUFFER-CHANGED-FUNCTIONS "Edit any sections which have been edited" ()
     443  (LIST-CHANGED-FUNCTIONS-INTERNAL T)
     444  (COM-NEXT-CALLER))
     445
     446(DEFUN LIST-CHANGED-FUNCTIONS-INTERNAL (ONE-BUFFER-P &AUX ITEM-LIST SYMBOL-LIST)
     447  (IF ONE-BUFFER-P
     448      (MULTIPLE-VALUE (ITEM-LIST SYMBOL-LIST)
     449        (LIST-CHANGED-FUNCTIONS-INTERNAL-1 *INTERVAL*))
     450      (DOLIST (BUFFER *ZMACS-BUFFER-LIST*)
     451        (AND (EQ (IF (EQ BUFFER *INTERVAL*) *MAJOR-MODE*
     452                   (BUFFER-SAVED-MAJOR-MODE BUFFER))
     453               'LISP-MODE)
     454             (MULTIPLE-VALUE-BIND (ITL SML)
     455                 (LIST-CHANGED-FUNCTIONS-INTERNAL-1 BUFFER)
     456               (SETQ ITEM-LIST (NCONC ITEM-LIST ITL)
     457                     SYMBOL-LIST (NCONC SYMBOL-LIST SML))))))
     458  (SETUP-ZMACS-CALLERS-TO-BE-EDITED SYMBOL-LIST)
     459  ITEM-LIST)
     460
     461(DEFUN LIST-CHANGED-FUNCTIONS-INTERNAL-1 (BUFFER &AUX ITEM-LIST SYMBOL-LIST)
     462  (DOLIST (SECTION (NODE-INFERIORS BUFFER))
     463    (AND (TYPEP SECTION 'SECTION-NODE)
     464         (> (NODE-TICK SECTION) (MIN (BUFFER-TICK BUFFER)
     465                                     (SECTION-NODE-COMPILE-TICK SECTION)))
     466         (SECTION-NODE-DEFUN-LINE SECTION)
     467         (LET ((SYMBOL (SECTION-NODE-NAME SECTION)))
     468           (PUSH SYMBOL SYMBOL-LIST)
     469           (PUSH (CONS (GET-SECTION-NODE-NAME SECTION) SYMBOL) ITEM-LIST))))
     470  (VALUES (NREVERSE ITEM-LIST) (NREVERSE SYMBOL-LIST)))
     471
     472
     473;;; These are the functions called from inside the compiler for maintaining the
     474;;; compiler-warnings buffer.
     475
     476;;; This is called by the compiler when it begins to compile something
     477(DEFUN SETUP-COMPILER-WARNINGS (&OPTIONAL INPUT-STREAM
     478                                &AUX WO NAME PATHNAME TYPE FULL-P WARNINGS-INT)
     479 
     480  (COND ((NULL INPUT-STREAM))
     481        ((MEMQ ':COMPILER-WARNINGS-NAME (SETQ WO (FUNCALL INPUT-STREAM ':WHICH-OPERATIONS)))
     482         (MULTIPLE-VALUE (PATHNAME NAME TYPE FULL-P)
     483           (FUNCALL INPUT-STREAM ':COMPILER-WARNINGS-NAME)))
     484        ((MEMQ ':PATHNAME WO)
     485         (AND (SETQ PATHNAME (FUNCALL INPUT-STREAM ':PATHNAME))
     486              (SETQ NAME (FUNCALL PATHNAME ':STRING-FOR-PRINTING)
     487                    TYPE "file"
     488                    FULL-P T))))
     489  (OR NAME
     490      (SETQ NAME "random" TYPE "Someplace" FULL-P NIL))
     491  (COND ((NULL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM)
     492         (SETQ FULL-P T))
     493        ((NEQ COMPILER:CONCATENATE-COMPILER-WARNINGS-P ':BY-FILE)
     494         (FORMAT COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
     495                 "~2&Compiling ~:[from ~]~A ~A~2%" FULL-P TYPE NAME)
     496         (SETQ FULL-P T))                       ;Pretend to be doing whole file
     497        (T
     498         (AND PATHNAME (SETQ NAME (FUNCALL PATHNAME ':STRING-FOR-PRINTING)
     499                             TYPE "file"))
     500         ;;Get the buffer into which warnings are going
     501         (SETQ WARNINGS-INT (BP-TOP-LEVEL-NODE
     502                              (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
     503                                       ':READ-BP)))
     504         (MULTIPLE-VALUE-BIND (START-BP END-BP)
     505             (FIND-WARNINGS-FOR-FILE WARNINGS-INT NAME)
     506           (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
     507                    ':SET-BP END-BP)
     508           (IF START-BP
     509               (AND FULL-P
     510                    (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
     511                             ':DELETE-INTERVAL
     512                             (LET ((*INTERVAL* WARNINGS-INT))
     513                               (BEG-LINE START-BP 1 T))
     514                             END-BP T))
     515               (FORMAT COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
     516                       "~2&~|~%Warnings for ~A ~A~%" TYPE NAME))
     517           (SETQ END-BP (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
     518                                   ':READ-BP))
     519           (LET ((*INTERVAL* WARNINGS-INT))
     520             (OR (LINE-BLANK-P (BP-LINE END-BP))
     521                 (WITH-BP (BP END-BP ':NORMAL)
     522                   (INSERT (BEG-LINE BP) #\CR)
     523                   (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
     524                            ':SET-BP BP)))))))
     525  FULL-P)
     526
     527(DEFUN FIND-WARNINGS-FOR-FILE (WARNINGS-INT NAME)
     528  (DO ((LINE (BP-LINE (INTERVAL-FIRST-BP WARNINGS-INT)) (LINE-NEXT LINE))
     529       (LAST-LINE (BP-LINE (INTERVAL-LAST-BP WARNINGS-INT)))
     530       (START-LINE) (START-BP)
     531       (LAST-P) (PAGE-P)
     532       (FIRST-P T PAGE-P))
     533      (NIL)
     534    (COND ((OR (SETQ LAST-P (EQ LINE LAST-LINE))
     535               (SETQ PAGE-P (%STRING-EQUAL LINE 0 "
     536" 0 1)))
     537           (COND ((OR START-LINE LAST-P)
     538                  (SETQ START-BP (CREATE-BP LINE (IF LAST-P
     539                                                     (BP-INDEX (INTERVAL-LAST-BP
     540                                                                 WARNINGS-INT))
     541                                                     0)))
     542                  (RETURN (AND START-LINE (CREATE-BP START-LINE 0))
     543                          START-BP))))
     544          ((AND FIRST-P
     545                (%STRING-EQUAL LINE 0 "Warnings for " 0 13.)
     546                (LET ((LEN (ARRAY-ACTIVE-LENGTH NAME)))
     547                  (%STRING-EQUAL LINE (- (LINE-LENGTH LINE) LEN) NAME 0 LEN)))
     548           (SETQ START-LINE LINE)))))
     549
     550;;; This is called when starting to compile from an interval stream
     551;;; Returns pathname, name, type, full-file-p
     552(DEFUN INTERVAL-IO-COMPILER-WARNINGS-NAME (IGNORE &AUX INT)
     553   (DECLARE (SPECIAL *LINE* *INDEX*))
     554   (AND (TYPEP (SETQ INT (BP-TOP-LEVEL-NODE (CREATE-BP *LINE* *INDEX*))) 'FILE-BUFFER)
     555        (VALUES (BUFFER-PATHNAME INT)
     556                (BUFFER-NAME INT)
     557                "buffer"
     558                (AND (BP-= (INTERVAL-FIRST-BP *INTERVAL*) (INTERVAL-FIRST-BP INT))
     559                     (BP-= (INTERVAL-LAST-BP *INTERVAL*) (INTERVAL-LAST-BP INT))))))
     560
     561;;; This is called when compiling single functions for each one.
     562;;; Find any warnings for this function from before and delete them.
     563(DEFUN COMPILER-WARNINGS-SETUP-FOR-PROCESSING-FUNCTION (FUNCTION &AUX START-BP END-BP)
     564  (LET* ((BP (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM ':READ-BP))
     565         (*INTERVAL* (BP-TOP-LEVEL-NODE BP)))
     566    (SETQ START-BP (FORWARD-PAGE BP -1 T)
     567          END-BP (FORWARD-PAGE START-BP 1 T))
     568    (AND (STRING-EQUAL (BP-LINE START-BP) "
     569")
     570         (SETQ START-BP (BEG-LINE START-BP 1 T)))
     571    (AND (STRING-EQUAL (BP-LINE END-BP) "
     572")
     573         (SETQ END-BP (BEG-LINE END-BP -1 T))))
     574  (LET ((NAME (FORMAT NIL "~S" FUNCTION)))
     575    (DO ((LINE (BP-LINE START-BP) (LINE-NEXT LINE))
     576         (END-LINE (BP-LINE END-BP))
     577         (LEN (ARRAY-ACTIVE-LENGTH NAME))
     578         (START-LINE) (LAST-P))
     579        (NIL)
     580      (COND ((OR (SETQ LAST-P (EQ LINE END-LINE))
     581                 (%STRING-EQUAL LINE 0 "<< While compiling " 0 19.))
     582             (COND (START-LINE
     583                    (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
     584                             ':DELETE-INTERVAL (CREATE-BP START-LINE 0) (CREATE-BP LINE 0) T)
     585                    (RETURN NIL)))
     586             (AND LAST-P (RETURN NIL))                                                       
     587             (AND (%STRING-EQUAL LINE (- (LINE-LENGTH LINE) LEN 3) NAME 0 LEN)
     588                  (SETQ START-LINE LINE)))))))
  • trunk/lisp/zwei/comd.lisp

    r258 r273  
    66;;; Puts the PROMPT in the mode line, and gets a qreg name in the echo area.
    77;;; Returns a symbol in the utility-package.
    8 (DEFUN GET-Q-REG-NAME (PROMPT &AUX CHAR STR OLDP SYM XCHAR)
     8(DEFUN GET-Q-REGISTER-NAME (PROMPT &AUX CHAR STR OLDP SYM XCHAR)
    99  (SETQ XCHAR (FUNCALL STANDARD-INPUT ':TYI-NO-HANG))
    1010  (COND ((NULL XCHAR)
    1111         (PROMPT-LINE "~A" PROMPT)
    12          (TYPEIN-LINE "Q-Reg: ")
     12         (TYPEIN-LINE "Q-Register: ")
    1313         (TYPEIN-LINE-ACTIVATE
    1414           (SETQ CHAR (FUNCALL STANDARD-INPUT ':TYI)))))
     
    2424  SYM)
    2525
    26 (DEFCOM COM-OPEN-GET-Q-REG "Insert text in a specified Q-reg, overwriting
     26(DEFCOM COM-OPEN-GET-Q-REGISTER "Insert text in a specified Q-Register, overwriting
    2727blank lines the way Return does (calling the definition of Return).
    2828Leaves the point after, and the mark before, the text.
    2929With an argument, puts point before and mark after." ()
    30   (LET ((QREG (GET-Q-REG-NAME "Get text from Q-Register.")))
     30  (LET ((QREG (GET-Q-REGISTER-NAME "Get text from Q-Register.")))
    3131    (LET ((POINT (POINT))
    3232          (MARK (MARK))
     
    4848  DIS-TEXT)
    4949
    50 (DEFCOM COM-GET-Q-REG "Get contents of Q-reg (reads name from kbd).
     50(DEFCOM COM-GET-Q-REGISTER "Get contents of Q-Register (reads name from kbd).
    5151Leaves the pointer before, and the mark after, the text.
    5252With argument, puts point after and mark before." ()
    53   (LET ((QREG (GET-Q-REG-NAME "Get text from Q-Register.")))
     53  (LET ((QREG (GET-Q-REGISTER-NAME "Get text from Q-Register.")))
    5454    (LET ((THING (GET QREG 'TEXT)))
    5555      (OR THING (BARF "The q-register ~A does not contain any text." QREG))
    5656      (MOVE-BP (MARK) (INSERT-INTERVAL (POINT) THING))
    5757      (SETQ *CURRENT-COMMAND-TYPE* 'YANK)
    58       (AND *NUMERIC-ARG-P*
    59            (SWAP-BPS (POINT) (MARK)))))
     58      (OR *NUMERIC-ARG-P*
     59          (SWAP-BPS (POINT) (MARK)))))
    6060  DIS-TEXT)
    6161
    62 (DEFCOM COM-PUT-Q-REG "Put point to mark into q-reg (reads name from kbd).
     62(DEFCOM COM-PUT-Q-REGISTER "Put point to mark into q-register (reads name from kbd).
    6363With an argument, the text is also deleted." ()
    6464  (REGION (BP1 BP2)
    65     (LET ((QREG (GET-Q-REG-NAME "Put text into Q-Register.")))
     65    (LET ((QREG (GET-Q-REGISTER-NAME "Put text into Q-Register.")))
    6666      (PUTPROP QREG (COPY-INTERVAL BP1 BP2 T) 'TEXT)
    6767      (COND (*NUMERIC-ARG-P*
     
    7070            (T DIS-NONE)))))
    7171
    72 (DEFCOM COM-VIEW-Q-REGISTER "Display the contents of a q-reg (reads name from kbd)." (KM)
    73   (VIEW-Q-REG (GET-Q-REG-NAME "View Q-Register."))
    74   DIS-NONE)
    75 
    76 (DEFUN VIEW-Q-REG (SYM)
     72(DEFCOM COM-VIEW-Q-REGISTER "Display the contents of a q-register (reads name from kbd)." (KM)
     73  (VIEW-Q-REGISTER (GET-Q-REGISTER-NAME "View Q-Register."))
     74  DIS-NONE)
     75
     76(DEFUN VIEW-Q-REGISTER (SYM)
    7777  (LET ((TEXT (GET SYM 'TEXT)))
    7878    (FORMAT T "~&~10,5,2A~A~%" SYM
     
    8282                  (T (NSUBSTRING TEXT 0 50.))))))
    8383
    84 (DEFCOM COM-LIST-Q-REGISTERS "List and display the contents of all defined q-regs." ()
     84(DEFCOM COM-LIST-Q-REGISTERS "List and display the contents of all defined q-registers." ()
    8585  (FORMAT T "List of all Q-registers:")
    8686  (DO L *Q-REG-LIST* (CDR L) (NULL L)
    87       (VIEW-Q-REG (CAR L)))
     87      (VIEW-Q-REGISTER (CAR L)))
    8888  (FORMAT T "Done.")
    8989  DIS-NONE)
    9090
    91 (DEFCOM COM-KILL-Q-REGISTER "Kill a q-reg." ()
    92   (LET ((Q-REG (GET-Q-REG-NAME "Kill Q-Register.")))
     91(DEFCOM COM-KILL-Q-REGISTER "Kill a q-register." ()
     92  (LET ((Q-REG (GET-Q-REGISTER-NAME "Kill Q-Register.")))
    9393    (COND ((GET Q-REG 'TEXT)
    9494           (SETQ *Q-REG-LIST* (DELQ Q-REG *Q-REG-LIST*))
     
    9797  DIS-NONE)
    9898
    99 (DEFCOM COM-POINT-TO-Q-REG "Save the current location in a q-reg." ()
    100   (LET ((Q-REG (GET-Q-REG-NAME "Point to Q-Register")))
     99(DEFCOM COM-POINT-TO-Q-REGISTER "Save the current location in a q-register." ()
     100  (LET ((Q-REG (GET-Q-REGISTER-NAME "Point to Q-Register")))
    101101    (LET ((PT (GET Q-REG 'POINT)))
    102102      (COND (PT
     
    108108  DIS-NONE)
    109109
    110 (DEFCOM COM-Q-REG-TO-POINT "Restore a saved point from a q-reg." (KM)
    111   (LET ((Q-REG (GET-Q-REG-NAME "Q-Register to point")))
     110(DEFCOM COM-Q-REGISTER-TO-POINT "Restore a saved point from a q-register." (KM)
     111  (LET ((Q-REG (GET-Q-REGISTER-NAME "Q-Register to point")))
    112112    (LET ((PT (GET Q-REG 'POINT)))
    113113      (COND ((NULL PT)
     
    135135         (DELETE-INTERVAL *INTERVAL*)
    136136         DIS-TEXT)))
     137
     138(DEFCOM COM-RECURSIVE-EDIT-ABORT "Quit out of recursive edit right away" ()
     139  (*THROW 'TOP-LEVEL T))
    137140
    138141(DEFVAR *MINI-BUFFER-COMMAND-IN-PROGRESS* NIL)
     
    151154    (AND INITIAL-CHAR-POS
    152155         (MOVE-BP BP (FORWARD-CHAR BP INITIAL-CHAR-POS))))
     156  (AND *MINI-BUFFER-COMMAND-IN-PROGRESS*        ;Recursive mini-buffers don't work
     157       (BARF "Mini-buffer entered recursively"))
    153158  (OR *MINI-BUFFER-COMMAND*
    154159      (MINI-BUFFER-RING-PUSH (SETQ *MINI-BUFFER-COMMAND*
     
    171176                 (SELECT-WINDOW *WINDOW*)))))))
    172177
    173 (DEFCOM COM-REPEAT-LAST-MINI-BUFFER-COMMAND "Repeat a recent mini-buffer command" ()
     178(DEFCOM COM-REPEAT-LAST-MINI-BUFFER-COMMAND "Repeat a recent mini-buffer command.
     179A numeric argument does the nth previous one.
     180An argument of 0 lists which ones are remembered." ()
    174181  (IF (NOT (ZEROP *NUMERIC-ARG*))
    175182      (RE-EXECUTE-MINI-BUFFER-COMMAND (NTH (1- *NUMERIC-ARG*) *MINI-BUFFER-RING*))
     
    193200
    194201(TV:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* :MINI-BUFFER-COMMAND "Re-execute"
    195                           RE-EXECUTE-MINI-BUFFER-COMMAND T)
     202                          RE-EXECUTE-MINI-BUFFER-COMMAND T
     203                          "Re-execute this command.")
    196204
    197205(DEFUN RE-EXECUTE-MINI-BUFFER-COMMAND (*MINI-BUFFER-REPEATED-COMMAND*)
     
    223231       (MULTIPLE-VALUE (CONTENTS NIL NIL NIL CHAR-POS)
    224232         (COMPLETE-STRING "" *COMPLETING-ALIST* *COMPLETING-DELIMS* T 0)))
    225   (EDIT-IN-MINI-BUFFER *COMPLETING-READER-COMTAB* CONTENTS CHAR-POS
    226                        (AND PROMPT (NCONS PROMPT))))
     233  (WITH-MINI-BUFFER-COMPLETION (*MINI-BUFFER-WINDOW*)
     234    (EDIT-IN-MINI-BUFFER *COMPLETING-READER-COMTAB* CONTENTS CHAR-POS
     235                         (AND PROMPT (NCONS PROMPT)))))
    227236
    228237;; Note that WINDOW is a window system type window, not a ZWEI-WINDOW
     
    279288                          (NEQ *LAST-COMMAND-TYPE* 'FAILING-COMPLETION)
    280289                          (NUMBERP *LAST-COMMAND-CHAR*)
    281                           (NOT (LDB-TEST %%KBD-CONTROL *LAST-COMMAND-CHAR*)))
     290                          (NOT (LDB-TEST %%KBD-CONTROL
     291                                         (COMTAB-CHAR-INDIRECTION *LAST-COMMAND-CHAR*))))
    282292                     (SETQ COMPLETION (COMPLETE-LINE T NIL))
    283293                     (SETQ COMPLETION (IF (= (LENGTH COMPLETION) 1) (CAR COMPLETION)
     
    302312  DIS-TEXT)
    303313
     314(DEFCOM COM-COMPLETE-AND-EXIT-IF-UNIQUE "Attempt to complete and return only if unique." ()
     315  (LET ((*COMPLETING-IMPOSSIBLE-IS-OK-P* NIL))
     316    (COM-COMPLETE-AND-EXIT)))
     317
    304318(DEFCOM COM-LIST-COMPLETIONS "Give a menu of possible completions for string so far." ()
    305319  (LET (POSS)
    306320    (MULTIPLE-VALUE (NIL POSS)
    307          (COMPLETE-STRING (BP-LINE (POINT)) *COMPLETING-ALIST* *COMPLETING-DELIMS*))
    308    (OR POSS (BARF))
    309    (AND *COMPLETING-HELP-MESSAGE* (FORMAT *TYPEOUT-WINDOW* "~&~A" *COMPLETING-HELP-MESSAGE*))
    310    (FORMAT *TYPEOUT-WINDOW*
    311            "~&These are the possible completions of the text you have typed:~2%")
    312    (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST 'COMPLETION
    313             (SORT (MAPCAR #'CAR POSS) #'STRING-LESSP))
    314    (TERPRI *TYPEOUT-WINDOW*)
    315    DIS-NONE))
     321      (COMPLETE-STRING (BP-LINE (POINT)) *COMPLETING-ALIST* *COMPLETING-DELIMS*))
     322    (OR POSS (BARF))
     323    (AND *COMPLETING-HELP-MESSAGE* (FORMAT *TYPEOUT-WINDOW* "~&~A" *COMPLETING-HELP-MESSAGE*))
     324    (LIST-COMPLETIONS-INTERNAL POSS))
     325  DIS-NONE)
     326
     327(DEFUN LIST-COMPLETIONS-INTERNAL (POSS &AUX LEN)
     328  (SETQ LEN (LENGTH POSS))
     329  (COND ((ZEROP LEN)
     330         (FORMAT *TYPEOUT-WINDOW*
     331                 "~&There are no possible completions of the text you have typed.~%"))
     332        ((= LEN 1)
     333         (FORMAT *TYPEOUT-WINDOW*
     334                 "~&The only possible completion of the text you have typed is ")
     335         (FUNCALL *TYPEOUT-WINDOW* ':ITEM 'COMPLETION (CAAR POSS))
     336         (FORMAT *TYPEOUT-WINDOW* ":~%")
     337         (COND (*COMPLETING-DOCUMENTER*
     338                (TERPRI *TYPEOUT-WINDOW*)
     339                (FUNCALL *COMPLETING-DOCUMENTER* (CAR POSS)))))
     340        ((OR (< LEN 50.)
     341             (LET ((QUERY-IO *TYPEOUT-WINDOW*))
     342               (FQUERY NIL "There are ~D possibilities, do you really want to see them all? "
     343                       LEN)))
     344         (FORMAT *TYPEOUT-WINDOW*
     345                 "~&These are the possible completions of the text you have typed:~2%")
     346         (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST 'COMPLETION
     347                  (SORT (MAPCAR #'CAR POSS) #'STRING-LESSP))
     348         (TERPRI *TYPEOUT-WINDOW*))))
    316349
    317350(DEFCOM COM-COMPLETION-APROPOS "Do apropos within the completions of what has been typed." ()
     
    351384  DIS-NONE)
    352385 
    353 (TV:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* COMPLETION "Select" SELECT-COMPLETION T)
     386(TV:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* COMPLETION "Select" SELECT-COMPLETION T
     387                          "Use this completion.")
    354388
    355389;Called if the user mouses one of the completions
     
    380414"You are typing to a mini-buffer, with the following commands redefined:
    381415Altmode causes as much of the string as can be determined to be inserted
    382 into the mini-buffer (this is called command completion).  Space and -
    383 are similar; they complete up to the next Space and - respectively.
    384 ? lists all the strings that match what you have typed so far.
     416into the mini-buffer (this is called command completion).  Space and )
     417are similar; they complete up to the next Space or ) respectively.
     418
     419Control-? lists all the strings that complete what you have typed so far,
     420without the rest of this HELP display.  Control-// lists all the strings
     421that contain what you have typed anywhere within them.
     422
     423End will complete as much as possible and return if that gives a unique result.
    385424Return will complete as much as possible, and ")
    386425   (FORMAT T
     
    391430   (FORMAT T "~2%")
    392431   (MULTIPLE-VALUE (NIL POSS)
    393          (COMPLETE-STRING (BP-LINE (POINT)) *COMPLETING-ALIST* *COMPLETING-DELIMS*))
    394    (SELECTQ (LENGTH POSS)
    395      (0 (FORMAT T "There are no possible completions of the text you have typed.~%"))
    396      (1 (FORMAT T "The only possible completion of the text you have typed
    397 is ~A.~%" (CAAR POSS))
    398         (COND (*COMPLETING-DOCUMENTER*
    399                (TERPRI T)
    400                (FUNCALL *COMPLETING-DOCUMENTER* (CAR POSS)))))
    401      (OTHERWISE
    402       (FORMAT T "These are the possible completions of the text you have typed:~2%")
    403       (DO ((L POSS (CDR L))
    404            (FLAG 1 0))
    405           ((NULL L))
    406         (FORMAT T "~[, ~]~A" FLAG (CAAR L)))
    407       (TERPRI))))
     432     (COMPLETE-STRING (BP-LINE (POINT)) *COMPLETING-ALIST* *COMPLETING-DELIMS*))
     433   (LIST-COMPLETIONS-INTERNAL POSS))
    408434   DIS-NONE)
    409435
     
    474500       (ALL-AMBIG))
    475501      ((EQ L TAIL))
    476     (DO NIL ((LISTP L)) (SETQ L (CAR L)))       ;Indirect through multiple alists
    477     (COND ((NULL (COMPLETE-CHUNK-COMPARE (CAAR L) NCHUNKS CHUNKS CHUNK-DELIMS TEMS
     502    (COND ((NLISTP L))                          ;Indirect through multiple alists
     503          ((NULL (COMPLETE-CHUNK-COMPARE (CAAR L) NCHUNKS CHUNKS CHUNK-DELIMS TEMS
    478504                                         (AND (NULL RETS) RCHUNKS)))
    479505           (OR RETS (SETQ CHUNKS RCHUNKS))      ;First winner determines case of result
     
    536562  (AND COMPLETED-P (EQ TRUNC 'NOSPACE)
    537563       (SETQ COMPLETED-P 'NOSPACE))
    538   (MVRETURN TEMS (NREVERSE RETS) COMPLETED-P CHAR-POS MAGIC-POS))
     564  (VALUES TEMS (NREVERSE RETS) COMPLETED-P CHAR-POS MAGIC-POS))
    539565
    540566;;;Compare a STR with the given chunks and return NIL if it is a possible completion,
     
    622648          (T (SETQ HIHI IDX))))
    623649  (SETQ ALIST (G-L-P ALIST))
    624   (MVRETURN (NTHCDR LO ALIST) (NTHCDR (1+ HI) ALIST)))
     650  (VALUES (NTHCDR LO ALIST) (NTHCDR (1+ HI) ALIST)))
    625651
    626652;;; Sort an art-q array, such as can be passed to the completing reader
    627 ;;; The second (1) element of the array leader is non-NIL if sorting is
     653;;; The second (1) element of the array leader is NIL if sorting is
    628654;;; required.
    629655(DEFUN SORT-COMPLETION-AARRAY (AARRAY)
     
    635661;; Merge a sorted array ADDITIONAL-AARRAY of additional pairs into AARRAY.
    636662;; Assuming that AARRAY was also sorted, the result is sorted.
    637 (DEFUN MERGE-COMPLETION-AARRAY (AARRAY ADDITIONAL-AARRAY &AUX NEW-AARRAY TEM TEM1)
    638   ;; Make a new AARRAY big enough to hold both.
    639   (SETQ NEW-AARRAY (MAKE-ARRAY NIL ART-Q-LIST
    640                                (+ (ARRAY-ACTIVE-LENGTH AARRAY)
    641                                   (ARRAY-ACTIVE-LENGTH ADDITIONAL-AARRAY))
    642                                NIL 2))
    643   ;; Mark it empty.
    644   (STORE-ARRAY-LEADER 0 NEW-AARRAY 0)
    645   ;; Now merge the two inputs into it.
    646   (DO ((OLD 0) (ADDED 0)
    647        (OLD-MAX (ARRAY-ACTIVE-LENGTH AARRAY))
    648        (ADDED-MAX (ARRAY-ACTIVE-LENGTH ADDITIONAL-AARRAY)))
    649       ;; Done when both inputs are empty.
    650       ((AND (= OLD OLD-MAX) (= ADDED ADDED-MAX)))
    651     ;; Find which input aarray's next element is least.  Remove it
    652     (COND ((OR (= ADDED ADDED-MAX)
    653                (AND (NOT (= OLD OLD-MAX))
    654                     (STRING-LESSP (CAR (AREF AARRAY OLD))
    655                                   (CAR (AREF ADDITIONAL-AARRAY ADDED)))))
    656            (SETQ TEM (AREF AARRAY OLD))
    657            (SETQ OLD (1+ OLD)))
    658           (T (SETQ TEM (AREF ADDITIONAL-AARRAY ADDED))
    659              (SETQ ADDED (1+ ADDED))))
    660     ;; and insert it into the new aarray.  But flush duplicate strings.
    661     (IF (AND (NOT (ZEROP (ARRAY-ACTIVE-LENGTH NEW-AARRAY)))
    662              (STRING-EQUAL (CAR TEM)
    663                            (CAR (SETQ TEM1 (AREF NEW-AARRAY
    664                                                  (1- (ARRAY-ACTIVE-LENGTH NEW-AARRAY)))))))
    665         (LET ((LIST (SI:ELIMINATE-DUPLICATES (NCONC (IF (LISTP (CDR TEM)) (CDR TEM)
    666                                                         (NCONS (CDR TEM)))
    667                                                     (IF (LISTP (CDR TEM1)) (CDR TEM1)
    668                                                         (NCONS (CDR TEM1)))))))
    669           (SETF (CDR TEM1) (IF (CDR LIST) LIST (CAR LIST))))
    670         (ARRAY-PUSH-EXTEND NEW-AARRAY TEM)))
    671   (STORE-ARRAY-LEADER T NEW-AARRAY 1)
    672   (STRUCTURE-FORWARD AARRAY NEW-AARRAY))
     663(DEFUN MERGE-COMPLETION-AARRAY (AARRAY ADDITIONAL-AARRAY &AUX OLD-MAX ADDED-MAX NEW-AARRAY)
     664  (IF (ZEROP (SETQ ADDED-MAX (ARRAY-ACTIVE-LENGTH ADDITIONAL-AARRAY)))
     665      AARRAY
     666      (IF (ZEROP (SETQ OLD-MAX (ARRAY-ACTIVE-LENGTH AARRAY)))
     667          (SETQ NEW-AARRAY ADDITIONAL-AARRAY)
     668          ;; Make a new AARRAY big enough to hold both.
     669          (SETQ NEW-AARRAY (MAKE-ARRAY (+ OLD-MAX ADDED-MAX)
     670                                       ':TYPE 'ART-Q-LIST
     671                                       ':LEADER-LENGTH 2
     672                                       ':LEADER-LIST '(0)))
     673          ;; Now merge the two inputs into it.
     674          (DO ((OLD 0) (ADDED 0)
     675               (OLD-ELEM) (ADDED-ELEM)
     676               (ELEM-TO-BE-ADDED)
     677               (LAST-ELEM-ADDED NIL ELEM-TO-BE-ADDED))
     678              ;; Done when both inputs are empty.
     679              ((AND (= OLD OLD-MAX) (= ADDED ADDED-MAX)))
     680            ;; Find which input aarray's next element is least.  Remove it
     681            (SETQ ADDED-ELEM (AND ( ADDED ADDED-MAX) (AREF ADDITIONAL-AARRAY ADDED))
     682                  OLD-ELEM (AND ( OLD OLD-MAX) (AREF AARRAY OLD)))
     683            (IF (AND OLD-ELEM
     684                     (OR (NULL ADDED-ELEM)
     685                         (STRING-LESSP (CAR OLD-ELEM) (CAR ADDED-ELEM))))
     686                (SETQ ELEM-TO-BE-ADDED OLD-ELEM
     687                      OLD (1+ OLD))
     688                (SETQ ELEM-TO-BE-ADDED ADDED-ELEM
     689                      ADDED (1+ ADDED)))
     690            ;; and insert it into the new aarray.  But flush duplicate strings.
     691            (COND ((AND LAST-ELEM-ADDED
     692                        (%STRING-EQUAL (CAR ELEM-TO-BE-ADDED) 0
     693                                       (CAR LAST-ELEM-ADDED) 0 NIL))
     694                   (SETF (CDR LAST-ELEM-ADDED)
     695                         (MERGE-AND-ELIMINATE-DUPLICATES (CDR ELEM-TO-BE-ADDED)
     696                                                         (CDR LAST-ELEM-ADDED))))
     697                  ((ARRAY-PUSH NEW-AARRAY ELEM-TO-BE-ADDED))
     698                  (T                            ;This ought to never happen
     699                   (ARRAY-PUSH-EXTEND NEW-AARRAY ELEM-TO-BE-ADDED))))
     700          (STORE-ARRAY-LEADER T NEW-AARRAY 1))
     701      (STRUCTURE-FORWARD AARRAY NEW-AARRAY)))
     702
     703(DEFUN MERGE-AND-ELIMINATE-DUPLICATES (L1 L2 &AUX LIST)
     704  (SETQ LIST (IF (ATOM L1) (NCONS L1) (NREVERSE L1)))
     705  (IF (ATOM L2)
     706      (PUSH* L2 LIST)
     707      (DOLIST (X L2)
     708        (PUSH* X LIST)))
     709  (SETQ LIST (NREVERSE LIST))
     710  (IF (CDR LIST) LIST (CAR LIST)))
    673711
    674712;;;Is this string in the completion list?
     
    677715  (DO ((LO 0)
    678716       (HI (ARRAY-ACTIVE-LENGTH AARRAY))
    679        (IDX)
    680        (INC))
     717       IDX INC TEM)
    681718      (NIL)
    682719    (AND (ZEROP (SETQ INC (// (- HI LO) 2)))
    683720         (RETURN NIL))
    684721    (SETQ IDX (+ LO INC))
    685     (SELECTQ (STRING-COMPARE STRING (CAR (AREF AARRAY IDX)))
    686       (:EQUAL
    687        (RETURN T))
    688       (:GREATER
    689        (SETQ LO IDX))
    690       (OTHERWISE
    691        (SETQ HI IDX)))))
    692 
    693 (DEFUN STRING-COMPARE (STR1 STR2)
    694   (DO ((I 0 (1+ I))
    695        (LEN1 (STRING-LENGTH STR1))
    696        (LEN2 (STRING-LENGTH STR2))
    697        (CH1)
    698        (CH2))
    699       (NIL)
    700     (AND (
    701  I LEN1)
    702          (RETURN (OR (IF (
    703  I LEN2) ':EQUAL ':LESS))))
    704     (AND (
    705  I LEN2)
    706          (RETURN ':GREATER))
    707     (SETQ CH1 (AREF STR1 I)
    708           CH2 (AREF STR2 I))
    709     (AND (CHAR-LESSP CH1 CH2)
    710          (RETURN ':LESS))
    711     (AND (CHAR-LESSP CH2 CH1)
    712          (RETURN ':GREATER))))
     722    (COND ((ZEROP (SETQ TEM (STRING-COMPARE STRING (CAR (AREF AARRAY IDX)))))
     723           (RETURN T))
     724          ((PLUSP TEM)
     725           (SETQ LO IDX))
     726          (T
     727           (SETQ HI IDX)))))
    713728
    714729
     
    755770(DEFCOM COM-VARIABLE-APROPOS "List all variables whose names contain a given substring.
    756771With an argument, print documentation as well." ()
    757   (MULTIPLE-VALUE-BIND (FUNCTION STR)
     772  (MULTIPLE-VALUE-BIND (FUNCTION ARG STR)
    758773      (GET-EXTENDED-SEARCH-STRINGS "Variable Apropos (substring):")
    759774    (FORMAT T "~%ZWEI variables containing /"~A/":~2%" STR)
    760775    (DO L *VARIABLE-ALIST* (CDR L) (NULL L)
    761         (COND ((FUNCALL FUNCTION STR (CAAR L))
     776        (COND ((FUNCALL FUNCTION ARG (CAAR L))
    762777               (PRINT-VARIABLE (CDAR L))
    763778               (AND *NUMERIC-ARG-P*
     
    777792  DIS-NONE)
    778793
    779 (DEFCOM COM-VARIABLE-SET "Set a variable, checking type.
     794(DEFCOM COM-SET-VARIABLE "Set a variable, checking type.
    780795Read the name of a variable (with completion), display current value
    781796and documentation, and read a new variable.  Some checking is done
     
    827842                (:BOOLEAN
    828843                 (LET ((V (TYPEIN-LINE-READ "New value (T or NIL)")))
    829                    (OR (EQ T V) (BARF "~S is neither T nor NIL." V))
     844                   (OR (MEMQ V '(T NIL)) (BARF "~S is neither T nor NIL." V))
    830845                   V))
    831846                (:KEYWORD
     
    852867           ((NULL VAL) STRING)
    853868         (ARRAY-PUSH-EXTEND STRING (CAR VAL)))))))
     869
  • trunk/lisp/zwei/come.lisp

    r258 r273  
    11;;; Zwei commands, see ZWEI;COMA for comments -*-Mode:LISP; Package:ZWEI-*-
    22;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
     3
     4;;; Some random file viewing commands
     5(DEFCOM COM-VIEW-DIRECTORY "List an ITS file directory." ()
     6  (LET ((PATHNAME (READ-DIRECTORY-NAME "View directory" (DEFAULT-PATHNAME))))
     7    (VIEW-DIRECTORY PATHNAME)))
     8
     9(DEFCOM COM-VIEW-LOGIN-DIRECTORY "List files in user's directory." ()
     10  (VIEW-DIRECTORY (FUNCALL (FS:USER-HOMEDIR) ':NEW-PATHNAME ':NAME ':WILD
     11                                                            ':TYPE ':WILD
     12                                                            ':VERSION ':WILD)))
     13
     14(DEFCOM COM-VIEW-XGP-QUEUE "List XGP queue." ()
     15  (VIEW-FILE "AI: XGP: FOO; .FILE. (DIR)")
     16  DIS-NONE)
     17
     18(DEFCOM COM-VIEW-DOVER-QUEUE "List DOVER queue." ()
     19  (PRESS:PRINT-DOVER-QUEUE)
     20  DIS-NONE)
     21
     22(DEFCOM COM-VIEW-TTY-USERS "TTY
     23F" ()
     24  (VIEW-FILE "TTY: FOO; .FILE. (DIR)")
     25  DIS-NONE)
     26
     27(DEFCOM COM-VIEW-MAIL "View any new mail." ()
     28  (LET ((PATHNAME (FUNCALL (FS:USER-HOMEDIR) ':NEW-MAIL-PATHNAME)))
     29    (COND ((PROBEF PATHNAME)
     30           (VIEW-FILE PATHNAME))
     31          (T
     32           (TYPEIN-LINE "No new mail"))))
     33  DIS-NONE)
     34
    335
    436;;; Various Quantities.
     
    2254Ls, H buffer.
    2355Numeric arguments are obeyed.  ? for help." ()
    24     (SELECT-WINDOW *WINDOW*)
    25     (LET (CH MODE-NAME MODE QUANTITY)
    26       (TYPEIN-LINE-ACTIVATE
    27         (COND ((NOT NIL
    28 ;                   (SUPPRESS-REDISPLAY)
    29                     )
     56  (SELECT-WINDOW *WINDOW*)
     57  (PROG KLUDGE (CH MODE-NAME MODE QUANTITY)
     58    (TYPEIN-LINE-ACTIVATE
     59      (UNWIND-PROTECT
     60        (COND ((NOT (SETQ CH (FUNCALL STANDARD-INPUT ':TYI-NO-HANG)))
    3061               (TYPEIN-LINE "~:[~*~;~D ~]~:C: "
    31                             *NUMERIC-ARG-P* *NUMERIC-ARG* *LAST-COMMAND-CHAR*)))
    32         (SETQ CH (FUNCALL STANDARD-INPUT ':TYI))
    33         (COND ((OR (LDB-TEST %%KBD-CONTROL-META CH)
    34                    (MEMQ CH '(#/ #/ #/ #/
     62                            *NUMERIC-ARG-P* *NUMERIC-ARG* *LAST-COMMAND-CHAR*)
     63               (SETQ CH (FUNCALL STANDARD-INPUT ':TYI))))
     64        (FUNCALL *TYPEIN-WINDOW* ':MAKE-COMPLETE))      ;Make C-Q Abort look right
     65      (COND ((OR (LDB-TEST %%KBD-META CH)
     66                 (MEMQ CH '(#/ #/ #/ #/
    3567 #\CR)))
    36                ;; If char has control/meta, or is alpha, beta, epsilon, or equiv, then
    37                ;; insert into buffer as a two character sequence in the standard way.
    38                (INSERT-MOVING (POINT) (FORMAT NIL "~C" CH))
    39                DIS-TEXT)
    40               ((OR (< (SETQ CH (CHAR-UPCASE CH)) #/?) (> CH #/Z))
    41                (COND ((AND (
     68             ;; If char has control/meta, or is alpha, beta, epsilon, or equiv, then
     69             ;; insert into buffer as a two character sequence in the standard way.
     70             ;; Changed by RMS:
     71             ;; IF I WANT to insert alpha-X, I can type that.  That is a useless feature.
     72             ;; If I want to insert an ASCII control-X,
     73             ;; because there are computers that care about such characters,
     74             ;; I don't want to have to figure out what its numeric code
     75             ;; or SAIL char set equivalent is.
     76             (SETQ CH (COMTAB-CHAR-INDIRECTION CH))     ;This is for EMACS mode mostly
     77             (INSERT-MOVING (POINT) (FORMAT NIL "~C" CH))
     78             (RETURN-FROM KLUDGE DIS-TEXT))
     79            ((LDB-TEST %%KBD-CONTROL CH)
     80             (INSERT-MOVING (POINT) (LOGAND 77 (LDB %%CH-CHAR CH)))
     81             (RETURN-FROM KLUDGE DIS-TEXT))
     82            ((OR (< (SETQ CH (CHAR-UPCASE CH)) #/?) (> CH #/Z))
     83             (COND ((AND (
    4284 CH #/0) (
    4385 CH #/7))
    44                       (FUNCALL *TYPEIN-WINDOW* ':TYO CH)
    45                       (SETQ CH (- CH #/0))
    46                       (DO ((I 2 (1- I))
    47                            (CH1))
    48                           ((
     86                    (FUNCALL *TYPEIN-WINDOW* ':TYO CH)
     87                    (SETQ CH (- CH #/0))
     88                    (DO ((I 2 (1- I))
     89                         (CH1))
     90                        ((
    4991 I 0))
    50                           (SETQ CH1 (FUNCALL STANDARD-INPUT ':TYI))
    51                           (COND ((AND (
     92                      (SETQ CH1 (FUNCALL STANDARD-INPUT ':TYI))
     93                      (COND ((AND (
    5294 CH1 #/0) (
    5395 CH1 #/7))
    54                                  (FUNCALL *TYPEIN-WINDOW* ':TYO CH1)
    55                                  (SETQ CH (+ (* CH 8) (- CH1 #/0))))
    56                                 (T (OR (= CH1 #\SP)
    57                                        (FUNCALL STANDARD-INPUT ':UNTYI CH1))
    58                                    (RETURN NIL))))))
    59                (LET ((*LAST-COMMAND-CHAR* CH))
    60                  (MULTIPLE-VALUE-CALL (COM-SELF-INSERT))))
    61               (T
    62                (PROG ()
    63                 GET-A-MODE
    64                   (SELECTQ CH
    65                    (#/?
    66                     (TYPEIN-LINE "~%Type strange character or rubout to be inserted, or octal escape, or
     96                             (FUNCALL *TYPEIN-WINDOW* ':TYO CH1)
     97                             (SETQ CH (+ (* CH 8) (- CH1 #/0))))
     98                            (T (OR (= CH1 #\SP)
     99                                   (FUNCALL STANDARD-INPUT ':UNTYI CH1))
     100                               (RETURN NIL))))))
     101             (LET ((*LAST-COMMAND-CHAR* CH))
     102               (MULTIPLE-VALUE-BIND (VAL1 VAL2 VAL3)
     103                   (COM-SELF-INSERT)
     104                 (RETURN-FROM KLUDGE VAL1 VAL2 VAL3))))
     105            (T
     106             (PROG ()
     107                GET-A-MODE
     108                   (SELECTQ CH
     109                     (#/?
     110                      (TYPEIN-LINE "~%Type strange character or rubout to be inserted, or octal escape, or
    67111F forward, B backward, D delete, R rubout, T twiddle, M mode, @ Mark, U uppercase, L lowercase,
    68112S save, C copy, Z reverse  ")
    69                     (TYPEIN-LINE-MORE "~:[~*~;~D ~]~:C: "
    70                                  *NUMERIC-ARG-P* *NUMERIC-ARG* *LAST-COMMAND-CHAR*)
    71                     (SETQ CH (CHAR-UPCASE (FUNCALL STANDARD-INPUT ':TYI)))
    72                     (GO GET-A-MODE))
    73                    (#/F
    74                     (SETQ MODE-NAME "Forward"
    75                           MODE 'COM-QUANTITY-FORWARD))
    76                    (#/B
    77                     (SETQ MODE-NAME "Backward"
    78                           MODE 'COM-QUANTITY-BACKWARD))
    79                    (#/D
    80                     (SETQ MODE-NAME "Delete"
    81                           MODE 'COM-QUANTITY-DELETE))
    82                    (#/R
    83                     (SETQ MODE-NAME "Rubout"
    84                           MODE 'COM-QUANTITY-RUBOUT))
    85                    (#/T
    86                     (SETQ MODE-NAME "Twiddle"
    87                           MODE 'COM-QUANTITY-TWIDDLE))
    88                    (#/@
    89                     (SETQ MODE-NAME "Mark"
    90                           MODE 'COM-QUANTITY-MARK))
    91                    (#/M
    92                     (SETQ MODE-NAME "Mode"
    93                           MODE 'QUANTITY-MODE-SET))
    94                    (#/U
    95                     (SETQ MODE-NAME "Uppercase"
    96                           MODE 'COM-QUANTITY-UPPERCASE))
    97                    (#/L
    98                     (SETQ MODE-NAME "Lowercase"
    99                           MODE 'COM-QUANTITY-LOWERCASE))
    100                    (#/S
    101                     (SETQ MODE-NAME "Save"
    102                           MODE 'COM-QUANTITY-SAVE))
    103                    (#/C
    104                     (SETQ MODE-NAME "Copy"
    105                           MODE 'COM-QUANTITY-COPY))
    106                    (#/Z
    107                     (SETQ MODE-NAME "Reverse"
    108                           MODE 'COM-QUANTITY-REVERSE))
    109                    (OTHERWISE
    110                     (BARF "Invalid quantity operation")))
    111                   (TYPEIN-LINE "")
    112                GET-A-QUANTITY
    113                   (TYPEIN-LINE "~A~:[~*~; ~R~] "
    114                                MODE-NAME *NUMERIC-ARG-P* *NUMERIC-ARG*)
    115                   (SETQ CH (CHAR-UPCASE (FUNCALL STANDARD-INPUT ':TYI)))
    116                   (SELECTQ CH
    117                    (#/?
    118                     (TYPEIN-LINE "Type quantity name: C character, W word, S sentence, P paragraph, A atom, L line, -
     113                      (TYPEIN-LINE-MORE "~:[~*~;~D ~]~:C: "
     114                                        *NUMERIC-ARG-P* *NUMERIC-ARG* *LAST-COMMAND-CHAR*)
     115                      (SETQ CH (CHAR-UPCASE (FUNCALL STANDARD-INPUT ':TYI)))
     116                      (GO GET-A-MODE))
     117                     (#/F
     118                      (SETQ MODE-NAME "Forward"
     119                            MODE 'COM-QUANTITY-FORWARD))
     120                     (#/B
     121                      (SETQ MODE-NAME "Backward"
     122                            MODE 'COM-QUANTITY-BACKWARD))
     123                     (#/D
     124                      (SETQ MODE-NAME "Delete"
     125                            MODE 'COM-QUANTITY-DELETE))
     126                     (#/R
     127                      (SETQ MODE-NAME "Rubout"
     128                            MODE 'COM-QUANTITY-RUBOUT))
     129                     (#/T
     130                      (SETQ MODE-NAME "Twiddle"
     131                            MODE 'COM-QUANTITY-TWIDDLE))
     132                     (#/@
     133                      (SETQ MODE-NAME "Mark"
     134                            MODE 'COM-QUANTITY-MARK))
     135                     (#/M
     136                      (SETQ MODE-NAME "Mode"
     137                            MODE 'QUANTITY-MODE-SET))
     138                     (#/U
     139                      (SETQ MODE-NAME "Uppercase"
     140                            MODE 'COM-QUANTITY-UPPERCASE))
     141                     (#/L
     142                      (SETQ MODE-NAME "Lowercase"
     143                            MODE 'COM-QUANTITY-LOWERCASE))
     144                     (#/S
     145                      (SETQ MODE-NAME "Save"
     146                            MODE 'COM-QUANTITY-SAVE))
     147                     (#/C
     148                      (SETQ MODE-NAME "Copy"
     149                            MODE 'COM-QUANTITY-COPY))
     150                     (#/Z
     151                      (SETQ MODE-NAME "Reverse"
     152                            MODE 'COM-QUANTITY-REVERSE))
     153                     (OTHERWISE
     154                      (BARF "Invalid quantity operation")))
     155                   (TYPEIN-LINE "")
     156                GET-A-QUANTITY
     157                   (TYPEIN-LINE "~A~:[~*~; ~R~] "
     158                                MODE-NAME *NUMERIC-ARG-P* *NUMERIC-ARG*)
     159                   (SETQ CH (CHAR-UPCASE (FUNCALL STANDARD-INPUT ':TYI)))
     160                   (SELECTQ CH
     161                     (#/?
     162                      (TYPEIN-LINE "Type quantity name: C character, W word, S sentence, P paragraph, A atom, L line, -
    119163S-expression, ( or ) list, D defun, Form page, H buffer~%")
    120                     (GO GET-A-QUANTITY))
    121                    (#/C
    122                     (SETQ MODE-NAME "Character"
    123                           QUANTITY 'FORWARD-CHAR))
    124                    (#/W
    125                     (SETQ MODE-NAME "Word"
    126                           QUANTITY 'FORWARD-WORD))
    127                    (#/A
    128                     (SETQ MODE-NAME "Atom"
    129                           QUANTITY 'FORWARD-ATOM))
    130                    (#/S
    131                     (SETQ MODE-NAME "Sentence"
    132                           QUANTITY 'FORWARD-SENTENCE))
    133                    (#/P
    134                     (SETQ MODE-NAME "Paragraph"
    135                           QUANTITY 'FORWARD-PARAGRAPH))
    136                    (#/L
    137                     (SETQ MODE-NAME "Line"
    138                           QUANTITY 'FORWARD-LINE))
    139                    (#/-
    140                     (SETQ MODE-NAME "S-Expression"
    141                           QUANTITY 'FORWARD-SEXP))
    142                    ((#/( #/))
    143                     (SETQ MODE-NAME "List"
    144                           QUANTITY 'FORWARD-LIST))
    145                    (#/D
    146                     (SETQ MODE-NAME "Defun"
    147                           QUANTITY 'FORWARD-DEFUN))
    148                    (#\FF
    149                     (SETQ MODE-NAME "Page"
    150                           QUANTITY 'FORWARD-PAGE))
    151                    (#/H
    152                     (SETQ MODE-NAME "Buffer"
    153                           QUANTITY 'FORWARD-BUFFER))
    154                    (OTHERWISE
    155                     (BARF "Invalid quantity type")))
    156                   (TYPEIN-LINE-MORE "~A~P" MODE-NAME *NUMERIC-ARG*)
    157                   )
    158                (COND ((EQ MODE 'QUANTITY-MODE-SET)
    159                       (QUANTITY-MODE-SET QUANTITY MODE-NAME)
    160                       DIS-NONE)
    161                      (T
    162                       (LET ((*QUANTITY-MODE* QUANTITY))
    163                            (FUNCALL MODE)))))))))
     164                      (GO GET-A-QUANTITY))
     165                     (#/C
     166                      (SETQ MODE-NAME "Character"
     167                            QUANTITY 'FORWARD-CHAR))
     168                     (#/W
     169                      (SETQ MODE-NAME "Word"
     170                            QUANTITY 'FORWARD-WORD))
     171                     (#/A
     172                      (SETQ MODE-NAME "Atom"
     173                            QUANTITY 'FORWARD-ATOM))
     174                     (#/S
     175                      (SETQ MODE-NAME "Sentence"
     176                            QUANTITY 'FORWARD-SENTENCE))
     177                     (#/P
     178                      (SETQ MODE-NAME "Paragraph"
     179                            QUANTITY 'FORWARD-PARAGRAPH))
     180                     (#/L
     181                      (SETQ MODE-NAME "Line"
     182                            QUANTITY 'FORWARD-LINE))
     183                     (#/-
     184                      (SETQ MODE-NAME "S-Expression"
     185                            QUANTITY 'FORWARD-SEXP))
     186                     ((#/( #/))
     187                      (SETQ MODE-NAME "List"
     188                            QUANTITY 'FORWARD-LIST))
     189                     (#/D
     190                      (SETQ MODE-NAME "Defun"
     191                            QUANTITY 'FORWARD-DEFUN))
     192                     (#\FF
     193                      (SETQ MODE-NAME "Page"
     194                            QUANTITY 'FORWARD-PAGE))
     195                     (#/H
     196                      (SETQ MODE-NAME "Buffer"
     197                            QUANTITY 'FORWARD-BUFFER))
     198                     (OTHERWISE
     199                      (BARF "Invalid quantity type")))
     200                   (TYPEIN-LINE-MORE "~A~P" MODE-NAME *NUMERIC-ARG*)
     201                   )
     202             (COND ((EQ MODE 'QUANTITY-MODE-SET)
     203                    (QUANTITY-MODE-SET QUANTITY MODE-NAME)
     204                    (RETURN-FROM KLUDGE DIS-NONE))
     205                   (T
     206                    (LET ((*QUANTITY-MODE* QUANTITY))
     207                      (RETURN-FROM KLUDGE (FUNCALL MODE))))))))))
    164208
    165209(DEFCOM COM-QUANTITY-FORWARD "Move forward according to the current quantity mode." (KM)
    166     (MOVE-BP (POINT) (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*) (BARF)))
    167     DIS-BPS)
     210  (MOVE-BP (POINT) (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*) (BARF)))
     211  DIS-BPS)
    168212
    169213(DEFCOM COM-QUANTITY-BACKWARD "Move backward according to the current quantity mode." (KM)
    170     (MOVE-BP (POINT) (OR (FUNCALL *QUANTITY-MODE* (POINT) (- *NUMERIC-ARG*)) (BARF)))
    171     DIS-BPS)
     214  (MOVE-BP (POINT) (OR (FUNCALL *QUANTITY-MODE* (POINT) (- *NUMERIC-ARG*)) (BARF)))
     215  DIS-BPS)
    172216
    173217(DEFCOM COM-QUANTITY-DELETE "Kill forward according to the current quantity mode." ()
    174     (SETQ *CURRENT-COMMAND-TYPE* 'KILL)
    175     (KILL-INTERVAL (POINT)
    176                    (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*)
    177                        (BARF))
    178                    NIL
    179                    T)
    180     DIS-TEXT)
     218  (SETQ *CURRENT-COMMAND-TYPE* 'KILL)
     219  (KILL-INTERVAL (POINT)
     220                 (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*)
     221                     (BARF))
     222                 NIL
     223                 T)
     224  DIS-TEXT)
    181225
    182226(DEFCOM COM-QUANTITY-RUBOUT "Kill backward according to the current quantity mode." ()
    183     (SETQ *CURRENT-COMMAND-TYPE* 'KILL)
    184     (KILL-INTERVAL (POINT)
    185                    (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*)
    186                        (BARF))
    187                    NIL
    188                    NIL)
    189     DIS-TEXT)
     227  (SETQ *CURRENT-COMMAND-TYPE* 'KILL)
     228  (KILL-INTERVAL (POINT)
     229                 (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*)
     230                     (BARF))
     231                 NIL
     232                 NIL)
     233  DIS-TEXT)
    190234
    191235(DEFCOM COM-QUANTITY-TWIDDLE "Exchange things according to the current quantity mode." ()
     
    210254
    211255(DEFCOM COM-QUANTITY-UPPERCASE "Uppercase according to the current quantity mode." ()
    212    (LET ((BP1 (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*) (BARF))))
    213      (LET ((BP2 (OR (FUNCALL *QUANTITY-MODE* BP1 (- *NUMERIC-ARG*)) (BARF))))
    214        (UNDO-SAVE BP1 BP2 NIL "Upcase")
    215        (UPCASE-INTERVAL BP1 BP2)
    216        (AND (PLUSP *NUMERIC-ARG*) (MOVE-BP (POINT) BP1))))
    217    DIS-TEXT)
     256  (LET ((BP1 (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*) (BARF))))
     257    (LET ((BP2 (OR (FUNCALL *QUANTITY-MODE* BP1 (- *NUMERIC-ARG*)) (BARF))))
     258      (UNDO-SAVE BP1 BP2 NIL "Upcase")
     259      (UPCASE-INTERVAL BP1 BP2)
     260      (AND (PLUSP *NUMERIC-ARG*) (MOVE-BP (POINT) BP1))))
     261  DIS-TEXT)
    218262
    219263(DEFCOM COM-QUANTITY-LOWERCASE "Lowercase according to the current quantity mode." ()
    220    (LET ((BP1 (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*) (BARF))))
    221      (LET ((BP2 (OR (FUNCALL *QUANTITY-MODE* BP1 (- *NUMERIC-ARG*)) (BARF))))
    222        (UNDO-SAVE BP1 BP2 NIL "Downcase")
    223        (DOWNCASE-INTERVAL BP1 BP2)
    224        (AND (PLUSP *NUMERIC-ARG*) (MOVE-BP (POINT) BP1))))
    225    DIS-TEXT)
     264  (LET ((BP1 (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*) (BARF))))
     265    (LET ((BP2 (OR (FUNCALL *QUANTITY-MODE* BP1 (- *NUMERIC-ARG*)) (BARF))))
     266      (UNDO-SAVE BP1 BP2 NIL "Downcase")
     267      (DOWNCASE-INTERVAL BP1 BP2)
     268      (AND (PLUSP *NUMERIC-ARG*) (MOVE-BP (POINT) BP1))))
     269  DIS-TEXT)
    226270
    227271(DEFCOM COM-QUANTITY-SAVE "Save on kill ring according to the current quantity mode." ()
    228    (LET ((BP1 (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*) (BARF))))
    229      (LET ((BP2 (OR (FUNCALL *QUANTITY-MODE* BP1 (- *NUMERIC-ARG*)) (BARF))))
    230        (KILL-RING-PUSH (COPY-INTERVAL BP1 BP2))
    231        (MOVE-BP (POINT) BP1)))
    232    DIS-TEXT)
     272  (LET ((BP1 (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*) (BARF))))
     273    (LET ((BP2 (OR (FUNCALL *QUANTITY-MODE* BP1 (- *NUMERIC-ARG*)) (BARF))))
     274      (KILL-RING-PUSH (COPY-INTERVAL BP1 BP2))
     275      (MOVE-BP (POINT) BP1)))
     276  DIS-TEXT)
    233277
    234278(DEFCOM COM-QUANTITY-COPY "Insert a copy according to the current quantity mode." ()
    235    (LET ((BP1 (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*) (BARF))))
    236      (LET ((BP2 (OR (FUNCALL *QUANTITY-MODE* BP1 (- *NUMERIC-ARG*)) (BARF))))
    237        (MOVE-BP (POINT)
    238                 (INSERT-INTERVAL BP2 (COPY-INTERVAL BP1 BP2)))))
    239    DIS-TEXT)
     279  (LET ((BP1 (OR (FUNCALL *QUANTITY-MODE* (POINT) *NUMERIC-ARG*) (BARF))))
     280    (LET ((BP2 (OR (FUNCALL *QUANTITY-MODE* BP1 (- *NUMERIC-ARG*)) (BARF))))
     281      (MOVE-BP (POINT)
     282               (INSERT-INTERVAL BP2 (COPY-INTERVAL BP1 BP2)))))
     283  DIS-TEXT)
    240284
    241285(DEFUN QUANTITY-MODE-SET (QUANTITY MODE-NAME)
    242     (SETQ *QUANTITY-MODE* QUANTITY)
    243     (COND ((NULL *QUANTITY-MODE-SAVE*)
    244            (SETQ *QUANTITY-MODE-SAVE* (MAKE-ARRAY NIL 'ART-Q 5))
    245            (ASET (COMMAND-LOOKUP 506 *COMTAB*) *QUANTITY-MODE-SAVE* 0)
    246            (ASET (COMMAND-LOOKUP 502 *COMTAB*) *QUANTITY-MODE-SAVE* 1)
    247            (ASET (COMMAND-LOOKUP 504 *COMTAB*) *QUANTITY-MODE-SAVE* 2)
    248            (ASET (COMMAND-LOOKUP 207 *COMTAB*) *QUANTITY-MODE-SAVE* 3)
    249            (ASET (COMMAND-LOOKUP 524 *COMTAB*) *QUANTITY-MODE-SAVE* 4)))
    250     (COND ((EQ QUANTITY 'FORWARD-CHAR)
    251            (SETQ *MODE-QUANTITY-NAME* NIL)
    252            (COMMAND-STORE (AREF *QUANTITY-MODE-SAVE* 0) 506 *COMTAB*)
    253            (COMMAND-STORE (AREF *QUANTITY-MODE-SAVE* 1) 502 *COMTAB*)
    254            (COMMAND-STORE (AREF *QUANTITY-MODE-SAVE* 2) 504 *COMTAB*)
    255            (COMMAND-STORE (AREF *QUANTITY-MODE-SAVE* 3) 207 *COMTAB*)
    256            (COMMAND-STORE (AREF *QUANTITY-MODE-SAVE* 4) 524 *COMTAB*))
    257           (T
    258            (SETQ *MODE-QUANTITY-NAME* MODE-NAME)
    259            (COMMAND-STORE 'COM-QUANTITY-FORWARD 506 *COMTAB*)
    260            (COMMAND-STORE 'COM-QUANTITY-BACKWARD 502 *COMTAB*)
    261            (COMMAND-STORE 'COM-QUANTITY-DELETE 504 *COMTAB*)
    262            (COMMAND-STORE 'COM-QUANTITY-RUBOUT 207 *COMTAB*)
    263            (COMMAND-STORE 'COM-QUANTITY-TWIDDLE 524 *COMTAB*))))
     286  (SETQ *QUANTITY-MODE* QUANTITY)
     287  (COND ((NULL *QUANTITY-MODE-SAVE*)
     288         (SETQ *QUANTITY-MODE-SAVE* (MAKE-ARRAY NIL 'ART-Q 5))
     289         (ASET (COMMAND-LOOKUP 506 *COMTAB*) *QUANTITY-MODE-SAVE* 0)
     290         (ASET (COMMAND-LOOKUP 502 *COMTAB*) *QUANTITY-MODE-SAVE* 1)
     291         (ASET (COMMAND-LOOKUP 504 *COMTAB*) *QUANTITY-MODE-SAVE* 2)
     292         (ASET (COMMAND-LOOKUP 207 *COMTAB*) *QUANTITY-MODE-SAVE* 3)
     293         (ASET (COMMAND-LOOKUP 524 *COMTAB*) *QUANTITY-MODE-SAVE* 4)))
     294  (COND ((EQ QUANTITY 'FORWARD-CHAR)
     295         (SETQ *MODE-QUANTITY-NAME* NIL)
     296         (COMMAND-STORE (AREF *QUANTITY-MODE-SAVE* 0) 506 *COMTAB*)
     297         (COMMAND-STORE (AREF *QUANTITY-MODE-SAVE* 1) 502 *COMTAB*)
     298         (COMMAND-STORE (AREF *QUANTITY-MODE-SAVE* 2) 504 *COMTAB*)
     299         (COMMAND-STORE (AREF *QUANTITY-MODE-SAVE* 3) 207 *COMTAB*)
     300         (COMMAND-STORE (AREF *QUANTITY-MODE-SAVE* 4) 524 *COMTAB*))
     301        (T
     302         (SETQ *MODE-QUANTITY-NAME* MODE-NAME)
     303         (COMMAND-STORE 'COM-QUANTITY-FORWARD 506 *COMTAB*)
     304         (COMMAND-STORE 'COM-QUANTITY-BACKWARD 502 *COMTAB*)
     305         (COMMAND-STORE 'COM-QUANTITY-DELETE 504 *COMTAB*)
     306         (COMMAND-STORE 'COM-QUANTITY-RUBOUT 207 *COMTAB*)
     307         (COMMAND-STORE 'COM-QUANTITY-TWIDDLE 524 *COMTAB*))))
    264308
    265309(DEFCOM COM-PREVIOUS-PAGE "Move to the previous page" (KM)
    266     (MOVE-BP (POINT) (FORWARD-PAGE (POINT) (MINUS *NUMERIC-ARG*) T))
    267     DIS-BPS)
     310  (MOVE-BP (POINT) (FORWARD-PAGE (POINT) (MINUS *NUMERIC-ARG*) T))
     311  DIS-BPS)
    268312
    269313(DEFCOM COM-NEXT-PAGE "Move to the next page" (KM)
    270     (MOVE-BP (POINT) (FORWARD-PAGE (POINT) *NUMERIC-ARG* T))
    271     DIS-BPS)
     314  (MOVE-BP (POINT) (FORWARD-PAGE (POINT) *NUMERIC-ARG* T))
     315  DIS-BPS)
    272316
    273317(DEFCOM COM-MARK-WHOLE "Put mark at beginning of buffer and point end,
    274318or with a numeric argument, vice versa" (SM)
    275     (LET ((BP1 (POINT)) (BP2 (MARK)))
    276      (AND *NUMERIC-ARG-P* (PSETQ BP1 BP2 BP2 BP1))
    277      (MOVE-BP BP1 (INTERVAL-LAST-BP *INTERVAL*))
    278      (MOVE-BP BP2 (INTERVAL-FIRST-BP *INTERVAL*)))
    279     DIS-BPS)
     319  (LET ((BP1 (POINT)) (BP2 (MARK)))
     320    (AND *NUMERIC-ARG-P* (PSETQ BP1 BP2 BP2 BP1))
     321    (MOVE-BP BP1 (INTERVAL-LAST-BP *INTERVAL*))
     322    (MOVE-BP BP2 (INTERVAL-FIRST-BP *INTERVAL*)))
     323  DIS-BPS)
    280324
    281325(DEFCOM COM-MARK-DEFUN "Put point and mark around current defun." ()
    282   (LET ((INT (DEFUN-INTERVAL (POINT) *NUMERIC-ARG* NIL T T))) ;including previous blank line
     326  (LET ((INT (DEFUN-INTERVAL (POINT) *NUMERIC-ARG* NIL T T)))   ;including previous blank line
    283327    (OR INT (BARF))
    284328    (SETF (WINDOW-MARK-P *WINDOW*) T)
     
    314358                                                  (PUT-POINT-AT-PLINE SHEET (BP-LINE POINT)
    315359                                                     (BP-INDEX POINT) (1- N-PLINES)
    316                                                      START-BP
     360                                                     (INTERVAL-FIRST-BP *INTERVAL*)
    317361                                                     (INTERVAL-LAST-BP *INTERVAL*))
    318362                                                (CREATE-BP LINE INDEX))))
     
    321365                  (BEEP))
    322366                 (T
     367                  (AND (BP-= (WINDOW-START-BP *WINDOW*) START-BP)
     368                       (SETQ START-BP (INTERVAL-FIRST-BP (DEFUN-INTERVAL (POINT) 1 T NIL))))
    323369                  (SETQ TOP-BP START-BP)))
    324370           (RECENTER-WINDOW *WINDOW* ':START TOP-BP))
     
    327373
    328374(DEFCOM COM-UPCASE-DIGIT "Up-shift the previous digit on this or the previous line." ()
    329     (LET ((BP (COPY-BP (POINT))))
    330      (RCHARMAP (BP (BEG-LINE (POINT) -1 T) NIL)
     375  (LET ((BP (COPY-BP (POINT))))
     376    (RCHARMAP (BP (BEG-LINE (POINT) -1 T) NIL)
    331377      (COND ((MEMQ (RCHARMAP-CH-CHAR) '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9))
    332              (RCHARMAP-SET-CHAR (LOGXOR (RCHARMAP-CHAR) 20))
     378             (RCHARMAP-SET-CHAR (LET* ((CHAR (RCHARMAP-CHAR))
     379                                       (FONT (LDB %%CH-FONT CHAR))
     380                                       (CH-CHAR (LDB %%CH-CHAR CHAR)))
     381                                  (DPB FONT %%CH-FONT (SHIFT-CHARACTER CH-CHAR))))
    333382             (RCHARMAP-RETURN NIL)))))
    334     DIS-TEXT)
     383  DIS-TEXT)
     384
     385(DEFUN SHIFT-CHARACTER (CHAR)
     386  (IF ( (LDB 0003 (%UNIBUS-READ 764102)) 1)    ;Last character new keyboard?
     387      (DOTIMES (I 100)
     388        (AND (= CHAR (AREF SI:KBD-TRANSLATE-TABLE 0 I))
     389             (RETURN (AREF SI:KBD-TRANSLATE-TABLE 1 I))))
     390      (DOTIMES (I 200)
     391        (AND (= CHAR (AREF SI:KBD-NEW-TABLE 0 I))
     392             (RETURN (AREF SI:KBD-NEW-TABLE 1 I))))))
    335393
    336394
    337395(LOCAL-DECLARE ((SPECIAL STREAM ARRAY UNRCHF OPS))
    338396(DEFUN MAKE-RECORDING-STREAM (STREAM LENGTH &AUX ARRAY UNRCHF OPS)
    339     (SETQ ARRAY (MAKE-ARRAY NIL 'ART-Q LENGTH NIL '(0 0)))
    340     (STORE-ARRAY-LEADER LENGTH ARRAY 0)
    341     (SETQ OPS (APPEND (FUNCALL STREAM ':WHICH-OPERATIONS) NIL))
    342     (MAPC (FUNCTION (LAMBDA (X) (SETQ OPS (DELQ X OPS))))
    343           '(:TYI :UNTYI :PLAYBACK :RECORD       ; Operations I want.
    344             :LINE-IN))                          ; Operations for default handler.
    345     (SETQ OPS `(:TYI :UNTYI :PLAYBACK :RECORD . ,OPS))
    346     (CLOSURE '(STREAM ARRAY UNRCHF OPS)
    347              #'RECORDING-STREAM))
     397  (SETQ ARRAY (MAKE-ARRAY NIL 'ART-Q LENGTH NIL '(0 0)))
     398  (STORE-ARRAY-LEADER LENGTH ARRAY 0)
     399  (SETQ OPS (APPEND (FUNCALL STREAM ':WHICH-OPERATIONS) NIL))
     400  (MAPC (FUNCTION (LAMBDA (X) (SETQ OPS (DELQ X OPS))))
     401        '(:TYI :UNTYI :PLAYBACK :RECORD         ; Operations I want.
     402               :LINE-IN))                       ; Operations for default handler.
     403  (SETQ OPS `(:TYI :UNTYI :PLAYBACK :RECORD . ,OPS))
     404  (CLOSURE '(STREAM ARRAY UNRCHF OPS)
     405           #'RECORDING-STREAM))
    348406
    349407(DEFSELECT (RECORDING-STREAM RECORDING-STREAM-DEFAULT-HANDLER T)
     
    355413                (FUNCALL STREAM SI:**DEFSELECT-OP**)
    356414              (RECORDING-STREAM ':RECORD CHAR)
    357               (MVRETURN CHAR TEM)))))
     415              (VALUES CHAR TEM)))))
    358416  (:LISTEN ()
    359417   (OR UNRCHF (FUNCALL STREAM ':LISTEN)))
     
    364422  (:RECORD (CH)
    365423   (LET ((PTR (ARRAY-LEADER ARRAY 1)))
    366         (COND ((NUMBERP CH)
    367                (SETQ PTR (\ (1+ PTR) (ARRAY-LEADER ARRAY 0)))
    368                (STORE-ARRAY-LEADER PTR ARRAY 1)
    369                (ASET CH ARRAY PTR)))))
     424     (COND ((NUMBERP CH)
     425            (SETQ PTR (\ (1+ PTR) (ARRAY-LEADER ARRAY 0)))
     426            (STORE-ARRAY-LEADER PTR ARRAY 1)
     427            (ASET CH ARRAY PTR)))))
    370428  (:PLAYBACK ()
    371429   ARRAY))
     
    399457  (*THROW 'EXIT-TOP-LEVEL NIL))
    400458
     459(DEFCOM COM-ABORT-AT-TOP-LEVEL
     460        "Noop.  Notifys user that you are at top level and can't abort"
     461        ()
     462  (BARF "Already at top level.")
     463  DIS-NONE)
     464
    401465(DEFVAR *INSIDE-BREAK* NIL)
    402466(DEFCOM COM-BREAK "Enter a lisp break loop" ()
     
    419483
    420484(DEFUN INITIALIZE-TAB-STOP-BUFFER ()
    421     (SETQ *TAB-STOP-BUFFER* (CREATE-INTERVAL NIL NIL T))
    422     (INSERT (INTERVAL-FIRST-BP *TAB-STOP-BUFFER*)
    423               "                                                                                         
     485  (SETQ *TAB-STOP-BUFFER* (CREATE-INTERVAL NIL NIL T))
     486  (INSERT (INTERVAL-FIRST-BP *TAB-STOP-BUFFER*)
     487          "                                                                                         
    424488        :       :       :       :       :       :       :       :       :       :       :       :")
    425     NIL)
     489  NIL)
    426490
    427491(DEFCOM COM-EDIT-TAB-STOPS "Edit the tab-stop buffer." ()
    428     (RECURSIVE-EDIT *TAB-STOP-BUFFER* "Edit tab stops")
    429     DIS-ALL)
     492  (RECURSIVE-EDIT *TAB-STOP-BUFFER* "Edit tab stops")
     493  DIS-ALL)
    430494
    431495(DEFCOM COM-TAB-TO-TAB-STOP "Tab to fixed column as specified by the tab-stop buffer." ()
    432   (LET ((GOAL (BP-VIRTUAL-INDENTATION (POINT)))
    433         (L2 (LINE-NEXT (BP-LINE (INTERVAL-FIRST-BP *TAB-STOP-BUFFER*))))
    434         (CHAR-POS))
     496  (LET* ((POINT (POINT))
     497         (GOAL (BP-VIRTUAL-INDENTATION POINT))
     498         (L2 (LINE-NEXT (BP-LINE (INTERVAL-FIRST-BP *TAB-STOP-BUFFER*))))
     499         (CHAR-POS))
    435500    (MULTIPLE-VALUE (NIL CHAR-POS)
    436501      (TV:SHEET-STRING-LENGTH (WINDOW-SHEET *WINDOW*) L2 0 NIL GOAL))
     
    446511                                     (SETQ I (1- I))
    447512                                     CP)))))
    448          (IF (CHAR-EQUAL (AREF L2 GOAL) #/:)
    449              (INDENT-TO (POINT) (BP-VIRTUAL-INDENTATION (CREATE-BP L2 GOAL)))
    450              (INSERT-MOVING (POINT) (NSUBSTRING (LINE-PREVIOUS L2) CHAR-POS GOAL)))))
     513         (IF (NOT (CHAR-EQUAL (AREF L2 GOAL) #/:))
     514             (INSERT-MOVING POINT (NSUBSTRING (LINE-PREVIOUS L2) CHAR-POS GOAL))
     515             (DELETE-AROUND *BLANKS* POINT)
     516             (INDENT-TO POINT (BP-VIRTUAL-INDENTATION (CREATE-BP L2 GOAL))))))
    451517  DIS-TEXT)
    452518
     
    466532Reads the name of the function from the mini-buffer and inserts its ground definition
    467533at point." ()
    468     (LET ((SYMBOL (TYPEIN-LINE-READ "Name of function:")))
    469       (SI:GRIND-1 SYMBOL 90. (INTERVAL-STREAM (POINT) (POINT) T) T))
    470     DIS-TEXT)
     534  (LET ((SYMBOL (TYPEIN-LINE-READ "Name of function:")))
     535    (SI:GRIND-1 SYMBOL 90. (INTERVAL-STREAM-INTO-BP (POINT)) T))
     536  DIS-TEXT)
    471537
    472538(DEFCOM COM-GRIND-S-EXPRESSION "Grind the evaluation of a form into the buffer.
    473539Reads a form from the mini-buffer, evals it and inserts the result, ground, at
    474540point." ()
    475     (LET ((TEM (EVAL (TYPEIN-LINE-READ "Lisp form:"))))
    476       (GRIND-INTO-BP (POINT) TEM))
    477     DIS-TEXT)
     541  (LET ((TEM (EVAL (TYPEIN-LINE-MULTI-LINE-READ "Lisp form: (end with END)"))))
     542    (GRIND-INTO-BP (POINT) TEM))
     543  DIS-TEXT)
    478544
    479545(DEFCOM COM-DOWN-INDENTED-LINE "Move to the next line and past any indentation." (KM)
    480     (LET ((POINT (POINT)) (EOL))
    481       (COND ((AND (NOT *NUMERIC-ARG-P*)
    482                   (BP-= (SETQ EOL (END-LINE POINT))
    483                         (INTERVAL-LAST-BP *INTERVAL*)))
    484              (MOVE-BP POINT (INSERT-MOVING EOL #\CR))
    485              DIS-TEXT)
    486             (T
    487              (MOVE-BP POINT (FORWARD-OVER *BLANKS* (FORWARD-LINE POINT *NUMERIC-ARG* T)))
    488              DIS-BPS))))
     546  (LET ((POINT (POINT)) (EOL))
     547    (COND ((AND (NOT *NUMERIC-ARG-P*)
     548                (BP-= (SETQ EOL (END-LINE POINT))
     549                      (INTERVAL-LAST-BP *INTERVAL*)))
     550           (MOVE-BP POINT (INSERT-MOVING EOL #\CR))
     551           DIS-TEXT)
     552          (T
     553           (MOVE-BP POINT (FORWARD-OVER *BLANKS* (FORWARD-LINE POINT *NUMERIC-ARG* T)))
     554           DIS-BPS))))
    489555
    490556(DEFCOM COM-UP-INDENTED-LINE "Move to previous line and after any indentation." (KM)
    491     (MOVE-BP (POINT) (FORWARD-OVER *BLANKS* (FORWARD-LINE (POINT) (- *NUMERIC-ARG*) T)))
    492     DIS-BPS)
     557  (MOVE-BP (POINT) (FORWARD-OVER *BLANKS* (FORWARD-LINE (POINT) (- *NUMERIC-ARG*) T)))
     558  DIS-BPS)
    493559
    494560
     
    501567            BP2)
    502568        (SETQ BP2 (FORWARD-WORD BP1 1 T))               ;Surround previous word
    503         (INSERT BP2 "*")
    504         (INSERT-MOVING BP1 #/)
     569        (MOVE-BP (POINT) (INSERT BP2 "*"))
     570        (SETQ BP1 (INSERT BP1 #/))
    505571        (INSERT BP1 (+ *NUMERIC-ARG* #/0)))             ;With indicated font change
    506572      (MULTIPLE-VALUE-BIND (BP1 BP2 TYPE)
     
    513579            (FIND-FONT-CHANGE BP3 BP1 NIL))             ;If moving over another one
    514580          (OR (MINUSP *NUMERIC-ARG*)
     581              (NULL NTYPE)
    515582              (SETQ TYPE NTYPE))
    516583          (OR (COND (BP4
    517584                     (DELETE-INTERVAL BP4 BP5 T)        ;flush it
    518585                     (CHAR-EQUAL (AREF TYPE 1) #/*)))
    519               (INSERT BP3 TYPE)))))                     ;Put in one moved unless was *
     586              (MOVE-BP (POINT) (INSERT BP3 TYPE))))))   ;Put in one moved unless was *
    520587  DIS-TEXT)
    521588
     
    550617                   BP1 (FORWARD-CHAR BP2 -2))
    551618             (SETQ BP2 (FORWARD-CHAR BP1 2)))
    552          (MVRETURN BP1 BP2 (STRING-INTERVAL BP1 BP2 T)))))
     619         (VALUES BP1 BP2 (STRING-INTERVAL BP1 BP2 T)))))
    553620
    554621(DEFCOM COM-TEXT-JUSTIFIER-UNDERLINE-WORD " Puts underlines around the previous word (R).
     
    558625*TEXT-JUSTIFIER-UNDERLINE-END* is the character that ends it." ()
    559626  (LET ((LIST (LIST *TEXT-JUSTIFIER-UNDERLINE-BEGIN* *TEXT-JUSTIFIER-UNDERLINE-END*))
    560         (BP (FORWARD-TO-WORD (POINT)))
     627        (BP (FORWARD-TO-WORD (POINT) 1 T))
    561628        BP1 TYPE)
    562     (SETQ BP1 (FORWARD-WORD (FORWARD-WORD BP1 -2 T)))
     629    (SETQ BP1 (FORWARD-WORD (FORWARD-WORD BP -2 T)))
    563630    (MULTIPLE-VALUE (BP TYPE)
    564       (SEARCH-SET BP1 LIST T NIL BP))
     631      (SEARCH-SET BP LIST T NIL BP1))
    565632    (IF (NULL BP)
    566633        (LET ((ARG (IF *NUMERIC-ARG-P* *NUMERIC-ARG* -1)))
    567              (LET ((BP2 (OR (FORWARD-WORD BP1 ARG) (BARF))))
    568                (COND ((MINUSP ARG)
    569                       (SETQ BP1 (FORWARD-WORD BP2 (- ARG)))
    570                       (INSERT BP1 *TEXT-JUSTIFIER-UNDERLINE-END*)
    571                       (INSERT BP2 *TEXT-JUSTIFIER-UNDERLINE-BEGIN*))
    572                      (T
    573                       (INSERT BP2 *TEXT-JUSTIFIER-UNDERLINE-END*)
    574                       (INSERT BP1 *TEXT-JUSTIFIER-UNDERLINE-BEGIN*)))))
     634          (SETQ BP1 (POINT))
     635          (LET ((BP2 (OR (FORWARD-WORD BP1 ARG) (BARF))))
     636            (COND ((MINUSP ARG)
     637                   (MOVE-BP BP1 (FORWARD-WORD BP2 (- ARG)))
     638                   (INSERT-MOVING BP1 *TEXT-JUSTIFIER-UNDERLINE-END*)
     639                   (INSERT BP2 *TEXT-JUSTIFIER-UNDERLINE-BEGIN*))
     640                  (T
     641                   (INSERT BP2 *TEXT-JUSTIFIER-UNDERLINE-END*)
     642                   (INSERT BP1 *TEXT-JUSTIFIER-UNDERLINE-BEGIN*)))))
    575643        (DELETE-INTERVAL BP (FORWARD-CHAR BP) T)
    576644        (SETQ BP1 (IF (MINUSP *NUMERIC-ARG*)
     
    585653                             (FORWARD-WORD (FORWARD-WORD BP (1- *NUMERIC-ARG*)))
    586654                             (FORWARD-WORD BP *NUMERIC-ARG*))))
    587                 (INSERT BP3 TYPE))))))
     655                (MOVE-BP (POINT) (INSERT BP3 TYPE)))))))
    588656  DIS-TEXT)
    589657
     
    604672          (INSERT BP1 *TEXT-JUSTIFIER-UNDERLINE-BEGIN*))))
    605673  DIS-TEXT)
     674
     675(DEFCOM COM-COPY-FROM-PREVIOUS-LINE "Copy characters from the last non-blank line.
     676Argument is the number of characters" ()
     677  (LET* ((POINT (POINT))
     678         (BP (DO ((BP (BEG-LINE POINT -1) (BEG-LINE BP -1))
     679                  (LIM (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)))
     680                  (LINE)
     681                  (IDX (BP-INDEX POINT)))
     682                 ((EQ (SETQ LINE (BP-LINE BP)) LIM)
     683                  (BARF))
     684               (AND (NOT (LINE-BLANK-P LINE))
     685                    (> (LINE-LENGTH LINE) IDX)
     686                    (RETURN (CREATE-BP LINE IDX))))))
     687    (INSERT-INTERVAL-MOVING POINT (COPY-INTERVAL BP (FORWARD-CHAR BP *NUMERIC-ARG*))))
     688  DIS-TEXT)
  • trunk/lisp/zwei/comf.lisp

    r258 r273  
    125125  (DO ((BP (FORWARD-LIST BP 1 NIL -1 T) (FORWARD-SEXP BP))
    126126       (I -1 (1+ I)))
    127       ((BP-= BP END-BP) I)))
     127      (NIL)
     128    (AND (NULL BP) (RETURN NIL))
     129    (AND (BP-= BP END-BP) (RETURN I))))
    128130
    129131;;; This tries to find someplace that looks like it probably doesn't have enough parens
     
    238240    (SETQ BP (BACKWARD-OVER *BLANKS* BP)
    239241          BP1 (FORWARD-OVER *BLANKS* BP)
    240           CH1 (BP-CH-CHAR (FORWARD-CHAR BP -1))
     242          CH1 (BP-CH-CHAR (OR (FORWARD-CHAR BP -1) (BARF)))
    241243          CH2 (BP-CH-CHAR BP1)
    242244          SYN1 (LIST-SYNTAX CH1)
     
    268270        (END-BP (INTERVAL-LAST-BP *INTERVAL*))
    269271        (POINT (POINT))
    270         (OLD-TICK (INTERVAL-TICK *INTERVAL*))
     272        (OLD-TICK (NODE-TICK *INTERVAL*))
    271273        BEG-BP-1 END-BP-1 BP)
    272274    (UNWIND-PROTECT
     
    293295             (DELETE-INTERVAL END-BP-1 END-BP T)
    294296             (FLUSH-BP END-BP-1)))
    295       (SETF (INTERVAL-TICK *INTERVAL*) OLD-TICK)))
     297      (SETF (NODE-TICK *INTERVAL*) OLD-TICK)))
    296298  DIS-BPS)
    297 
    298 (DEFCOM COM-DESCRIBE-CLASS "Describe the specified class." ()
    299   (LET ((CLASS (COMPLETING-READ-FROM-MINI-BUFFER
    300                  "Describe class:"
    301                  (MAPCAR #'(LAMBDA (X)
    302                              (SETQ X (<- X ':CLASS-SYMBOL))
    303                              (CONS (FORMAT NIL "~S" X) X))
    304                          (CONS OBJECT-CLASS (SI:ALL-SUBCLASSES-OF-CLASS OBJECT-CLASS)))
    305                  NIL NIL "You are typing the name of a class, to be described.")))
    306     (AND (ATOM CLASS) (BARF))
    307     (DESCRIBE-CLASS-INTERNAL (CDR CLASS)))
    308   DIS-NONE)
    309 
    310 (DEFUN DESCRIBE-CLASS-INTERNAL (CLASS)
    311   (OR (AND (SYMBOLP CLASS) (BOUNDP CLASS)
    312            (ENTITYP (SETQ CLASS (SYMEVAL CLASS))))
    313       (BARF "~S is not a class" CLASS))
    314   (FORMAT *TYPEOUT-WINDOW* "~&Instance variables of ~A:~%"
    315           (SYMEVAL-IN-CLOSURE CLASS ':NAME))
    316   (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST NIL (SYMEVAL-IN-CLOSURE CLASS 'SI:INSTANCE-PATTERN))
    317   (DO ((SYM (SYMEVAL-IN-CLOSURE CLASS 'SI:CLASS-METHOD-SYMBOL))
    318        (METHS NIL)
    319        (CL)
    320        (ML))
    321       ((EQ SYM 'SI:UNCLAIMED-MESSAGE))
    322     (SETQ CL (SYMEVAL SYM)
    323           ML (%MAKE-POINTER DTP-LIST (FSYMEVAL SYM)))
    324     (FORMAT *TYPEOUT-WINDOW* "~2%Methods~:[ as a subclass~] of ~A:~%" (EQ CL CLASS)
    325             (SYMEVAL-IN-CLOSURE CL ':NAME))
    326     (DO ((L ML (CDR L))
    327          (M)
    328          (LL NIL))
    329         ((NLISTP L)
    330          (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST 'FUNCTION-NAME (NREVERSE LL))
    331          (SETQ SYM L
    332                METHS (APPEND ML METHS))
    333          (RPLACD (LAST METHS) NIL))
    334       (OR (ASSQ (CAR (SETQ M (CAR L))) METHS)
    335           (PUSH M LL))))
    336   NIL)
    337 
    338 (DEFVAR *ALL-FLAVOR-NAMES-ALIST* NIL)
    339 (DEFVAR *LAST-ALL-FLAVOR-NAMES* NIL)
    340 
    341 (DEFCOM COM-DESCRIBE-FLAVOR "Describe the specified flavor." ()
    342   (AND (NEQ *LAST-ALL-FLAVOR-NAMES* SI:*ALL-FLAVOR-NAMES*)
    343        (SETQ *LAST-ALL-FLAVOR-NAMES* SI:*ALL-FLAVOR-NAMES*
    344              *ALL-FLAVOR-NAMES-ALIST* (MAPCAR #'(LAMBDA (X) (CONS (FORMAT NIL "~S" X) X))
    345                                               *LAST-ALL-FLAVOR-NAMES*)))
    346   (LET ((FLAVOR (COMPLETING-READ-FROM-MINI-BUFFER
    347                  "Describe flavor:"
    348                  *ALL-FLAVOR-NAMES-ALIST*
    349                  NIL NIL "You are typing the name of a flavor, to be described.")))
    350     (AND (ATOM FLAVOR) (BARF))
    351     (DESCRIBE-FLAVOR-INTERNAL (CDR FLAVOR)))
    352   DIS-NONE)
    353 
    354 (DEFUN DESCRIBE-FLAVOR-INTERNAL (FLAVOR &AUX FL TEM)
    355   (OR (SETQ FL (GET FLAVOR 'SI:FLAVOR))
    356       (BARF "~S is not the name of a flavor" FLAVOR))
    357   (COND ((SETQ TEM (SI:FLAVOR-DEPENDS-ON FL))
    358          (FORMAT *TYPEOUT-WINDOW* "~&Flavor ~S directly depends on flavor~P:~%"
    359                  FLAVOR (LENGTH TEM))
    360          (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST 'FLAVOR-NAME TEM))
    361         (T
    362          (FORMAT *TYPEOUT-WINDOW*
    363                  "~&Flavor ~S does not directly depend on any other flavors~%"
    364                  FLAVOR)))
    365   (COND ((SETQ TEM (SI:FLAVOR-INCLUDES FL))
    366          (FORMAT *TYPEOUT-WINDOW* "~& and directly includes flavor~P:~%"
    367                  (LENGTH TEM))
    368          (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST 'FLAVOR-NAME TEM)))
    369   (COND ((SETQ TEM (SI:FLAVOR-DEPENDED-ON-BY FL))
    370          (FORMAT *TYPEOUT-WINDOW* "~& and is directly depended on by flavor~P:~%"
    371                  (LENGTH TEM))
    372          (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST 'FLAVOR-NAME TEM)))
    373   (LOCAL-DECLARE ((SPECIAL LIV))                ;For the REM-IF below
    374     (LET ((LIV (SI:FLAVOR-LOCAL-INSTANCE-VARIABLES FL)))
    375       (IF (NULL LIV)
    376           (FORMAT *TYPEOUT-WINDOW* "~&~S has no local instance variables~%" FLAVOR)
    377           (FORMAT *TYPEOUT-WINDOW* "~&Instance variable~P of ~S: ~{~S~^, ~}~%"
    378                   (LENGTH LIV) FLAVOR LIV))
    379       (AND (SETQ TEM (SI:FLAVOR-INSTANCE-SIZE FL))
    380            (FORMAT *TYPEOUT-WINDOW* "Flavor ~S has instance size ~D,
    381  with inherited instance variables: ~{~S~^, ~}~%"
    382                    FLAVOR TEM
    383                    (REM-IF #'(LAMBDA (X) (MEMQ X LIV))
    384                            (SI:FLAVOR-ALL-INSTANCE-VARIABLES FL))))))
    385   (SI:MAP-OVER-COMPONENT-FLAVORS 0 T NIL #'DESCRIBE-FLAVOR-1 FLAVOR (LIST NIL NIL) FLAVOR)
    386   (DO ((PLIST (SI:FLAVOR-PLIST FL) (CDDR PLIST))
    387        (FLAG NIL))
    388       ((NULL PLIST))
    389     (COND ((NOT (MEMQ (CAR PLIST) '(:DEFAULT-INIT-PLIST
    390                                      :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES)))
    391            (COND ((NOT FLAG)
    392                   (FORMAT *TYPEOUT-WINDOW* "Random properties:~%")
    393                   (SETQ FLAG T)))
    394            (FORMAT *TYPEOUT-WINDOW* "~5X~S:     ~S~%" (CAR PLIST) (CADR PLIST)))))
    395   NIL)
    396 
    397 (DEFUN DESCRIBE-FLAVOR-1 (FL STATE TOP-FLAVOR-NAME &AUX (FLAVOR-FLAG NIL))
    398   (COND ((NOT (MEMQ FL (SECOND STATE)))
    399          (DO ((METHS (SI:FLAVOR-METHOD-TABLE FL) (CDR METHS))
    400               (METH)
    401               (ELEM)
    402               (MSG)
    403               (MSG-FLAG NIL NIL)
    404               (TEM))
    405              ((NULL METHS))
    406            (SETQ METH (CAR METHS) MSG (FIRST METH) METH (CDDDR METH))
    407            (OR (SETQ ELEM (ASSQ MSG (FIRST STATE)))
    408                (PUSH (SETQ ELEM (LIST MSG NIL NIL NIL NIL)) (FIRST STATE)))
    409            (COND ((AND (SETQ TEM (ASSQ ':BEFORE METH)) (NOT (MEMQ TEM (SECOND ELEM))))
    410                   (MULTIPLE-VALUE (FLAVOR-FLAG MSG-FLAG)
    411                     (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (CADR TEM) "before"
    412                                                MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME))
    413                   (PUSH TEM (SECOND ELEM))))
    414            (COND ((AND (SETQ TEM (ASSQ 'NIL METH)) (NULL (THIRD ELEM)))
    415                   (MULTIPLE-VALUE (FLAVOR-FLAG MSG-FLAG)
    416                     (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (CADR TEM) "primary"
    417                                                MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME))
    418                   (SETF (THIRD ELEM) TEM)))
    419            (COND ((AND (SETQ TEM (ASSQ ':AFTER METH)) (NOT (MEMQ TEM (FOURTH ELEM))))
    420                   (MULTIPLE-VALUE (FLAVOR-FLAG MSG-FLAG)
    421                     (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (CADR TEM) "after"
    422                                                MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME))
    423                   (PUSH TEM (FOURTH ELEM))))
    424            (COND ((AND (SETQ TEM (ASSQ ':WRAPPER METH)) (NOT (MEMQ TEM (FIFTH ELEM))))
    425                   (MULTIPLE-VALUE (FLAVOR-FLAG MSG-FLAG)
    426                     (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (CADR TEM) "wrapper"
    427                                                MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME))
    428                   (PUSH TEM (FIFTH ELEM))))
    429            (AND MSG-FLAG (TERPRI *TYPEOUT-WINDOW*)))
    430          (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST
    431                              FL (SI:FLAVOR-GETTABLE-INSTANCE-VARIABLES FL)
    432                              "automatically-generated methods to get instance variable" ""
    433                              FLAVOR-FLAG TOP-FLAVOR-NAME))
    434          (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST
    435                              FL (SI:FLAVOR-SETTABLE-INSTANCE-VARIABLES FL)
    436                              "automatically-generated methods to set instance variable" ""
    437                              FLAVOR-FLAG TOP-FLAVOR-NAME))
    438          (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST
    439                              FL (SI:FLAVOR-INITABLE-INSTANCE-VARIABLES FL)
    440                              "instance variable" " that may be set by initialization"
    441                              FLAVOR-FLAG TOP-FLAVOR-NAME))
    442          (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST
    443                              FL (SI:FLAVOR-INIT-KEYWORDS FL)
    444                              "keyword" " in the :INIT message"
    445                              FLAVOR-FLAG TOP-FLAVOR-NAME))
    446          (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST
    447                              FL (GET (LOCF (SI:FLAVOR-PLIST FL))
    448                                      ':OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES)
    449                              "macros to access variable" ""
    450                              FLAVOR-FLAG TOP-FLAVOR-NAME))
    451          (LET ((DEFAULT-PLIST (GET (LOCF (SI:FLAVOR-PLIST FL)) ':DEFAULT-INIT-PLIST)))
    452            (COND (DEFAULT-PLIST
    453                   (DESCRIBE-FLAVOR-PRINT-FLAVOR-NAME FL FLAVOR-FLAG TOP-FLAVOR-NAME)
    454                   (FORMAT *TYPEOUT-WINDOW* " Plus default init plist: ")
    455                   (DO ((L DEFAULT-PLIST (CDDR L))
    456                        (FLAG T NIL))
    457                       ((NULL L))
    458                     (FORMAT *TYPEOUT-WINDOW* "~:[, ~]~S ~S" FLAG (CAR L) (CADR L)))
    459                   (TERPRI *TYPEOUT-WINDOW*))))
    460          (PUSH FL (SECOND STATE))))
    461   STATE)
    462 
    463 (DEFUN DESCRIBE-FLAVOR-PRINT-FLAVOR-NAME (FL FLAG TOP-FLAVOR-NAME &AUX FLAVOR-NAME)
    464   (COND ((NOT FLAG)                             ;If not already printed
    465          (SETQ FLAVOR-NAME (SI:FLAVOR-NAME FL))
    466          (FORMAT *TYPEOUT-WINDOW* "Method(s) ~:[inherited from~;of~] ~S:~%"
    467                  (EQ FLAVOR-NAME TOP-FLAVOR-NAME) FLAVOR-NAME)))
    468   T)                                            ;New value of flag
    469 
    470 (DEFUN DESCRIBE-FLAVOR-PRINT-MSG (FL MSG FUNCTION TYPE MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME)
    471   (DESCRIBE-FLAVOR-PRINT-FLAVOR-NAME FL FLAVOR-FLAG TOP-FLAVOR-NAME)
    472   (OR MSG-FLAG (FORMAT *TYPEOUT-WINDOW* "   :~A " MSG))
    473   (FUNCALL *TYPEOUT-WINDOW* ':ITEM 'FUNCTION-NAME FUNCTION TYPE)
    474   (FUNCALL *TYPEOUT-WINDOW* ':TYO #\SP)
    475   (MVRETURN T T))                               ;New values for the flags
    476 
    477 (DEFUN DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST (FL LIST STR1 STR2 FLAG TOP-FLAVOR-NAME)
    478   (COND (LIST                                   ;If there is something there
    479          (DESCRIBE-FLAVOR-PRINT-FLAVOR-NAME FL FLAG TOP-FLAVOR-NAME)
    480          (FORMAT *TYPEOUT-WINDOW* " Plus ~A~P~A: ~{~:S~^, ~}~%" STR1 (LENGTH LIST) STR2 LIST)
    481          T)))                                   ;New value of the flag
    482 
    483 (TV:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* FLAVOR-NAME "Edit" EDIT-DEFINITION T)
    484 
    485 
    486 (TV:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* FLAVOR-NAME "Describe"
    487                           DESCRIBE-FLAVOR-INTERNAL)
    488 
    489 
    490 ;;;Multics EMACS compatible macro commands
    491 (DEFCOM COM-START-KBD-MACRO "Begin defining a keyboard macro" ()
    492   (OR (MEMQ ':MACRO-PUSH (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))
    493       (BARF "This stream doesnt support macros"))
    494   (FUNCALL STANDARD-INPUT ':MACRO-PUSH (+ 2 *NUMERIC-ARG-N-DIGITS*))
    495   DIS-NONE)
    496 
    497 (DEFCOM COM-END-KBD-MACRO "Terminate the definition of a keyboard macro" ()
    498   (OR (MEMQ ':MACRO-POP (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))
    499       (BARF "This stream doesnt support macros"))
    500   (*CATCH 'MACRO-LOOP                           ;In case no macro running
    501      (FUNCALL STANDARD-INPUT ':MACRO-POP (+ 2 *NUMERIC-ARG-N-DIGITS*)
    502                                          (AND (NOT (ZEROP *NUMERIC-ARG*)) *NUMERIC-ARG*)))
    503   DIS-NONE)
    504 
    505 (DEFCOM COM-CALL-LAST-KBD-MACRO "Repeat the last keyboard macro" ()
    506   (OR (MEMQ ':MACRO-EXECUTE (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))
    507       (BARF "This stream doesnt support macros"))
    508   (FUNCALL STANDARD-INPUT ':MACRO-EXECUTE NIL (AND (NOT (ZEROP *NUMERIC-ARG*)) *NUMERIC-ARG*))
    509   DIS-NONE)
    510 
    511 (DEFCOM COM-KBD-MACRO-QUERY "Interactive keyboard macro" ()
    512   (OR (MEMQ ':MACRO-QUERY (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))
    513       (BARF "This stream doesnt support macros"))
    514   (FUNCALL STANDARD-INPUT ':MACRO-QUERY)
    515   DIS-NONE)
    516 
    517 (DEFCOM COM-VIEW-KBD-MACRO "Typeout the specified keyboard macro.
    518 The macro should be a /"permanent/" macro, that has a name.
    519 The name of the macro is read from the mini-buffer, just cr means the last
    520 one defined, which can also be temporary." ()
    521   (OR (MEMQ ':MACRO-PREVIOUS-ARRAY (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))
    522       (BARF "This stream does not support macros"))
    523   (LET ((PACKAGE SI:PKG-USER-PACKAGE)
    524         NAME MAC)
    525     (SETQ NAME (TYPEIN-LINE-READ "Name of macro to view (CR for last macro defined):"))
    526     (COND ((EQ NAME '*EOF*)
    527            (SETQ MAC (FUNCALL STANDARD-INPUT ':MACRO-PREVIOUS-ARRAY)))
    528           ((NOT (SETQ MAC (GET NAME 'MACRO-STREAM-MACRO)))
    529            (BARF "~A is not a defined macro." NAME)))
    530     (DO ((I 0 (1+ I))
    531          (LEN (MACRO-LENGTH MAC))
    532          (CH))
    533         ((> I LEN))
    534       (FORMAT T (SELECTQ (SETQ CH (AREF MAC I))
    535                   (*MOUSE* "Mouse command ~*")
    536                   (*SPACE* "Macro query ~*")
    537                   (*RUN* "Repeat ~*")
    538                   (NIL "Input ~*")
    539                   (OTHERWISE "~:C "))
    540               CH)))
    541   DIS-NONE)
    542299
    543300(DEFCOM COM-DECLARE-SPECIAL "Add the nth previous word to the last special declaration" ()
     
    594351(DEFVAR *LAST-PATTERN-RESTART-LIST*)
    595352
    596 (DEFCOM COM-FIND-PATTERN "Move to next occurence of the given pattern.
     353(DEFCOM COM-FIND-PATTERN "Move to next occurrence of the given pattern.
    597354The pattern must be a list, ** matches any one thing, ... any number of things.
    598355A numeric argument repeats the last search." ()
     
    677434                  (PUSH (CDR LIST) RESTART-LIST)
    678435                  (RETURN NIL))))))
    679   (MVRETURN VAL RESTART-LIST))
     436  (VALUES VAL RESTART-LIST))
    680437
    681438;;; Simple minded pattern matcher
     
    700457(DEFCOM COM-UNDO "Undo the last undoable command" ()
    701458  (OR (BOUNDP '*UNDO-START-BP*) (BARF "Nothing to undo"))
    702   (OR (EQ (BP-INTERVAL *UNDO-START-BP*) *INTERVAL*) (BARF "No longer in the same buffer"))
     459  (OR (EQ (BP-TOP-LEVEL-NODE *UNDO-START-BP*)
     460          (BP-TOP-LEVEL-NODE (INTERVAL-FIRST-BP *INTERVAL*)))
     461      (BARF "No longer in the same buffer"))
     462  (TYPEIN-LINE "")
    703463  (LET ((POINT (POINT)) (MARK (MARK))
    704464        (OLD *UNDO-OLD-INTERVAL*)
    705465        (NAME *UNDO-TYPE*))
    706     (TYPEIN-LINE "Undo ~A? " NAME)
    707     (COND ((TYPEIN-LINE-ACTIVATE (Y-OR-N-P NIL *TYPEIN-WINDOW*))
     466    (COND ((FQUERY '(:SELECT T) "Undo ~A? " NAME)
    708467           (MOVE-BP MARK *UNDO-START-BP*)
    709468           (MOVE-BP POINT *UNDO-END-BP*)
     
    713472           (TYPEIN-LINE "~A undone." NAME))))
    714473  DIS-TEXT)
     474
     475(DEFCOM COM-EXECUTE-COMMAND-INTO-BUFFER "Direct typeout from a command into the buffer" ()
     476  (LET* ((*TYPEOUT-WINDOW* (MAKE-INTERVAL-TYPEOUT-STREAM))
     477         (STANDARD-OUTPUT *TYPEOUT-WINDOW*))
     478    (PROMPT-LINE "Key: ")
     479    (PROCESS-COMMAND-CHAR (PROMPT-LINE-ACTIVATE (FUNCALL STANDARD-INPUT ':TYI)))
     480    (MOVE-BP (MARK) (POINT))
     481    (MOVE-BP (POINT) (FUNCALL *TYPEOUT-WINDOW* ':READ-BP))
     482    (SETQ *CURRENT-COMMAND-TYPE* 'YANK))
     483  DIS-TEXT)
     484
     485(DEFCOM COM-INSERT-DATE "Print the curent date into the buffer.
     486Calls TIME:PRINT-CURRENT-TIME, or if given an argument TIME:PRINT-CURRENT-DATE" ()
     487  (LET ((STREAM (INTERVAL-STREAM (POINT) (POINT) T)))
     488    (FUNCALL (IF *NUMERIC-ARG-P* #'TIME:PRINT-CURRENT-DATE #'TIME:PRINT-CURRENT-TIME)
     489             STREAM)
     490    (MOVE-BP (MARK) (POINT))
     491    (MOVE-BP (POINT) (FUNCALL STREAM ':READ-BP)))
     492  DIS-TEXT)
     493
     494(DEFCOM COM-COUNT-LINES-REGION "Print the number of lines in the region in the echo area." ()
     495  (REGION (BP1 BP2)
     496    (TYPEIN-LINE "~D line~:P.  " (1- (COUNT-LINES BP1 BP2 T))))
     497  DIS-NONE)
     498
     499(DEFCOM COM-WHERE-AM-I "Print various things about where the point is.
     500Print the X and Y positions, the octal code for the following character,
     501the current line number and its percentage of the total file size.
     502If there is a region, the number of lines in it is printed.
     503Fast Where Am I prints a subset of this information faster." (KM)
     504  (REDISPLAY *WINDOW* ':POINT NIL NIL T)
     505  (LET ((POINT (POINT))
     506        (FIRST-BP (INTERVAL-FIRST-BP *INTERVAL*))
     507        (LAST-BP (INTERVAL-LAST-BP *INTERVAL*)))
     508    (LET ((POINT-LINES (1- (COUNT-LINES FIRST-BP POINT)))
     509          (INTERVAL-LINES (1- (COUNT-LINES FIRST-BP LAST-BP)))
     510          (AT-END-P (BP-= (INTERVAL-LAST-BP *INTERVAL*) POINT))
     511          (BP-IND (BP-INDENTATION POINT))
     512          (SW (FONT-SPACE-WIDTH)))
     513      (TYPEIN-LINE "X=[~D. chars|~D. pixels|~:[~S~;~D.~] columns] ~
     514                        Y=~D.~@[ Char=~O~] Line=~D.(~D%)"
     515                   (BP-INDEX POINT)
     516                   BP-IND
     517                   (ZEROP (\ BP-IND SW))
     518                   (IF (ZEROP (\ BP-IND SW))
     519                       (// BP-IND SW)
     520                       (// (FLOAT BP-IND) SW))
     521                   (FIND-BP-IN-WINDOW *WINDOW* POINT)
     522                   (AND (NOT AT-END-P) (BP-CHAR POINT))
     523                   POINT-LINES
     524                   (IF (ZEROP INTERVAL-LINES)
     525                       0
     526                       (// (* 100. POINT-LINES) INTERVAL-LINES)))))
     527  (AND (WINDOW-MARK-P *WINDOW*)
     528       (REGION (BP1 BP2)
     529         (TYPEIN-LINE-MORE ", Region has ~D line~:P.  " (1- (COUNT-LINES BP1 BP2 T)))))
     530  DIS-NONE)
     531
     532(DEFCOM COM-FAST-WHERE-AM-I "Quickly print various things about where the point is.
     533Print the X and Y positions, and the octal code for the following character.
     534If there is a region, the number of lines in it is printed.
     535Where Am I prints the same things and more." (KM)
     536  (REDISPLAY *WINDOW* ':POINT NIL NIL T)
     537  (LET ((POINT (POINT)))
     538    (LET ((AT-END-P (BP-= (INTERVAL-LAST-BP *INTERVAL*) POINT))
     539          (BP-IND (BP-INDENTATION POINT))
     540          (SW (FONT-SPACE-WIDTH)))
     541      (TYPEIN-LINE "X=[~D. chars|~D. pixels|~:[~S~;~D.~] columns] Y=~D.~@[ Char=~O~]"
     542                   (BP-INDEX POINT)
     543                   BP-IND
     544                   (ZEROP (\ BP-IND SW))
     545                   (IF (ZEROP (\ BP-IND SW))
     546                       (// BP-IND SW)
     547                       (// (FLOAT BP-IND) SW))
     548                   (FIND-BP-IN-WINDOW *WINDOW* POINT)
     549                   (AND (NOT AT-END-P) (BP-CHAR POINT)))))
     550  (AND (WINDOW-MARK-P *WINDOW*)
     551       (REGION (BP1 BP2)
     552         (TYPEIN-LINE-MORE ", Region has ~D line~:P.  " (1- (COUNT-LINES BP1 BP2 T)))))
     553  DIS-NONE)
     554
     555(DEFCOM COM-ARGLIST "Print the argument list of the specified function.
     556Reads the name of the function from the mini-buffer (the top of the kill
     557ring has the /"current/" function from the buffer) and prints the arglist
     558in the echo area." ()
     559  (LET ((NAME (READ-FUNCTION-NAME "Arglist" (RELEVANT-FUNCTION-NAME (POINT)) T)))
     560    (PRINT-ARGLIST NAME))
     561  DIS-NONE)
     562
     563(DEFCOM COM-QUICK-ARGLIST "Print the argument list of the function to left of cursor." ()
     564  (QUICK-ARGLIST)
     565  DIS-NONE)
     566
     567(DEFUN QUICK-ARGLIST (&OPTIONAL (STREAM *TYPEIN-WINDOW*))
     568  (IF *NUMERIC-ARG-P*
     569      (LET ((NAME (READ-FUNCTION-NAME "Arglist" (RELEVANT-FUNCTION-NAME (POINT)) T)))
     570        (PRINT-ARGLIST NAME STREAM))
     571      (LET ((SYMBOL (RELEVANT-FUNCTION-NAME (POINT))))
     572        (COND ((COND ((MEMQ SYMBOL '(FUNCALL FUNCALL-SELF <-))
     573                      (SETQ SYMBOL (RELEVANT-METHOD-NAME (POINT)
     574                                                         (IF (EQ SYMBOL 'FUNCALL-SELF) 1 2))))
     575                     ((EQ SYMBOL 'DEFMETHOD)
     576                      (LET ((METHOD-SYMBOL (RELEVANT-DEFMETHOD-METHOD-NAME (POINT))))
     577                        (COND (METHOD-SYMBOL
     578                               (SETQ SYMBOL METHOD-SYMBOL)
     579                               T)))))
     580               (MULTIPLE-VALUE-BIND (ARGLIST NAME RETLIST)
     581                   (METHOD-ARGLIST SYMBOL)
     582                 (COND ((EQ STREAM *TYPEIN-WINDOW*)
     583                        (TYPEIN-LINE "")
     584                        (FUNCALL STREAM ':TYPEOUT-STAYS)))
     585                 (FORMAT STREAM "~S: ~:A~@[ ~:A~]"
     586                         (OR NAME SYMBOL) ARGLIST RETLIST)))
     587              ((AND SYMBOL (FDEFINEDP SYMBOL))
     588               (PRINT-ARGLIST SYMBOL STREAM))
     589              ((BARF))))))      ;Looked hard but couldn't find a defined function
     590
     591(DEFUN PRINT-ARGLIST (SYMBOL &OPTIONAL (STREAM *TYPEIN-WINDOW*))
     592  (COND ((EQ STREAM *TYPEIN-WINDOW*)
     593         (TYPEIN-LINE "")
     594         (FUNCALL STREAM ':TYPEOUT-STAYS)))
     595  (MULTIPLE-VALUE-BIND (ARGLIST RETURNS TYPE)
     596      (ARGLIST SYMBOL)
     597    (FORMAT STREAM "~S~@[ (~A)~]: " SYMBOL TYPE)
     598    (IF (OR (LISTP ARGLIST) (NULL ARGLIST))
     599        (PRINT-ARGLIST-INTERNAL ARGLIST STREAM)
     600        (PRINC "??" STREAM))
     601    (AND RETURNS (FORMAT STREAM " ~:A" RETURNS))))
     602
     603;; This prints an arglist in a convenient form, ie:
     604;; (si:first &special si:second &local &optional (si:third (quote si:default)))
     605;; prints: (first &special si:second &local &optional (third 'si:default))
     606(DEFUN PRINT-ARGLIST-INTERNAL (LIST STREAM &AUX SPECIAL)
     607  (FUNCALL STREAM ':TYO #/()
     608  (DO ((L LIST (CDR L)))
     609      ((NULL L)
     610       (FUNCALL STREAM ':TYO #/)))
     611    (COND ((SYMBOLP L)
     612           (FUNCALL STREAM ':STRING-OUT ". ")
     613           (FUNCALL (IF SPECIAL #'PRIN1 #'PRINC) L STREAM)
     614           (FUNCALL STREAM ':TYO #/))
     615           (RETURN NIL)))
     616    (SELECTQ (CAR L)
     617      (&SPECIAL (SETQ SPECIAL T))
     618      (&LOCAL (SETQ SPECIAL NIL)))
     619    (COND ((OR (NLISTP (CAR L))                 ;If the element is a symbol
     620               (NLISTP (CDAR L))                ;Or if it's not a list with exactly two elmts.
     621               (NOT (NULL (CDDAR L))))
     622           (FUNCALL (IF SPECIAL #'PRIN1 #'PRINC) (CAR L) STREAM))       ;Just print it.
     623          (T ;; This is the special case of an element with a default.
     624             (FUNCALL STREAM ':TYO #/()
     625             (FUNCALL (IF SPECIAL #'PRIN1 #'PRINC) (CAAR L) STREAM)
     626             (FUNCALL STREAM ':TYO #\SP)
     627             ;; If the default is quoted, print it nicely.
     628             (COND ((AND (LISTP (CADAR L))
     629                         (EQ (CAADAR L) 'QUOTE))
     630                    (FUNCALL STREAM ':TYO #/')
     631                    (PRIN1 (CADR (CADAR L)) STREAM))
     632                   (T (PRIN1 (CADAR L) STREAM)))
     633             (FUNCALL STREAM ':TYO #/))))
     634    (AND (CDR L) (FUNCALL STREAM ':TYO #\SP))))
     635
     636(DEFCOM COM-BRIEF-DOCUMENTATION "Print brief documentation for the specified function.
     637Reads the name of the function from the mini-buffer (the default is
     638the /"current/" function from the buffer) and prints the first
     639line of its documentation in the echo area." ()
     640    (LET ((NAME (READ-FUNCTION-NAME "Brief Document" (RELEVANT-FUNCTION-NAME (POINT)) T)))
     641      (LET ((DOC (FUNCTION-DOCUMENTATION NAME)))
     642        (COND ((NULL DOC) (TYPEIN-LINE "~S is not documented" NAME))
     643              (T (TYPEIN-LINE "~S: ~A" NAME
     644                              (NSUBSTRING DOC 0 (STRING-SEARCH-CHAR #\CR DOC)))))))
     645    DIS-NONE)
     646
     647(DEFCOM COM-LONG-DOCUMENTATION "Print long documentation for the specified function.
     648Reads the name of the function from the mini-buffer (the default is
     649the /"current/" function from the buffer) and displays the
     650function's arguments and documentation" ()
     651    (LET ((NAME (READ-FUNCTION-NAME "Document" (RELEVANT-FUNCTION-NAME (POINT)) T)))
     652      (LET ((DOC (FUNCTION-DOCUMENTATION NAME)))
     653        (COND ((NULL DOC) (TYPEIN-LINE "~S is not documented" NAME))
     654              (T (PRINT-ARGLIST NAME)
     655                 (FORMAT T "~%~A" DOC)))))
     656    DIS-NONE)
     657
     658(DEFCOM COM-DESCRIBE-VARIABLE-AT-POINT "Print information about variable at or before cursor.
     659The information printed is whether it is declared special, whether it has a value,
     660and whether it has documentation put on by DEFVAR.  If none of these are present,
     661looks for lookalike symbols in other packages." ()
     662  (LET* ((BP1 (FORWARD-ATOM (FORWARD-CHAR (POINT) 1 T) -1 T))
     663         (BP2 (FORWARD-ATOM BP1)))
     664    (IF (NULL BP2) (BARF))
     665    (MULTIPLE-VALUE-BIND (VAR ERROR)
     666        (CATCH-ERROR (WITH-INPUT-FROM-STRING (S (BP-LINE BP1) (BP-INDEX BP1) (BP-INDEX BP2))
     667                       (READ S)))
     668      (IF (OR ERROR (NOT (SYMBOLP VAR))) (BARF))
     669      (TYPEIN-LINE "")                          ;Clear the echo area
     670      (COND ((NOT (DESCRIBE-VARIABLE-INTERNAL VAR))
     671             (TYPEIN-LINE "~S is not a declared variable." VAR)
     672             (MAPC #'DESCRIBE-VARIABLE-INTERNAL
     673                   (PACKAGE-LOOKALIKE-SYMBOLS VAR SI:PKG-GLOBAL-PACKAGE
     674                                              '(SPECIAL COMPILER:SYSTEM-CONSTANT
     675                                                :VALUE-DOCUMENTATION)))))
     676      DIS-NONE)))
     677
     678(DEFUN DESCRIBE-VARIABLE-INTERNAL (VAR)
     679  (LET ((DECL (GETL VAR '(SPECIAL COMPILER:SYSTEM-CONSTANT)))
     680        (BOUND (BOUNDP VAR))
     681        (DOC (GET VAR ':VALUE-DOCUMENTATION)))
     682    (COND ((OR DECL BOUND DOC)
     683           (TYPEIN-LINE-MORE "~&~S has ~:[no~;a~] value" VAR BOUND)
     684           (IF (EQ (CAR DECL) 'SPECIAL)
     685               (TYPEIN-LINE-MORE " and is declared special ~:[by file ~A~]"
     686                                 (EQ (CADR DECL) T) (CADR DECL)))
     687           (IF (EQ (CAR DECL) 'COMPILER:SYSTEM-CONSTANT)
     688               (TYPEIN-LINE-MORE " and is a system-constant"))
     689           (IF DOC
     690               (TYPEIN-LINE-MORE "~%~A" DOC))
     691           T))))
     692
     693(DEFCOM COM-TRACE "Trace or untrace a function.
     694Reads the name of the function from the mini-buffer (the top of the kill
     695ring has the /"current/" function from the buffer) then pops up a menu
     696of trace options.  With an argument, omits menu step" ()
     697  (LET ((FCN (READ-FUNCTION-NAME "Trace" (RELEVANT-FUNCTION-NAME (POINT)) T)))
     698    (IF (NOT *NUMERIC-ARG-P*)
     699        (TV:TRACE-VIA-MENUS FCN)
     700        (EVAL (IF (ATOM FCN) `(TRACE (,FCN)) `(TRACE (:FUNCTION ,FCN))))))
     701  DIS-NONE)
     702
     703(DEFCOM COM-WHERE-IS-SYMBOL "Show which packages contain the specified symbol." ()
     704  (MULTIPLE-VALUE-BIND (SYMBOL NAME)
     705      (READ-FUNCTION-NAME "Where is symbol" NIL NIL T)
     706    (WHERE-IS (OR NAME SYMBOL)))
     707  DIS-NONE)
     708
     709(DEFCOM COM-COUNT-LINES-PAGE "Type number of lines on this page.
     710Also add, in parentheses, the number of lines on the page
     711before point, and the number of lines after point." ()
     712   (LET ((POINT (POINT)))
     713     (LET ((N1 (1- (COUNT-LINES (FORWARD-PAGE POINT -1 T) POINT)))
     714           (N2 (1- (COUNT-LINES POINT (FORWARD-PAGE POINT 1 T)))))
     715       (TYPEIN-LINE "Page has ~D (~D + ~D) lines" (+ N1 N2) N1 N2)))
     716   DIS-NONE)
     717
     718(TV:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* FUNCTION-NAME "Disassemble" DO-DISASSEMBLE
     719                          NIL "Disassemble this function.")
     720
     721(DEFCOM COM-DISASSEMBLE "Disassemble the specified function." ()
     722  (DO-DISASSEMBLE (READ-FUNCTION-NAME "Disassemble" (RELEVANT-FUNCTION-NAME (POINT)) T))
     723  DIS-NONE)
     724
     725(DEFCOM COM-QUICK-DISASSEMBLE "Disassemble the function to the left of the cursor." ()
     726  (IF *NUMERIC-ARG-P*
     727      (DO-DISASSEMBLE (READ-FUNCTION-NAME "Disassemble" (RELEVANT-FUNCTION-NAME (POINT)) T))
     728      (DO-DISASSEMBLE (RELEVANT-FUNCTION-NAME (POINT))))
     729  DIS-NONE)
     730
     731(DEFUN DO-DISASSEMBLE (SYMBOL &AUX FSPEC)
     732  (COND ((FDEFINEDP SYMBOL)
     733         (SETQ FSPEC (FDEFINITION (SI:UNENCAPSULATE-FUNCTION-SPEC SYMBOL)))
     734         (COND ((OR (= (%DATA-TYPE FSPEC) DTP-FEF-POINTER)
     735                    (AND (LISTP FSPEC)
     736                         (EQ (CAR FSPEC) 'MACRO)
     737                         (= (%DATA-TYPE (CDR FSPEC)) DTP-FEF-POINTER)))
     738                (FORMAT T "~&~S:" SYMBOL)
     739                (DISASSEMBLE SYMBOL))
     740               ((BARF "Can't find FEF for ~S" SYMBOL))))
     741        ((BARF)))
     742  NIL)
  • trunk/lisp/zwei/coms.lisp

    r259 r273  
    55;;; Character search
    66
    7 (DEFCOM COM-CHAR-SEARCH "Search for a single character.
     7(DEFCONST *STRING-SEARCH-OPTION-DOCUMENTATION*
     8"While you are typing the search string, the following characters have special meanings:
     9C-B     Search forward from the beginning of the buffer.
     10C-E     Search backwards from the end of the buffer.
     11C-F     Leave the point at the top of the window, if the window must be recentered.
     12C-G     Abort the search.
     13C-D     Get a string to search for from the ring buffer of previously-searched strings.
     14C-L     Redisplay the typein line.
     15C-Q     Quotes the next character.
     16C-R     Reverse the direction of the search.
     17C-S     Do the search, then come back to the command loop.
     18C-U     Flush all characters typed so far.
     19C-V     Delimited Search: Search for occurrences of the string surrounded by delimiters.
     20C-W     Word Search: Search for words in this sequence regardless of intervening
     21             punctuation, whitespace, newlines, and other delimiters.
     22C-Y     Append the string on top of the ring buffer to the search string.
     23Rubout  Rub out the previous character typed.
     24Clear-Input  Flush all characters typed so far.
     25Altmode Do the search and exit.
     26
     27If you search for the empty string, the default is used.  Otherwise, the
     28string you type becomes the default, and the default is saved on a ring
     29buffer unless it is a single character.")
     30
     31(DEFCOM COM-CHAR-SEARCH DOC-CHAR-SEARCH (KM)
     32   (CHAR-SEARCH-INTERNAL NIL))
     33
     34(DEFUN DOC-CHAR-SEARCH (COMMAND CHAR TYPE)
     35  CHAR ;is not used
     36  (SELECTQ TYPE
     37    (:NAME (GET COMMAND 'COMMAND-NAME))
     38    ((:FULL :SHORT)
     39     (FUNCALL STANDARD-OUTPUT ':STRING-OUT "Search for a single character.")
     40     (COND ((EQ TYPE ':FULL)
     41            (FUNCALL STANDARD-OUTPUT ':STRING-OUT "
    842Special characters:
    9 C-A     Do string search
    10 C-B     Go to beginning first
    11 C-E     Go to end first
     43C-A     Do string search (see below).
     44C-B     Search forward from the beginning of the buffer.
     45C-E     Search backwards from the end of the buffer.
     46C-F     Leave the point at the top of the window, if the window must be recentered.
     47C-R     Search backwards.
     48C-S     Repeat the last search.
     49
     50String search, which you get into from C-A, reads in a string and searches for it.
     51")
     52            (FUNCALL STANDARD-OUTPUT ':STRING-OUT *STRING-SEARCH-OPTION-DOCUMENTATION*))))))
     53
     54(DEFCOM COM-REVERSE-CHAR-SEARCH DOC-REVERSE-CHAR-SEARCH (KM)
     55   (CHAR-SEARCH-INTERNAL T))
     56
     57(DEFUN DOC-REVERSE-CHAR-SEARCH (COMMAND CHAR TYPE)
     58  CHAR ;is not used
     59  (SELECTQ TYPE
     60    (:NAME (GET COMMAND 'COMMAND-NAME))
     61    ((:FULL :SHORT)
     62     (FUNCALL STANDARD-OUTPUT ':STRING-OUT "Search backward for a single character.")
     63     (COND ((EQ TYPE ':FULL)
     64            (FUNCALL STANDARD-OUTPUT ':STRING-OUT "
     65Special characters:
     66C-A     Do Reverse String Search (see below).
     67C-B     Search forward from the beginning of the buffer.
     68C-E     Search backwards from the end of the buffer.
    1269C-F     Put the line containing the search object at the top of the screen
    13 C-R     Search backwards
    14 C-S     Repeat the last search." (KM)
    15    (CHAR-SEARCH-INTERNAL NIL))
    16 
    17 (DEFCOM COM-REVERSE-CHAR-SEARCH "Search backward for a single character.
    18 Special characters:
    19 C-A     Do string search
    20 C-B     Go to beginning first
    21 C-E     Go to end first
    22 C-F     Put the line containing the search object at the top of the screen
    23 C-R     Repeat the last search
    24 C-S     Ditto." (KM)
    25    (CHAR-SEARCH-INTERNAL T))
     70C-R     Repeat the last search.
     71C-S     Repeat the last search.
     72
     73Reverse String search, which you get into from C-A, reads in a string and searches for it.
     74")
     75            (FUNCALL STANDARD-OUTPUT ':STRING-OUT *STRING-SEARCH-OPTION-DOCUMENTATION*))))))
    2676
    2777(DEFUN CHAR-SEARCH-INTERNAL (REVERSEP)
    2878  (UNWIND-PROTECT
    29     (PROG (XCHAR CHAR UCHAR BJP ZJP TOP-P STRING BP FAILED-P
    30            (ORIG-PT (COPY-BP (POINT))) (ARG *NUMERIC-ARG*))
     79    (PROG (XCHAR CHAR UCHAR BJP ZJP TOP-P STRING BP FAILED-P QUOTE-P
     80           (ORIG-PT (COPY-BP (POINT))) (ARG *NUMERIC-ARG*)
     81           (FCN 'SEARCH))
    3182        (AND (MINUSP ARG) (SETQ REVERSEP (NOT REVERSEP) ARG (- ARG)))
    3283     LOOP (COND ((OR FAILED-P                   ;Force redisplay on failing search
    3384                     (NULL (SETQ XCHAR (FUNCALL STANDARD-INPUT ':TYI-NO-HANG))))
    34                  (TYPEIN-LINE-WITH-REDISPLAY "")
     85                 (TYPEIN-LINE-WITH-REDISPLAY "~:|")
    3586                 (AND BJP (TYPEIN-LINE-MORE "Begin "))
    3687                 (AND ZJP (TYPEIN-LINE-MORE "End "))
     
    3889                      (TYPEIN-LINE-MORE "Top Line "))
    3990                 (AND REVERSEP (TYPEIN-LINE-MORE "Reverse "))
     91                 (AND QUOTE-P (TYPEIN-LINE-MORE "Quoted-ascii "))
    4092                 (TYPEIN-LINE-MORE "Search: ")))
    4193          (COND ((NOT FAILED-P)
     
    4496                                  (FUNCALL STANDARD-INPUT ':TYI))))
    4597                 (SETQ UCHAR (CHAR-UPCASE CHAR))
    46                  (COND ((= UCHAR #/A)
     98                 (COND (QUOTE-P
     99                        (AND (LDB-TEST %%KBD-CONTROL-META CHAR)
     100                             (SETQ CHAR (LOGAND CHAR 37)))
     101                        (SETQ STRING CHAR)
     102                        (SEARCH-RING-PUSH CHAR FCN))
     103                       ((= UCHAR #/A)
    47104                        (RETURN (COM-STRING-SEARCH-INTERNAL REVERSEP BJP ZJP TOP-P)))
    48105                       ((AND (= UCHAR #/R) (NOT REVERSEP))
     
    60117                       ((= UCHAR #/G)
    61118                        (BEEP)
     119                        (FUNCALL *TYPEIN-WINDOW* ':MAKE-COMPLETE)
    62120                        (GO QUIT))
    63121                       ((OR (= UCHAR #/S)
    64122                            (AND REVERSEP (= UCHAR #/R)))
    65123                        (OR *SEARCH-RING* (BARF))
    66                         (SETQ STRING (CAR *SEARCH-RING*)))
     124                        (SETQ STRING (CAAR *SEARCH-RING*)
     125                              FCN (CADAR *SEARCH-RING*)))
     126                       ((= UCHAR #/Q)          ;Funny ascii compatibility
     127                        (SETQ QUOTE-P T)
     128                        (GO LOOP))
    67129                       ((> CHAR 220)            ;Random control character
    68130                        (BEEP)
     
    70132                       (T
    71133                        (SETQ STRING CHAR)
    72                         (SEARCH-RING-PUSH CHAR)))))
     134                        (SEARCH-RING-PUSH CHAR FCN)))))
    73135          (AND (OR (NULL XCHAR) FAILED-P)
    74136               (IF (NUMBERP STRING)
     
    80142                                       (ZJP (INTERVAL-LAST-BP *INTERVAL*))
    81143                                       (T (POINT)))
    82                                  (SEARCH BP STRING REVERSEP)))
     144                                 (FUNCALL FCN BP STRING REVERSEP)))
    83145                            ((OR (
    84146 I ARG) (NULL BP))
     
    96158    (FUNCALL *MODE-LINE-WINDOW* ':DONE-WITH-MODE-LINE-WINDOW)))
    97159
    98 (DEFCOM COM-STRING-SEARCH "Search for a specified string." (KM)
     160(DEFCOM COM-STRING-SEARCH
     161        (LAMBDA (COMMAND CHAR TYPE)
     162          (DOC-STRING-SEARCH COMMAND TYPE "Search for a specified string.")) (KM)
    99163    (COM-STRING-SEARCH-INTERNAL NIL NIL NIL NIL))
    100164
    101 (DEFCOM COM-REVERSE-STRING-SEARCH "Search backward for a specified string." (KM)
     165(DEFCOM COM-REVERSE-STRING-SEARCH
     166        (LAMBDA (COMMAND CHAR TYPE)
     167          (DOC-STRING-SEARCH COMMAND TYPE "Search backward for a specified string.")) (KM)
    102168    (COM-STRING-SEARCH-INTERNAL T NIL NIL NIL))
     169
     170(DEFUN DOC-STRING-SEARCH (COMMAND TYPE SHORT-STRING)
     171  (SELECTQ TYPE
     172    (:NAME (GET COMMAND 'COMMAND-NAME))
     173    ((:SHORT :FULL)
     174     (FUNCALL STANDARD-OUTPUT ':STRING-OUT SHORT-STRING)
     175     (COND ((EQ TYPE ':FULL)
     176            (FUNCALL STANDARD-OUTPUT ':FRESH-LINE)
     177            (FUNCALL STANDARD-OUTPUT ':STRING-OUT *STRING-SEARCH-OPTION-DOCUMENTATION*))))))
    103178
    104179;; A special hack is needed to stop an altmode that follows a
     
    107182(DEFUN COM-STRING-SEARCH-INTERNAL (REVERSEP BJP ZJP TOP-P &AUX TEM)
    108183  (UNWIND-PROTECT
    109     (PROG ((STRING (MAKE-ARRAY NIL ART-STRING 200 NIL '(0)))
    110            (ORIG-PT (COPY-BP (POINT)))
    111            XCHAR CHAR WORD-P HACK1 HACK2 ECHOED-P FAILED-P)
     184    (PROG ((STRING (MAKE-ARRAY 10 ':TYPE 'ART-STRING ':LEADER-LIST '(0)))
     185           (ORIG-PT (COPY-BP (POINT))) (FCN 'SEARCH)
     186           XCHAR CHAR HACK1 HACK2 ECHOED-P FAILED-P)
    112187       REDIS (COND ((NULL (SETQ XCHAR (AND (NOT ECHOED-P)
    113188                                           (FUNCALL STANDARD-INPUT ':TYI-NO-HANG))))
    114189                    (SETQ ECHOED-P T)                   ;Started to echo now
    115                     (TYPEIN-LINE-WITH-REDISPLAY "")
     190                    (TYPEIN-LINE-WITH-REDISPLAY "~:|")
    116191                    (AND BJP (TYPEIN-LINE-MORE "Begin "))
    117192                    (AND ZJP (TYPEIN-LINE-MORE "End "))
    118193                    (AND TOP-P (TYPEIN-LINE-MORE "Top Line "))
    119194                    (AND REVERSEP (TYPEIN-LINE-MORE "Reverse "))
    120                     (TYPEIN-LINE-MORE (IF WORD-P "Word search: " "String search: "))
     195                    (TYPEIN-LINE-MORE (SELECTQ FCN
     196                                        (SEARCH "String search: ")
     197                                        (WORD-SEARCH "Word search: ")
     198                                        (DELIMITED-SEARCH "Delimited search: ")))
    121199                    (TYPEIN-LINE-MORE "~A" STRING)))
    122200             (AND FAILED-P (GO FAILED))
     
    124202        LOOP (SETQ XCHAR (AND (NOT ECHOED-P)
    125203                              (FUNCALL STANDARD-INPUT ':TYI-NO-HANG)))
    126         LOP1 (SETQ CHAR (OR XCHAR (TYPEIN-LINE-ACTIVATE (TYI-WITH-SCROLLING))))
     204        LOP1 (SETQ CHAR (OR XCHAR (TYPEIN-LINE-ACTIVATE (TYI-WITH-SCROLLING-AND-MOUSING))))
    127205             (SETQ HACK2 HACK1 HACK1 NIL)
    128206             (COND ((BIT-TEST 400 CHAR)
     
    135213                         (#/F (SETQ *CENTERING-FRACTION* 0.0s0 TOP-P T)
    136214                              (GO REDIS))
    137                          (#/G (TYPEIN-LINE "")
     215                         (#/G (FUNCALL *TYPEIN-WINDOW* ':MAKE-COMPLETE)
    138216                              (BARF))
    139                          (#/D (SETQ TEM (SEARCH-RING-POP))
     217                         (#/D (MULTIPLE-VALUE (TEM FCN)
     218                                (SEARCH-RING-POP))
    140219                              (COND ((NUMBERP TEM)
    141                                      (SETQ STRING (MAKE-ARRAY NIL ART-STRING
    142                                                               200 NIL '(1)))
     220                                     (SETQ STRING (MAKE-ARRAY 10 ':TYPE 'ART-STRING
     221                                                              ':LEADER-LIST '(1)))
    143222                                     (ASET TEM STRING 0))
    144223                                    (T (SETQ STRING TEM)))
    145224                              (GO REDIS))
    146225                         (#/L (GO REDIS))
    147                          (#/Q (TYPEIN-LINE-ACTIVATE
    148                                (SETQ CHAR (LOGAND 377 (FUNCALL STANDARD-INPUT ':TYI))))
     226                         (#/M (IF (NOT (WINDOW-MARK-P *WINDOW*))
     227                                  (BEEP)
     228                                  (REGION (BP1 BP2)
     229                                    (APPEND-TO-ARRAY STRING (STRING-INTERVAL BP1 BP2 T)))
     230                                  (SETF (WINDOW-MARK-P *WINDOW*) NIL)
     231                                  (MUST-REDISPLAY *WINDOW* DIS-MARK-GOES)
     232                                  (REDISPLAY *WINDOW* ':NONE))
     233                              (GO REDIS))
     234                         (#/Q (TYPEIN-LINE-ACTIVATE
     235                               (SETQ CHAR (FUNCALL STANDARD-INPUT ':TYI)))
     236                              (SETQ CHAR (LOGAND (IF (LDB-TEST %%KBD-CONTROL CHAR)
     237                                                     37 377)
     238                                                 CHAR))
    149239                              (GO NORMAL))
    150240                         (#/R (SETQ REVERSEP (NOT REVERSEP))
    151241                              (GO REDIS))
    152                          (#/S (LET ((TEM (FUNCALL (IF WORD-P #'WORD-SEARCH #'SEARCH )
     242                         (#/S (AND (EQUAL "" STRING)
     243                                   *SEARCH-RING*
     244                                   (SETQ STRING (CAAR *SEARCH-RING*)
     245                                         FCN (CADAR *SEARCH-RING*)))
     246                              (LET ((TEM (FUNCALL FCN
    153247                                                  (COND (ZJP (INTERVAL-LAST-BP *INTERVAL*))
    154248                                                        (BJP (INTERVAL-FIRST-BP *INTERVAL*))
    155249                                                        (T (POINT)))
    156                                                   (COND ((AND (EQUAL "" STRING)
    157                                                               *SEARCH-RING*)
    158                                                          (CAR *SEARCH-RING*))
    159                                                         (T STRING))
     250                                                  STRING
    160251                                                  REVERSEP)))
    161252                                (COND ((NULL TEM)
     
    165256                                       ;; But don't forget to update search default ring
    166257                                       (OR (EQUAL "" STRING)
    167                                            (SEARCH-RING-PUSH STRING))
     258                                           (SEARCH-RING-PUSH STRING FCN))
    168259                                       (GO FAILED)
    169260                                       )
     
    182273                         (#/U (STORE-ARRAY-LEADER 0 STRING 0)
    183274                              (GO REDIS))
    184                          (#/W (SETQ WORD-P T)
     275                         (#/V (SETQ FCN 'DELIMITED-SEARCH)
     276                              (GO REDIS))
     277                         (#/W (SETQ FCN 'WORD-SEARCH)
    185278                              (GO REDIS))
    186                          (#/Y (SETQ TEM (CAR *SEARCH-RING*))
     279                         (#/Y (SETQ TEM (CAAR *SEARCH-RING*))
    187280                              (IF (NUMBERP TEM)
    188                                   (ARRAY-PUSH STRING CHAR)
    189                                   (DOTIMES (I (STRING-LENGTH TEM))
    190                                     (ARRAY-PUSH STRING (AREF TEM I))))
     281                                  (ARRAY-PUSH-EXTEND STRING TEM)
     282                                  (APPEND-TO-ARRAY STRING TEM))
    191283                              (GO REDIS))
    192284                         (OTHERWISE (BEEP)
     
    199291                    (STORE-ARRAY-LEADER 0 STRING 0)
    200292                    (GO REDIS))
    201                    ((= CHAR #/)
     293                   ((OR (= CHAR #/) (= CHAR #\END))
    202294                    (OR XCHAR
    203295                        (TYPEIN-LINE-MORE "~C" CHAR))
    204296                    (OR (EQUAL "" STRING)
    205                         (SEARCH-RING-PUSH STRING))
     297                        (SEARCH-RING-PUSH STRING FCN))
    206298                    (OR HACK2
    207                         (DO ((FCN (IF WORD-P #'WORD-SEARCH #'SEARCH))
    208                              (ARG (ABS *NUMERIC-ARG*) (1- ARG))
     299                        (DO ((ARG (ABS *NUMERIC-ARG*) (1- ARG))
    209300                             (KEY (COND ((AND (EQUAL "" STRING)
    210301                                              *SEARCH-RING*)
    211                                          (CAR *SEARCH-RING*))
     302                                         (SETQ FCN (CADAR *SEARCH-RING*))
     303                                         (CAAR *SEARCH-RING*))
    212304                                        (T STRING)))
    213305                             (BP (COND (ZJP (INTERVAL-LAST-BP *INTERVAL*))
     
    221313                    (RETURN DIS-BPS)))
    222314             (SETQ CHAR (LOGAND 377 CHAR))
    223       NORMAL (ARRAY-PUSH STRING CHAR)
     315      NORMAL (ARRAY-PUSH-EXTEND STRING CHAR)
    224316             (IF XCHAR
    225317                 (GO REDIS)
     
    379471          (SETQ XCHAR (CHAR-UPCASE CHAR))
    380472          (COND ((NOT (OR (LDB-TEST %%KBD-CONTROL-META CHAR) (LDB-TEST %%KBD-MOUSE CHAR)
    381                           (= CHAR #/) (= CHAR #\RUBOUT)))
     473                          (= CHAR #/) (= CHAR #\END) (= CHAR #\RUBOUT)
     474                          (= CHAR #\ABORT)))
    382475                 (GO NORMAL))
    383476                ((MEMQ XCHAR '(#/S #/R))
     
    391484                      (ASET ':REVERSE *IS-OPERATION* P))
    392485                     ((ZEROP (AREF *IS-POINTER* P))
    393                       (LET ((STRING (STRING (SEARCH-RING-POP))))
     486                      (LET ((STRING (STRING (OR (CAAR *SEARCH-RING*) (BARF)))))
    394487                        (COPY-ARRAY-CONTENTS STRING *IS-STRING*)
    395488                        (ASET (ARRAY-ACTIVE-LENGTH STRING) *IS-POINTER* P))
     
    399492                 (SETQ CHAR (LOGAND 377 (FUNCALL STANDARD-INPUT ':TYI)))
    400493                 (GO NORMAL))
    401                 ((= XCHAR #/G)
     494                ((OR (= XCHAR #/G) (= CHAR #\ABORT))
    402495                 (BEEP)
    403                  (COND ((OR SUPPRESSED-REDISPLAY (NEQ (AREF *IS-STATUS* P) T))
     496                 (COND ((AND (OR SUPPRESSED-REDISPLAY (NEQ (AREF *IS-STATUS* P) T))
     497                             (PLUSP P))
    404498                        ;;
    405499G in other than a successful search
     
    413507                        (TYPEIN-LINE "")
    414508                        (RETURN))))
    415                 ((= CHAR #/)
     509                ((OR (= CHAR #/) (= CHAR #\END))
    416510                 (AND (ZEROP P)
    417511                      (RETURN (COM-STRING-SEARCH-INTERNAL REVERSE-P NIL NIL NIL)))
     
    438532   NORMAL (OR MUST-REDIS (TYPEIN-LINE-MORE "~C" CHAR))
    439533          (PUSH-ISEARCH-STATUS)
    440           (AND (= (AREF *IS-POINTER* P) (STRING-LENGTH *IS-STRING*))
    441                (ADJUST-ARRAY-SIZE *IS-STRING* (+ 100 (STRING-LENGTH *IS-STRING*))))
    442           (ASET CHAR *IS-STRING* (AREF *IS-POINTER* P))
    443           (ASET (1+ (AREF *IS-POINTER* P)) *IS-POINTER* P)
     534          (LET ((IDX (AREF *IS-POINTER* P)))
     535            (AND (
     536 IDX (ARRAY-LENGTH *IS-STRING*))
     537                 (ADJUST-ARRAY-SIZE *IS-STRING* (+ IDX 100)))
     538            (ASET CHAR *IS-STRING* IDX)
     539            (ASET (1+ IDX) *IS-POINTER* P))
    444540          (ASET ':NORMAL *IS-OPERATION* P)
    445541          ;; Come here after possibly processing input to update the search tables
     
    455551          (COND (MUST-REDIS
    456552                 (SETQ MUST-REDIS NIL)
    457                  (TYPEIN-LINE "")
     553                 (TYPEIN-LINE "~:|")
    458554                 (OR (AREF *IS-STATUS* P1) (TYPEIN-LINE-MORE "Failing "))
    459555                 (AND (AREF *IS-REVERSE-P* P) (TYPEIN-LINE-MORE "Reverse "))
     
    521617                (INPUT-DONE
    522618                 (SEARCH-RING-PUSH
    523                    (SUBSTRING *IS-STRING* 0 (ARRAY-ACTIVE-LENGTH *IS-STRING*)))
     619                   (SUBSTRING *IS-STRING* 0 (ARRAY-ACTIVE-LENGTH *IS-STRING*))
     620                   'SEARCH)
    524621                 (TYPEIN-LINE-MORE "")
    525622                 (MAYBE-PUSH-POINT ORIG-PT)
     
    535632
    536633
     634;;; If there is a region, use it
     635(DEFMACRO WITH-QUERY-REPLACE-INTERVAL ((REGION-P-VAR) &BODY BODY)
     636  `(MULTIPLE-VALUE-BIND (*INTERVAL* ,REGION-P-VAR)
     637       (QUERY-REPLACE-INTERVAL)
     638     (UNWIND-PROTECT
     639       (PROGN . ,BODY)
     640       (COND (,REGION-P-VAR
     641              (FLUSH-BP (INTERVAL-FIRST-BP *INTERVAL*))
     642              (FLUSH-BP (INTERVAL-LAST-BP *INTERVAL*)))))))
     643
     644(DEFUN QUERY-REPLACE-INTERVAL ()
     645  (DECLARE (RETURN-LIST *INTERVAL* REGION-P))
     646  (IF (NOT (WINDOW-MARK-P *WINDOW*))
     647      *INTERVAL*
     648      (LET ((POINT (POINT)) (MARK (MARK)))
     649        (AND (BP-< MARK POINT) (SWAP-BPS POINT MARK))
     650        (SETF (WINDOW-MARK-P *WINDOW*) NIL)
     651        (MUST-REDISPLAY *WINDOW* DIS-MARK-GOES)
     652        (VALUES (CREATE-INTERVAL (COPY-BP POINT ':NORMAL) (COPY-BP MARK ':MOVES))
     653                T))))
     654
    537655(DEFCOM COM-REPLACE-STRING "Replace all occurrences of a given string with another.
    538656Prompts for two string: to replace all FOO's with BAR's, type FOO and BAR.
     
    541659If *CASE-REPLACE-P* is nonnull, BAR's initial will be capitalized
    542660if FOO's initial had been (supply it in lower case)." ()
    543   (LET ((FROM (TYPEIN-LINE-READLINE "Replace all occurrences of:")))
    544     (AND (ZEROP (STRING-LENGTH FROM))
    545          (BARF "The string may not be null."))
    546     (LET ((TO (TYPEIN-LINE-READLINE "Replace all occurrences of /"~A/" with:" FROM)))
    547       (REPLACE-STRING (POINT) FROM TO (AND *NUMERIC-ARG-P*
    548                                            *NUMERIC-ARG*))))
     661  (WITH-QUERY-REPLACE-INTERVAL (REGION-P)
     662    (LET ((FROM (TYPEIN-LINE-READLINE "Replace all occurrences ~:[in the region ~]of:"
     663                                      (NOT REGION-P))))
     664      (AND (ZEROP (STRING-LENGTH FROM))
     665           (BARF "The string may not be null."))
     666    (LET ((TO (TEMP-KILL-RING FROM
     667                 (TYPEIN-LINE-READLINE
     668                   "Replace all occurrences ~:[in the region ~]of /"~A/" with:"
     669                   (NOT REGION-P) FROM))))
     670      (TYPEIN-LINE "~D. replacement~:P."
     671                   (REPLACE-STRING (POINT) FROM TO (AND *NUMERIC-ARG-P*
     672                                                        *NUMERIC-ARG*))))))
    549673  DIS-TEXT)
    550674
     
    570694If you give a numeric argument, it will not consider FOOs that are not
    571695bounded on both sides by delimiter characters." ()
    572   (MULTIPLE-VALUE-BIND (FROM TO)
    573       (QUERY-REPLACE-STRINGS)
    574     (QUERY-REPLACE (POINT) FROM TO *NUMERIC-ARG-P*))
     696  (WITH-QUERY-REPLACE-INTERVAL (REGION-P)
     697    (MULTIPLE-VALUE-BIND (FROM TO)
     698        (QUERY-REPLACE-STRINGS REGION-P)
     699      (QUERY-REPLACE (POINT) FROM TO *NUMERIC-ARG-P*)))
    575700  DIS-TEXT)
    576 
    577701
    578702(DEFCOM COM-ATOM-QUERY-REPLACE "Query replaces delimited atoms.
     
    582706      (COM-QUERY-REPLACE))))
    583707
    584 (DEFUN QUERY-REPLACE-STRINGS (&OPTIONAL (TYPE "replace") RETURN-EMPTY &AUX FROM TO)
    585   (SETQ FROM (TYPEIN-LINE-READLINE "Query-~A some occurrences of:" TYPE))
     708(DEFUN QUERY-REPLACE-STRINGS (REGION-P &OPTIONAL (TYPE "replace") RETURN-EMPTY &AUX FROM TO)
     709  (SETQ FROM (TYPEIN-LINE-READLINE "Query-~A some occurrences ~:[in the region ~]of:"
     710                                   TYPE (NOT REGION-P)))
    586711  (COND ((NOT (ZEROP (STRING-LENGTH FROM)))
    587712         (TEMP-KILL-RING FROM
    588            (SETQ TO (TYPEIN-LINE-READLINE "Query-~A some occurrences of /"~A/" with:"
    589                                           TYPE FROM)))
    590          (MVRETURN FROM TO))
     713           (SETQ TO (TYPEIN-LINE-READLINE
     714                      "Query-~A some occurrences ~:[in the region ~]of /"~A/" with:"
     715                      TYPE (NOT REGION-P) FROM)))
     716         (VALUES FROM TO))
    591717        ((NOT RETURN-EMPTY)
    592718         (BARF "The string may not be null."))
     
    597723
    598724;;; This is the normal form of query replace
    599 (DEFUN QUERY-REPLACE (BP *QUERY-FROM* *QUERY-TO* &OPTIONAL BREAKS)
     725(DEFUN QUERY-REPLACE (BP *QUERY-FROM* *QUERY-TO* &OPTIONAL BREAKS
     726                                                 &AUX (*CASE-REPLACE-P* *CASE-REPLACE-P*))
     727  ;;If from isn't all lowercase, user probably has something specific in mind
     728  (AND (DO ((I 0 (1+ I))
     729            (LEN (STRING-LENGTH *QUERY-FROM*)))
     730           ((
     731 I LEN))
     732         (AND (CHAR-UPPERCASE-P (AREF *QUERY-FROM* I))
     733              (RETURN T)))
     734       (SETQ *CASE-REPLACE-P* NIL))
    600735  (QUERY-REPLACE-INTERNAL BP *QUERY-FROM* *QUERY-TO* #'QUERY-REPLACE-SEARCH BREAKS))
    601736
    602737(DEFUN QUERY-REPLACE-SEARCH (BP QUERY-FROM IGNORE &AUX BP1)
    603738  (AND (SETQ BP1 (SEARCH BP QUERY-FROM))
    604        (MVRETURN BP1 (FORWARD-CHAR BP1 (- (STRING-LENGTH QUERY-FROM))))))
     739       (VALUES BP1 (FORWARD-CHAR BP1 (- (STRING-LENGTH QUERY-FROM))))))
    605740
    606741(DEFMACRO QREP ()
    607742  `(COND ((NOT FLAG-2)
    608           (MOVE-BP BP (CASE-REPLACE BP1 BP *QUERY-TO*))
     743          (UNDO-SAVE BP1 BP2 T "Replace")
     744          (MOVE-BP BP2 (CASE-REPLACE BP1 BP2 *QUERY-TO*))
     745          (MOVE-BP BP BP2)
    609746          (MUST-REDISPLAY *WINDOW* DIS-TEXT))))
    610747
     
    615752;;; FLAG-1 and FLAG-2 implement the hairy COMMA command.
    616753(DEFUN QUERY-REPLACE-INTERNAL (BP QUERY-FROM QUERY-TO FUNCTION BREAKS
    617                                &AUX TEM BP1 DO-THE-REST CHAR UCHAR FLAG-1 FLAG-2)
     754                               &AUX BP1 BP2 DO-THE-REST CHAR UCHAR FLAG-1 FLAG-2)
    618755  (BIND-MODE-LINE ("Query Replacing " *QUERY-FROM* " => " *QUERY-TO*)
    619     (SETQ BP1 (COPY-BP BP))
     756    (SETQ BP1 (COPY-BP BP)
     757          BP2 (COPY-BP BP))
    620758    (DO () (NIL)
    621759      (SETQ FLAG-2 FLAG-1 FLAG-1 NIL)
    622760      (COND ((NOT FLAG-2)
    623              (MULTIPLE-VALUE (TEM BP1)
    624                (FUNCALL FUNCTION BP QUERY-FROM QUERY-TO))
    625              (OR TEM (RETURN NIL))
    626              (MOVE-BP BP TEM)
    627              (MUST-REDISPLAY *WINDOW* DIS-BPS)))
     761             (MULTIPLE-VALUE (BP2 BP1)
     762               (FUNCALL FUNCTION BP2 QUERY-FROM QUERY-TO))
     763             (OR BP2 (RETURN NIL))))
    628764      (COND ((OR FLAG-2
    629765                 (NOT BREAKS)                   ; If we don't care about breaks, go ahead.
    630766                 (AND                           ; Both beginning and end must be breaks.
    631                    (OR (EQ BP (INTERVAL-LAST-BP *INTERVAL*))    ; EOB counts as a break.
    632                        (= (WORD-SYNTAX (BP-CHAR BP)) WORD-DELIMITER))
    633                    (OR (EQ BP1 (INTERVAL-FIRST-BP *INTERVAL*))
     767                   (OR (BP-= BP2 (INTERVAL-LAST-BP *INTERVAL*)) ; EOB counts as a break.
     768                       (= (WORD-SYNTAX (BP-CHAR BP2)) WORD-DELIMITER))
     769                   (OR (BP-= BP1 (INTERVAL-FIRST-BP *INTERVAL*))
    634770                       (= (WORD-SYNTAX (BP-CHAR-BEFORE BP1)) WORD-DELIMITER))))
     771             ;; Move point after checking delimiters
     772             (COND ((NOT FLAG-2)
     773                    (MOVE-BP BP BP2)
     774                    (MUST-REDISPLAY *WINDOW* DIS-BPS)))
    635775             ;; We want to offer this string for replacement.
    636776             (COND (DO-THE-REST (QREP))
     
    645785                          (SETQ UCHAR (CHAR-UPCASE CHAR))
    646786                          (COND ((= UCHAR #/^)
     787                                 (POINT-PDL-POP *WINDOW*)       ;Already done once
    647788                                 (MULTIPLE-VALUE-BIND (BP1 PLINE)
    648789                                     (POINT-PDL-POP *WINDOW*)
     
    657798                                                     (COM-RECENTER-WINDOW)))
    658799                                 (REDISPLAY *WINDOW* ':POINT)
     800                                 (GO GETCHAR))
     801                                ((MEMQ UCHAR '(#/? #\HELP))
     802                                 (PRINT-DOC ':FULL *CURRENT-COMMAND*)
     803                                 (CHECK-FOR-TYPEOUT-WINDOW-TYPEOUT)
     804                                 (REDISPLAY-ALL-WINDOWS)
    659805                                 (GO GETCHAR))))
    660806                    (SELECTQ UCHAR
     
    664810                       (QREP)
    665811                       (SETQ FLAG-1 T))
    666                       (#/ (RETURN NIL))        ;Altmode: Quit.
     812                      ((#/ #\END) (RETURN NIL))        ;Altmode: Quit.
    667813                      (#/. (QREP)               ;Point: Replace and quit.
    668814                       (RETURN NIL))
     
    681827Argument means things must be surrounded by breaks.
    682828Negative argument means delimited atoms, rather than words." ()
    683   (MULTIPLE-VALUE-BIND (FROM TO)
    684       (QUERY-REPLACE-STRINGS "exchange")
    685     (LET ((*MODE-WORD-SYNTAX-TABLE* (IF (AND *NUMERIC-ARG-P* (MINUSP *NUMERIC-ARG*))
    686                                    *ATOM-WORD-SYNTAX-TABLE* *MODE-WORD-SYNTAX-TABLE*)))
    687       (QUERY-REPLACE-LIST (POINT) (LIST FROM TO) (LIST TO FROM)
    688                           *NUMERIC-ARG-P*)))
     829  (WITH-QUERY-REPLACE-INTERVAL (REGION-P)
     830    (MULTIPLE-VALUE-BIND (FROM TO)
     831        (QUERY-REPLACE-STRINGS REGION-P "exchange")
     832      (LET ((*MODE-WORD-SYNTAX-TABLE* (IF (AND *NUMERIC-ARG-P* (MINUSP *NUMERIC-ARG*))
     833                                          *ATOM-WORD-SYNTAX-TABLE* *MODE-WORD-SYNTAX-TABLE*)))
     834        (QUERY-REPLACE-LIST (POINT) (LIST FROM TO) (LIST TO FROM)
     835                            *NUMERIC-ARG-P*))))
    689836  DIS-TEXT)
    690837
     
    693840Argument means things must be surrounded by breaks.
    694841Negative argument means delimited atoms, rather than words." ()
    695   (LET ((*MODE-WORD-SYNTAX-TABLE* (IF (AND *NUMERIC-ARG-P* (MINUSP *NUMERIC-ARG*))
    696                                  *ATOM-WORD-SYNTAX-TABLE* *MODE-WORD-SYNTAX-TABLE*))
    697         FROM-LIST TO-LIST)
    698     (MULTIPLE-VALUE (FROM-LIST TO-LIST)
    699       (MULTIPLE-QUERY-REPLACE-STRINGS))
    700     (QUERY-REPLACE-LIST (POINT) FROM-LIST TO-LIST *NUMERIC-ARG-P*))
     842  (WITH-QUERY-REPLACE-INTERVAL (REGION-P)
     843    (LET ((*MODE-WORD-SYNTAX-TABLE* (IF (AND *NUMERIC-ARG-P* (MINUSP *NUMERIC-ARG*))
     844                                        *ATOM-WORD-SYNTAX-TABLE* *MODE-WORD-SYNTAX-TABLE*))
     845          FROM-LIST TO-LIST)
     846      (MULTIPLE-VALUE (FROM-LIST TO-LIST)
     847        (MULTIPLE-QUERY-REPLACE-STRINGS REGION-P))
     848      (QUERY-REPLACE-LIST (POINT) FROM-LIST TO-LIST *NUMERIC-ARG-P*)))
    701849  DIS-TEXT)
    702850
     
    709857  (OR (BP-= BP *BP*) (SETQ *STATE* 0))          ;If bp has moved, reset state
    710858  (MULTIPLE-VALUE (*BP* TEM *STATE*)
    711     (FSM-SEARCH BP FROM-LIST NIL NIL NIL *STATE*))
     859    (FSM-SEARCH BP FROM-LIST NIL NIL NIL NIL *STATE*))
    712860  (COND (*BP*
    713861         (SETQ *QUERY-FROM* TEM
    714862               *QUERY-TO* (NTH (FIND-POSITION-IN-LIST TEM FROM-LIST) TO-LIST))
    715          (MVRETURN *BP* (FORWARD-CHAR *BP* (- (STRING-LENGTH TEM)))))))
    716 )
    717 
    718 (DEFUN MULTIPLE-QUERY-REPLACE-STRINGS (&AUX FROM-LIST TO-LIST)
     863         (VALUES *BP* (FORWARD-CHAR *BP* (- (STRING-LENGTH TEM)))))))
     864);LOCAL-DECLARE
     865
     866(DEFUN MULTIPLE-QUERY-REPLACE-STRINGS (REGION-P &AUX FROM-LIST TO-LIST)
    719867  (DO ((FROM) (TO)) (NIL)
    720868    (MULTIPLE-VALUE (FROM TO)
    721       (QUERY-REPLACE-STRINGS "replace" T))
     869      (QUERY-REPLACE-STRINGS REGION-P "replace" T))
    722870    (OR FROM (RETURN (NREVERSE FROM-LIST) (NREVERSE TO-LIST)))
    723871    (PUSH FROM FROM-LIST)
     
    728876
    729877(DEFCOM COM-OCCUR "Display text lines that contain a given string.
     878With an argument, show the next n lines containing the string.  If
     879no argument is given, all lines are shown." ()
     880  (COM-LIST-MATCHING-LINES))
     881
     882(DEFCOM COM-LIST-MATCHING-LINES "Display text lines that contain a given string.
    730883With an argument, show the next n lines containing the string.  If
    731884no argument is given, all lines are shown." ()
     
    744897      (LET ((LINE (BP-LINE BP))
    745898            (INDEX (BP-INDEX BP)))
    746         (FUNCALL *TYPEOUT-WINDOW* ':ITEM 'BP (CREATE-BP LINE INDEX NIL *INTERVAL*) LINE))
     899        (FUNCALL *TYPEOUT-WINDOW* ':ITEM 'BP (CREATE-BP LINE INDEX) "~A" LINE))
    747900      (FUNCALL *TYPEOUT-WINDOW* ':TYO #\CR)
    748901      (OR (SETQ BP (BEG-LINE BP 1)) (RETURN NIL)))
     
    751904
    752905(DEFCOM COM-KEEP-LINES "Delete all lines not containing the specified string.
     906Covers from point to the end of the buffer" ()
     907  (COM-DELETE-NON-MATCHING-LINES))
     908
     909(DEFCOM COM-DELETE-NON-MATCHING-LINES "Delete all lines not containing the specified string.
    753910Covers from point to the end of the buffer" ()
    754911  (MULTIPLE-VALUE-BIND (FUNCTION KEY)
     
    765922(DEFCOM COM-FLUSH-LINES "Delete all lines containing the specified string.
    766923Covers from point to the end of the buffer" ()
     924  (COM-DELETE-MATCHING-LINES))
     925
     926(DEFCOM COM-DELETE-MATCHING-LINES "Delete all lines containing the specified string.
     927Covers from point to the end of the buffer" ()
    767928  (MULTIPLE-VALUE-BIND (FUNCTION KEY)
    768929      (GET-EXTENDED-STRING-SEARCH-STRINGS NIL "Flush lines containing:"
     
    774935  DIS-TEXT)
    775936
    776 (DEFCOM COM-HOW-MANY "Counts occurences of a substring, after point." ()
     937(DEFCOM COM-HOW-MANY "Counts occurrences of a substring, after point." ()
     938  (COM-COUNT-OCCURRENCES))
     939
     940(DEFCOM COM-COUNT-OCCURRENCES "Counts occurrences of a substring, after point." ()
    777941  (MULTIPLE-VALUE-BIND (FUNCTION KEY REVERSE-P BJ-P)
    778       (GET-EXTENDED-STRING-SEARCH-STRINGS NIL "How many occurences of:"
     942      (GET-EXTENDED-STRING-SEARCH-STRINGS NIL "How many occurrences of:"
    779943                                          *STRING-SEARCH-SINGLE-LINE-COMTAB*)
    780944    (DO ((BP (COND ((NOT BJ-P) (POINT))
     
    784948         (N 0 (1+ N)))
    785949        ((NULL BP)
    786          (TYPEIN-LINE "~D. occurence~:P.~%" (1- N)))))
     950         (TYPEIN-LINE "~D. occurrence~:P.~%" (1- N)))))
    787951  DIS-NONE)
    788952
  • trunk/lisp/zwei/comtab.lisp

    r258 r273  
    2121
    2222;;; Needed by COM-LIST-COMMANDS, among others.
    23 (DEFUN EXTENDED-COMMAND-ALIST (COMTAB) (COMTAB-EXTENDED-COMMANDS COMTAB))
     23(DEFUN EXTENDED-COMMAND-ALIST (COMTAB)
     24  (DO ((CI (COMTAB-INDIRECT-TO COMTAB) (COMTAB-INDIRECT-TO CI))
     25       (C COMTAB CI)
     26       (EC))
     27      ((NULL CI))
     28    (COND ((LISTP (SETQ EC (COMTAB-EXTENDED-COMMANDS C)))
     29           (RPLACD (LAST EC)                    ;Put in alist indirections
     30                   (LOCF (COMTAB-EXTENDED-COMMANDS CI))))
     31          ((OR (NULL EC) (LOCATIVEP EC))
     32           (SETF (COMTAB-EXTENDED-COMMANDS C)
     33                 (LOCF (COMTAB-EXTENDED-COMMANDS CI))))))
     34  (COMTAB-EXTENDED-COMMANDS COMTAB))
    2435
    2536;;; Given a COMTAB and a character like those from the command stream,
     
    7283(DEFUN COMMAND-EXECUTE (COMMAND CHAR &OPTIONAL PREFIX-CHAR HOOK-LIST)
    7384  (COND ((MEMQ COMMAND '(NIL :UNDEFINED))
     85         (FUNCALL STANDARD-INPUT ':CLEAR-INPUT) ;More randomness may follow
    7486         (BARF "~:[~:@C ~;~*~]~:@C is not a defined key.~:[  (Do Dah, Do Dah)~]"
    7587               (NOT PREFIX-CHAR) PREFIX-CHAR CHAR (NOT (= CHAR #/))))
     
    251263
    252264(DEFUN KEY-EXECUTE (KEY &OPTIONAL (*NUMERIC-ARG-P* NIL) (*NUMERIC-ARG* 1))
    253   (COMMAND-EXECUTE (COMMAND-LOOKUP KEY *COMTAB*) KEY))
     265  (PROCESS-COMMAND-CHAR KEY)
     266  DIS-NONE)
    254267
    255268;; This is the Meta-X command.
     
    281294  (COND ((EQ OP ':NAME) "a prefix for extended commands")
    282295        ((MEMQ OP '(:FULL :SHORT))
    283          (FORMAT T "Completing reads and executes a command from the mini buffer")
     296         (FORMAT T "Completing reads and executes a command from the mini buffer.~%")
    284297         (COND ((EQ OP ':FULL)
    285298                (SETQ COMMAND (GET-EXTENDED-COMMAND "Type a command to document:" *COMTAB*))
     
    288301
    289302(DEFUN GET-EXTENDED-COMMAND (PROMPT COMTAB)
    290   (DO ((CI (COMTAB-INDIRECT-TO COMTAB) (COMTAB-INDIRECT-TO CI))
    291        (C *COMTAB* CI)
    292        (EC))
    293       ((NULL CI))
    294     (COND ((LISTP (SETQ EC (COMTAB-EXTENDED-COMMANDS C)))
    295            (RPLACD (LAST EC)                    ;Put in alist indirections
    296                    (LOCF (COMTAB-EXTENDED-COMMANDS CI))))
    297           ((OR (NULL EC) (LOCATIVEP EC))
    298            (SETF (COMTAB-EXTENDED-COMMANDS C)
    299                  (LOCF (COMTAB-EXTENDED-COMMANDS CI))))))
    300303  (COMPLETING-READ-FROM-MINI-BUFFER PROMPT
    301                                     (COMTAB-EXTENDED-COMMANDS *COMTAB*)
     304                                    (EXTENDED-COMMAND-ALIST COMTAB)
    302305                                    NIL ;Impossible is not OK.
    303306                                    NIL ;Don't do initial completion (it won't work anyway)
    304307                                    "You are typing an extended command."
    305308                                    #'(LAMBDA (X)
    306                                               (LET ((STANDARD-OUTPUT *TYPEOUT-WINDOW*))
    307                                                 (PRINT-DOC ':FULL (CDR X))))))
     309                                        (LET ((STANDARD-OUTPUT *TYPEOUT-WINDOW*))
     310                                          (PRINT-DOC ':FULL (CDR X))))))
    308311
    309312(DEFCOM COM-ANY-EXTENDED-COMMAND "Execute any loaded zwei command, even if not assigned" ()
     
    358361       (EQ (%FIND-STRUCTURE-HEADER TEM) 'SYMBOL)))
    359362
    360 (DEFUN MAKE-MACRO-COMMAND (THE-SYMBOL)
    361   (LET-CLOSED ((SYMBOL THE-SYMBOL))
     363(DEFUN MAKE-MACRO-COMMAND (THE-SYMBOL &OPTIONAL MOUSE-P)
     364  (LET-CLOSED ((SYMBOL THE-SYMBOL)
     365               (MOVE-TO-MOUSE-P MOUSE-P)
     366               (PREVIOUS-COMMAND NIL))
    362367    #'(LAMBDA ()
    363368        (LET ((MAC (GET SYMBOL 'MACRO-STREAM-MACRO)))
     
    365370          (OR (MEMQ ':MACRO-EXECUTE (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))
    366371              (BARF "The input stream does not support macros."))
     372          (AND MOVE-TO-MOUSE-P
     373               (MOVE-BP (POINT) (MOUSE-BP *WINDOW* *MOUSE-X* *MOUSE-Y*)))
    367374          (FUNCALL STANDARD-INPUT ':MACRO-EXECUTE MAC
    368375                   (AND *NUMERIC-ARG-P* *NUMERIC-ARG*))
    369376          DIS-NONE))))
     377
     378(DEFUN MOUSE-MACRO-COMMAND-LAST-COMMAND (COMMAND)
     379  (OR (MACRO-COMMAND-P COMMAND)
     380      (BARF "That command is not a keyboard macro"))
     381  (SYMEVAL-IN-CLOSURE COMMAND 'PREVIOUS-COMMAND))
     382
     383(DEFUN SET-MOUSE-MACRO-COMMAND-LAST-COMMAND (COMMAND OLD-VALUE)
     384  (OR (MACRO-COMMAND-P COMMAND)
     385      (BARF "That command is not a keyboard macro"))
     386  (SET-IN-CLOSURE COMMAND 'PREVIOUS-COMMAND OLD-VALUE))
    370387
    371388(DEFUN KEY-FOR-COMMAND (COMMAND &OPTIONAL (COMTAB *COMTAB*))
     
    382399             (SETQ TEM (KEY-FOR-COMMAND COMMAND (GET-PREFIX-COMMAND-COMTAB TEM)))
    383400             (RETURN-FROM FOUND (FORMAT NIL "~:C ~A" CH TEM)))))))
     401
     402;;; Given a character, return what character that would get a command from
     403(DEFUN COMTAB-CHAR-INDIRECTION (CHAR &OPTIONAL (COMTAB *COMTAB*))
     404  (DO ((CH CHAR (DPB (FIRST NCH) %%KBD-CONTROL-META (SECOND NCH)))
     405       (NCH))
     406      ((NLISTP (SETQ NCH (COMMAND-LOOKUP CH COMTAB T)))
     407       CH)))
    384408
    385409
     
    416440  (SETQ *INTERVAL* (WINDOW-INTERVAL *WINDOW*)))
    417441
     442(DEFVAR *EDITORS-WHOSE-MODES-TO-RESET* NIL)
     443(DEFUN RESET-ALL-EDITOR-MODES ()
     444  (DOLIST (EDITOR *EDITORS-WHOSE-MODES-TO-RESET*)
     445    (SET-IN-INSTANCE EDITOR '*USER-MODES-SET* NIL)))
     446
     447(ADD-INITIALIZATION "RESET-ALL-EDITOR-MODES"
     448                    '(RESET-ALL-EDITOR-MODES)
     449                    '(LOGOUT))
     450
    418451(DEFMETHOD (TOP-LEVEL-EDITOR :AFTER :INIT) (IGNORE)
    419452  (SETQ *MODE-COMTAB* (CREATE-SPARSE-COMTAB))
     
    422455  (SETQ *MODE-WORD-SYNTAX-TABLE* (MAKE-SPARSE-SYNTAX-TABLE *WORD-SYNTAX-TABLE*))
    423456  (TURN-ON-MODE *MAJOR-MODE*)
     457  (PUSH SELF *EDITORS-WHOSE-MODES-TO-RESET*)
     458  (COMTAB-MOUSE-PROMPT *COMTAB* (WINDOW-WHO-LINE-DOCUMENTATION-STRING *WINDOW*))
     459  (PUSH* *WINDOW* *WINDOW-LIST*)
    424460  (SETQ TV:IO-BUFFER (WINDOW-IO-BUFFER *WINDOW*))
    425461  (SETQ *TYPEOUT-WINDOW* (WINDOW-TYPEOUT-WINDOW *WINDOW*))
     
    438474                                   (APPLY #'PROCESS-SPECIAL-COMMAND CH)
    439475                                   NIL)
    440                                   ((EQ (CAR CH) 'REDISPLAY)
     476                                  ((MEMQ (CAR CH) '(CONFIGURATION-CHANGED REDISPLAY))
    441477                                   NIL)
    442478                                  (T CH))))
     
    444480    (PROGN (FUNCALL (WINDOW-SHEET *WINDOW*)     ;Don't expose yet, but on first redisplay
    445481                    ':START-DELAYED-SELECT)
     482           (REDISPLAY-MODE-LINE)                ;Do this once since may change size
    446483           (*CATCH 'RETURN-FROM-COMMAND-LOOP
    447484             (*CATCH (IF TOP-LEVEL-P 'EXIT-TOP-LEVEL 'EXIT-CONTROL-R)
    448                (DO ;;Make things like BREAK, TRACE, errors use typeout window
    449                    ((TERMINAL-IO *TYPEOUT-WINDOW*)
    450                     (STANDARD-OUTPUT 'SI:TERMINAL-IO-SYN-STREAM))
    451                    (NIL)
    452                  (*CATCH 'SI:TOP-LEVEL    ;Catch C-Z in error handlers.
     485               (DO () (NIL)
     486                 (*CATCH 'SYS:COMMAND-LEVEL    ;Catch C-Z in error handlers.
    453487                   (*CATCH 'ZWEI-COMMAND-LOOP
    454488                     (*CATCH (IF TOP-LEVEL-P 'TOP-LEVEL 'DUMMY-TAG)
     
    462496                               *MINI-BUFFER-COMMAND* NIL)
    463497                         (REDISPLAY-ALL-WINDOWS)
     498                         (FUNCALL *TYPEIN-WINDOW* ':COMMAND-LOOP-REDISPLAY)
    464499                         (SETQ *CENTERING-FRACTION* *CENTER-FRACTION*)
    465500                        UNREAL-COMMAND
     
    482517                         ;; hasn't finished reading, wait for a character, and if it's space,
    483518                         ;; ignore it and redisplay.
    484                          (COND ((TV:BASIC-TYPEOUT-WINDOW-INCOMPLETE-P *TYPEOUT-WINDOW*)
    485                                 (FUNCALL *TYPEOUT-WINDOW* ':MAKE-COMPLETE)
    486                                 (WITHOUT-IO-BUFFER-OUTPUT-FUNCTION
    487                                   (DO ((CHAR (FUNCALL STANDARD-INPUT ':ANY-TYI)
    488                                              (FUNCALL STANDARD-INPUT ':ANY-TYI)))
    489                                       ((NOT (AND (LISTP CHAR)
    490                                                  ;; Ignore requests to select current window
    491                                                  (EQ (FIRST CHAR) 'SELECT-WINDOW)
    492                                                  (EQ (SECOND CHAR) *WINDOW*)))
    493                                        (OR (EQ CHAR #\SP)
    494                                            ;; If it's not a space, unread it.  That will
    495                                            ;; prevent redisplay.
    496                                            (FUNCALL STANDARD-INPUT ':UNTYI CHAR)))))))))))
     519                         (CHECK-FOR-TYPEOUT-WINDOW-TYPEOUT)))))
    497520                 ;; If we
    498521Z from BREAK or an error, make the typeout go away.
     
    536559    NIL)
    537560  (SELECT-WINDOW (WINDOW)
    538     (MAKE-WINDOW-CURRENT WINDOW)
    539     T)
     561    (PROG1 (NEQ WINDOW *WINDOW*)
     562           (MAKE-WINDOW-CURRENT WINDOW)))
    540563  (CONFIGURATION-CHANGED ()
    541564   (AND (NOT (WINDOW-EXPOSED-P *WINDOW*))
     
    545568   NIL)
    546569  (SCROLL (WINDOW NLINES TYPE)
    547     (OR (EQ TYPE ':RELATIVE)
    548         (SETQ TYPE ':START
    549               NLINES (FORWARD-LINE (INTERVAL-FIRST-BP (WINDOW-INTERVAL WINDOW)) NLINES T)))
    550     (REDISPLAY WINDOW TYPE NLINES)
     570    (IF (EQ TYPE ':RELATIVE)
     571        (RECENTER-WINDOW-RELATIVE WINDOW NLINES)
     572        (RECENTER-WINDOW WINDOW ':START
     573                         (FORWARD-LINE (INTERVAL-FIRST-BP (WINDOW-INTERVAL WINDOW))
     574                                       NLINES T)))
    551575    T)
    552576  (:MOUSE (WINDOW CH *MOUSE-X* *MOUSE-Y*)
     577    (DECF *MOUSE-X* (TV:SHEET-INSIDE-LEFT (WINDOW-SHEET WINDOW)))
     578    (DECF *MOUSE-Y* (TV:SHEET-INSIDE-TOP (WINDOW-SHEET WINDOW)))
    553579    (AND (MEMQ ':RECORD (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))
    554580         (FUNCALL STANDARD-INPUT ':RECORD CH))
    555581    (IF (NEQ WINDOW *WINDOW*)           ;Given in another window,
    556         (LET ((*COMTAB* *STANDARD-COMTAB*)
     582        (LET ((*COMTAB* (IF (EQ *WINDOW* *MINI-BUFFER-WINDOW*) *STANDARD-COMTAB* *COMTAB*))
    557583              (*LAST-COMMAND-TYPE* NIL) ;dont confuse mouse mark thing, and
    558584              *CURRENT-COMMAND-TYPE*
    559               (*WINDOW* WINDOW))                ;temporarily act there (mini-buffer)
     585              (*WINDOW* WINDOW)
     586              (*INTERVAL* (WINDOW-INTERVAL WINDOW)))    ;temporarily act there (mini-buffer)
    560587          (PROCESS-COMMAND-CHAR CH))
    561588        (PROCESS-COMMAND-CHAR CH))
     
    577604          ((AND MOUSE-OR-KBD-TYI-P (EQ (CAR CH) ':MOUSE))
    578605           (RETURN (THIRD CH) CH)))))
     606
     607(DEFUN TYI-WITH-SCROLLING-AND-MOUSING ()
     608  (DO (CH REAL-CH) (NIL)
     609    (MULTIPLE-VALUE (CH REAL-CH)
     610      (TYI-WITH-SCROLLING T))
     611    (IF (LDB-TEST %%KBD-MOUSE CH)
     612        (APPLY #'PROCESS-SPECIAL-COMMAND REAL-CH)
     613        (RETURN CH))))
     614
     615(DEFUN CHECK-FOR-TYPEOUT-WINDOW-TYPEOUT ()
     616  (COND ((TYPEOUT-WINDOW-INCOMPLETE-P *TYPEOUT-WINDOW*)
     617         (FUNCALL *TYPEOUT-WINDOW* ':MAKE-COMPLETE)
     618         (WITHOUT-IO-BUFFER-OUTPUT-FUNCTION
     619           (DO ((CHAR (FUNCALL STANDARD-INPUT ':ANY-TYI)
     620                      (FUNCALL STANDARD-INPUT ':ANY-TYI)))
     621               ((NOT (AND (LISTP CHAR)
     622                          ;; Ignore requests to select current window
     623                          (EQ (FIRST CHAR) 'SELECT-WINDOW)
     624                          (EQ (SECOND CHAR) *WINDOW*)))
     625                (OR (EQ CHAR #\SP)
     626                    ;; If it's not a space, unread it.  That will
     627                    ;; prevent redisplay.
     628                    (FUNCALL STANDARD-INPUT ':UNTYI CHAR))))))))
    579629
    580630;;; Recursive edit on the same buffer
     
    602652;;; Reports an error.  Takes a FORMAT control string and args.  If the string
    603653;;; is not given, no message is reported.
    604 (DEFUN BARF (&OPTIONAL CTL-STRING &REST ARGS)
    605   (OR (AND (MEMQ ':MACRO-ERROR (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))
    606            (FUNCALL STANDARD-INPUT ':MACRO-ERROR))
    607       (BEEP))
    608   (AND CTL-STRING
    609        (LEXPR-FUNCALL #'TYPEIN-LINE CTL-STRING ARGS))
     654(DEFUN BARF (&OPTIONAL CTL-STRING &REST ARGS &AUX TEM1 TEM2)
    610655  (MUST-REDISPLAY *WINDOW* DIS-TEXT)    ;May have altered the text before erring
    611   (*THROW 'ZWEI-COMMAND-LOOP T))        ; so run the full redisplay algorithm
     656  (MULTIPLE-VALUE (TEM1 TEM2)
     657    (LEXPR-FUNCALL #'SIGNAL 'BARF CTL-STRING ARGS))
     658  (IF TEM1 TEM2
     659      (OR (AND (MEMQ ':MACRO-ERROR (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))
     660               (FUNCALL STANDARD-INPUT ':MACRO-ERROR))
     661          (BEEP))
     662      (AND CTL-STRING
     663           (LEXPR-FUNCALL #'TYPEIN-LINE CTL-STRING ARGS))
     664      (*THROW 'ZWEI-COMMAND-LOOP T)))
    612665
    613666
     
    731784            #/ COM-EVALUATE-DEFUN-VERBOSE
    732785            #/ COM-EVALUATE-DEFUN-HACK
    733             #/? COM-SELF-DOCUMENT
     786            #ˆ/C COM-COMPILE-DEFUN
     787            #ˆ/E COM-EVALUATE-DEFUN
     788            #ˆ/E COM-EVALUATE-DEFUN-VERBOSE
     789            #ˆ/E COM-EVALUATE-DEFUN-HACK
     790;           #/? COM-SELF-DOCUMENT
    734791            #/? COM-SELF-DOCUMENT
    735792            #/? COM-DOCUMENTATION
    736793            #\HELP COM-DOCUMENTATION
     794            #\HELP COM-DOCUMENTATION
    737795            #/Q COM-VARIOUS-QUANTITIES
    738796            #/X COM-EXTENDED-COMMAND
     
    748806            #/
    749807 COM-FIND-PATTERN
     808            #ˆ/S COM-FIND-PATTERN
    750809            #/Z COM-QUIT
    751             #\END COM-QUIT
     810;           #\END COM-QUIT
     811            #\ABORT COM-ABORT-AT-TOP-LEVEL
    752812            #/~ COM-NOT-MODIFIED
    753813            #/& COM-FROB-LISP-CONDITIONAL
     
    759819            #/
    760820 COM-LONG-DOCUMENTATION
     821            #/ˆ COM-DESCRIBE-VARIABLE-AT-POINT
     822            #ˆ/A COM-QUICK-ARGLIST
     823            #ˆ/D COM-BRIEF-DOCUMENTATION
     824            #ˆ/D COM-LONG-DOCUMENTATION
     825            #ˆ/V COM-DESCRIBE-VARIABLE-AT-POINT
    761826            #/J COM-CHANGE-FONT-CHAR
    762827            #/J COM-CHANGE-FONT-WORD
     
    777842             COM-COMPILE-REGION COM-COMPILE-BUFFER COM-EVALUATE-REGION COM-EVALUATE-BUFFER
    778843             COM-VIEW-Q-REGISTER COM-LIST-Q-REGISTERS COM-KILL-Q-REGISTER
    779              COM-LIST-VARIABLES COM-VARIABLE-APROPOS COM-VARIABLE-DOCUMENT COM-VARIABLE-SET
     844             COM-LIST-VARIABLES COM-VARIABLE-APROPOS COM-VARIABLE-DOCUMENT COM-SET-VARIABLE
    780845             COM-GRIND-DEFINITION COM-GRIND-S-EXPRESSION COM-EVALUATE-INTO-BUFFER COM-TRACE
    781              COM-VIEW-LOGIN-DIRECTORY COM-VIEW-XGP-QUEUE COM-VIEW-TTY-USERS COM-VIEW-MAIL
     846             COM-VIEW-LOGIN-DIRECTORY COM-VIEW-XGP-QUEUE COM-VIEW-DOVER-QUEUE
     847             COM-VIEW-TTY-USERS COM-VIEW-MAIL
    782848             COM-ATOM-QUERY-REPLACE COM-FORMAT-CODE COM-MULTIPLE-QUERY-REPLACE
    783849             COM-MULTIPLE-QUERY-REPLACE-FROM-BUFFER COM-QUERY-EXCHANGE
     
    786852             COM-UNDO COM-FILL-LONG-COMMENT COM-UNCOMMENT-REGION
    787853             COM-SORT-LINES COM-SORT-PARAGRAPHS COM-SORT-VIA-KEYBOARD-MACROS
     854             COM-EXECUTE-COMMAND-INTO-BUFFER COM-INSERT-DATE COM-DISASSEMBLE
    788855             ;; DOC:
    789856             COM-LIST-COMMANDS COM-APROPOS COM-WHERE-IS COM-DESCRIBE-COMMAND
    790857             ;; FILES:
    791858             COM-INSERT-FILE COM-WRITE-REGION COM-APPEND-TO-FILE COM-PREPEND-TO-FILE
    792              COM-VIEW-FILE COM-LIST-FILES COM-RENAME-FILE COM-COPY-FILE COM-DELETE-FILE
     859             COM-VIEW-FILE COM-LIST-FILES COM-PRINT-FILE
     860             COM-RENAME-FILE COM-DELETE-FILE COM-COPY-TEXT-FILE COM-COPY-BINARY-FILE
    793861             ;; MODES:
    794862             COM-LISP-MODE COM-TEXT-MODE COM-FUNDAMENTAL-MODE COM-PL1-MODE COM-BOLIO-MODE
     
    798866             COM-DEFINE-WORD-ABBREVS COM-EDIT-WORD-ABBREVS COM-LIST-SOME-WORD-ABBREVS
    799867             COM-WRITE-WORD-ABBREV-FILE COM-READ-WORD-ABBREV-FILE COM-MAKE-WORD-ABBREV
    800              COM-EDIT-TAB-STOPS COM-MIDAS-MODE COM-ELECTRIC-SHIFT-LOCK-MODE
     868             COM-EDIT-TAB-STOPS COM-MIDAS-MODE
     869             COM-ELECTRIC-SHIFT-LOCK-MODE COM-ELECTRIC-FONT-LOCK-MODE
    801870             ;; FONT, KBDMAC, DIRED
    802              COM-SET-FONTS COM-INSTALL-MACRO COM-VIEW-KBD-MACRO
     871             COM-SET-FONTS
     872             COM-INSTALL-MACRO COM-INSTALL-MOUSE-MACRO COM-DEINSTALL-MACRO
     873             COM-VIEW-KBD-MACRO COM-NAME-LAST-KBD-MACRO
    803874             ))))
    804875  (SETQ *STANDARD-CONTROL-X-COMTAB*
     
    808879                          #/P COM-MARK-PAGE
    809880                          #/X COM-SWAP-POINT-AND-MARK
    810                           #/G COM-OPEN-GET-Q-REG
    811                           #/X COM-PUT-Q-REG
     881                          #/G COM-OPEN-GET-Q-REGISTER
     882                          #/X COM-PUT-Q-REGISTER
    812883                          #/L COM-COUNT-LINES-PAGE
    813884                          #\RUBOUT COM-BACKWARD-KILL-SENTENCE
     
    835906                          #/_ COM-TEXT-JUSTIFIER-UNDERLINE-REGION
    836907                          #\SP COM-MOVE-TO-DEFAULT-PREVIOUS-POINT
     908                          #\HELP COM-DOCUMENT-CONTAINING-PREFIX-COMMAND
    837909                          )))
    838910  (SET-COMTAB-CONTROL-INDIRECTION *STANDARD-CONTROL-X-COMTAB*)
     
    843915                          #\SP COM-SELF-INSERT-AND-COMPLETE
    844916                          #/) COM-SELF-INSERT-AND-COMPLETE
    845                           #/? COM-LIST-COMPLETIONS
     917                          #/? COM-LIST-COMPLETIONS
    846918                          #/Q COM-QUOTED-INSERT
    847919                          #\HELP COM-DOCUMENT-COMPLETING-READ
     
    849921                          #\CR COM-COMPLETE-AND-EXIT
    850922                          #/G COM-MINI-BUFFER-BEEP
     923                          #\ABORT COM-RECURSIVE-EDIT-ABORT
    851924                          #\CR COM-COMPLETE-AND-EXIT
    852                           #\END COM-COMPLETE-AND-EXIT
     925                          #\END COM-COMPLETE-AND-EXIT-IF-UNIQUE
    853926                          #\MOUSE-1-1 COM-MOUSE-END-OF-MINI-BUFFER
    854927                          #\MOUSE-3-1 COM-MOUSE-LIST-COMPLETIONS
     928                          #/Y COM-POP-MINI-BUFFER-RING
    855929                          #/Z :UNDEFINED
    856930                          #/Z :UNDEFINED
     
    859933  (SETQ *CONTROL-R-COMTAB*
    860934        (SET-COMTAB NIL '(#/ COM-EXIT-CONTROL-R
    861                           #\END COM-EXIT-CONTROL-R)))
     935                          #\END COM-EXIT-CONTROL-R
     936                          #\ABORT COM-EXIT-CONTROL-R)))
    862937  (SET-COMTAB-INDIRECTION *CONTROL-R-COMTAB* *STANDARD-COMTAB*)
    863938  (SETQ *RECURSIVE-EDIT-COMTAB*
    864939        (SET-COMTAB NIL '(#/ COM-EXIT-CONTROL-R
    865940                          #\END COM-EXIT-CONTROL-R
    866                           #/G COM-RECURSIVE-EDIT-BEEP)))
     941                          #/G COM-RECURSIVE-EDIT-BEEP
     942                          #\ABORT COM-RECURSIVE-EDIT-ABORT)))
    867943  (SET-COMTAB-INDIRECTION *RECURSIVE-EDIT-COMTAB* *STANDARD-COMTAB*)
    868944  (SETQ *STANDALONE-COMTAB*
    869         (SET-COMTAB NIL '(#/ COM-QUIT)))
     945        (SET-COMTAB NIL '(#\END COM-QUIT
     946                          #/ COM-QUIT)))
    870947  (SET-COMTAB-INDIRECTION *STANDALONE-COMTAB* *STANDARD-COMTAB*)
    871948  )
     
    881958      ((NULL CL) (NREVERSE RET))))
    882959
     960
     961;;; Mouse prompting stuff
     962(DEFUN COMTAB-MOUSE-PROMPT (COMTAB STRING &AUX (INHIBIT-SCHEDULING-FLAG T))
     963  (STORE-ARRAY-LEADER 0 STRING 0)
     964  (DO ((BUTTON 0 (1+ BUTTON))
     965       (NAMES '(#/L #/M #/R) (CDR NAMES))
     966       (FIRST-P T))
     967      ((
     968 BUTTON 3)
     969       (OR FIRST-P (ARRAY-PUSH-EXTEND STRING #/.)))
     970    (DO ((CLICKS 0 (1+ CLICKS))
     971         (COMMAND) (PROMPT))
     972        ((
     973 CLICKS 2))
     974      (COND ((OR (AND (SETQ COMMAND (COMMAND-LOOKUP (DPB 1 %%KBD-MOUSE
     975                                                         (DPB CLICKS %%KBD-MOUSE-N-CLICKS
     976                                                              (DPB BUTTON %%KBD-MOUSE-BUTTON
     977                                                                   0)))
     978                                                    COMTAB))
     979                      (OR (SETQ PROMPT (GET COMMAND ':MOUSE-SHORT-DOCUMENTATION))
     980                          (AND (MENU-COMMAND-P COMMAND)
     981                               (SETQ PROMPT "Menu"))))
     982                 (AND (= BUTTON 2) (= CLICKS 1)
     983                      (SETQ PROMPT "System menu")))
     984             (IF FIRST-P
     985                 (SETQ FIRST-P NIL)
     986                 (APPEND-TO-ARRAY STRING ", "))
     987             (ARRAY-PUSH-EXTEND STRING (CAR NAMES))
     988             (AND (> CLICKS 0) (ARRAY-PUSH-EXTEND STRING #/2))
     989             (ARRAY-PUSH-EXTEND STRING #/:)
     990             (APPEND-TO-ARRAY STRING PROMPT)))))
     991  STRING)
    883992
    884993;;; This makes WINDOW edit INTERVAL.
     
    9581067  (SETQ *WORD-SYNTAX-TABLE* (MAKE-SYNTAX-TABLE
    9591068                              '((40 WORD-ALPHABETIC)
    960                                 WORD-DELIMITER  ;040 space
    961                                 WORD-DELIMITER  ;041 !
    962                                 WORD-DELIMITER  ;042 ""
    963                                 WORD-DELIMITER  ;043 #
    964                                 WORD-ALPHABETIC ;044 $
    965                                 WORD-ALPHABETIC ;045 %
    966                                 WORD-DELIMITER  ;046 &
    967                                 WORD-DELIMITER  ;047 '
    968                                 WORD-DELIMITER  ;050 (
    969                                 WORD-DELIMITER  ;051 )
    970                                 WORD-DELIMITER  ;052 *
    971                                 WORD-DELIMITER  ;053 +
    972                                 WORD-DELIMITER  ;054 ,
    973                                 WORD-DELIMITER  ;055 -
    974                                 WORD-ALPHABETIC ;056 .
    975                                 WORD-DELIMITER  ;057 /
    976                                 (10. WORD-ALPHABETIC)   ;DIGITS
    977                                 WORD-DELIMITER  ;072 :
    978                                 WORD-DELIMITER  ;073 ;
    979                                 WORD-DELIMITER  ;074 <
    980                                 WORD-DELIMITER  ;075 =
    981                                 WORD-DELIMITER  ;076 >
    982                                 WORD-DELIMITER  ;077 ?
    983                                 WORD-DELIMITER  ;100 @
    984                                 (26. WORD-ALPHABETIC)   ;LETTERS
    985                                 WORD-DELIMITER  ;133 [
    986                                 WORD-DELIMITER  ;134 \
    987                                 WORD-DELIMITER  ;135 ]
    988                                 WORD-DELIMITER  ;136 ^
    989                                 WORD-DELIMITER  ;137 _
    990                                 WORD-DELIMITER  ;140 `
    991                                 (26. WORD-ALPHABETIC)   ;LETTERS
     1069                                WORD-DELIMITER          ;040 space
     1070                                WORD-DELIMITER          ;041 !
     1071                                WORD-DELIMITER          ;042 "
     1072                                WORD-DELIMITER          ;043 #
     1073                                WORD-ALPHABETIC         ;044 $
     1074                                WORD-ALPHABETIC         ;045 %
     1075                                WORD-DELIMITER          ;046 &
     1076                                WORD-DELIMITER          ;047 '
     1077                                WORD-DELIMITER          ;050 (
     1078                                WORD-DELIMITER          ;051 )
     1079                                WORD-DELIMITER          ;052 *
     1080                                WORD-DELIMITER          ;053 +
     1081                                WORD-DELIMITER          ;054 ,
     1082                                WORD-DELIMITER          ;055 -
     1083                                WORD-ALPHABETIC         ;056 .
     1084                                WORD-DELIMITER          ;057 /
     1085                                (10. WORD-ALPHABETIC)   ;Digits
     1086                                WORD-DELIMITER          ;072 :
     1087                                WORD-DELIMITER          ;073 ;
     1088                                WORD-DELIMITER          ;074 <
     1089                                WORD-DELIMITER          ;075 =
     1090                                WORD-DELIMITER          ;076 >
     1091                                WORD-DELIMITER          ;077 ?
     1092                                WORD-DELIMITER          ;100 @
     1093                                (26. WORD-ALPHABETIC)   ;Uppercase letters
     1094                                WORD-DELIMITER          ;133 [
     1095                                WORD-DELIMITER          ;134 \
     1096                                WORD-DELIMITER          ;135 ]
     1097                                WORD-DELIMITER          ;136 ^
     1098                                WORD-DELIMITER          ;137 _
     1099                                WORD-DELIMITER          ;140 `
     1100                                (26. WORD-ALPHABETIC)   ;Lowercase letters
    9921101                                (205 WORD-DELIMITER)))
    9931102        *LIST-SYNTAX-TABLE* (MAKE-SYNTAX-TABLE
    9941103                              '((40 LIST-ALPHABETIC)
    995                                 LIST-DELIMITER  ;040 space
    996                                 LIST-ALPHABETIC ;041 !
    997                                 LIST-DOUBLE-QUOTE       ;042 "     "
     1104                                LIST-DELIMITER          ;040 space
     1105                                LIST-ALPHABETIC         ;041 !
     1106                                LIST-DOUBLE-QUOTE       ;042 "
    9981107                                LIST-SINGLE-QUOTE       ;043 #
    999                                 LIST-ALPHABETIC ;044 $
    1000                                 LIST-ALPHABETIC ;045 %
    1001                                 LIST-ALPHABETIC ;046 &
     1108                                LIST-ALPHABETIC         ;044 $
     1109                                LIST-ALPHABETIC         ;045 %
     1110                                LIST-ALPHABETIC         ;046 &
    10021111                                LIST-SINGLE-QUOTE       ;047 '
    10031112                                LIST-OPEN               ;050 (
    10041113                                LIST-CLOSE              ;051 )
    1005                                 LIST-ALPHABETIC ;052 *
    1006                                 LIST-ALPHABETIC ;053 +
     1114                                LIST-ALPHABETIC         ;052 *
     1115                                LIST-ALPHABETIC         ;053 +
    10071116                                LIST-SINGLE-QUOTE       ;054 ,
    1008                                 LIST-ALPHABETIC ;055 -
    1009                                 LIST-ALPHABETIC ;056 .
     1117                                LIST-ALPHABETIC         ;055 -
     1118                                LIST-ALPHABETIC         ;056 .
    10101119                                LIST-SLASH              ;057 /
    1011                                 (10. LIST-ALPHABETIC)   ;DIGITS
    1012                                 LIST-ALPHABETIC ;072 :
    1013                                 LIST-COMMENT    ;073 ;
    1014                                 LIST-ALPHABETIC ;074 <
    1015                                 LIST-ALPHABETIC ;075 =
    1016                                 LIST-ALPHABETIC ;076 >
    1017                                 LIST-ALPHABETIC ;077 ?
    1018                                 LIST-ALPHABETIC ;100 @
    1019                                 (26. LIST-ALPHABETIC)   ;LETTERS
    1020                                 LIST-ALPHABETIC ;133 [
    1021                                 LIST-ALPHABETIC ;134 \
    1022                                 LIST-ALPHABETIC ;135 ]
    1023                                 LIST-ALPHABETIC ;136 ^
    1024                                 LIST-ALPHABETIC ;137 _
    1025                                 LIST-SINGLE-QUOTE       ;140 ` STANDARD MACRO
    1026                                 (26. LIST-ALPHABETIC)   ;MORE LETTERS
    1027                                 LIST-ALPHABETIC ;173 {
    1028                                 LIST-DOUBLE-QUOTE       ;174 |            |
    1029                                 LIST-ALPHABETIC ;175 }
    1030                                 LIST-ALPHABETIC ;176 ~
    1031                                 LIST-ALPHABETIC ;177 integral ???
     1120                                (10. LIST-ALPHABETIC)   ;Digits
     1121                                LIST-ALPHABETIC         ;072 :
     1122                                LIST-COMMENT            ;073 ;
     1123                                LIST-ALPHABETIC         ;074 <
     1124                                LIST-ALPHABETIC         ;075 =
     1125                                LIST-ALPHABETIC         ;076 >
     1126                                LIST-ALPHABETIC         ;077 ?
     1127                                LIST-SINGLE-QUOTE       ;100 @
     1128                                (26. LIST-ALPHABETIC)   ;Uppercase letters
     1129                                LIST-ALPHABETIC         ;133 [
     1130                                LIST-ALPHABETIC         ;134 \
     1131                                LIST-ALPHABETIC         ;135 ]
     1132                                LIST-ALPHABETIC         ;136 ^
     1133                                LIST-ALPHABETIC         ;137 _
     1134                                LIST-SINGLE-QUOTE       ;140 `
     1135                                (26. LIST-ALPHABETIC)   ;Lowercase letters
     1136                                LIST-ALPHABETIC         ;173 {
     1137                                LIST-DOUBLE-QUOTE       ;174 |
     1138                                LIST-ALPHABETIC         ;175 }
     1139                                LIST-ALPHABETIC         ;176 ~
     1140                                LIST-ALPHABETIC         ;177 
    10321141                               
    1033                                 LIST-ALPHABETIC ;200 null character
    1034                                 LIST-DELIMITER  ;201 break
    1035                                 LIST-DELIMITER  ;202 clear
    1036                                 LIST-DELIMITER  ;203 call
    1037                                 LIST-DELIMITER  ;204 escape (NOT altmode!)
    1038                                 LIST-DELIMITER  ;205 backnext
    1039                                 LIST-DELIMITER  ;206 help
    1040                                 LIST-DELIMITER  ;207 rubout
    1041                                 LIST-ALPHABETIC ;210 bs
    1042                                 LIST-DELIMITER  ;211 tab
    1043                                 LIST-DELIMITER  ;212 line
    1044                                 LIST-DELIMITER  ;213 vt
    1045                                 LIST-DELIMITER  ;214 form = newpage
    1046                                 LIST-DELIMITER  ;215 return = newline
     1142                                LIST-ALPHABETIC         ;200 null
     1143                                LIST-DELIMITER          ;201 break
     1144                                LIST-DELIMITER          ;202 clear
     1145                                LIST-DELIMITER          ;203 call
     1146                                LIST-DELIMITER          ;204 escape
     1147                                LIST-DELIMITER          ;205 backnext
     1148                                LIST-DELIMITER          ;206 help
     1149                                LIST-DELIMITER          ;207 rubout
     1150                                LIST-ALPHABETIC         ;210 bs
     1151                                LIST-DELIMITER          ;211 tab
     1152                                LIST-DELIMITER          ;212 line
     1153                                LIST-DELIMITER          ;213 vt
     1154                                LIST-DELIMITER          ;214 form
     1155                                LIST-DELIMITER          ;215 return
    10471156                                (162 LIST-ALPHABETIC)))
    10481157        *ATOM-WORD-SYNTAX-TABLE* (MAKE-SYNTAX-TABLE
     
    10501159                                     WORD-DELIMITER     ;040 space
    10511160                                     WORD-ALPHABETIC    ;041 !
    1052                                      WORD-ALPHABETIC    ;042 "    "
     1161                                     WORD-ALPHABETIC    ;042 "
    10531162                                     WORD-ALPHABETIC    ;043 #
    10541163                                     WORD-ALPHABETIC    ;044 $
     
    10641173                                     WORD-ALPHABETIC    ;056 .
    10651174                                     WORD-ALPHABETIC    ;057 /
    1066                                      (10. WORD-ALPHABETIC)      ;DIGITS
     1175                                     (10. WORD-ALPHABETIC)      ;Digits
    10671176                                     WORD-ALPHABETIC    ;072 :
    10681177                                     WORD-DELIMITER     ;073 ;
     
    10711180                                     WORD-ALPHABETIC    ;076 >
    10721181                                     WORD-ALPHABETIC    ;077 ?
    1073                                      WORD-ALPHABETIC    ;100 @
    1074                                      (26. WORD-ALPHABETIC)      ;LETTERS
     1182                                     WORD-DELIMITER     ;100 @
     1183                                     (26. WORD-ALPHABETIC)      ;Uppercase letters
    10751184                                     WORD-ALPHABETIC    ;133 [
    10761185                                     WORD-ALPHABETIC    ;134 \
     
    10791188                                     WORD-ALPHABETIC    ;137 _
    10801189                                     WORD-DELIMITER     ;140 `
    1081                                      (31. WORD-ALPHABETIC)      ;LETTERS
     1190                                     (31. WORD-ALPHABETIC)      ;Lowercase letters
    10821191                                     (200 WORD-DELIMITER)))))
    10831192
     
    11021211  (INITIALIZE-TAB-STOP-BUFFER)
    11031212  (INITIALIZE-MOUSE)
     1213  (SETQ *PATHNAME-DEFAULTS* (FS:MAKE-PATHNAME-DEFAULTS)
     1214        *AUX-PATHNAME-DEFAULTS* (FS:MAKE-PATHNAME-DEFAULTS))
    11041215  )
    11051216
     
    11161227                          #\END COM-END-OF-MINI-BUFFER
    11171228                          #/G COM-MINI-BUFFER-BEEP
     1229                          #\ABORT COM-RECURSIVE-EDIT-ABORT
    11181230                          #/Z :UNDEFINED
    11191231                          #/Z :UNDEFINED
     
    11251237  (SETQ *MINI-BUFFER-COMTAB* (SET-COMTAB NIL '(#\CR COM-END-OF-MINI-BUFFER)))
    11261238  (SET-COMTAB-INDIRECTION *MINI-BUFFER-COMTAB* *MINI-BUFFER-MULTI-LINE-COMTAB*)
     1239  (SETQ *PATHNAME-READING-COMTAB*
     1240        (SET-COMTAB NIL '(#/ COM-PATHNAME-COMPLETE
     1241;                         #/? COM-PATHNAME-LIST-COMPLETIONS
     1242                          #/Q COM-QUOTED-INSERT
     1243                          #\END COM-PATHNAME-COMPLETE-AND-EXIT-IF-UNIQUE
     1244                          #\HELP COM-DOCUMENT-PATHNAME-READ)))
     1245  (SET-COMTAB-INDIRECTION *PATHNAME-READING-COMTAB* *MINI-BUFFER-COMTAB*)
    11271246  (INITIALIZE-MINI-BUFFER-WINDOW))
  • trunk/lisp/zwei/defs.lisp

    r258 r273  
    1010(DEFMACRO DEFGLOBAL (VAR &OPTIONAL (INITIAL-VALUE NIL IVP))
    1111  `(PROGN 'COMPILE
    12      (SPECIAL ,VAR)
     12     (DEFVAR ,VAR)
    1313     . ,(AND IVP
    1414             `((PUSH (CONS ',VAR ,INITIAL-VALUE) *GLOBAL-INITIALIZATION-LIST*)))))
     
    2626(DEFGLOBAL *STANDARD-CONTROL-X-COMTAB*) ;Similarly, the simple control-X commands.
    2727(DEFGLOBAL *COMPLETING-READER-COMTAB*)  ;Comtab for the completing reader environment.
     28(DEFGLOBAL *PATHNAME-READING-COMTAB*)   ;Comtab for reading pathnames in mini-buffer.
    2829(DEFGLOBAL *CONTROL-R-COMTAB*)          ;Comtab for recursive edits on the same buffer.
    2930(DEFGLOBAL *RECURSIVE-EDIT-COMTAB*)     ;Comtab for recursive edits on a new buffer.
     
    4243(DEFGLOBAL *UNDO-OLD-INTERVAL*)         ;Copy of old contents
    4344(DEFGLOBAL *UNDO-TYPE*)                 ;Type of command that caused undo saving
     45(DEFGLOBAL *PATHNAME-DEFAULTS*)         ;Default file names
     46(DEFGLOBAL *AUX-PATHNAME-DEFAULTS*)     ;Auxiliary default, for Insert File, etc.
     47(DEFGLOBAL *WORD-ABBREV-FILE-NAME* NIL) ;Last file used for word abbrevs
     48(DEFGLOBAL *WORD-ABBREV-FILE-TICK* -1)  ;Time for that file
     49(DEFGLOBAL *WORD-ABBREV-TICK* -1)       ;Time last modified
    4450
    4551;;; Redisplay levels.  These are symbolic constants.
    4652;;; They have global values and should never be bound.
    47 (DEFVAR DIS-NONE 0)             ;No redisplay needed.
    48 (DEFVAR DIS-MARK-GOES 1)        ;No redisplay needed except maybe removing region underlining.
    49 (DEFVAR DIS-BPS 2)              ;Point and mark may have moved, but text is unchanged.
    50 (DEFVAR DIS-LINE 3)             ;Text in one line may have changed.
     53(DEFCONST DIS-NONE 0)           ;No redisplay needed.
     54(DEFCONST DIS-MARK-GOES 1)      ;No redisplay needed except maybe removing region underlining.
     55(DEFCONST DIS-BPS 2)            ;Point and mark may have moved, but text is unchanged.
     56(DEFCONST DIS-LINE 3)           ;Text in one line may have changed.
    5157                                ;WINDOW-REDISPLAY-LINE is that line.
    5258                                ;WINDOW-REDISPLAY-INDEX says where in the line changes start.
    53 (DEFVAR DIS-TEXT 4)             ;Any text might have changed.
    54 (DEFVAR DIS-ALL 5)              ;Global parameters of the window have changed.
     59(DEFCONST DIS-TEXT 4)           ;Any text might have changed.
     60(DEFCONST DIS-ALL 5)            ;Global parameters of the window have changed.
    5561                                ;Clean the window and redisplay all lines from scratch.
    5662
    5763;;; Syntax codes in *LISP-SYNTAX-TABLE*
    58 (DEFVAR LIST-ALPHABETIC 0)      ;Part of an atom.
    59 (DEFVAR LIST-DELIMITER 1)       ;Separates things but has no other significance.
    60 (DEFVAR LIST-SLASH 2)           ;Quotes the following character.
    61 (DEFVAR LIST-DOUBLE-QUOTE 3)    ;Starts a grouping terminated by another of itself.
    62 (DEFVAR LIST-SINGLE-QUOTE 4)    ;Tacks onto the front of a sexp to make another sexp.
    63 (DEFVAR LIST-CLOSE 5)           ;Closeparentheses
    64 (DEFVAR LIST-OPEN 6)            ;Openparentheses
    65 (DEFVAR LIST-COMMENT 7)         ;Starts a comment.
     64(DEFCONST LIST-ALPHABETIC 0)    ;Part of an atom.
     65(DEFCONST LIST-DELIMITER 1)     ;Separates things but has no other significance.
     66(DEFCONST LIST-SLASH 2)         ;Quotes the following character.
     67(DEFCONST LIST-DOUBLE-QUOTE 3)  ;Starts a grouping terminated by another of itself.
     68(DEFCONST LIST-SINGLE-QUOTE 4)  ;Tacks onto the front of a sexp to make another sexp.
     69(DEFCONST LIST-CLOSE 5)         ;Closeparentheses
     70(DEFCONST LIST-OPEN 6)          ;Openparentheses
     71(DEFCONST LIST-COMMENT 7)       ;Starts a comment.
     72(DEFCONST LIST-COLON 10)        ;End of package prefix
    6673
    6774;;; Syntax codes in *WORD-SYNTAX-TABLE*.
    68 (DEFVAR WORD-ALPHABETIC 0)      ;Part of words.
    69 (DEFVAR WORD-DELIMITER 1)       ;Separates words.
     75(DEFCONST WORD-ALPHABETIC 0)    ;Part of words.
     76(DEFCONST WORD-DELIMITER 1)     ;Separates words.
    7077
    7178
     
    8996        (*CURRENT-COMMAND-TYPE* NIL)    ;The "type" (a symbol) of the current command.
    9097        (*LAST-COMMAND-TYPE* NIL)       ;The "type" of the last command executed.
    91         *REAL-LINE-GOAL-XPOS*           ;Used by real-line commands.
    92         *MARK-STAYS*                    ;Tells command loop whether to preserve region.
     98        (*REAL-LINE-GOAL-XPOS* 0)       ;Used by real-line commands.
     99        (*MARK-STAYS* NIL)              ;Tells command loop whether to preserve region.
    93100        (*CENTERING-FRACTION* *CENTER-FRACTION*);Tells redisplay where to recenter, if needed.
    94101        *QUANTITY-MODE*                 ;Current MODE, also free var for the generic cmds.
     
    99106        (*COM-DOC-LAST-CHAR* #/B)       ;Last char typed to COM-DOCUMENTATION.
    100107        (*LAST-FILE-NAME-TYPED* "")     ;Last thing the guy typed when asked for a file name.
    101         (*LAST-EXPANDED* NIL)           ;The last thing expanded
    102         (*LAST-EXPANSION* NIL)          ;What it expanded to
    103         (*LAST-EXPANSION-BP* NIL)       ;Where the expansion begins
    104         *LAST-EXPANSION-USAGE-PROP*     ;Its usage parameter
    105         *LAST-EXPANSION-SYMBOL*         ;The symbol it is stored as in the utility-package
    106         (*WORD-ABBREV-PREFIX-MARK* NIL) ;A BP for expanding prefixed word abbrevs
    107         (*STANDARD-COMMAND* 'COM-SELF-INSERT)   ;The command to be performed by alphanumerics.
    108108        (*FONT-NAME* NIL)               ;As is this
    109109        (*MACRO-LEVEL* NIL)             ;And this
     
    124124        *MODE-COMTAB*                   ;A sparse comtab for mode redefinitions
    125125        *MODE-WORD-SYNTAX-TABLE*        ;A sparse syntax table for mode redefinitions
     126        (*USER-MODES-SET* NIL)          ;Reset by logout
    126127        (*WINDOW-LIST* NIL)             ;List of windows belonging to this editor
    127128        (*COMMAND-HOOK* NIL)            ;List of functions to be applied to command char.
     
    132133        *MINI-BUFFER-WINDOW*            ;A special editor window
    133134
     135        ;;These are for modes SETQing to work right
     136        (*SPACE-INDENT-FLAG* *SPACE-INDENT-FLAG*)
     137        (*PARAGRAPH-DELIMITER-LIST* *PARAGRAPH-DELIMITER-LIST*)
     138        (*COMMENT-START* *COMMENT-START*)
     139        (*COMMENT-BEGIN* *COMMENT-BEGIN*)
     140        (*COMMENT-END* *COMMENT-END*)
     141        (*STANDARD-COMMAND* 'COM-SELF-INSERT)
     142        (*COMMENT-COLUMN* *COMMENT-COLUMN*)
     143        (*LAST-EXPANDED* NIL)
     144        (*LAST-EXPANSION* NIL)
     145        (*LAST-EXPANSION-BP* NIL)
     146        *LAST-EXPANSION-SYMBOL*
     147        *LAST-EXPANSION-USAGE-PROP*
     148        (*WORD-ABBREV-PREFIX-MARK* NIL)
     149        (*LIST-SYNTAX-TABLE* *LIST-SYNTAX-TABLE*)
     150
    134151        TV:IO-BUFFER
    135152        )
     
    146163       ((*MODE-LINE-LIST* '("ZMACS " "(" *MODE-NAME-LIST*
    147164                                     (*MODE-QUANTITY-NAME* " <" *MODE-QUANTITY-NAME* ">")
    148                                      ") " *ZMACS-BUFFER-NAME*
     165                                     ") " *ZMACS-BUFFER-NAME* *ZMACS-BUFFER-VERSION-STRING*
    149166                                     (*FONT-NAME* "  Font: " *FONT-NAME*)
    150167                                     (*MACRO-LEVEL* "  Macro-level: " *MACRO-LEVEL*)
    151168                                     *BUFFER-MODIFIED-P*))
    152         STANDARD-INPUT
    153169        (PACKAGE PACKAGE)       ;Must not be unbound or who-line will blow out
    154170        )
    155        (ZMACS-EDITOR TOP-LEVEL-EDITOR)
    156   (:INITABLE-INSTANCE-VARIABLES STANDARD-INPUT)
    157   (:GETTABLE-INSTANCE-VARIABLES STANDARD-INPUT)
     171       (ZMACS-EDITOR OWN-STANDARD-INPUT-EDITOR-MIXIN TOP-LEVEL-EDITOR)
    158172  (:DOCUMENTATION :SPECIAL-PURPOSE "The actual (ED) editor"))
    159173
     
    173187(GLOBALLY-DECLARE-FLAVOR-INSTANCE-VARIABLES TOP-LEVEL-EDITOR)
    174188
    175 
    176 (DEFSTRUCT (LINE :ARRAY-LEADER)
    177      LINE-LENGTH                        ;Number of characters.
    178      LINE-NEXT                          ;Next line.
    179      LINE-PREVIOUS                      ;Previous line.
    180      LINE-BP-LIST                       ;List of permanent BPs.
    181      LINE-TICK                          ;Last time modified.
    182      LINE-CONTENTS-PLIST                ;Plist cleared out by MUNG-LINE.
    183                                         ;Holds properties of the text in the line.
    184      LINE-PLIST                         ;Plist not cleared out.  Props of line itself.
    185      )
     189(DEFUN ALLOW-SETTING-INSTANCE-VARIABLES-INSIDE-MODE (FLAVOR-NAME)
     190  (DOLIST (VAR (SI:FLAVOR-LOCAL-INSTANCE-VARIABLES (GET FLAVOR-NAME 'SI:FLAVOR)))
     191    (AND (LISTP VAR) (SETQ VAR (CAR VAR)))
     192    (PUTPROP VAR T 'MODE-SETTABLE-P)))
     193
     194(ALLOW-SETTING-INSTANCE-VARIABLES-INSIDE-MODE 'TOP-LEVEL-EDITOR)
     195
     196
     197(DEFSTRUCT (LINE :ARRAY-LEADER (:SIZE-SYMBOL LINE-LEADER-SIZE))
     198  LINE-LENGTH                                   ;Number of characters.
     199  LINE-NEXT                                     ;Next line.
     200  LINE-PREVIOUS