Changeset 258


Ignore:
Timestamp:
08/18/11 15:23:42 (3 years ago)
Author:
rjs
Message:

Update.

Location:
trunk/lisp/nzwei
Files:
24 edited

Legend:

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

    r257 r258  
    286286
    287287(DEFCOM COM-PUSH-POP-POINT-EXPLICIT "Push or pop point onto the point pdl.
     288With no argument, push point onto the point pdl.
    288289With an argument, exchanges point with the nth position on the stack." (KM)
    289290  (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  
    340340                            "Evaluating"
    341341                            "evaluated."
    342                             NIL T)
     342                            ':PROMPT T)
    343343   DIS-NONE)
    344344
  • trunk/lisp/nzwei/comd.lisp

    r257 r258  
    278278                          ;; If allowed one failure
    279279                          (NEQ *LAST-COMMAND-TYPE* 'FAILING-COMPLETION)
    280                           (NOT (BIT-TEST 400 *LAST-COMMAND-CHAR*)))
     280                          (NUMBERP *LAST-COMMAND-CHAR*)
     281                          (NOT (LDB-TEST %%KBD-CONTROL *LAST-COMMAND-CHAR*)))
    281282                     (SETQ COMPLETION (COMPLETE-LINE T NIL))
    282283                     (SETQ COMPLETION (IF (= (LENGTH COMPLETION) 1) (CAR COMPLETION)
  • trunk/lisp/nzwei/come.lisp

    r257 r258  
    280280
    281281(DEFCOM COM-MARK-DEFUN "Put point and mark around current defun." ()
    282   (LET ((INT (DEFUN-INTERVAL (POINT) *NUMERIC-ARG*)))
     282  (LET ((INT (DEFUN-INTERVAL (POINT) *NUMERIC-ARG* NIL T T))) ;including previous blank line
    283283    (OR INT (BARF))
    284284    (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  
    124124        LOOP (SETQ XCHAR (AND (NOT ECHOED-P)
    125125                              (FUNCALL STANDARD-INPUT ':TYI-NO-HANG)))
    126         LOP1 (SETQ CHAR (OR XCHAR
    127                             (TYPEIN-LINE-ACTIVATE
    128                               (FUNCALL STANDARD-INPUT ':TYI))))
     126        LOP1 (SETQ CHAR (OR XCHAR (TYPEIN-LINE-ACTIVATE (TYI-WITH-SCROLLING))))
    129127             (SETQ HACK2 HACK1 HACK1 NIL)
    130128             (COND ((BIT-TEST 400 CHAR)
     
    375373              (SETQ SUPPRESSED-REDISPLAY T))
    376374          (MULTIPLE-VALUE (CHAR REAL-CHAR)
    377             (FUNCALL STANDARD-INPUT ':MOUSE-OR-KBD-TYI))
     375            (TYI-WITH-SCROLLING T))
    378376          (SETQ XCHAR (CHAR-UPCASE CHAR))
    379377          (COND ((NOT (OR (LDB-TEST %%KBD-CONTROL-META CHAR) (LDB-TEST %%KBD-MOUSE CHAR)
     
    759757        (SETQ NEW-BP (FUNCALL FUNCTION BP KEY NIL T))
    760758        (DELETE-INTERVAL BP (BEG-LINE NEW-BP 0) T)
    761         (OR (SETQ BP (BEG-LINE BP 1)) (RETURN NIL)))))
     759        (OR (SETQ BP (BEG-LINE NEW-BP 1)) (RETURN NIL)))))
    762760  DIS-TEXT)
    763761
     
    770768      (DO () (())
    771769        (OR (SETQ BP (FUNCALL FUNCTION BP KEY)) (RETURN NIL))
    772         (DELETE-INTERVAL (BEG-LINE BP 0) (BEG-LINE BP 1)))))
     770        (DELETE-INTERVAL (BEG-LINE BP 0) (SETQ BP (BEG-LINE BP 1))))))
    773771  DIS-TEXT)
    774772
  • trunk/lisp/nzwei/comtab.lisp

    r257 r258  
    764764            #/# COM-TEXT-JUSTIFIER-CHANGE-FONT-WORD
    765765            #/_ COM-TEXT-JUSTIFIER-UNDERLINE-WORD
     766            #/# COM-GOTO-CHARACTER
    766767            #\MOUSE-1-1 COM-MOUSE-MARK-REGION
    767768            #\MOUSE-1-2 COM-MOUSE-MOVE-REGION
  • trunk/lisp/nzwei/defs.lisp

    r257 r258  
    253253     BUFFER-TICK                        ;If FILE-ID is a string, this is the tick
    254254                                        ;at which we got that ID.  Else meaningless.
     255     BUFFER-FILE-NAME                   ;The filename object for if a file, else meaningless
    255256     BUFFER-SAVED-POINT                 ;POINT the last time this was on a window.
    256257     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  
    10521052    (SELECTQ (SETQ CH (WITHOUT-IO-BUFFER-OUTPUT-FUNCTION
    10531053                        (FUNCALL STANDARD-INPUT ':TYI)))
    1054       ((#\SP #/V #/v)
     1054      ((#\SP #/V #/v #\HAND-DOWN)
    10551055       (AND AT-END-P (RETURN NIL))
    10561056       (RECENTER-WINDOW-RELATIVE ZWEI-WINDOW N-LINES))
    1057       ((#\BS #/V #/v)
     1057      ((#\BS #/V #/v #\HAND-UP)
    10581058       (RECENTER-WINDOW-RELATIVE ZWEI-WINDOW (- N-LINES)))
    10591059      (#\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*)))
     
    387392    (FUNCALL ACTOR ':ADD-LINE LINE)
    388393    (INSERT-LINE-WITH-LEADER LINE AT-LINE)))
     394
  • trunk/lisp/nzwei/for.lisp

    r257 r258  
    490490;;; Return an interval surrounding the DEFUN that BP is in, or NIL if it fails.
    491491
    492 (DEFUN DEFUN-INTERVAL (BP &OPTIONAL (TIMES 1) FIXUP-P (COMMENTS-P T))
     492(DEFUN DEFUN-INTERVAL (BP &OPTIONAL (TIMES 1) FIXUP-P (COMMENTS-P T) (TOP-BLANK-P NIL))
    493493  (PROG (BP1 BP2 BP3 BP4 SBP)
    494494        (COND ((NULL (SETQ BP1 (FORWARD-DEFUN BP -1)))
     
    499499        (OR (SETQ BP2 (FORWARD-SEXP BP1 TIMES))
    500500            (IF (NOT FIXUP-P) (RETURN NIL)
    501                 (SETQ BP2 (BEG-LINE (BACKWARD-OVER-COMMENT-LINES (FORWARD-DEFUN BP1 1 T))
     501                (SETQ BP2 (BEG-LINE (BACKWARD-OVER-COMMENT-LINES (FORWARD-DEFUN BP1 1 T)
     502                                                                 TOP-BLANK-P)
    502503                                    -1))))
    503504        (OR (BP-< (END-LINE BP2) BP)
     
    518519        (SETQ SBP BP1)                  ;Save real starting line
    519520     CONTIN
    520         (AND COMMENTS-P (SETQ BP1 (BACKWARD-OVER-COMMENT-LINES BP1)))
     521        (AND COMMENTS-P (SETQ BP1 (BACKWARD-OVER-COMMENT-LINES BP1 TOP-BLANK-P)))
    521522        (SETQ BP3 (FORWARD-OVER *BLANKS* BP2))
    522523        (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
     325;;; Handy things for saving out macros on disk and editing them
     326(DEFMACRO DEFINE-KEYBOARD-MACRO (NAME (COUNT) . EXPANSION)
     327  `(DEFINE-KEYBOARD-MACRO-1 ',NAME ,(OR COUNT 1) ',(COPYLIST EXPANSION)))
     328
     329(DEFUN DEFINE-KEYBOARD-MACRO-1 (NAME COUNT EXPANSION &AUX MACRO-ARRAY (LEN 0) STRING)
     330  (SETQ STRING (STRING NAME)
     331        NAME (INTERN STRING ""))
     332  (DOLIST (THING EXPANSION)
     333    (IF (STRINGP THING)
     334        (SETQ LEN (+ LEN (STRING-LENGTH THING)))
     335        (SETQ LEN (1+ LEN))))
     336  (SETQ MACRO-ARRAY (MAKE-MACRO-ARRAY MAKE-ARRAY (NIL 'ART-Q LEN)
     337                                      MACRO-LENGTH (1- LEN)
     338                                      MACRO-DEFAULT-COUNT COUNT
     339                                      MACRO-NAME STRING))
     340  (DOLIST (THING EXPANSION)
     341    (IF (STRINGP THING)
     342        (APPEND-TO-ARRAY MACRO-ARRAY THING)
     343        (COND ((NUMBERP THING))
     344              ((STRING-EQUAL THING '*INPUT*)
     345               (SETQ THING NIL))
     346              ((STRING-EQUAL THING '*SPACE*)
     347               (SETQ THING '*SPACE*))
     348              ((STRING-EQUAL THING '*MOUSE*)
     349               (SETQ THING '*MOUSE*))
     350              ((STRING-EQUAL THING '*MICE*)
     351               (SETQ THING '*MICE*))
     352              (T
     353               (FERROR NIL "~S is not a known macro expansion element." THING)))
     354        (ARRAY-PUSH MACRO-ARRAY THING)))
     355  (PUTPROP NAME MACRO-ARRAY 'MACRO-STREAM-MACRO)
     356  NAME)
     357
     358(DEFUN PRINT-KEYBOARD-MACRO-DEFINITION (STREAM NAME &OPTIONAL MACRO-ARRAY)
     359  (LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI"))
     360        (BASE 'CHARACTER))
     361    (SI:GRIND-TOP-LEVEL (GET-KEYBOARD-MACRO-DEFINITION NAME MACRO-ARRAY) 95. STREAM)))
     362
     363(DEFUN GET-KEYBOARD-MACRO-DEFINITION (NAME MACRO-ARRAY)
     364  (OR MACRO-ARRAY (SETQ MACRO-ARRAY (GET NAME 'MACRO-STREAM-MACRO)))
     365  (SETQ NAME (INTERN NAME "ZWEI"))
     366  (DO ((I 0 (1+ I))
     367       (LEN (1+ (MACRO-LENGTH MACRO-ARRAY)))
     368       (THING)
     369       (STATE NIL)
     370       (LIST NIL)
     371       (STRING (MAKE-ARRAY NIL 'ART-STRING 10. NIL 1)))
     372      ((
     373 I LEN)
     374       `(DEFINE-KEYBOARD-MACRO ,NAME () . ,(NREVERSE LIST)))
     375    (SETQ THING (AREF MACRO-ARRAY I))
     376    (COND ((OR (SYMBOLP THING) (LDB-TEST %%KBD-CONTROL-META THING))
     377           (COND (STATE
     378                  (PUSH (STRING-APPEND STRING) LIST)
     379                  (SETQ STATE NIL)))
     380           (COND ((NUMBERP THING))
     381                 ((NULL THING)
     382                  (SETQ THING '*INPUT*)))
     383           (PUSH THING LIST))
     384          (T
     385           (COND ((NOT STATE)
     386                  (STORE-ARRAY-LEADER 0 STRING 0)
     387                  (SETQ STATE T)))
     388           (ARRAY-PUSH-EXTEND STRING THING)))))
     389
     390(DEFUN (CHARACTER SI:PRINC-FUNCTION) (-N STREAM)
     391  (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  
    441441
    442442(SETQ *DEFAULT-INDENT-ALIST* '((LET 1 1) (LET* 1 1) (LET-GLOBALLY 1 1) (LAMBDA 1 1)
     443                               (*CATCH 1 1)
    443444                               (DOLIST 1 1) (DO 2 1)
    444445                               (PROG . INDENT-PROG) (PROG* . INDENT-PROG)
  • trunk/lisp/nzwei/modes.lisp

    r257 r258  
    541541
    542542(DEFCOM COM-PREFIX-CONTROL DOCUMENT-PREFIX-CHAR ()
    543    (KEY-EXECUTE (DPB -1 %%KBD-CONTROL (GET-ECHO-CHAR "Control-" NIL))
     543   (KEY-EXECUTE (DPB 1 %%KBD-CONTROL (GET-ECHO-CHAR "Control-" NIL))
    544544                *NUMERIC-ARG-P*
    545545                *NUMERIC-ARG*))
     
    547547(DEFCOM COM-PREFIX-META DOCUMENT-PREFIX-CHAR ()
    548548        ()
    549    (KEY-EXECUTE (DPB -1 %%KBD-META (GET-ECHO-CHAR "Meta-" NIL))
     549   (KEY-EXECUTE (DPB 1 %%KBD-META (GET-ECHO-CHAR "Meta-" NIL))
    550550                *NUMERIC-ARG-P*
    551551                *NUMERIC-ARG*))
     
    553553(DEFCOM COM-PREFIX-CONTROL-META DOCUMENT-PREFIX-CHAR ()
    554554        ()
    555    (KEY-EXECUTE (DPB -1 %%KBD-CONTROL-META (GET-ECHO-CHAR "Control-Meta-" NIL))
     555   (KEY-EXECUTE (DPB 1 %%KBD-CONTROL (DPB 1 %%KBD-META (GET-ECHO-CHAR "Control-Meta-" NIL)))
    556556                *NUMERIC-ARG-P*
    557557                *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)
Note: See TracChangeset for help on using the changeset viewer.