Changeset 258

Show
Ignore:
Timestamp:
08/18/11 08:23:42 (21 months ago)
Author:
rjs
Message:

Update.

Location:
trunk/lisp/nzwei
Files:
24 modified

Legend:

Unmodified
Added
Removed

  • trunk/lisp/nzwei/coma.lisp

    r257 r258  
    283283 
    284284(DEFCOM COM-PUSH-POP-POINT-EXPLICIT "Push or pop point onto the point pdl. 
     285With no argument, push point onto the point pdl. 
    285286With an argument, exchanges point with the nth position on the stack." (KM) 
    286287  (COND ((NOT *NUMERIC-ARG-P*) 

  • trunk/lisp/nzwei/comb.lisp

    r257 r258  
    326326                                                    LINE)) 
    327327             (SETQ START-END-INDEX (+ START-START-INDEX 
    328                                       (STRING-LENGTH *COMMENT-START*))))) 
     328                                      (STRING-LENGTH (OR *COMMENT-START* *COMMENT-BEGIN*)))))) 
    329329    (RETURN START-START-INDEX START-END-INDEX))) 
    330330 
    … …  
    382382    (DO ((LINE (LINE-PREVIOUS (BP-LINE (POINT))) (LINE-PREVIOUS LINE))) 
    383383        ((NULL LINE) (BARF)) 
    384       (SETQ START-INDEX (FIND-COMMENT-START LINE)) 
     384      (SETQ START-INDEX (FIND-COMMENT-START LINE T)) 
    385385      (AND START-INDEX (RETURN (SETQ BP (CREATE-BP LINE START-INDEX))))) 
    386386    (SETQ *COMMENT-COLUMN* (BP-INDENTATION BP)) 

  • trunk/lisp/nzwei/comc.lisp

    r257 r258  
    338338                            "Evaluating" 
    339339                            "evaluated." 
    340                             NIL T) 
     340                            ':PROMPT T) 
    341341   DIS-NONE) 
    342342 

  • trunk/lisp/nzwei/comd.lisp

    r257 r258  
    277277                          ;; If allowed one failure 
    278278                          (NEQ *LAST-COMMAND-TYPE* 'FAILING-COMPLETION) 
    279                           (NOT (BIT-TEST 400 *LAST-COMMAND-CHAR*))) 
     279                          (NUMBERP *LAST-COMMAND-CHAR*) 
     280                          (NOT (LDB-TEST %%KBD-CONTROL *LAST-COMMAND-CHAR*))) 
    280281                     (SETQ COMPLETION (COMPLETE-LINE T NIL)) 
    281282                     (SETQ COMPLETION (IF (= (LENGTH COMPLETION) 1) (CAR COMPLETION) 

  • trunk/lisp/nzwei/come.lisp

    r257 r258  
    273273 
    274274(DEFCOM COM-MARK-DEFUN "Put point and mark around current defun." () 
    275   (LET ((INT (DEFUN-INTERVAL (POINT) *NUMERIC-ARG*))) 
     275  (LET ((INT (DEFUN-INTERVAL (POINT) *NUMERIC-ARG* NIL T T))) ;including previous blank line 
    276276    (OR INT (BARF)) 
    277277    (SETF (WINDOW-MARK-P *WINDOW*) T) 

  • trunk/lisp/nzwei/comf.lisp

    r257 r258  
    5050                        (SETQ BP1 (BACKWARD-OVER '(#\CR #\TAB #\SP) BP1)) 
    5151                        (SETQ BP1 (FORWARD-CHAR BP1 -1)) 
     52                        (SETQ N (COUNT-LIST-ELEMENTS (FORWARD-SEXP COND-BP))) 
    5253                        (DELETE-INTERVAL BP1 BP3 T) 
    53                         (SETQ COND-TYPE "IF")))) 
     54                        (SETQ COND-TYPE (IF (= N 1) "OR" "IF"))))) 
    5455               (DELETE-INTERVAL COND-BP (FORWARD-WORD COND-BP) T) 
    5556               (AND (EQ COND-TYPE 'COND)        ;Still not determined 

  • trunk/lisp/nzwei/coms.lisp

    r257 r258  
    123123        LOOP (SETQ XCHAR (AND (NOT ECHOED-P) 
    124124                              (FUNCALL STANDARD-INPUT ':TYI-NO-HANG))) 
    125         LOP1 (SETQ CHAR (OR XCHAR 
    126                             (TYPEIN-LINE-ACTIVATE 
    127                               (FUNCALL STANDARD-INPUT ':TYI)))) 
     125        LOP1 (SETQ CHAR (OR XCHAR (TYPEIN-LINE-ACTIVATE (TYI-WITH-SCROLLING)))) 
    128126             (SETQ HACK2 HACK1 HACK1 NIL) 
    129127             (COND ((BIT-TEST 400 CHAR) 
    … …  
    358356              (SETQ SUPPRESSED-REDISPLAY T)) 
    359357          (MULTIPLE-VALUE (CHAR REAL-CHAR) 
    360             (FUNCALL STANDARD-INPUT ':MOUSE-OR-KBD-TYI)) 
     358            (TYI-WITH-SCROLLING T)) 
    361359          (SETQ XCHAR (CHAR-UPCASE CHAR)) 
    362360          (COND ((NOT (OR (LDB-TEST %%KBD-CONTROL-META CHAR) (LDB-TEST %%KBD-MOUSE CHAR) 
    … …  
    735733        (SETQ NEW-BP (FUNCALL FUNCTION BP KEY NIL T)) 
    736734        (DELETE-INTERVAL BP (BEG-LINE NEW-BP 0) T) 
    737         (OR (SETQ BP (BEG-LINE BP 1)) (RETURN NIL))))) 
     735        (OR (SETQ BP (BEG-LINE NEW-BP 1)) (RETURN NIL))))) 
    738736  DIS-TEXT) 
    739737 
    … …  
    746744      (DO () (()) 
    747745        (OR (SETQ BP (FUNCALL FUNCTION BP KEY)) (RETURN NIL)) 
    748         (DELETE-INTERVAL (BEG-LINE BP 0) (BEG-LINE BP 1))))) 
     746        (DELETE-INTERVAL (BEG-LINE BP 0) (SETQ BP (BEG-LINE BP 1)))))) 
    749747  DIS-TEXT) 
    750748 

  • trunk/lisp/nzwei/comtab.lisp

    r257 r258  
    759759            #/# COM-TEXT-JUSTIFIER-CHANGE-FONT-WORD 
    760760            #/_ COM-TEXT-JUSTIFIER-UNDERLINE-WORD 
     761            #/# COM-GOTO-CHARACTER 
    761762            #\MOUSE-1-1 COM-MOUSE-MARK-REGION 
    762763            #\MOUSE-1-2 COM-MOUSE-MOVE-REGION 

  • trunk/lisp/nzwei/defs.lisp

    r257 r258  
    250250     BUFFER-TICK                        ;If FILE-ID is a string, this is the tick 
    251251                                        ;at which we got that ID.  Else meaningless. 
     252     BUFFER-FILE-NAME                   ;The filename object for if a file, else meaningless 
    252253     BUFFER-SAVED-POINT                 ;POINT the last time this was on a window. 
    253254     BUFFER-SAVED-MARK                  ;Same for MARK. 

  • trunk/lisp/nzwei/dired.lisp

    r257 r258  
    1111  (PROGN (OR (BOUNDP '*DIRED-MOUSE-COMMAND*) 
    1212             (SETQ *DIRED-MOUSE-COMMAND* 
    13                    (MAKE-MENU-COMMAND '(DIRED-SORT-BY-INCREASING-REFERENCE-DATE 
     13                   (MAKE-MENU-COMMAND 'DIRED-COMMAND-MENU 
     14                                      '(DIRED-SORT-BY-INCREASING-REFERENCE-DATE 
    1415                                        DIRED-SORT-BY-DECREASING-REFERENCE-DATE 
    1516                                        DIRED-SORT-BY-INCREASING-CREATION-DATE 

  • trunk/lisp/nzwei/displa.lisp

    r257 r258  
    10501050    (SELECTQ (SETQ CH (WITHOUT-IO-BUFFER-OUTPUT-FUNCTION 
    10511051                        (FUNCALL STANDARD-INPUT ':TYI))) 
    1052       ((#\SP #/V #/v) 
     1052      ((#\SP #/V #/v #\HAND-DOWN) 
    10531053       (AND AT-END-P (RETURN NIL)) 
    10541054       (RECENTER-WINDOW-RELATIVE ZWEI-WINDOW N-LINES)) 
    1055       ((#\BS #/V #/v) 
     1055      ((#\BS #/V #/v #\HAND-UP) 
    10561056       (RECENTER-WINDOW-RELATIVE ZWEI-WINDOW (- N-LINES))) 
    10571057      (#\SP 

  • trunk/lisp/nzwei/doc.lisp

    r257 r258  
    109109               (FORMAT T " is undefined.~%")) 
    110110              ((SYMBOLP TEM) 
    111                (FORMAT T " is ~A, implemented by " (COMMAND-NAME TEM)) 
    112                (FUNCALL STANDARD-OUTPUT ':ITEM 'FUNCTION-NAME TEM) 
    113                (FORMAT T ":~%") 
    114                (DO L *COMMAND-HOOK* (CDR L) (NULL L) 
    115                    (LET ((DOCFN (GET (CAR L) 'HOOK-DOCUMENTATION-FUNCTION))) 
    116                      (AND DOCFN 
    117                           (FUNCALL DOCFN TEM CHAR)))) 
    118                (PRINT-DOC ':FULL TEM CHAR)) 
     111               (IF (NOT (GET TEM 'COMMAND-NAME)) 
     112                   (FORMAT T " is ~A, which is not implemented.~%" TEM) 
     113                   (FORMAT T " is ~A, implemented by " (COMMAND-NAME TEM)) 
     114                   (FUNCALL STANDARD-OUTPUT ':ITEM 'FUNCTION-NAME TEM) 
     115                   (FORMAT T ":~%") 
     116                   (DO L *COMMAND-HOOK* (CDR L) (NULL L) 
     117                       (LET ((DOCFN (GET (CAR L) 'HOOK-DOCUMENTATION-FUNCTION))) 
     118                         (AND DOCFN 
     119                              (FUNCALL DOCFN TEM CHAR)))) 
     120                   (PRINT-DOC ':FULL TEM CHAR))) 
    119121              ((LISTP TEM) 
    120122               (FORMAT T " is an alias for ~@[~:@C ~]~:@C.~%~@[~:@C ~]~:@C" 

  • trunk/lisp/nzwei/fasupd.lisp

    r257 r258  
    3838  (SETQ INFILE (BUFFER-FILE-NAME BUFFER)) 
    3939  (SETQ OUTFILE 
    40         (IF OUTFILE (FILE-DEFAULT-FN2 OUTFILE "QFASL") (FILE-SET-FN2 INFILE "QFASL"))) 
     40        (IF OUTFILE 
     41            (SI:FILE-PARSE-NAME OUTFILE NIL (FUNCALL INFILE ':COPY-WITH-TYPE ':QFASL)) 
     42            (FUNCALL INFILE ':COPY-WITH-TYPE ':QFASL))) 
    4143  (SETQ INPUT-STREAM (INTERVAL-STREAM BUFFER)) 
    4244  (UNWIND-PROTECT 

  • trunk/lisp/nzwei/files.lisp

    r257 r258  
    2121;;; Copy from the interval into the stream. 
    2222;;; Leaves the stream open. 
    23 (DEFUN STREAM-OUT-INTERVAL (STREAM FROM-BP &OPTIONAL TO-BP IN-ORDER-P &OPTIONAL HACK-FONTS) 
     23(DEFUN STREAM-OUT-INTERVAL (STREAM FROM-BP &OPTIONAL TO-BP IN-ORDER-P HACK-FONTS) 
    2424  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P) 
    2525  (STREAM-COPY-UNTIL-EOF 

  • trunk/lisp/nzwei/font.lisp

    r257 r258  
    1 ;;; Font hacking function and commands -*-Mode:LISP;Package:NZWEI-*- 
     1;;; Font hacking function and commands -*-Mode:LISP;Package:ZWEI-*- 
     2;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** 
    23 
    34;;; Change the font in the given area 
    … …  
    5657 CH #/Z)) 
    5758                    (SETQ NUM (- CH #/A)) 
    58                     (RETURN NIL))) 
    59              (BEEP)) 
     59                    (RETURN NIL)) 
     60                   ((OR (= CH #\HELP) (= CH #/?)) 
     61                    (TYPEIN-LINE "Type a font letter, ~ 
     62                                  or altmode to enter a new font in a mini-buffer, ~@ 
     63                                  or mouse a character left for its font, ~ 
     64                                  or mouse-right for a menu.~%") 
     65                    (TYPEIN-LINE-MORE "Font ID: ")) 
     66                   (T 
     67                    (BEEP)))) 
    6068         (TYPEIN-LINE-MORE "~C (~A)" (+ NUM #/A) (CAR (NTH NUM (WINDOW-FONT-ALIST *WINDOW*)))) 
    6169         (SETQ *SAVE-FONT-NUM* NUM)))) 
    … …  
    7078         (PKG-BIND "FONTS" 
    7179           (SETQ FONT (READ-FROM-STRING FONT '*EOF*))) 
    72          (COND ((NOT (SYMBOLP FONT)) 
    73                 (BARF "~S is not the name of a font" FONT)) 
    74                ((NOT (BOUNDP FONT)) 
    75                 (LOAD (FORMAT NIL "DSK: LMFONT; ~A QFASL" FONT) "FONTS" T) 
    76                 (OR (BOUNDP FONT) (BARF "~S is not a known font" FONT)))) 
     80         (SETQ FONT (FONT-NAME (FUNCALL (TV:SHEET-GET-SCREEN (WINDOW-SHEET *WINDOW*)) 
     81                                        ':PARSE-FONT-DESCRIPTOR FONT))) 
    7782         (SETQ FONT (CONS (GET-PNAME FONT) (SYMEVAL FONT))) 
    7883         (LET ((OLD-LIST (WINDOW-FONT-ALIST *WINDOW*))) 
    … …  
    385390    (FUNCALL ACTOR ':ADD-LINE LINE) 
    386391    (INSERT-LINE-WITH-LEADER LINE AT-LINE))) 
     392 

  • trunk/lisp/nzwei/for.lisp

    r257 r258  
    484484;;; Return an interval surrounding the DEFUN that BP is in, or NIL if it fails. 
    485485 
    486 (DEFUN DEFUN-INTERVAL (BP &OPTIONAL (TIMES 1) FIXUP-P (COMMENTS-P T)) 
     486(DEFUN DEFUN-INTERVAL (BP &OPTIONAL (TIMES 1) FIXUP-P (COMMENTS-P T) (TOP-BLANK-P NIL)) 
    487487  (PROG (BP1 BP2 BP3 BP4 SBP) 
    488488        (COND ((NULL (SETQ BP1 (FORWARD-DEFUN BP -1))) 
    … …  
    493493        (OR (SETQ BP2 (FORWARD-SEXP BP1 TIMES)) 
    494494            (IF (NOT FIXUP-P) (RETURN NIL) 
    495                 (SETQ BP2 (BEG-LINE (BACKWARD-OVER-COMMENT-LINES (FORWARD-DEFUN BP1 1 T)) 
     495                (SETQ BP2 (BEG-LINE (BACKWARD-OVER-COMMENT-LINES (FORWARD-DEFUN BP1 1 T) 
     496                                                                 TOP-BLANK-P) 
    496497                                    -1)))) 
    497498        (OR (BP-< (END-LINE BP2) BP) 
    … …  
    512513        (SETQ SBP BP1)                  ;Save real starting line 
    513514     CONTIN 
    514         (AND COMMENTS-P (SETQ BP1 (BACKWARD-OVER-COMMENT-LINES BP1))) 
     515        (AND COMMENTS-P (SETQ BP1 (BACKWARD-OVER-COMMENT-LINES BP1 TOP-BLANK-P))) 
    515516        (SETQ BP3 (FORWARD-OVER *BLANKS* BP2)) 
    516517        (AND BP3 (OR (= (LIST-SYNTAX (BP-CHAR BP3)) LIST-COMMENT) 

  • trunk/lisp/nzwei/indent.lisp

    r257 r258  
    273273                 (DELETE-BACKWARD-OVER *BLANKS* BP2) 
    274274                 (COND ((NOT BREAK-NEXT) 
    275                         (SETQ BP1 (INSERT-MOVING (END-LINE BP1) #\SP)) 
     275                        (SETQ BP1 (END-LINE BP1)) 
     276                        (OR (BEG-LINE-P BP1) (INSERT-MOVING BP1 #\SP)) 
    276277                        (MOVE-BP BP2 (LINE-NEXT (BP-LINE BP1)) 0) 
    277278                        (DELETE-INTERVAL BP1 BP2 T))) 

  • trunk/lisp/nzwei/insert.lisp

    r257 r258  
    1 ;;; -*- Mode:LISP; Package:NZWEI -*- 
     1;;; -*- Mode:LISP; Package:ZWEI -*- 
     2;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** 
    23;;;  This file contains basic text manipulation functions for ZWEI.  
    34 

  • trunk/lisp/nzwei/kbdmac.lisp

    r257 r258  
    6464              (NULL (MACRO-DEFAULT-COUNT MACRO-CURRENT-ARRAY)) 
    6565              (MEMQ (AREF MACRO-CURRENT-ARRAY (MACRO-POSITION MACRO-CURRENT-ARRAY)) 
    66                     '(*SPACE* *MOUSE* *MICE*))) 
     66                    '(*SPACE* *MOUSE* *MICE* NIL))) 
    6767          (FUNCALL MACRO-STREAM ':LISTEN)) 
    6868         (T T))) 
    … …  
    321321                  (AND (NOT (MINUSP MACRO-LEVEL)) 
    322322                       (FORMAT NIL "~D" (1+ MACRO-LEVEL))))))) 
     323 
     324;;; Handy things for saving out macros on disk and editing them 
     325(DEFMACRO DEFINE-KEYBOARD-MACRO (NAME (COUNT) . EXPANSION) 
     326  `(DEFINE-KEYBOARD-MACRO-1 ',NAME ,(OR COUNT 1) ',(COPYLIST EXPANSION))) 
     327 
     328(DEFUN DEFINE-KEYBOARD-MACRO-1 (NAME COUNT EXPANSION &AUX MACRO-ARRAY (LEN 0) STRING) 
     329  (SETQ STRING (STRING NAME) 
     330        NAME (INTERN STRING "")) 
     331  (DOLIST (THING EXPANSION) 
     332    (IF (STRINGP THING) 
     333        (SETQ LEN (+ LEN (STRING-LENGTH THING))) 
     334        (SETQ LEN (1+ LEN)))) 
     335  (SETQ MACRO-ARRAY (MAKE-MACRO-ARRAY MAKE-ARRAY (NIL 'ART-Q LEN) 
     336                                      MACRO-LENGTH (1- LEN) 
     337                                      MACRO-DEFAULT-COUNT COUNT 
     338                                      MACRO-NAME STRING)) 
     339  (DOLIST (THING EXPANSION) 
     340    (IF (STRINGP THING) 
     341        (APPEND-TO-ARRAY MACRO-ARRAY THING) 
     342        (COND ((NUMBERP THING)) 
     343              ((STRING-EQUAL THING '*INPUT*) 
     344               (SETQ THING NIL)) 
     345              ((STRING-EQUAL THING '*SPACE*) 
     346               (SETQ THING '*SPACE*)) 
     347              ((STRING-EQUAL THING '*MOUSE*) 
     348               (SETQ THING '*MOUSE*)) 
     349              ((STRING-EQUAL THING '*MICE*) 
     350               (SETQ THING '*MICE*)) 
     351              (T 
     352               (FERROR NIL "~S is not a known macro expansion element." THING))) 
     353        (ARRAY-PUSH MACRO-ARRAY THING))) 
     354  (PUTPROP NAME MACRO-ARRAY 'MACRO-STREAM-MACRO) 
     355  NAME) 
     356 
     357(DEFUN PRINT-KEYBOARD-MACRO-DEFINITION (STREAM NAME &OPTIONAL MACRO-ARRAY) 
     358  (LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI")) 
     359        (BASE 'CHARACTER)) 
     360    (SI:GRIND-TOP-LEVEL (GET-KEYBOARD-MACRO-DEFINITION NAME MACRO-ARRAY) 95. STREAM))) 
     361 
     362(DEFUN GET-KEYBOARD-MACRO-DEFINITION (NAME MACRO-ARRAY) 
     363  (OR MACRO-ARRAY (SETQ MACRO-ARRAY (GET NAME 'MACRO-STREAM-MACRO))) 
     364  (SETQ NAME (INTERN NAME "ZWEI")) 
     365  (DO ((I 0 (1+ I)) 
     366       (LEN (1+ (MACRO-LENGTH MACRO-ARRAY))) 
     367       (THING) 
     368       (STATE NIL) 
     369       (LIST NIL) 
     370       (STRING (MAKE-ARRAY NIL 'ART-STRING 10. NIL 1))) 
     371      (( 
     372 I LEN) 
     373       `(DEFINE-KEYBOARD-MACRO ,NAME () . ,(NREVERSE LIST))) 
     374    (SETQ THING (AREF MACRO-ARRAY I)) 
     375    (COND ((OR (SYMBOLP THING) (LDB-TEST %%KBD-CONTROL-META THING)) 
     376           (COND (STATE 
     377                  (PUSH (STRING-APPEND STRING) LIST) 
     378                  (SETQ STATE NIL))) 
     379           (COND ((NUMBERP THING)) 
     380                 ((NULL THING) 
     381                  (SETQ THING '*INPUT*))) 
     382           (PUSH THING LIST)) 
     383          (T 
     384           (COND ((NOT STATE) 
     385                  (STORE-ARRAY-LEADER 0 STRING 0) 
     386                  (SETQ STATE T))) 
     387           (ARRAY-PUSH-EXTEND STRING THING))))) 
     388 
     389(DEFUN (CHARACTER SI:PRINC-FUNCTION) (-N STREAM) 
     390  (FORMAT STREAM "~@C" (- -N))) 

  • trunk/lisp/nzwei/lparse.lisp

    r257 r258  
    191191      (( 
    192192 INDEX END-INDEX) NIL) 
    193     (SETQ CH (LDB %%CH-CHAR (AR-1 LINE INDEX))) 
     193    (SETQ CH (LDB %%CH-CHAR (AREF LINE INDEX))) 
    194194    (SETQ SYNTAX (LIST-SYNTAX CH)) 
    195195    (COND ((= SYNTAX LIST-SLASH) (SETQ INDEX (1+ INDEX))) 
    … …  
    214214        (DO ((I1 INDEX (1+ I1))) 
    215215            ((OR (= I1 END-INDEX) 
    216                  ( (LIST-SYNTAX (AR-1 LINE I1)) LIST-COMMENT)) 
     216                 ( (LIST-SYNTAX (AREF LINE I1)) LIST-COMMENT)) 
    217217             (SETQ I2 I1))) 
    218218        (RETURN INDEX (BP-INDEX (FORWARD-OVER *BLANKS* (CREATE-BP LINE I2)))))) 

  • trunk/lisp/nzwei/macros.lisp

    r257 r258  
    438438 
    439439(SETQ *DEFAULT-INDENT-ALIST* '((LET 1 1) (LET* 1 1) (LET-GLOBALLY 1 1) (LAMBDA 1 1) 
     440                               (*CATCH 1 1) 
    440441                               (DOLIST 1 1) (DO 2 1) 
    441442                               (PROG . INDENT-PROG) (PROG* . INDENT-PROG) 

  • trunk/lisp/nzwei/modes.lisp

    r257 r258  
    539539 
    540540(DEFCOM COM-PREFIX-CONTROL DOCUMENT-PREFIX-CHAR () 
    541    (KEY-EXECUTE (DPB -1 %%KBD-CONTROL (GET-ECHO-CHAR "Control-" NIL)) 
     541   (KEY-EXECUTE (DPB 1 %%KBD-CONTROL (GET-ECHO-CHAR "Control-" NIL)) 
    542542                *NUMERIC-ARG-P* 
    543543                *NUMERIC-ARG*)) 
    … …  
    545545(DEFCOM COM-PREFIX-META DOCUMENT-PREFIX-CHAR () 
    546546        () 
    547    (KEY-EXECUTE (DPB -1 %%KBD-META (GET-ECHO-CHAR "Meta-" NIL)) 
     547   (KEY-EXECUTE (DPB 1 %%KBD-META (GET-ECHO-CHAR "Meta-" NIL)) 
    548548                *NUMERIC-ARG-P* 
    549549                *NUMERIC-ARG*)) 
    … …  
    551551(DEFCOM COM-PREFIX-CONTROL-META DOCUMENT-PREFIX-CHAR () 
    552552        () 
    553    (KEY-EXECUTE (DPB -1 %%KBD-CONTROL-META (GET-ECHO-CHAR "Control-Meta-" NIL)) 
     553   (KEY-EXECUTE (DPB 1 %%KBD-CONTROL (DPB 1 %%KBD-META (GET-ECHO-CHAR "Control-Meta-" NIL))) 
    554554                *NUMERIC-ARG-P* 
    555555                *NUMERIC-ARG*)) 

  • trunk/lisp/nzwei/mouse.lisp

    r257 r258  
    1212 
    1313(DEFVAR *MOUSE-P*) 
     14(DEFVAR *MOUSE-BLINKER*) 
    1415(DEFVAR *MOUSE-CHAR-BLINKER*) 
     16(DEFVAR *MOUSE-BOX-BLINKER*) 
    1517(DEFVAR *GLOBAL-MOUSE-CHAR-BLINKER*) 
    1618(DEFVAR *GLOBAL-MOUSE-CHAR-BLINKER-HANDLER*) 
    … …  
    2628                                                ':FONT TV:(SCREEN-DEFAULT-FONT DEFAULT-SCREEN) 
    2729                                                ':CHAR #/?) 
     30        *MOUSE-BOX-BLINKER* (TV:DEFINE-BLINKER TV:MOUSE-SHEET 'TV:HOLLOW-RECTANGULAR-BLINKER 
     31                                               ':VISIBILITY NIL) 
     32        *MOUSE-BLINKER* *MOUSE-CHAR-BLINKER* 
    2833        *GLOBAL-MOUSE-CHAR-BLINKER* (TV:DEFINE-BLINKER TV:MOUSE-SHEET 'TV:RECTANGULAR-BLINKER 
    2934                                                       ':VISIBILITY NIL 

  • trunk/lisp/nzwei/pl1mod.lisp

    r257 r258  
    1313;;; to the PL/1 mode commands), or a string. 
    1414 
    15 (DEFVAR PL1-PACKAGE (PKG-FIND-PACKAGE "ZWEI")) 
    16 (DEFVAR PL1-DELIMS '(#/- #/+ #/. #/* #/; #/: #/, #/& #/^ #/< #/> #/= #/| #/( #/))) 
    17 (DEFVAR PL1-INTERESTING-KEYWORDS '(PROC PROCEDURE BEGIN END DO IF ELSE ON DCL DECLARE)) 
     15(DEFVAR *PL1-PACKAGE* (PKG-FIND-PACKAGE "ZWEI")) 
     16(DEFVAR *PL1-DELIMS* '(#/- #/+ #/. #/* #/; #/: #/, #/& #/^ #/< #/> #/= #/| #/( #/))) 
     17(DEFVAR *PL1-INTERESTING-KEYWORDS* '(PROC PROCEDURE BEGIN END DO IF ELSE ON DCL DECLARE)) 
    1818 
    1919;; Leaves BP after all blanks, counting comments as blanks. 
    2020;; Returns BP. 
    2121(DEFUN PL1-SKIP-BLANKS (BP) 
    22     (DO ((LAST-BP (INTERVAL-LAST-BP *INTERVAL*))) 
    23         (NIL) 
    24       (AND (BP-= BP LAST-BP) (RETURN NIL)) 
    25       (MOVE-BP BP (FORWARD-OVER *WHITESPACE-CHARS* BP)) 
    26       (OR (LOOKING-AT BP "//*") (RETURN NIL)) 
    27       (PL1-SKIP-COMMENT BP)) 
    28     BP) 
     22  (DO ((LAST-BP (INTERVAL-LAST-BP *INTERVAL*))) 
     23      (NIL) 
     24    (AND (BP-= BP LAST-BP) (RETURN NIL)) 
     25    (MOVE-BP BP (FORWARD-OVER *WHITESPACE-CHARS* BP)) 
     26    (OR (LOOKING-AT BP "//*") (RETURN NIL)) 
     27    (PL1-SKIP-COMMENT BP)) 
     28  BP) 
    2929 
    3030;; BP should be right before the beginning of a comment. 
    3131;; Leaves BP after the comment, returns BP. 
    3232(DEFUN PL1-SKIP-COMMENT (BP) 
    33     (MOVE-BP BP (FORWARD-CHAR BP 2)) 
    34     (LET ((X (SEARCH BP "*//"))) 
    35       (COND ((NULL X) (BARF "Unbalenced comment.")) 
    36             (T (MOVE-BP BP X))))) 
     33  (MOVE-BP BP (FORWARD-CHAR BP 2)) 
     34  (LET ((X (SEARCH BP "*//"))) 
     35    (COND ((NULL X) (BARF "Unbalenced comment.")) 
     36          (T (MOVE-BP BP X))))) 
    3737 
    3838;; Starts at BP and scans forward.  Returns NIL at EOB, else 
    3939;; the token.  Moves BP. 
    4040(DEFUN PL1-GET-TOKEN-FORWARD (BP) 
    41     (PL1-SKIP-BLANKS BP) 
    42     (COND ((BP-= BP (INTERVAL-LAST-BP *INTERVAL*)) NIL) 
    43           (T (LET ((CH (BP-CHAR BP))) 
    44                (COND ((MEM #'CHAR-EQUAL CH PL1-DELIMS) 
    45                       (MOVE-BP BP (FORWARD-CHAR BP)) 
    46                       CH) 
    47                      ((CHAR-EQUAL CH #/$) 
    48                       (MOVE-BP BP (FORWARD-CHAR BP)) 
    49                       "$") 
    50                      ((CHAR-EQUAL CH #//) 
    51                       (MOVE-BP BP (FORWARD-CHAR BP)) 
    52                       CH) 
    53                      ((CHAR-EQUAL CH #/") 
    54                       (PL1-GET-STRING-FORWARD BP)) 
    55                      (T (LET ((M (FORWARD-WORD BP))) 
    56                            (LET ((N (FORWARD-WORD M -1))) 
    57                              (PROG1 (STRING-INTERVAL N M T) 
    58                                     (MOVE-BP BP M)))))))))) 
     41  (PL1-SKIP-BLANKS BP) 
     42  (COND ((BP-= BP (INTERVAL-LAST-BP *INTERVAL*)) NIL) 
     43        (T (LET ((CH (BP-CHAR BP))) 
     44             (COND ((MEM #'CHAR-EQUAL CH *PL1-DELIMS*) 
     45                    (MOVE-BP BP (FORWARD-CHAR BP)) 
     46                    CH) 
     47                   ((CHAR-EQUAL CH #/$) 
     48                    (MOVE-BP BP (FORWARD-CHAR BP)) 
     49                    "$") 
     50                   ((CHAR-EQUAL CH #//) 
     51                    (MOVE-BP BP (FORWARD-CHAR BP)) 
     52                    CH) 
     53                   ((CHAR-EQUAL CH #/") 
     54                    (PL1-GET-STRING-FORWARD BP)) 
     55                   (T (LET ((M (FORWARD-WORD BP))) 
     56                        (LET ((N (FORWARD-WORD M -1))) 
     57                          (PROG1 (STRING-INTERVAL N M T) 
     58                                 (MOVE-BP BP M)))))))))) 
    5959 
    6060;; Subfunction of GET-TOKEN-FORWARD 
    6161(DEFUN PL1-GET-STRING-FORWARD (BP) 
    62    (PROG (SAVE-BP) 
    63       RETRY 
    64          (SETQ SAVE-BP (COPY-BP BP)) 
    65          (MOVE-BP BP (FORWARD-CHAR BP)) 
    66          (LET ((X (SEARCH BP "/""))) 
    67            (COND ((NULL X) (BARF "Unbalenced string")) 
    68                  (T (MOVE-BP BP X)))) 
    69          (AND (CHAR-EQUAL (BP-CHAR BP) #/") 
    70               (GO RETRY)) 
    71          (RETURN (STRING-INTERVAL SAVE-BP BP T)) 
    72          )) 
     62  (PROG (SAVE-BP) 
     63     RETRY 
     64        (SETQ SAVE-BP (COPY-BP BP)) 
     65        (MOVE-BP BP (FORWARD-CHAR BP)) 
     66        (LET ((X (SEARCH BP "/""))) 
     67          (COND ((NULL X) (BARF "Unbalenced string")) 
     68                (T (MOVE-BP BP X)))) 
     69        (AND (CHAR-EQUAL (BP-CHAR BP) #/") 
     70             (GO RETRY)) 
     71        (RETURN (STRING-INTERVAL SAVE-BP BP T)) 
     72        )) 
    7373 
    7474;; Leaves BP before all blanks, counting comments as blanks. 
    7575;; Returns BP. 
    7676(DEFUN PL1-SKIP-BLANKS-BACKWARD (BP) 
    77     (DO ((FIRST-BP (INTERVAL-FIRST-BP *INTERVAL*))) 
    78         (NIL) 
    79       (AND (BP-= BP FIRST-BP) (RETURN NIL)) 
    80       (MOVE-BP BP (BACKWARD-OVER *WHITESPACE-CHARS* BP)) 
    81       (OR (LOOKING-AT-BACKWARD BP "*//") (RETURN NIL)) 
    82       (PL1-SKIP-COMMENT-BACKWARD BP)) 
    83     BP) 
     77  (DO ((FIRST-BP (INTERVAL-FIRST-BP *INTERVAL*))) 
     78      (NIL) 
     79    (AND (BP-= BP FIRST-BP) (RETURN NIL)) 
     80    (MOVE-BP BP (BACKWARD-OVER *WHITESPACE-CHARS* BP)) 
     81    (OR (LOOKING-AT-BACKWARD BP "*//") (RETURN NIL)) 
     82    (PL1-SKIP-COMMENT-BACKWARD BP)) 
     83  BP) 
    8484 
    8585;; BP should be right after the end of a comment. 
    8686;; Leaves BP before the comment, returns BP. 
    8787(DEFUN PL1-SKIP-COMMENT-BACKWARD (BP) 
    88     (MOVE-BP BP (FORWARD-CHAR BP -2)) 
    89     (LET ((X (SEARCH BP "//*" T))) 
    90       (COND ((NULL X) (BARF "Unbalenced comment.")) 
    91             (T (MOVE-BP BP X))))) 
     88  (MOVE-BP BP (FORWARD-CHAR BP -2)) 
     89  (LET ((X (SEARCH BP "//*" T))) 
     90    (COND ((NULL X) (BARF "Unbalenced comment.")) 
     91          (T (MOVE-BP BP X))))) 
    9292 
    9393;; Starts at BP and scans backward.  Returns NIL at BOB, else 
    9494;; the token.  Moves BP. 
    9595(DEFUN PL1-GET-TOKEN-BACKWARD (BP) 
    96     (PL1-SKIP-BLANKS-BACKWARD BP) 
    97     (COND ((BP-= BP (INTERVAL-FIRST-BP *INTERVAL*)) NIL) 
    98           (T (LET ((CH (BP-CHAR-BEFORE BP))) 
    99                (COND ((MEM #'CHAR-EQUAL CH PL1-DELIMS) 
    100                       (MOVE-BP BP (FORWARD-CHAR BP -1)) 
    101                       CH) 
    102                      ((CHAR-EQUAL CH #/$) 
    103                       (MOVE-BP BP (FORWARD-CHAR BP -1)) 
    104                       "$") 
    105                      ((CHAR-EQUAL CH #//) 
    106                       (MOVE-BP BP (FORWARD-CHAR BP -1)) 
    107                       CH) 
    108                      ((CHAR-EQUAL CH #/") 
    109                       (PL1-GET-STRING-BACKWARD BP)) 
    110                      (T (LET ((M (FORWARD-WORD BP -1))) 
    111                           (LET ((N (FORWARD-WORD M))) 
    112                             (PROG1 (STRING-INTERVAL M N T) 
    113                                    (MOVE-BP BP M)))))))))) 
     96  (PL1-SKIP-BLANKS-BACKWARD BP) 
     97  (COND ((BP-= BP (INTERVAL-FIRST-BP *INTERVAL*)) NIL) 
     98        (T (LET ((CH (BP-CHAR-BEFORE BP))) 
     99             (COND ((MEM #'CHAR-EQUAL CH *PL1-DELIMS*) 
     100                    (MOVE-BP BP (FORWARD-CHAR BP -1)) 
     101                    CH) 
     102                   ((CHAR-EQUAL CH #/$) 
     103                    (MOVE-BP BP (FORWARD-CHAR BP -1)) 
     104                    "$") 
     105                   ((CHAR-EQUAL CH #//) 
     106                    (MOVE-BP BP (FORWARD-CHAR BP -1)) 
     107                    CH) 
     108                   ((CHAR-EQUAL CH #/") 
     109                    (PL1-GET-STRING-BACKWARD BP)) 
     110                   (T (LET ((M (FORWARD-WORD BP -1))) 
     111                        (LET ((N (FORWARD-WORD M))) 
     112                          (PROG1 (STRING-INTERVAL M N T) 
     113                                 (MOVE-BP BP M)))))))))) 
    114114 
    115115;; Subfunction of GET-TOKEN-BACKWARD 
    116116(DEFUN PL1-GET-STRING-BACKWARD (BP) 
    117    (PROG (SAVE-BP) 
    118       RETRY 
    119          (SETQ SAVE-BP (COPY-BP BP)) 
    120          (MOVE-BP BP (FORWARD-CHAR BP -1)) 
    121          (LET ((X (SEARCH BP "/"" T))) 
    122            (COND ((NULL X) (BARF "Unbalenced string")) 
    123                  (T (MOVE-BP BP X)))) 
    124          (AND (= (BP-CHAR-BEFORE BP) #/") 
    125               (GO RETRY)) 
    126          (RETURN (STRING-INTERVAL BP SAVE-BP T)) 
    127          )) 
     117  (PROG (SAVE-BP) 
     118     RETRY 
     119        (SETQ SAVE-BP (COPY-BP BP)) 
     120        (MOVE-BP BP (FORWARD-CHAR BP -1)) 
     121        (LET ((X (SEARCH BP "/"" T))) 
     122          (COND ((NULL X) (BARF "Unbalenced string")) 
     123                (T (MOVE-BP BP X)))) 
     124        (AND (= (BP-CHAR-BEFORE BP) #/") 
     125             (GO RETRY)) 
     126        (RETURN (STRING-INTERVAL BP SAVE-BP T)) 
     127        )) 
    128128 
    129129;; Returns a cons.  Car is the last token, cdr is a list of tokens from 
    130130;; the beginning of the statement up to where BP started.  Moves BP. 
    131131(DEFUN PL1-GET-STATEMENT-BACKWARD (BP) 
    132    (LET ((LT (PL1-GET-TOKEN-BACKWARD BP))) 
    133      (AND LT 
    134           (DO ((TOK) 
    135                (A-BUILDING (NCONS LT) (CONS TOK A-BUILDING))) 
    136               (NIL) 
    137             (SETQ TOK (PL1-GET-TOKEN-BACKWARD BP)) 
    138             (SELECTQ TOK 
    139                (NIL (RETURN (CONS LT A-BUILDING))) 
    140                (#/; (MOVE-BP BP (FORWARD-CHAR BP 1)) 
    141                    (RETURN (CONS LT A-BUILDING)))))))) 
     132  (LET ((LT (PL1-GET-TOKEN-BACKWARD BP))) 
     133    (AND LT 
     134         (DO ((TOK) 
     135              (A-BUILDING (NCONS LT) (CONS TOK A-BUILDING))) 
     136             (NIL) 
     137           (SETQ TOK (PL1-GET-TOKEN-BACKWARD BP)) 
     138           (SELECTQ TOK 
     139             (NIL (RETURN (CONS LT A-BUILDING))) 
     140             (#/; (MOVE-BP BP (FORWARD-CHAR BP 1)) 
     141              (RETURN (CONS LT A-BUILDING)))))))) 
    142142 
    143143;; Returns four values. 
    … …  
    147147;; Fourth is T if the statement is incomplete. 
    148148(DEFUN PL1-FIND-START-PREV-STA (BP) 
    149     (PROG (PREV-STA INCOMPLETE-FLAG) 
    150           CHOMP-BACKWARD-SOME-MORE 
    151           (OR (SETQ PREV-STA (PL1-GET-STATEMENT-BACKWARD BP)) 
    152               (RETURN NIL)) 
    153           (AND (EQ (CAR PREV-STA) #/:) 
    154                (GO CHOMP-BACKWARD-SOME-MORE)) 
    155           (SETQ INCOMPLETE-FLAG (NOT (EQ (CAR PREV-STA) #/;))) 
    156           (SETQ PREV-STA (PL1-SKIP-OVER-LABELS (CDR PREV-STA) BP)) 
    157           (PL1-SKIP-BLANKS BP) 
    158           (RETURN BP (BP-INDEX BP) PREV-STA INCOMPLETE-FLAG))) 
     149  (PROG (PREV-STA INCOMPLETE-FLAG) 
     150     CHOMP-BACKWARD-SOME-MORE 
     151        (OR (SETQ PREV-STA (PL1-GET-STATEMENT-BACKWARD BP)) 
     152            (RETURN NIL)) 
     153        (AND (EQ (CAR PREV-STA) #/:) 
     154             (GO CHOMP-BACKWARD-SOME-MORE)) 
     155        (SETQ INCOMPLETE-FLAG (NOT (EQ (CAR PREV-STA) #/;))) 
     156        (SETQ PREV-STA (PL1-SKIP-OVER-LABELS (CDR PREV-STA) BP)) 
     157        (PL1-SKIP-BLANKS BP) 
     158        (RETURN BP (BP-INDEX BP) PREV-STA INCOMPLETE-FLAG))) 
    159159 
    160160;; Takes a statement, and returns a tail of that statement with the 
    … …  
    162162;; If BP is given, it will be moved as we parse. 
    163163(DEFUN PL1-SKIP-OVER-LABELS (STA &OPTIONAL BP) 
    164     (PROG (CLOSE-PTR) 
    165           RESCAN 
    166           ;; Skip over regular labels. 
    167           (COND ((EQ (SECOND STA) #/:) 
    168                 (COND (BP 
    169                         (PL1-PARSE-CHK BP (FIRST STA)) 
    170                         (PL1-PARSE-CHK BP #/:))) 
    171                 (SETQ STA (REST2 STA)) 
    172                 (GO RESCAN))) 
    173  
    174           ;; Look for label arrays: "   FOO(56):  " 
    175           (COND ((AND (STRINGP (FIRST STA)) 
    176                       (EQ (SECOND STA) #/() 
    177                       (PL1-STRING-FIXNUM-P (THIRD STA)) 
    178                       (EQ (FOURTH STA) #/)) 
    179                       (EQ (FIFTH STA) #/:)) 
    180                  (COND (BP 
    181                         (PL1-PARSE-CHK BP (FIRST STA)) 
    182                         (PL1-PARSE-CHK BP #/() 
    183                         (PL1-PARSE-CHK BP (THIRD STA)) 
    184                         (PL1-PARSE-CHK BP #/)) 
    185                         (PL1-PARSE-CHK BP #/:))) 
    186                  (SETQ STA (NTHCDR 5 STA)) 
    187                  (GO RESCAN))) 
    188  
    189           ;; Skip over condition prefixes. 
    190           (COND ((AND (EQ (FIRST STA) #/() 
    191                       (SETQ CLOSE-PTR (MEMQ #/) (REST1 STA))) 
    192                       (EQ (SECOND CLOSE-PTR) #/:)) 
    193                  (DO X STA (CDR X) (EQ X (CDDR CLOSE-PTR)) 
    194                   (AND BP (PL1-PARSE-CHK BP (CAR STA))) 
    195                   (SETQ STA (CDR STA))) 
    196                  (GO RESCAN))) 
    197  
    198           (RETURN STA))) 
     164  (PROG (CLOSE-PTR) 
     165     RESCAN 
     166        ;; Skip over regular labels. 
     167        (COND ((EQ (SECOND STA) #/:) 
     168              (COND (BP 
     169                      (PL1-PARSE-CHK BP (FIRST STA)) 
     170                      (PL1-PARSE-CHK BP #/:))) 
     171              (SETQ STA (REST2 STA)) 
     172              (GO RESCAN))) 
     173            
     174           ;; Look for label arrays: "   FOO(56):  " 
     175           (COND ((AND (STRINGP (FIRST STA)) 
     176                       (EQ (SECOND STA) #/() 
     177                       (PL1-STRING-FIXNUM-P (THIRD STA)) 
     178                       (EQ (FOURTH STA) #/)) 
     179                       (EQ (FIFTH STA) #/:)) 
     180                  (COND (BP 
     181                         (PL1-PARSE-CHK BP (FIRST STA)) 
     182                         (PL1-PARSE-CHK BP #/() 
     183                         (PL1-PARSE-CHK BP (THIRD STA)) 
     184                         (PL1-PARSE-CHK BP #/)) 
     185                         (PL1-PARSE-CHK BP #/:))) 
     186                  (SETQ STA (NTHCDR 5 STA)) 
     187                  (GO RESCAN))) 
     188               
     189              ;; Skip over condition prefixes. 
     190              (COND ((AND (EQ (FIRST STA) #/() 
     191                          (SETQ CLOSE-PTR (MEMQ #/) (REST1 STA))) 
     192                          (EQ (SECOND CLOSE-PTR) #/:)) 
     193                     (DO X STA (CDR X) (EQ X (CDDR CLOSE-PTR)) 
     194                        (AND BP (PL1-PARSE-CHK BP (CAR STA))) 
     195                        (SETQ STA (CDR STA))) 
     196                     (GO RESCAN))) 
     197                  
     198                (RETURN STA))) 
    199199 
    200200;; T => This string represents a number in PL1 syntax. 
    201201(DEFUN PL1-STRING-FIXNUM-P (X) 
    202    (AND (STRINGP X) 
    203         (PLUSP (STRING-LENGTH X)) 
    204         (LET ((CH (AR-1 X 0))) 
    205           (AND (< CH 71) (> CH 57))))) 
     202  (AND (STRINGP X) 
     203       (PLUSP (STRING-LENGTH X)) 
     204       (LET ((CH (AREF X 0))) 
     205         (AND ( 
     206 CH #/0) ( 
     207 CH #/9))))) 
    206208 
    207209;; Returns two values: a type (a keyword symbol), and ??? 
    208210;; If BP is given, it will be moved as we parse. 
    209211(DEFUN PL1-TYPIFY-STATEMENT (STA &OPTIONAL BP &AUX (KEY (CAR STA))) 
    210    (PROG () 
    211     (COND ((EQ KEY #/;) 
    212            (RETURN 'NULL NIL)) 
    213           ((NOT (STRINGP KEY)) 
    214            (RETURN 'RANDOM NIL))) 
    215     (SETQ KEY (INTERN (STRING-UPCASE (STRING-TRIM '(#\SP #\TAB) KEY)) 
    216                       PL1-PACKAGE)) 
    217     (COND ((NOT (MEMQ KEY PL1-INTERESTING-KEYWORDS)) 
    218            (RETURN 'RANDOM STA)) 
    219           ((EQ (SECOND STA) #/;) 
    220            (AND BP (PL1-PARSE-CHK BP (FIRST STA))) 
    221            (RETURN KEY (CDR STA))) 
    222           ((EQ KEY 'IF) 
    223            (PL1-TYPIFY-IF-HACKER STA BP)) 
    224           ((AND (FIXP (SECOND STA)) 
    225                 (NOT (EQ (SECOND STA) #/())) 
    226            (RETURN 'RANDOM STA)) 
    227           ((EQ KEY 'BEGIN) 
    228            (COND ((STRINGP (SECOND STA)) 
    229                   (RETURN KEY STA)) 
    230                  (T (RETURN 'RANDOM STA)))) 
    231           ((EQ KEY 'ON) 
    232            (PL1-TYPIFY-ON-HACKER STA BP)) 
    233           ((EQ KEY 'DO) 
    234            (PL1-TYPIFY-DO-HACKER STA BP)) 
    235           ((EQ KEY 'ELSE) 
    236            (AND BP (PL1-PARSE-CHK BP "ELSE")) 
    237            (RETURN 'ELSE (CDR STA))) 
    238           ((PL1-TYPIFY-0LEV-PARENCHECK STA BP) 
    239            (RETURN 'RANDOM STA)) 
    240           (T (RETURN KEY (CDR STA)))))) 
     212  (PROG () 
     213        (COND ((EQ KEY #/;) 
     214               (RETURN 'NULL NIL)) 
     215              ((NOT (STRINGP KEY)) 
     216               (RETURN 'RANDOM NIL))) 
     217        (SETQ KEY (INTERN (STRING-UPCASE (STRING-TRIM '(#\SP #\TAB) KEY)) 
     218                          *PL1-PACKAGE*)) 
     219        (COND ((NOT (MEMQ KEY *PL1-INTERESTING-KEYWORDS*)) 
     220               (RETURN 'RANDOM STA)) 
     221              ((EQ (SECOND STA) #/;) 
     222               (AND BP (PL1-PARSE-CHK BP (FIRST STA))) 
     223               (RETURN KEY (CDR STA))) 
     224              ((EQ KEY 'IF) 
     225               (PL1-TYPIFY-IF-HACKER STA BP)) 
     226              ((AND (FIXP (SECOND STA)) 
     227                    (NOT (EQ (SECOND STA) #/())) 
     228               (RETURN 'RANDOM STA)) 
     229              ((EQ KEY 'BEGIN) 
     230               (COND ((STRINGP (SECOND STA)) 
     231                      (RETURN KEY STA)) 
     232                     (T (RETURN 'RANDOM STA)))) 
     233              ((EQ KEY 'ON) 
     234               (PL1-TYPIFY-ON-HACKER STA BP)) 
     235              ((EQ KEY 'DO) 
     236               (PL1-TYPIFY-DO-HACKER STA BP)) 
     237              ((EQ KEY 'ELSE) 
     238               (AND BP (PL1-PARSE-CHK BP "ELSE")) 
     239               (RETURN 'ELSE (CDR STA))) 
     240              ((PL1-TYPIFY-0LEV-PARENCHECK STA BP) 
     241               (RETURN 'RANDOM STA)) 
     242              (T (RETURN KEY (CDR STA)))))) 
    241243 
    242244;; T => This is an assignment statment. 
    243245(DEFUN PL1-TYPIFY-0LEV-PARENCHECK (STA IGNORE) 
    244     (DO ((PARNCT 0) 
    245         (X STA (CDR X))) 
    246         ((OR (NULL X) 
    247              (EQ (CAR X) #/;)) 
    248         NIL) 
    249       (COND ((EQ (CAR X) #/() 
    250              (SETQ PARNCT (1+ PARNCT))) 
    251             ((EQ (CAR X) #/)) 
    252              (SETQ PARNCT (1- PARNCT))) 
    253             ((NOT (ZEROP PARNCT))) 
    254             ((EQ (CAR X) #/=) 
    255              (RETURN T))))) 
     246  (DO ((PARNCT 0) 
     247      (X STA (CDR X))) 
     248      ((OR (NULL X) 
     249           (EQ (CAR X) #/;)) 
     250      NIL) 
     251    (COND ((EQ (CAR X) #/() 
     252           (SETQ PARNCT (1+ PARNCT))) 
     253          ((EQ (CAR X) #/)) 
     254           (SETQ PARNCT (1- PARNCT))) 
     255          ((NOT (ZEROP PARNCT))) 
     256          ((EQ (CAR X) #/=) 
     257           (RETURN T))))) 
    256258 
    257259(DEFUN PL1-TYPIFY-DO-HACKER (STA IGNORE) 
    258     (COND ((OR (STRINGP (SECOND STA)) 
    259                (EQ (SECOND STA) #/;)) 
    260            (MVRETURN 'DO STA)) 
    261           (T (MVRETURN 'RANDOM STA)))) 
     260  (COND ((OR (STRINGP (SECOND STA)) 
     261             (EQ (SECOND STA) #/;)) 
     262         (MVRETURN 'DO STA)) 
     263        (T (MVRETURN 'RANDOM STA)))) 
    262264 
    263265(DEFUN PL1-TYPIFY-IF-HACKER (STA BP) 
    264266  (PROG (VAL1) 
    265     (COND ((AND (FIXP (SECOND STA)) 
    266                 (NOT (MEMQ (SECOND STA) '(#/- #/+ #/^ #/()))) 
    267            (SETQ VAL1 'RANDOM)) 
    268           ((AND (EQ (SECOND STA) #/-) 
    269                 (EQ (THIRD STA) #/>)) 
    270            (SETQ VAL1 'RANDOM)) 
    271           (T (DO ((PARNCT 0) 
    272                   (PREV #/=) 
    273                   (TSTA STA (CDR TSTA))) 
    274                  ((OR (NULL TSTA) 
    275                       (EQ (FIRST TSTA) #/;)) 
    276                   (SETQ VAL1 'RANDOM)) 
    277                (COND ((EQ (FIRST TSTA) #/() 
    278                       (SETQ PARNCT (1+ PARNCT))) 
    279                     ((EQ (FIRST TSTA) #/)) 
    280                       (SETQ PARNCT (1- PARNCT))) 
    281                     ((NOT (ZEROP PARNCT))) 
    282                     ((NOT (STRINGP (FIRST TSTA)))) 
    283                     ((NOT (STRING-EQUAL (FIRST TSTA) "THEN"))) 
    284                     ((OR (STRINGP PREV) 
    285                           (EQ PREV #/)) 
    286                           (EQ PREV #/.)) 
    287                       ;; It is really an IF statement! 
    288                       (RETURN  
    289                        (DO ((X STA (CDR X))) 
    290                            ((EQ X (CDR TSTA)) 
    291                             (SETQ VAL1 'IF STA X)) 
    292                          (AND BP (PL1-PARSE-CHK BP (CAR X))))))) 
    293                (SETQ PREV (CAR TSTA))))) 
    294     (RETURN VAL1 STA))) 
     267        (COND ((AND (FIXP (SECOND STA)) 
     268                    (NOT (MEMQ (SECOND STA) '(#/- #/+ #/^ #/()))) 
     269               (SETQ VAL1 'RANDOM)) 
     270              ((AND (EQ (SECOND STA) #/-) 
     271                    (EQ (THIRD STA) #/>)) 
     272               (SETQ VAL1 'RANDOM)) 
     273              (T (DO ((PARNCT 0) 
     274                      (PREV #/=) 
     275                      (TSTA STA (CDR TSTA))) 
     276                     ((OR (NULL TSTA) 
     277                          (EQ (FIRST TSTA) #/;)) 
     278                      (SETQ VAL1 'RANDOM)) 
     279                   (COND ((EQ (FIRST TSTA) #/() 
     280                          (SETQ PARNCT (1+ PARNCT))) 
     281                        ((EQ (FIRST TSTA) #/)) 
     282                          (SETQ PARNCT (1- PARNCT))) 
     283                        ((NOT (ZEROP PARNCT))) 
     284                        ((NOT (STRINGP (FIRST TSTA)))) 
     285                        ((NOT (STRING-EQUAL (FIRST TSTA) "THEN"))) 
     286                        ((OR (STRINGP PREV) 
     287                              (EQ PREV #/)) 
     288                              (EQ PREV #/.)) 
     289                          ;; It is really an IF statement! 
     290                          (RETURN  
     291                            (DO ((X STA (CDR X))) 
     292                                ((EQ X (CDR TSTA)) 
     293                                (SETQ VAL1 'IF STA X)) 
     294                              (AND BP (PL1-PARSE-CHK BP (CAR X))))))) 
     295                   (SETQ PREV (CAR TSTA))))) 
     296        (RETURN VAL1 STA))) 
    295297 
    296298(DEFUN PL1-TYPIFY-ON-HACKER (STA BP) 
    297     (COND ((NOT (STRINGP (SECOND STA))) 
    298            (MVRETURN 'RANDOM STA)) 
    299           (T (AND BP (PL1-PARSE-CHK BP "ON")) 
    300              (AND BP (PL1-PARSE-CHK BP (SECOND STA))) 
    301              (SETQ STA (CDDR STA)) 
    302              (DO () (NIL) 
    303                (COND ((AND (STRINGP (SECOND STA)) 
    304                            (EQ (CAR STA) #/,)) 
    305                       (COND (BP 
    306                              (PL1-PARSE-CHK BP (FIRST STA)) 
    307                              (PL1-PARSE-CHK BP (SECOND STA)))) 
    308                       (SETQ STA (CDDR STA))) 
    309                      (T (RETURN NIL)))) 
    310              (COND ((AND (EQ (SECOND STA) #/;) 
    311                         (STRINGP (FIRST STA)) 
    312                         (STRING-EQUAL (FIRST STA) "SYSTEM")) 
    313                     (AND BP (PL1-PARSE-CHK BP "SYSTEM")) 
    314                     (SETQ STA (CDR STA)))) 
    315              (COND ((AND (STRINGP (FIRST STA)) 
    316                         (STRING-EQUAL (FIRST STA) "SNAP") 
    317                         (PL1-TYPIFY-RIDICULOUS-SNAP-SCREW STA BP)) 
    318                     (AND BP (PL1-PARSE-CHK BP "SNAP")) 
    319                     (SETQ STA (CDR STA)))) 
    320              (MVRETURN 'ON STA)))) 
     299  (COND ((NOT (STRINGP (SECOND STA))) 
     300         (MVRETURN 'RANDOM STA)) 
     301        (T (AND BP (PL1-PARSE-CHK BP "ON")) 
     302           (AND BP (PL1-PARSE-CHK BP (SECOND STA))) 
     303           (SETQ STA (CDDR STA)) 
     304           (DO () (NIL) 
     305             (COND ((AND (STRINGP (SECOND STA)) 
     306                         (EQ (CAR STA) #/,)) 
     307                    (COND (BP 
     308                           (PL1-PARSE-CHK BP (FIRST STA)) 
     309                           (PL1-PARSE-CHK BP (SECOND STA)))) 
     310                    (SETQ STA (CDDR STA))) 
     311                   (T (RETURN NIL)))) 
     312           (COND ((AND (EQ (SECOND STA) #/;) 
     313                      (STRINGP (FIRST STA)) 
     314                      (STRING-EQUAL (FIRST STA) "SYSTEM")) 
     315                  (AND BP (PL1-PARSE-CHK BP "SYSTEM")) 
     316                  (SETQ STA (CDR STA)))) 
     317           (COND ((AND (STRINGP (FIRST STA)) 
     318                      (STRING-EQUAL (FIRST STA) "SNAP") 
     319                      (PL1-TYPIFY-RIDICULOUS-SNAP-SCREW STA BP)) 
     320                  (AND BP (PL1-PARSE-CHK BP "SNAP")) 
     321                  (SETQ STA (CDR STA)))) 
     322           (MVRETURN 'ON STA)))) 
    321323 
    322324(DEFUN PL1-TYPIFY-RIDICULOUS-SNAP-SCREW (STA IGNORE) 
    323    (COND ((EQ (SECOND STA) #/;) T) 
    324          ((NULL (CDR STA)) T) 
    325          ((STRINGP (CADR STA)) T) 
    326          ((NOT (EQ (SECOND STA) #/()) NIL) 
    327          ;; Now we worry about whether we have 
    328          ;;     SNAP (13) = 5; or SNAP (FIXEDOVERFLOW): or SNAP (13): 
    329          ((NOT (EQ (PL1-SKIP-OVER-LABELS STA NIL) STA)) NIL)  ; Label array. 
    330          ((EQ (PL1-SKIP-OVER-LABELS (CDR STA) NIL) (CDR STA)) NIL); Assignment stmt. 
    331          (T T))) 
     325  (COND ((EQ (SECOND STA) #/;) T) 
     326        ((NULL (CDR STA)) T) 
     327        ((STRINGP (CADR STA)) T) 
     328        ((NOT (EQ (SECOND STA) #/()) NIL) 
     329        ;; Now we worry about whether we have 
     330        ;;     SNAP (13) = 5; or SNAP (FIXEDOVERFLOW): or SNAP (13): 
     331        ((NOT (EQ (PL1-SKIP-OVER-LABELS STA NIL) STA)) NIL)     ; Label array. 
     332        ((EQ (PL1-SKIP-OVER-LABELS (CDR STA) NIL) (CDR STA)) NIL)       ; Assignment stmt. 
     333        (T T))) 
    332334 
    333335(DEFUN PL1-PARSE-CHK (BP LEXEME) 
    … …  
    344346;; T => This statement is a declaration. 
    345347(DEFUN PL1-DECLARE-P (STA) 
    346    (MEMQ (PL1-TYPIFY-STATEMENT STA) '(DCL DECLARE))) 
     348  (MEMQ (PL1-TYPIFY-STATEMENT STA) '(DCL DECLARE))) 
    347349 
    348350(DEFUN COMPUTE-PL1-INDENTATION (BP) 
    349     (PROG (PREVHPOS PREV-STA INCOMP-FLAG BP1 S S-TYPE) 
    350           (MULTIPLE-VALUE (BP1 PREVHPOS PREV-STA INCOMP-FLAG) 
    351                   (PL1-FIND-START-PREV-STA BP)) 
    352           (COND ((AND BP1 (PL1-DECLARE-P PREV-STA)) 
    353                  (DO () (NIL) 
    354                    (MULTIPLE-VALUE (BP1 PREVHPOS PREV-STA INCOMP-FLAG) 
    355                      (PL1-FIND-START-PREV-STA BP)) 
    356                    (OR (AND BP1 (PL1-DECLARE-P PREV-STA)) 
    357                        (RETURN NIL))))) 
    358           (OR BP1 (RETURN 10.)) 
    359           (AND INCOMP-FLAG (RETURN (+ 5 PREVHPOS))) 
     351  (PROG (PREVHPOS PREV-STA INCOMP-FLAG BP1 S S-TYPE) 
     352        (MULTIPLE-VALUE (BP1 PREVHPOS PREV-STA INCOMP-FLAG) 
     353          (PL1-FIND-START-PREV-STA BP)) 
     354        (COND ((AND BP1 (PL1-DECLARE-P PREV-STA)) 
     355               (DO () (NIL) 
     356                 (MULTIPLE-VALUE (BP1 PREVHPOS PREV-STA INCOMP-FLAG) 
     357                   (PL1-FIND-START-PREV-STA BP)) 
     358                 (OR (AND BP1 (PL1-DECLARE-P PREV-STA)) 
     359                     (RETURN NIL))))) 
     360        (OR BP1 (RETURN 10.)) 
     361        (AND INCOMP-FLAG (RETURN (+ 5 PREVHPOS))) 
     362        (MULTIPLE-VALUE (S-TYPE S) 
     363          (PL1-TYPIFY-STATEMENT PREV-STA NIL)) 
     364        (DO ((LEVELS 0)) 
     365            (NIL) 
     366          (COND ((MEMQ S-TYPE '(IF ELSE ON)) 
     367                 (SETQ LEVELS (1+ LEVELS))) 
     368                ((MEMQ S-TYPE '(DO BEGIN)) 
     369                 (SETQ PREVHPOS (+ PREVHPOS (* 5 (MAX LEVELS 1)))) 
     370                 (RETURN T)) 
     371                ((AND (EQ S-TYPE 'END) 
     372                      (= *PL1-INDING-STYLE* 2)) 
     373                 (SETQ PREVHPOS (- PREVHPOS 5)) 
     374                 (RETURN T)) 
     375                (T (RETURN NIL))) 
    360376          (MULTIPLE-VALUE (S-TYPE S) 
    361                   (PL1-TYPIFY-STATEMENT PREV-STA NIL)) 
    362           (DO ((LEVELS 0)) 
    363               (NIL) 
    364             (COND ((MEMQ S-TYPE '(IF ELSE ON)) 
    365                    (SETQ LEVELS (1+ LEVELS))) 
    366                   ((MEMQ S-TYPE '(DO BEGIN)) 
    367                    (SETQ PREVHPOS (+ PREVHPOS (* 5 (MAX LEVELS 1)))) 
    368                    (RETURN T)) 
    369                   ((AND (EQ S-TYPE 'END) 
    370                         (= PL1-INDING-STYLE 2)) 
    371                    (SETQ PREVHPOS (- PREVHPOS 5)) 
    372                    (RETURN T)) 
    373                   (T (RETURN NIL))) 
    374             (MULTIPLE-VALUE (S-TYPE S) 
    375                   (PL1-TYPIFY-STATEMENT (PL1-SKIP-OVER-LABELS S) NIL))) 
    376           (RETURN PREVHPOS))) 
     377            (PL1-TYPIFY-STATEMENT (PL1-SKIP-OVER-LABELS S) NIL))) 
     378        (RETURN PREVHPOS))) 
    377379 
    378380(DEFUN WHITESPACE-TO-HPOS (BP GOAL) 
    379     (LET ((HERE (BP-INDEX BP))) 
    380       (AND (> GOAL HERE) 
    381            (DO ((I 0 (1+ I)) 
    382                 (CHAR (IN-CURRENT-FONT #\SP)) 
    383                 (SPACES (- GOAL HERE))) 
    384                 ((>= I SPACES)) 
    385               (INSERT-MOVING BP CHAR))))) 
     381  (LET ((HERE (BP-INDEX BP))) 
     382    (AND (> GOAL HERE) 
     383         (DO ((I 0 (1+ I)) 
     384              (CHAR (IN-CURRENT-FONT #\SP)) 
     385              (SPACES (- GOAL HERE))) 
     386             (( 
     387 I SPACES)) 
     388           (INSERT-MOVING BP CHAR))))) 
    386389 
    387390(DEFCOM COM-INDENT-FOR-PL1 "Indent sufficiently for the PL/I statement 
    388391or statement fragment that I am about to type." () 
    389     (DELETE-AROUND *BLANKS* (POINT)) 
    390     (WHITESPACE-TO-HPOS (POINT) 
    391                         (COMPUTE-PL1-INDENTATION (COPY-BP (POINT)))) 
    392     DIS-TEXT) 
     392  (DELETE-AROUND *BLANKS* (POINT)) 
     393  (WHITESPACE-TO-HPOS (POINT) 
     394                      (COMPUTE-PL1-INDENTATION (COPY-BP (POINT)))) 
     395  DIS-TEXT) 
    393396 
    394397(DEFCOM COM-SET-PL1-STYLE "Set the PL/I mode indentation style. 
    3953981 = Standard indentation. 
    3963992 = /"end/" line up with statements within their group (they are indented)." () 
    397    (SETQ PL1-INDING-STYLE *NUMERIC-ARG*) 
    398    DIS-NONE) 
     400  (SETQ *PL1-INDING-STYLE* *NUMERIC-ARG*) 
     401  DIS-NONE) 
    399402 
    400403(DEFCOM COM-ROLL-BACK-PL1-INDENTATION "Undent 5 spaces." () 
    401    (LET ((INDEX (BP-INDEX (POINT)))) 
    402      (DELETE-AROUND *BLANKS* (POINT)) 
    403      (WHITESPACE-TO-HPOS (POINT) (- INDEX 5))) 
    404    DIS-TEXT) 
    405  
    406 (DEFVAR PL1DCL) 
     404  (LET ((INDEX (BP-INDEX (POINT)))) 
     405    (DELETE-AROUND *BLANKS* (POINT)) 
     406    (WHITESPACE-TO-HPOS (POINT) (- INDEX 5))) 
     407  DIS-TEXT) 
     408 
     409(DEFVAR *PL1DCL*) 
    407410 
    408411(DEFCOM COM-PL1DCL "Complete Multics PL/I declaration for system entrypoint." () 
    409    (LET ((BP (COPY-BP (POINT))) 
    410          (THE-ENTRY)) 
    411      (LET ((BP1 (FORWARD-WORD BP -1))) 
    412        (SETQ THE-ENTRY (STRING-INTERVAL BP1 (FORWARD-WORD BP1) T))) 
    413      (OR (BOUNDP 'PL1DCL) (READ-PL1DCL)) 
    414      (DO ((I 0 (1+ I)) 
    415           (LIM (ARRAY-ACTIVE-LENGTH PL1DCL))) 
    416          ((>= I LIM) 
    417           (BARF "No declaration found in file.")) 
    418        (LET ((L (AR-1 PL1DCL I))) 
    419          (LET ((B (STRING-SEARCH-CHAR #\SP L))) 
    420             (COND ((STRING-EQUAL L THE-ENTRY 0 0 B) 
    421                    (INSERT-MOVING (POINT) #\SP) 
    422                    (INSERT-MOVING (POINT) (NSUBSTRING L (1+ B))) 
    423                    (RETURN NIL))))))) 
    424    DIS-TEXT) 
     412  (LET ((BP (COPY-BP (POINT))) 
     413        (THE-ENTRY)) 
     414    (LET ((BP1 (FORWARD-WORD BP -1))) 
     415      (SETQ THE-ENTRY (STRING-INTERVAL BP1 (FORWARD-WORD BP1) T))) 
     416    (OR (BOUNDP '*PL1DCL*) (READ-PL1DCL)) 
     417    (DO ((I 0 (1+ I)) 
     418         (LIM (ARRAY-ACTIVE-LENGTH *PL1DCL*))) 
     419        (( 
     420 I LIM) 
     421         (BARF "No declaration found in file.")) 
     422      (LET ((L (AREF *PL1DCL* I))) 
     423        (LET ((B (STRING-SEARCH-CHAR #\SP L))) 
     424          (COND ((STRING-EQUAL L THE-ENTRY 0 0 B) 
     425                 (INSERT-MOVING (POINT) #\SP) 
     426                 (INSERT-MOVING (POINT) (NSUBSTRING L (1+ B))) 
     427                 (RETURN NIL))))))) 
     428  DIS-TEXT) 
    425429 
    426430(DEFUN READ-PL1DCL ( &AUX LINE EOFP) 
    427     (SETQ PL1DCL (MAKE-ARRAY NIL 'ART-Q 100. NIL '(0))) 
    428     (OPEN-FILE (STREAM "AI:ZWEI;PL1DCL >" '(READ)) 
    429       (DO () (NIL) 
    430         (MULTIPLE-VALUE (LINE EOFP) 
    431              (FUNCALL STREAM ':LINE-IN)) 
    432         (AND EOFP (RETURN NIL)) 
    433         (ARRAY-PUSH-EXTEND PL1DCL LINE)))) 
     431  (SETQ *PL1DCL* (MAKE-ARRAY NIL 'ART-Q 100. NIL '(0))) 
     432  (OPEN-FILE (STREAM "AI:ZWEI;PL1DCL >" '(READ)) 
     433    (DO () (NIL) 
     434      (MULTIPLE-VALUE (LINE EOFP) 
     435        (FUNCALL STREAM ':LINE-IN)) 
     436      (AND EOFP (RETURN NIL)) 
     437      (ARRAY-PUSH-EXTEND *PL1DCL* LINE)))) 
    434438 
    435439(DEFCOM COM-PL1-ELECTRIC-SEMICOLON "Try it, you'll like it." () 
    436440  (LET ((BP (POINT))) 
    437     (COND ((AND (= PL1-INDING-STYLE 1) 
     441    (COND ((AND (= *PL1-INDING-STYLE* 1) 
    438442                (LOOKING-AT-BACKWARD BP "END")) 
    439443           (MOVE-BP BP (FORWARD-CHAR BP -3)) 
    … …  
    447451 
    448452(DEFCOM COM-PL1-ELECTRIC-COLON "Try it, you'll like it." () 
    449     (LET ((BP (BEG-LINE (POINT)))) 
    450       (DELETE-OVER *BLANKS* BP)) 
    451     (INSERT-MOVING (POINT) ":") 
    452     (COM-INDENT-FOR-PL1) 
    453     DIS-TEXT) 
     453  (LET ((BP (BEG-LINE (POINT)))) 
     454    (DELETE-OVER *BLANKS* BP)) 
     455  (INSERT-MOVING (POINT) ":") 
     456  (COM-INDENT-FOR-PL1) 
     457  DIS-TEXT)