Changeset 275


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

Update from System 78.

Location:
trunk/lisp/lmwin
Files:
3 added
4 deleted
28 edited

Legend:

Unmodified
Added
Removed
  • trunk/lisp/lmwin/basstr.lisp

    r220 r275  
    66;;; IO buffers (definition in NTVDEF)
    77
    8 (DEFUN IO-BUFFER (OP BUFFER &REST ARGS)
     8(DEFUN (IO-BUFFER NAMED-STRUCTURE-INVOKE) (OP BUFFER &REST ARGS)
    99  "Printer for IO-BUFFER named structures"
    1010  (SELECTQ OP
    11     (:WHICH-OPERATIONS '(:PRINT :PRINT-SELF))
    12     ((:PRINT :PRINT-SELF)
    13             (FORMAT (CAR ARGS) "#<IO-BUFFER ~O: " (%POINTER BUFFER))
    14             (COND ((= (IO-BUFFER-INPUT-POINTER BUFFER)
    15                       (IO-BUFFER-OUTPUT-POINTER BUFFER))
    16                    (PRINC "empty, " (CAR ARGS)))
    17                   (T (FORMAT (CAR ARGS) "~D entr~:@P, "
    18                              (LET ((DIFF (- (IO-BUFFER-INPUT-POINTER BUFFER)
    19                                             (IO-BUFFER-OUTPUT-POINTER BUFFER))))
    20                                (IF (< DIFF 0)
    21                                    (+ DIFF (IO-BUFFER-SIZE BUFFER))
    22                                    DIFF)))))
    23             (FORMAT (CAR ARGS) "State: ~A>" (IO-BUFFER-STATE BUFFER)))
    24     (OTHERWISE (FORMAT T "I don't know about ~S" OP))))
     11    (:WHICH-OPERATIONS '(:PRINT-SELF))
     12    ((:PRINT-SELF)
     13     (SI:PRINTING-RANDOM-OBJECT (BUFFER (CAR ARGS) :NO-POINTER)
     14       (FORMAT (CAR ARGS) "IO-BUFFER ~O: " (%POINTER BUFFER))
     15       (COND ((= (IO-BUFFER-INPUT-POINTER BUFFER)
     16                 (IO-BUFFER-OUTPUT-POINTER BUFFER))
     17              (PRINC "empty, " (CAR ARGS)))
     18             (T (FORMAT (CAR ARGS) "~D entr~:@P, "
     19                        (LET ((DIFF (- (IO-BUFFER-INPUT-POINTER BUFFER)
     20                                       (IO-BUFFER-OUTPUT-POINTER BUFFER))))
     21                          (IF (< DIFF 0)
     22                              (+ DIFF (IO-BUFFER-SIZE BUFFER))
     23                              DIFF)))))
     24            (FORMAT (CAR ARGS) "State: ~A" (IO-BUFFER-STATE BUFFER))))
     25    (OTHERWISE (FERROR NIL "I don't know about ~S" OP))))
    2526
    2627
    2728(DEFUN MAKE-IO-BUFFER (SIZE &OPTIONAL IN-FUN OUT-FUN PLIST STATE &AUX BUFFER)
    2829  "Create a new IO buffer of specified size"
    29   (SETQ BUFFER (MAKE-ARRAY NIL 'ART-Q SIZE NIL (GET 'IO-BUFFER 'SI:DEFSTRUCT-SIZE) NIL T))
     30  (SETQ BUFFER (MAKE-ARRAY NIL 'ART-Q SIZE NIL IO-BUFFER-LEADER-SIZE NIL T))
    3031  (STORE-ARRAY-LEADER 'IO-BUFFER BUFFER 1)
    3132  (SETF (IO-BUFFER-FILL-POINTER BUFFER) 0)
     
    161162from the hardware, and performing any immediate processing associated with the character."
    162163  (DO () (NIL)
    163     (*CATCH 'SI:TOP-LEVEL
     164    (*CATCH 'SYS:COMMAND-LEVEL
    164165      (PROGN
    165166        (IO-BUFFER-CLEAR KBD-IO-BUFFER)
     
    189190           (SETQ RAW-P (GET PLIST ':RAW))))
    190191    (DO ((CHAR)
    191          (SOFT-CHAR)
    192          (IFUN (GET PLIST ':INTERRUPT-FUNCTION)))
     192         (SOFT-CHAR))
    193193        ((OR KBD-ESC-HAPPENED
    194194             (NOT (KBD-HARDWARE-CHAR-AVAILABLE))))
    195195      (SETQ CHAR (KBD-GET-HARDWARE-CHAR))
    196196      (COND (RAW-P
    197              (COND ((NOT (IO-BUFFER-FULL-P BUFFER))
    198                     (AND IFUN (FUNCALL IFUN BUFFER CHAR))
    199                     (IO-BUFFER-PUT BUFFER CHAR))))
     197             (OR (IO-BUFFER-FULL-P BUFFER)
     198                 (IO-BUFFER-PUT BUFFER CHAR)))
    200199            (T
    201200             (SETQ SOFT-CHAR (KBD-CONVERT-TO-SOFTWARE-CHAR CHAR))
     
    211210                                  (NOT (GET PLIST ':SUPER-IMAGE)))
    212211                             (KBD-CALL BUFFER))
    213                             ((AND (= CHAR #\ABORT)
     212                            ((AND (MEMQ SOFT-CHAR '(#\ABORT #\ABORT #\BREAK #\BREAK))
    214213                                  (NOT (GET PLIST ':SUPER-IMAGE)))
    215                              (KBD-ABORT BUFFER))
     214                             (KBD-ASYNCHRONOUS-INTERCEPT-CHARACTER SOFT-CHAR))
    216215                            ((NOT (IO-BUFFER-FULL-P KBD-IO-BUFFER))
    217                              (AND IFUN (FUNCALL IFUN BUFFER SOFT-CHAR))
    218216                             (IO-BUFFER-PUT KBD-IO-BUFFER SOFT-CHAR))))))))))
    219217
     
    259257(DEFUN KBD-SNARF-INPUT (BUFFER &OPTIONAL NO-HARDWARE-CHARS-P)
    260258  (WITHOUT-INTERRUPTS
    261     (COND ((EQ BUFFER (KBD-GET-IO-BUFFER))
     259    (COND ((NULL BUFFER))                       ;This can happen due to timing error
     260          ((EQ BUFFER (KBD-GET-IO-BUFFER))
    262261           ;; There is potentially input for us
    263262           (OR NO-HARDWARE-CHARS-P (KBD-PROCESS-MAIN-LOOP-INTERNAL))
     
    270269             (AND ELT (IO-BUFFER-PUT BUFFER ELT T)))))))
    271270
    272 ;;; This is a crock, but I suppose someone might want to...
    273 (DEFVAR KBD-TYI-HOOK NIL)
     271(DEFVAR KBD-TYI-HOOK NIL)  ;This is a crock, but I suppose someone might want to...
     272(DEFCONST KBD-STANDARD-INTERCEPTED-CHARACTERS '(#\ABORT #\ABORT #\BREAK #\BREAK))
     273(DEFVAR KBD-INTERCEPTED-CHARACTERS KBD-STANDARD-INTERCEPTED-CHARACTERS)
     274(ADD-INITIALIZATION "Don't Ignore Abort"
     275                    '(SETQ KBD-INTERCEPTED-CHARACTERS KBD-STANDARD-INTERCEPTED-CHARACTERS)
     276                    '(SYSTEM))
    274277
    275278(DEFUN KBD-DEFAULT-OUTPUT-FUNCTION (IGNORE CHAR)
    276   "System standard IO-BUFFER output function.  Must be called with INHIBIT-SCHEDULING-FLAG
    277 bound to T, and this may SETQ it to NIL."
    278   ;; Default IO-BUFFER-OUTPUT-FUNCTION for keyboard io buffers.  Implements control-Z.
    279   (PROG ()
    280     (IF (AND KBD-TYI-HOOK (FUNCALL KBD-TYI-HOOK CHAR))
    281         (RETURN CHAR T)
    282         (SETQ INHIBIT-SCHEDULING-FLAG NIL)
    283         (SELECTQ CHAR
    284           ((#/Z #/z) (*THROW 'SI:TOP-LEVEL NIL))
    285           (#\BREAK
    286 ;;;        (FUNCALL-SELF ':BREAK)
    287            (BREAK BREAK T)
    288            (RETURN CHAR T))))
    289     (RETURN CHAR NIL)))
     279  "System standard IO-BUFFER output function.
     280Intercepts those characters in KBD-INTERCEPTED-CHARACTERS.
     281Must be called with INHIBIT-SCHEDULING-FLAG bound to T, and this may SETQ it to NIL."
     282  (IF (AND KBD-TYI-HOOK (FUNCALL KBD-TYI-HOOK CHAR))
     283      (VALUES CHAR T)
     284      ;; Note, this must not use =, since the character may not be a number
     285      (COND ((MEMQ CHAR KBD-INTERCEPTED-CHARACTERS)
     286             (KBD-INTERCEPT-CHARACTER CHAR)
     287             (VALUES CHAR T))           ;If returns, ignore the char and retry
     288            (T CHAR))))
     289
     290;;; This function knows what to do in response to each of the standard intercepted
     291;;; characters.  It is called by other functions besides KBD-DEFAULT-OUTPUT-FUNCTION
     292(DEFUN KBD-INTERCEPT-CHARACTER (CHAR)
     293  (SETQ INHIBIT-SCHEDULING-FLAG NIL)            ;It was T in the IO-BUFFER-OUTPUT-FUNCTION
     294  (SELECTQ CHAR
     295    (#\ABORT
     296     (IF (NOT (AND (TYPEP TERMINAL-IO 'SHEET)   ;Kludge to avoid being unable to abort
     297                   (SHEET-OUTPUT-HELD-P TERMINAL-IO)))
     298         (FUNCALL TERMINAL-IO ':STRING-OUT "[Abort]"))
     299     (*THROW 'SYS:COMMAND-LEVEL NIL))
     300    (#\ABORT
     301     (IF (NOT (AND (TYPEP TERMINAL-IO 'SHEET)   ;Kludge to avoid being unable to abort
     302                   (SHEET-OUTPUT-HELD-P TERMINAL-IO)))
     303         (FUNCALL TERMINAL-IO ':STRING-OUT "[Abort all]"))
     304     (FUNCALL CURRENT-PROCESS ':RESET ':ALWAYS))
     305    (#\BREAK (BREAK BREAK))
     306    (#\BREAK (FUNCALL %ERROR-HANDLER-STACK-GROUP '(:BREAK))
     307     NIL)       ;This NIL is here for a reason!
     308    (OTHERWISE (FERROR NIL "~:@C is not a standard intercepted character" CHAR))))
     309
     310;;; This function is called, possibly in the keyboard process, when one of the
     311;;; standard asynchronous intercepted characters, of the sort that mungs over the
     312;;; process, is typed.  Scheduling is inhibited.
     313;;; This does the actual munging of the process in a separate process, in case
     314;;; it has to wait for the process' stack-group to get out of some weird state.
     315(DEFUN KBD-ASYNCHRONOUS-INTERCEPT-CHARACTER (CHAR &AUX P)
     316  (KBD-ESC-CLEAR NIL)  ;Forget chars typed before "CTRL-abort", even those inside window's iob
     317  (AND (SETQ P SELECTED-WINDOW)                 ;Find process to be hacked
     318       (SETQ P (FUNCALL P ':PROCESS))
     319       (SELECTQ CHAR
     320         ((#\ABORT #\ABORT)
     321          (PROCESS-RUN-TEMPORARY-FUNCTION "Abort" P ':INTERRUPT
     322                        #'KBD-INTERCEPT-CHARACTER (DPB 0 %%KBD-CONTROL CHAR)))
     323         (#\BREAK
     324          (PROCESS-RUN-TEMPORARY-FUNCTION "Break" P ':INTERRUPT 'BREAK 'BREAK))
     325         (#\BREAK
     326          (PROCESS-RUN-TEMPORARY-FUNCTION "Break" P ':INTERRUPT %ERROR-HANDLER-STACK-GROUP
     327                                                                '(:BREAK))))))
    290328
    291329(DEFVAR KBD-PROCESS)
     
    328366  (COND ((NULL SELECTED-WINDOW)
    329367         ;; This shouldn't be necessary, but try not to lose too big
    330          (SETQ SELECTED-IO-BUFFER NIL))
     368         (KBD-CLEAR-SELECTED-IO-BUFFER))
    331369        (SELECTED-IO-BUFFER SELECTED-IO-BUFFER)
    332370        (T (PROG1 (SETQ SELECTED-IO-BUFFER (FUNCALL SELECTED-WINDOW ':IO-BUFFER))
     
    336374  BUFFER                                        ;Not used
    337375  (IO-BUFFER-CLEAR KBD-IO-BUFFER)               ;Forget chars typed before "call"
    338   (PROCESS-RUN-FUNCTION "Call" #'(LAMBDA (WINDOW)
    339                                    (IF WINDOW
    340                                       (FUNCALL WINDOW ':CALL)
    341                                       (SETQ WINDOW (KBD-DEFAULT-CALL-WINDOW))
    342                                       (FUNCALL WINDOW ':MOUSE-SELECT)))
    343                         SELECTED-WINDOW))
     376  (PROCESS-RUN-TEMPORARY-FUNCTION "Call" #'(LAMBDA (WINDOW)
     377                                             (IF WINDOW
     378                                                (FUNCALL WINDOW ':CALL)
     379                                                (SETQ WINDOW (KBD-DEFAULT-CALL-WINDOW))
     380                                                (FUNCALL WINDOW ':MOUSE-SELECT)))
     381                                  SELECTED-WINDOW))
    344382
    345383(DEFUN KBD-DEFAULT-CALL-WINDOW (&OPTIONAL (SCREEN DEFAULT-SCREEN) &AUX PREVIOUS-WINDOW)
     
    350388      PREVIOUS-WINDOW
    351389      (FUNCALL SCREEN ':IDLE-LISP-LISTENER)))
    352 
    353 (DEFUN KBD-ABORT (BUFFER)
    354   BUFFER                                        ;Not used
    355   (KBD-ESC-CLEAR NIL)  ;Forget chars typed before "abort", even those inside window's iob
    356   (AND SELECTED-WINDOW
    357        (PROCESS-RUN-FUNCTION "Abort" SELECTED-WINDOW ':ABORT)))
    358 
    359 (DEFUN KBD-BREAK (BUFFER)
    360   BUFFER                                        ;Not used
    361   (AND SELECTED-WINDOW
    362        (PROCESS-RUN-FUNCTION "Break" SELECTED-WINDOW ':BREAK)))
    363390
    364391;Return the state of a key, T if it is depressed, NIL if it is not.
     
    400427;       effect of treating everything typed before the ESC as typeahead to
    401428;       the currently selected window.  Useful for ESC commands that
    402 ;       change the selected window.
     429;       change the selected window.  These commands should set KBD-ESC-TIME to NIL
     430;       as soon as they change the selected window, unless they complete quickly
     431;       (input should never be done with KBD-ESC-TIME non-NIL).
    403432;    :KEYBOARD-PROCESS - run the function in the keyboard process instead of starting
    404433;       a new process for it.
     434
    405435; Unknown or misspelled keywords are ignored.
    406436(DEFVAR *ESCAPE-KEYS*
    407      '( (#\BREAK (AND SELECTED-WINDOW (FUNCALL SELECTED-WINDOW ':BREAK))
    408          "Force process into error-handler")
    409         (#\CLEAR KBD-ESC-CLEAR "Discard type-ahead" :KEYBOARD-PROCESS)
    410         (#\FORM (KBD-SCREEN-REDISPLAY) "Clear and redisplay all windows")
     437     '( (#\CLEAR KBD-ESC-CLEAR "Discard type-ahead" :KEYBOARD-PROCESS)
     438        (#\FORM (KBD-SCREEN-REDISPLAY)
     439                "Clear and redisplay all windows (Page = Clear Screen)")
    411440        (#/A KBD-ESC-ARREST
    412441             "Arrest process in who-line (minus means unarrest)" :KEYBOARD-PROCESS)
    413         (#/C (COMPLEMENT-BOW-MODE) "Complement video black-on-white state" :KEYBOARD-PROCESS)
    414         (#/D (CHAOS:BUZZ-DOOR) (AND (CHAOS:TECH-SQUARE-FLOOR-P 9) "Open the door"))
    415         (#/E (CHAOS:CALL-ELEVATOR) (AND (OR (CHAOS:TECH-SQUARE-FLOOR-P 8)
    416                                             (CHAOS:TECH-SQUARE-FLOOR-P 9))
    417                                         "Call the elevator"))
    418         (#/F KBD-FINGER "Finger (AI, or arg=1:Lisp machines, 2 MC, 3 AI+MC, 0 ask)"
     442        (#/C KBD-COMPLEMENT
     443             '("Complement video black-on-white state"
     444               "With an argument, complement the who-line documentation window")
     445              :KEYBOARD-PROCESS)
     446        (#/D (SI:BUZZ-DOOR) (AND (SI:TECH-SQUARE-FLOOR-P 9) "Open the door"))
     447        (#/E (SI:CALL-ELEVATOR) (AND (OR (SI:TECH-SQUARE-FLOOR-P 8)
     448                                         (SI:TECH-SQUARE-FLOOR-P 9))
     449                                     "Call the elevator"))
     450        (#/F KBD-FINGER (FINGER-ARG-PROMPT)
    419451                        :TYPEAHEAD)
     452        (#/H (KBD-HOSTAT) "Show status of CHAOSnet hosts" :TYPEAHEAD)
    420453        (#/M KBD-ESC-MORE "**MORE** enable (complement, or arg=1:on, 0 off)"
    421454                          :KEYBOARD-PROCESS)
    422455        (#/O KBD-OTHER-EXPOSED-WINDOW "Select another exposed window" :TYPEAHEAD)
    423         (#/Q (SI:SCREEN-XGP-HARDCOPY-BACKGROUND DEFAULT-SCREEN)
    424              "Hardcopy the screen on the XGP")
     456        (#/Q KBD-ESC-Q
     457             (AND *SCREEN-HARDCOPY-MODE*
     458                  (FORMAT NIL "Hardcopy the screen on the ~A" *SCREEN-HARDCOPY-MODE*)))
    425459        (#/S KBD-SWITCH-WINDOWS
    426460         '("Select the most recently selected window.  With an argument, select the nth"
     
    430464           "attention, e.g. to report an error.")
    431465           :TYPEAHEAD)
     466        (#/T KBD-ESC-T
     467         '("Control the selected window's notification properties."
     468           "Toggle output notification, and make input the same as output."
     469           "0 Turn both off; 1 turn both on; 2 output on, input off; 3 output off, input on."
     470           "4 Let output proceed with with window deexposed, input on; 5 Same, input off."
     471           "(You can also use the Attribute command in the Screen Editor.)"))
    432472        (#/W KBD-ESC-W
    433473         '("Switch which process the wholine looks at.  Default is just to refresh it"
    434474           " 1 means selected-window's process, 2 means freeze on this process,"
    435            " 3 means rotate right in active-processes, 4 means rotate left.")
    436            :KEYBOARD-PROCESS)
     475           " 3 means rotate among all processes, 4 means rotate other direction,"
     476           " 0 gives a menu of all processes"))
    437477        (#\HOLD-OUTPUT KBD-ESC-OUTPUT-HOLD "Expose window on which we have /"Output Hold/"")
    438478        (#/? KBD-ESC-HELP NIL :TYPEAHEAD)
     
    440480        (NIL) ;Ones after here are "for wizards"
    441481        (#\CALL (KBD-USE-COLD-LOAD-STREAM) "Get to cold-load stream" :TYPEAHEAD)
     482        (#/T KBD-CLEAR-TEMPORARY-WINDOWS "Flush temporary windows")
    442483        (#\CLEAR KBD-CLEAR-LOCKS "Clear window-system locks")
    443         (#/T KBD-CLEAR-TEMPORARY-WINDOWS "Flush temporary windows")
    444484        (#/G (BEEP) "Beep the beeper")))  ;Should this be flushed now?
    445485       
    446 (DEFUN KBD-ESC (&AUX CH ARG MINUS FCN)
     486(DEFUN KBD-ESC (&AUX CH ARG MINUS FCN ENT)
    447487  "Handle ESC typed on keyboard"
    448488  (LET-GLOBALLY ((WHO-LINE-PROCESS CURRENT-PROCESS))
     
    460500  (WHO-LINE-RUN-STATE-UPDATE)   ;Switch LAST-WHO-LINE-PROCESS back
    461501  (AND MINUS (SETQ ARG (MINUS (OR ARG 1))))
    462   (COND ((SETQ CH (ASSQ CH *ESCAPE-KEYS*))
     502  (COND ((SETQ ENT (ASSQ CH *ESCAPE-KEYS*))
    463503         (WITHOUT-INTERRUPTS
    464            (AND (MEMQ ':TYPEAHEAD (CDDDR CH)) (KBD-GET-IO-BUFFER)
    465                 (KBD-SNARF-INPUT SELECTED-IO-BUFFER T)))
    466          (SETQ FCN (SECOND CH))
     504           (COND ((MEMQ ':TYPEAHEAD (CDDDR ENT))
     505                  (KBD-GET-IO-BUFFER)
     506                  (KBD-SNARF-INPUT SELECTED-IO-BUFFER T)
     507                  (SETQ KBD-ESC-TIME (TIME)))))
     508         (SETQ FCN (SECOND ENT))
    467509         (AND (LISTP FCN) (SETQ ARG FCN FCN #'EVAL))
    468          (COND ((MEMQ ':KEYBOARD-PROCESS (CDDDR CH))
    469                 (FUNCALL FCN ARG))
    470                (T (SETQ KBD-ESC-TIME (TIME))
    471                   (PROCESS-RUN-FUNCTION "KBD ESC"
    472                                         #'(LAMBDA (FCN ARG)
    473                                             (FUNCALL FCN ARG)
    474                                             (SETQ KBD-ESC-TIME NIL))
    475                                         FCN ARG))))))
     510         (COND ((MEMQ ':KEYBOARD-PROCESS (CDDDR ENT))
     511                (FUNCALL FCN ARG)
     512                (SETQ KBD-ESC-TIME NIL))
     513               (T (PROCESS-RUN-TEMPORARY-FUNCTION "KBD ESC"
     514                                                  #'(LAMBDA (FCN ARG)
     515                                                      (FUNCALL FCN ARG)
     516                                                      (SETQ KBD-ESC-TIME NIL))
     517                                                  FCN ARG))))
     518        ((MEMQ (LDB %%KBD-CHAR CH) '(#\ABORT #\BREAK))  ;Override :SUPER-IMAGE
     519         (KBD-ASYNCHRONOUS-INTERCEPT-CHARACTER (DPB 1 %%KBD-CONTROL CH)))))
     520
     521(DEFUN KBD-COMPLEMENT (ARG) ;esc C
     522  (IF ARG
     523      (FUNCALL WHO-LINE-DOCUMENTATION-WINDOW ':SET-REVERSE-VIDEO-P
     524               (NOT (FUNCALL WHO-LINE-DOCUMENTATION-WINDOW ':REVERSE-VIDEO-P)))
     525      (COMPLEMENT-BOW-MODE)))
    476526
    477527(DEFUN KBD-ESC-MORE (ARG) ;esc M
     
    517567  ;; ESC 0 S selects a window which has an error pending (or otherwise wants attention)
    518568  (OR ARG (SETQ ARG 2))
    519   (COND ((= ARG 0) (AND (SETQ TEM (FIND-INTERESTING-WINDOW))
    520                         (FUNCALL TEM ':MOUSE-SELECT)))
     569  (COND ((= ARG 0) (COND ((SETQ TEM (FIND-INTERESTING-WINDOW))
     570                          (FUNCALL TEM ':MOUSE-SELECT)
     571                          (SETQ BACKGROUND-INTERESTING-WINDOWS
     572                                (DELQ TEM BACKGROUND-INTERESTING-WINDOWS)))))
    521573        (T (DELAYING-SCREEN-MANAGEMENT          ;Inhibit auto-selection
    522574             (COND ((SETQ TEM SELECTED-WINDOW)  ;Put current window on front of array
     
    564616  ARRAY)
    565617
    566 (DEFUN KBD-SCREEN-REDISPLAY (&OPTIONAL (SCREEN MOUSE-SHEET))
     618(DEFUN KBD-SCREEN-REDISPLAY ()
    567619  "Like SCREEN-REDISPLAY, but goes over windows by hand, and never waits for a lock."
    568   (DOLIST (I (SHEET-EXPOSED-INFERIORS SCREEN))
    569     (AND (SHEET-CAN-GET-LOCK I)
    570          (FUNCALL I ':REFRESH)))
    571   (WHO-LINE-CLOBBERED)
    572   (AND (NEQ DEFAULT-SCREEN MOUSE-SHEET)
    573        (FUNCALL DEFAULT-SCREEN ':SCREEN-MANAGE))
    574   (FUNCALL MOUSE-SHEET ':SCREEN-MANAGE))
     620  (DOLIST (SCREEN ALL-THE-SCREENS)
     621    (COND ((SHEET-EXPOSED-P SCREEN)
     622           (DOLIST (I (SHEET-EXPOSED-INFERIORS SCREEN))
     623             (AND (SHEET-CAN-GET-LOCK I)
     624                  (FUNCALL I ':REFRESH)))
     625           (FUNCALL SCREEN ':SCREEN-MANAGE))))
     626  (WHO-LINE-CLOBBERED))
    575627
    576628(DEFUN KBD-CLEAR-LOCKS (IGNORE) ;esc c-clear
     629  (KBD-CLEAR-TEMPORARY-WINDOWS NIL)             ;First flush any temporary windows
    577630  (SHEET-CLEAR-LOCKS))
    578631
     
    582635                            (SHEET-EXPOSED-P SHEET)
    583636                            (SHEET-CAN-GET-LOCK SHEET)
    584                             (ERRSET (FUNCALL SHEET ':DEEXPOSE) NIL)))))
     637                            (CATCH-ERROR (FUNCALL SHEET ':DEEXPOSE) NIL)))))
    585638
    586639(DEFUN KBD-USE-COLD-LOAD-STREAM ()
    587640  (FUNCALL COLD-LOAD-STREAM ':HOME-CURSOR)
    588641  (FUNCALL COLD-LOAD-STREAM ':CLEAR-EOL)
    589   (*CATCH 'SI:TOP-LEVEL
     642  (*CATCH 'SYS:COMMAND-LEVEL
    590643    (LET ((INHIBIT-SCHEDULING-FLAG NIL)         ;NIL or BREAK would complain
    591644          (TERMINAL-IO COLD-LOAD-STREAM))
     
    593646      (BREAK COLD-LOAD-STREAM))))
    594647
    595 (DEFUN KBD-ESC-OUTPUT-HOLD (IGNORE &AUX P W)
    596   (COND ((AND (SETQ P LAST-WHO-LINE-PROCESS)
    597               (EQUAL (PROCESS-WHOSTATE P) "Output Hold")
    598               (TYPEP (SETQ W (CAR (PROCESS-WAIT-ARGUMENT-LIST P))) 'SHEET)
    599               (SHEET-OUTPUT-HOLD-FLAG W))
    600          (SHEET-FREE-TEMPORARY-LOCKS W)
    601          (FUNCALL W ':EXPOSE))
    602         ((BEEP))))
    603 
    604 (DEFVAR POP-UP-FINGER-WINDOW)
    605 (DEFUN KBD-FINGER (ARG)
    606   (SETF (SHEET-TRUNCATE-LINE-OUT-FLAG POP-UP-FINGER-WINDOW) 1)
    607   (FUNCALL POP-UP-FINGER-WINDOW ':SET-LABEL (COND ((NULL ARG)
    608                                                    "Who's on AI")
    609                                                   ((= ARG 0)
    610                                                    "Finger")
    611                                                   ((= ARG 1)
    612                                                    "Who's on Lisp Machines")
    613                                                   ((= ARG 2)
    614                                                    "Who's on MC")
    615                                                   (T
    616                                                    "Who's on AI and MC")))
    617   (FUNCALL POP-UP-FINGER-WINDOW ':SET-PROCESS CURRENT-PROCESS)
    618   (WINDOW-CALL (POP-UP-FINGER-WINDOW :DEACTIVATE)
    619     (SETQ KBD-ESC-TIME NIL)     ;Window configuration stable now, let kbd process proceed
    620     (COND ((NULL ARG)
    621            (CHAOS:FINGER "@AI" POP-UP-FINGER-WINDOW))
    622           ((= ARG 0)
    623            (FORMAT POP-UP-FINGER-WINDOW "~&Finger:~%")
    624            (FUNCALL #'CHAOS:FINGER (READLINE POP-UP-FINGER-WINDOW) POP-UP-FINGER-WINDOW))
    625           ((= ARG 1)
    626            (CHAOS:FINGER-ALL-LMS POP-UP-FINGER-WINDOW T))
    627           ((= ARG 2)
    628            (CHAOS:FINGER "//L@MC" POP-UP-FINGER-WINDOW))
    629           (T
    630            (CHAOS:FINGER "@AI" POP-UP-FINGER-WINDOW)
    631            (TERPRI POP-UP-FINGER-WINDOW)
    632            (CHAOS:FINGER "@MC" POP-UP-FINGER-WINDOW)))
    633     (FORMAT POP-UP-FINGER-WINDOW "~&~%Type a space to flush: ")
    634     (FUNCALL POP-UP-FINGER-WINDOW ':TYI)))
     648(DEFUN KBD-ESC-OUTPUT-HOLD (IGNORE)
     649  (PROG (P W LOCKED ANS)
     650    (COND ((AND (SETQ P LAST-WHO-LINE-PROCESS)
     651                (MEMBER (PROCESS-WHOSTATE P) '("Output Hold" "Lock"))
     652                (TYPEP (SETQ W (CAR (PROCESS-WAIT-ARGUMENT-LIST P))) 'SHEET)
     653                (SHEET-OUTPUT-HELD-P W))
     654           ;; Bludgeon our way past any deadlocks, e.g. due to the process P holding
     655           ;; the lock on the window we are trying to expose, or on something we need
     656           ;; to de-expose in order to expose it.  This code probably doesn't do a good
     657           ;; enough job explaining what is going on to the user.
     658           (COND ((AND (LISTP (SHEET-LOCK W))   ;Only temp-locked?
     659                       (ZEROP (SHEET-LOCK-COUNT W))
     660                       (LOOP FOR TW IN (SHEET-LOCK W)
     661                             ALWAYS (SHEET-CAN-GET-LOCK TW)))
     662                  (SHEET-FREE-TEMPORARY-LOCKS W))
     663                 ((OR (NOT (SHEET-CAN-GET-LOCK (SETQ LOCKED W)))
     664                      (AND (SHEET-SUPERIOR W)
     665                           (LOOP FOR I IN (SHEET-EXPOSED-INFERIORS (SHEET-SUPERIOR W))
     666                                 THEREIS (AND (SHEET-OVERLAPS-SHEET-P W I)
     667                                              (NOT (SHEET-CAN-GET-LOCK (SETQ LOCKED I)))))))
     668                  (FUNCALL COLD-LOAD-STREAM ':HOME-CURSOR)
     669                  (SETQ ANS (LET ((QUERY-IO COLD-LOAD-STREAM))
     670                              (FQUERY '(:CHOICES (((T "Yes.") #/Y #\SP #/T)
     671                                                  ((NIL "No.") #/N #\RUBOUT)
     672                                                  ((EH "To error-handler.") #/E))
     673                                        :BEEP T)
     674                                      "Cannot expose ~S because~@
     675                                       ~:[~S~;~*it~] is locked by ~S.~@
     676                                       Forcibly unlock all window-system locks? "
     677                                      W (EQ W LOCKED) LOCKED (SHEET-LOCK LOCKED))))
     678                  (COND ((EQ ANS 'EH)
     679                         (SETQ EH:ERROR-HANDLER-IO COLD-LOAD-STREAM)
     680                         (FUNCALL P ':INTERRUPT %ERROR-HANDLER-STACK-GROUP '(:BREAK))
     681                         (RETURN NIL))          ;Don't try to expose
     682                        (ANS (SHEET-CLEAR-LOCKS))))
     683                 ((AND (SHEET-EXPOSED-P W)      ;This can happen, I don't know how
     684                       (NOT (SHEET-LOCK W)))
     685                  (FUNCALL COLD-LOAD-STREAM ':HOME-CURSOR)
     686                  (IF (LET ((QUERY-IO COLD-LOAD-STREAM))
     687                        (FQUERY '(:BEEP T)
     688                                "~S is output-held for no apparent reason.~@
     689                                 If you know the circumstances that led to this, please~@
     690                                 mail in a bug report describing them.  ~
     691                                 Do you want to forcibly clear output-hold? "
     692                                W))
     693                      (SETF (SHEET-OUTPUT-HOLD-FLAG W) 0))))
     694           (FUNCALL W ':EXPOSE))
     695          ((BEEP)))))
     696
     697(DEFINE-SITE-VARIABLE *FINGER-ARG-ALIST* :ESC-F-ARG-ALIST)
     698
     699(DEFUN KBD-FINGER (ARG &AUX MODE HOSTS)
     700  (USING-RESOURCE (WINDOW POP-UP-FINGER-WINDOW)
     701    (SETF (SHEET-TRUNCATE-LINE-OUT-FLAG WINDOW) 1)
     702    (SETQ MODE (OR (CDR (ASSQ ARG *FINGER-ARG-ALIST*))
     703                   (CDR (ASSQ 'T *FINGER-ARG-ALIST*))
     704                   ':LOGIN)
     705          HOSTS (COND ((MEMQ MODE '(:LOGIN :ASSOCIATED))
     706                       (LIST (IF (EQ MODE ':LOGIN)
     707                                 FS:USER-LOGIN-MACHINE
     708                                 SI:ASSOCIATED-MACHINE)))
     709                      (T MODE)))
     710    (IF (LISTP HOSTS)
     711        (SETQ HOSTS (MAPCAR #'(LAMBDA (X) (STRING (SI:PARSE-HOST X))) HOSTS)))
     712    (FUNCALL WINDOW ':SET-LABEL
     713             (IF (EQ MODE ':READ) "Finger"
     714                 (WITH-OUTPUT-TO-STRING (STREAM)
     715                   (FUNCALL STREAM ':STRING-OUT "Who's on ")
     716                   (IF (EQ HOSTS ':LISP-MACHINES)
     717                       (FUNCALL STREAM ':STRING-OUT "Lisp Machines")
     718                       (LOOP FOR HOST IN HOSTS
     719                             WITH AND-P = NIL
     720                             DO (IF AND-P (FUNCALL STREAM ':STRING-OUT " and ")
     721                                          (SETQ AND-P T))
     722                             DO (FUNCALL STREAM ':STRING-OUT HOST))))))
     723    (FUNCALL WINDOW ':SET-PROCESS CURRENT-PROCESS)
     724    (WINDOW-CALL (WINDOW :DEACTIVATE)
     725      (LET ((TERMINAL-IO WINDOW))       ;In case of [Abort] printout and the like
     726        (SETQ KBD-ESC-TIME NIL) ;Window configuration stable now, let kbd process proceed
     727        (COND ((EQ HOSTS ':LISP-MACHINES)
     728               (CHAOS:FINGER-ALL-LMS WINDOW T))
     729              ((EQ HOSTS ':READ)
     730               (FORMAT WINDOW
     731                       "~&Finger (type NAME@HOST or just @HOST, followed by Return):~%")
     732               (CHAOS:FINGER (READLINE WINDOW) WINDOW))
     733              (T
     734               (LOOP FOR HOSTS ON HOSTS
     735                     WITH FIRST-P = T
     736                     DO (IF FIRST-P (SETQ FIRST-P NIL) (TERPRI WINDOW))
     737                     DO (CHAOS:FINGER (STRING-APPEND #/@ (CAR HOSTS)) WINDOW))))
     738        (FORMAT WINDOW "~&~%Type a space to flush: ")
     739        (FUNCALL WINDOW ':TYI)))))
     740
     741(DEFUN FINGER-ARG-PROMPT ()
     742  (WITH-OUTPUT-TO-STRING (STREAM)
     743    (FUNCALL STREAM ':STRING-OUT "Finger (")
     744    (LOOP FOR (ARG . VAL) IN *FINGER-ARG-ALIST*
     745          WITH ARG-PRINTED = NIL AND COMMA-P = NIL
     746          DO (IF COMMA-P (FUNCALL STREAM ':STRING-OUT ", ") (SETQ COMMA-P T))
     747          WHEN ARG
     748          DO (COND ((NOT ARG-PRINTED)
     749                    (FUNCALL STREAM ':STRING-OUT "or arg=")
     750                    (SETQ ARG-PRINTED T)))
     751             (PRIN1-THEN-SPACE ARG STREAM)
     752          DO (IF (SYMBOLP VAL)
     753                 (FUNCALL STREAM ':STRING-OUT (SELECTQ VAL
     754                                                (:LOGIN
     755                                                 (SI:HOST-SHORT-NAME FS:USER-LOGIN-MACHINE))
     756                                                (:ASSOCIATED
     757                                                 (SI:HOST-SHORT-NAME SI:ASSOCIATED-MACHINE))
     758                                                (:LISP-MACHINES
     759                                                 "Lisp machines")
     760                                                (:READ
     761                                                 "ask")))
     762                 (LOOP FOR HOST IN VAL
     763                       WITH PLUS-P = NIL
     764                       DO (IF PLUS-P (FUNCALL STREAM ':TYO #/+) (SETQ PLUS-P T))
     765                          (FUNCALL STREAM ':STRING-OUT (SI:HOST-SHORT-NAME HOST)))))
     766    (FUNCALL STREAM ':STRING-OUT ")")))
     767
     768(DEFUN KBD-HOSTAT ()
     769  (USING-RESOURCE (WINDOW POP-UP-FINGER-WINDOW)
     770    (SETF (SHEET-TRUNCATE-LINE-OUT-FLAG WINDOW) 1)
     771    (FUNCALL WINDOW ':SET-LABEL "Hostat")
     772    (FUNCALL WINDOW ':SET-PROCESS CURRENT-PROCESS)
     773    (WINDOW-CALL (WINDOW :DEACTIVATE)
     774      (LET ((TERMINAL-IO WINDOW))
     775        (SETQ KBD-ESC-TIME NIL)                 ;Window configuration stable.
     776        (HOSTAT)
     777        (FORMAT WINDOW "~&Type a space to flush: ")
     778        (FUNCALL WINDOW ':TYI)))))
     779
     780(DEFUN KBD-ESC-T (ARG)
     781  "Control the selected window's notification properties.
     782Toggle output notification and set input notification to the same thing.
     783 0 Turn off output and input notification.
     784 1 Turn on output and input notification.
     785 2 Turn output notification on and input notification off.
     786 3 Turn output notification off and input notification on.
     787 4 Let output proceed with window deexposed and turn input notification on.
     788 5 Let output proceed with window deexposed and turn input notification off."
     789  (COND ((NOT (OR (NULL ARG) (
     790 ARG 5)))
     791         (TV:BEEP))
     792        ((NOT (NULL SELECTED-WINDOW))                               
     793         (LET ((CURRENT-OUT-ACTION (FUNCALL SELECTED-WINDOW ':DEEXPOSED-TYPEOUT-ACTION)))
     794           (FUNCALL SELECTED-WINDOW ':SET-DEEXPOSED-TYPEOUT-ACTION
     795                    (COND ((OR (MEMQ ARG '(0 3))
     796                               (AND (NULL ARG)
     797                                    (NOT (EQ CURRENT-OUT-ACTION ':NORMAL))))
     798                           ':NORMAL)
     799                          ((OR (MEMQ ARG '(1 2))
     800                               (AND (NULL ARG)
     801                                    (NOT (EQ CURRENT-OUT-ACTION ':NOTIFY))))
     802                           ':NOTIFY)
     803                          ((MEMQ ARG '(4 5))
     804                           ':PERMIT)))
     805           (FUNCALL SELECTED-WINDOW ':SET-DEEXPOSED-TYPEIN-ACTION
     806                    (COND ((NULL ARG) (IF (EQ CURRENT-OUT-ACTION ':NORMAL) ':NOTIFY ':NORMAL))
     807                          ((MEMQ ARG '(0 2 5)) ':NORMAL)
     808                          (T ':NOTIFY)))))
     809        (T (TV:BEEP))))
    635810
    636811(DEFUN KBD-ESC-W (ARG &AUX PROC)
    637812  (SETQ PROC LAST-WHO-LINE-PROCESS)
    638813  (SELECTQ ARG
    639     (NIL (SHEET-CLEAR WHO-LINE-WINDOW)
    640          (WHO-LINE-CLOBBERED))
     814    (NIL (FUNCALL WHO-LINE-SCREEN ':REFRESH))
     815    (0 (SETQ WHO-LINE-PROCESS
     816             (LET ((ALIST (MAPCAR #'(LAMBDA (P) (CONS (PROCESS-NAME P) P)) ALL-PROCESSES)))
     817               (MENU-CHOOSE ALIST "Who-line process:" '(:MOUSE) (RASSOC PROC ALIST)))))
    641818    (1 (SETQ WHO-LINE-PROCESS NIL))
    642819    (2 (SETQ WHO-LINE-PROCESS PROC))
    643     (3 (SETQ WHO-LINE-PROCESS (DO ((L ACTIVE-PROCESSES (CDR L)))
    644                                   ((NULL L) (CAAR ACTIVE-PROCESSES))
    645                                 (AND (EQ (CAAR L) PROC)
    646                                      (RETURN (OR (CAADR L) (CAAR ACTIVE-PROCESSES)))))))
    647     (4 (SETQ WHO-LINE-PROCESS (OR (DO ((L ACTIVE-PROCESSES (CDR L))
     820    (3 (SETQ WHO-LINE-PROCESS (DO ((L ALL-PROCESSES (CDR L)))
     821                                  ((NULL L) (CAR ALL-PROCESSES))
     822                                (AND (EQ (CAR L) PROC)
     823                                     (RETURN (OR (CADR L) (CAR ALL-PROCESSES)))))))
     824    (4 (SETQ WHO-LINE-PROCESS (OR (DO ((L ALL-PROCESSES (CDR L))
    648825                                       (OL NIL L))
    649826                                      ((NULL L) NIL)
    650                                     (AND (EQ (CAAR L) PROC)
    651                                          (RETURN (CAAR OL))))
    652                                   (DO ((L ACTIVE-PROCESSES (CDR L))
    653                                        (OL NIL L))
    654                                       ((NULL (CAR L)) (CAAR OL)))))))
     827                                    (AND (EQ (CAR L) PROC)
     828                                         (RETURN (CAR OL))))
     829                                  (CAR (LAST ALL-PROCESSES))))))
    655830  (WHO-LINE-RUN-STATE-UPDATE)
    656831  (WHO-LINE-UPDATE))
    657832
     833(DEFINE-SITE-VARIABLE *SCREEN-HARDCOPY-MODE* :HARDCOPY-SCREEN-MODE)
     834
     835(DEFRESOURCE HARDCOPY-BIT-ARRAY ()
     836  :CONSTRUCTOR (MAKE-ARRAY '(1400 1730) ':TYPE 'ART-1B) ;Big enough for
     837  :INITIAL-COPIES 0)                            ; for (SET-TV-SPEED 60.)
     838
     839;;; ESC 0 Q copies without wholine, ESC 1 Q copies just selected window.
     840(DEFUN KBD-ESC-Q (ARG &AUX FUN)
     841  (IF (AND *SCREEN-HARDCOPY-MODE*
     842           (SETQ FUN (GET *SCREEN-HARDCOPY-MODE* 'KBD-ESC-Q-FUNCTION)))
     843      (USING-RESOURCE (ARRAY HARDCOPY-BIT-ARRAY)
     844        (MULTIPLE-VALUE-BIND (NIL WIDTH HEIGHT)
     845            (SNAPSHOT-SCREEN (SELECTQ ARG
     846                               (1 SELECTED-WINDOW)
     847                               (0 DEFAULT-SCREEN)
     848                               (OTHERWISE (MAIN-SCREEN-AND-WHO-LINE)))
     849                             ARRAY)
     850          (BEEP)
     851          (FUNCALL FUN ARRAY WIDTH HEIGHT)))
     852      (TV:NOTIFY NIL "I don't know how to hardcopy the screen at your site")))
     853
     854(DEFUN SNAPSHOT-SCREEN (FROM-ARRAY TO-ARRAY &OPTIONAL WIDTH HEIGHT)
     855  (WITHOUT-INTERRUPTS
     856    (COND ((ARRAYP FROM-ARRAY)
     857           (OR WIDTH (SETQ WIDTH (ARRAY-DIMENSION-N 1 FROM-ARRAY)))
     858           (OR HEIGHT (SETQ HEIGHT (ARRAY-DIMENSION-N 2 FROM-ARRAY))))
     859          (T
     860           (OR WIDTH (SETQ WIDTH (SHEET-WIDTH FROM-ARRAY)))
     861           (OR HEIGHT (SETQ HEIGHT (SHEET-HEIGHT FROM-ARRAY)))
     862           (SETQ FROM-ARRAY (OR (SHEET-SCREEN-ARRAY FROM-ARRAY)
     863                                (FERROR NIL "Window ~S does not have an array" FROM-ARRAY)))))
     864    (WHO-LINE-UPDATE)
     865    (BITBLT ALU-SETZ (ARRAY-DIMENSION-N 1 TO-ARRAY) (ARRAY-DIMENSION-N 2 TO-ARRAY)
     866            TO-ARRAY 0 0 TO-ARRAY 0 0)
     867    (BITBLT ALU-SETA WIDTH HEIGHT FROM-ARRAY 0 0 TO-ARRAY 0 0))
     868  (VALUES TO-ARRAY WIDTH HEIGHT))
     869
    658870(DEFUN KBD-ESC-HELP (IGNORE &AUX DOC (INDENT 15.))
    659   (SETF (SHEET-TRUNCATE-LINE-OUT-FLAG POP-UP-FINGER-WINDOW) 0)
    660   (FUNCALL POP-UP-FINGER-WINDOW ':SET-LABEL "Keyboard documentation")
    661   (WINDOW-MOUSE-CALL (POP-UP-FINGER-WINDOW :DEACTIVATE)
    662      (FORMAT POP-UP-FINGER-WINDOW "~25TType Terminal//Escape followed by:
    663 
    664 0-9, -~VTNumeric argument to following command~%" INDENT)
    665      (DOLIST (X *ESCAPE-KEYS*)
    666        (COND ((NULL (CAR X))
    667               (SETQ INDENT 20.)
    668               (FORMAT POP-UP-FINGER-WINDOW "~%~5XThese are for wizards:~2%"))
    669              ((SETQ DOC (EVAL (CADDR X)))
    670               (FORMAT POP-UP-FINGER-WINDOW "~:C~VT~A~%" (CAR X) INDENT
    671                       (IF (ATOM DOC) DOC (CAR DOC)))
    672               (OR (ATOM DOC) (DOLIST (LINE (CDR DOC))
    673                                (FORMAT POP-UP-FINGER-WINDOW "~VT~A~%" INDENT LINE))))))
    674      (FORMAT POP-UP-FINGER-WINDOW "~3%~25TNew-keyboard function keys:
    675 
    676 Macro           Keyboard macros (ed)            Abort           Kill running program
    677 Terminal        The above commands              Break           Get read-eval-print loop
    678 System          Select a Program                Resume          Continue from break/error
    679 Network         Supdup//Telnet commands         Call            Stop program, get a Lisp
    680 Quote           (not used)                      Status          (not used)
    681 Overstrike      /"backspace/"                   Delete          (not used)
    682 Clear-Input     Forget typein                   End             Terminate input
    683 Clear-Screen    Refresh screen                  Help            Print documentation
    684 Hold-Output     (not used)                      Return          Carriage return
    685 Stop-Output     (not used)                      Line            Next line and indent (ed)
     871  (USING-RESOURCE (WINDOW POP-UP-FINGER-WINDOW)
     872    (SETF (SHEET-TRUNCATE-LINE-OUT-FLAG WINDOW) 0)
     873    (FUNCALL WINDOW ':SET-LABEL "Keyboard documentation")
     874    (WINDOW-MOUSE-CALL (WINDOW :DEACTIVATE)
     875      (SETQ KBD-ESC-TIME NIL)
     876      (FORMAT WINDOW "~25TType Terminal//Escape followed by:
     877
     878Rubout~VTDo nothing. (Use this if you typed Terminal by accident and want to cancel it.)
     8790-9, -~VTNumeric argument to following command~%" INDENT INDENT)
     880      (DOLIST (X *ESCAPE-KEYS*)
     881        (COND ((NULL (CAR X))
     882               (SETQ INDENT 20.)
     883               (FORMAT WINDOW "~%~5XThese are for wizards:~2%"))
     884              ((SETQ DOC (EVAL (CADDR X)))
     885               (FORMAT WINDOW "~:C~VT~A~%" (CAR X) INDENT
     886                       (IF (ATOM DOC) DOC (CAR DOC)))
     887               (OR (ATOM DOC) (DOLIST (LINE (CDR DOC))
     888                                (FORMAT WINDOW "~VT~A~%" INDENT LINE))))))
     889      (FORMAT WINDOW "~3%~25TNew-keyboard function keys:
     890
     891Abort           Throw to command level          Break           Get read-eval-print loop
     892Control-Abort   To command level immediately    Control-Break   BREAK immediately
     893Meta-Abort      Throw out of all levels         Meta-Break      Get to error-handler
     894C-M-Abort       Out of all levels immediately   C-M-Break       Error-handler immediately
     895Macro           Keyboard macros (ed)            Stop-Output     (not used)
     896Terminal        The above commands              Resume          Continue from break//error
     897System          Select a Program                Call            Stop program, get a Lisp
     898Network         Supdup//Telnet commands         Status          (not used)
     899Quote           (not used)                      Delete          (not used)
     900Overstrike      /"backspace/"                   End             Terminate input
     901Clear-Input     Forget typein                   Help            Print documentation
     902Clear-Screen    Refresh screen                  Return          Carriage return
     903Hold-Output     (not used)                      Line            Next line and indent (ed)
    686904")
    687      (FORMAT POP-UP-FINGER-WINDOW "~%Type a space to flush: ")
    688      (FUNCALL POP-UP-FINGER-WINDOW ':TYI)))
     905      (FORMAT WINDOW "~%Type a space to flush: ")
     906      (FUNCALL WINDOW ':TYI))))
    689907
    690908;Keys you can type after SYSTEM.
    691 ;Each element is a list (character flavor documentation-string create-p)
    692 ;create-p is T if OK to create a window of that flavor, NIL if only select existing ones.
    693 ;If create-p is a list, it is the form to evaluate in a separate process to create
    694 ;one, otherwise the window is created the default way and assumed to provide its
    695 ;own process and whatever else it may require.
     909;Each element is a list (character flavor documentation-string create-flavor)
     910;If create-p is NIL if can only select existing ones.  create-p is list of
     911;form to evaluate to create one.  If create-flavor is T, window is created from flavor,
     912;any other symbol is the name of the flavor.
    696913;In place of the flavor you may also have the window itself.
    697914(DEFVAR *SYSTEM-KEYS*
    698      '( (#/E NZWEI:ZMACS-FRAME "Editor" T)
    699         (#/I INSPECT-FRAME "Inspector" (TV:INSPECT))
    700         (#/L LISP-LISTENER "Lisp" T)
     915     '( (#/E ZWEI:ZMACS-FRAME "Editor" T)
     916        (#/I INSPECT-FRAME "Inspector" (PROGN (SETQ KBD-ESC-TIME NIL) (TV:INSPECT)))
     917        (#/L LISTENER-MIXIN "Lisp" LISP-LISTENER)
    701918        (#/P PEEK "Peek" T)
    702         (#/R EH:ERROR-HANDLER-FRAME "Window error-handler" NIL)
    703         (#/S SUPDUP:SUPDUP "Supdup" T)
     919        ;(#/R EH:ERROR-HANDLER-FRAME "Window error-handler" NIL)  ;not a program!
     920        (#/S (PROGN SUPDUP:SUPDUP-FLAVOR) "Supdup" T)
    704921        (#/T SUPDUP:TELNET "Telnet" T) ))
    705922
     
    715932         (KBD-SNARF-INPUT SELECTED-IO-BUFFER T)))
    716933  (SETQ KBD-ESC-TIME (TIME))
    717   (PROCESS-RUN-FUNCTION "KBD SYS" #'KBD-SYS-1 CH))
    718 
    719 (DEFUN KBD-SYS-1 (CH &AUX E W SW)
     934  (PROCESS-RUN-TEMPORARY-FUNCTION "KBD SYS" #'KBD-SYS-1 CH))
     935
     936(DEFUN KBD-SYS-1 (CH &AUX E W SW MAKENEW FLAVOR-OR-WINDOW)
     937  (SETQ MAKENEW (LDB-TEST %%KBD-CONTROL CH)
     938        CH (LDB %%KBD-CHAR CH))
    720939  (COND ((OR (= CH #/?) (= CH #\HELP))
    721          (SETF (SHEET-TRUNCATE-LINE-OUT-FLAG POP-UP-FINGER-WINDOW) 0)
    722          (FUNCALL POP-UP-FINGER-WINDOW ':SET-LABEL "Keyboard system commands")
    723          (WINDOW-CALL (POP-UP-FINGER-WINDOW :DEACTIVATE)
    724            (FORMAT POP-UP-FINGER-WINDOW
    725                    "Type ~:@C followed by one of these letters to select the corresponding ~
     940         (USING-RESOURCE (WINDOW POP-UP-FINGER-WINDOW)
     941           (SETF (SHEET-TRUNCATE-LINE-OUT-FLAG WINDOW) 0)
     942           (FUNCALL WINDOW ':SET-LABEL "Keyboard system commands")
     943           (WINDOW-CALL (WINDOW :DEACTIVATE)
     944             (FORMAT WINDOW
     945                     "Type ~:@C followed by one of these letters to select the corresponding ~
    726946                    program:~2%~:{~C~8T~*~A~%~}"
    727                    #\SYSTEM *SYSTEM-KEYS*)
    728            (FORMAT POP-UP-FINGER-WINDOW "~%Type a space to flush: ")
    729            (FUNCALL POP-UP-FINGER-WINDOW ':TYI)))
     947                     #\SYSTEM *SYSTEM-KEYS*)
     948             (FORMAT
     949               WINDOW
     950               "~%Hold down control to create a new one.~@
     951                Type Rubout after System to do nothing (if you typed System by accident).~%~@
     952                Type a space to flush: ")
     953             (SETQ KBD-ESC-TIME NIL)            ;Let kbd process proceed before we TYI.
     954             (FUNCALL WINDOW ':TYI))))
    730955        ((SETQ E (ASSQ CH *SYSTEM-KEYS*))
    731956         ;; Find the most recently selected window of the desired type.
     
    737962         ;; that has already been properly taken care of and we don't want to snarf
    738963         ;; any characters already typed after the [SYSTEM] command.
     964         (SETQ FLAVOR-OR-WINDOW
     965               (COND ((LISTP (SECOND E)) (EVAL (SECOND E)))
     966                     (T (SECOND E))))
    739967         (DELAYING-SCREEN-MANAGEMENT    ;Inhibit auto selection
    740            (COND ((= (%DATA-TYPE (SECOND E)) DTP-INSTANCE)
     968           (COND ((= (%DATA-TYPE FLAVOR-OR-WINDOW) DTP-INSTANCE)
     969                  ;; If the *SYSTEM-KEYS* list has a specific window indicated, use that.
    741970                  (AND (SETQ SW SELECTED-WINDOW) (FUNCALL SW ':DESELECT NIL))
    742                   (FUNCALL (SECOND E) ':MOUSE-SELECT))
    743                  ((SETQ W (FIND-WINDOW-OF-FLAVOR (SECOND E)))   ;Already exists?
     971                  (FUNCALL FLAVOR-OR-WINDOW ':MOUSE-SELECT))
     972                 ((AND (NOT MAKENEW)
     973                       (SETQ W (FIND-WINDOW-OF-FLAVOR FLAVOR-OR-WINDOW)))
     974                  ;; Cycle through other windows of this flavor.
    744975                  (COND ((SETQ SW SELECTED-WINDOW)
    745976                         (FUNCALL SW ':DESELECT NIL)
    746                          (AND (TYPEP SW (SECOND E))
     977                         (AND (TYPEP SW FLAVOR-OR-WINDOW)
    747978                              (ADD-TO-PREVIOUSLY-SELECTED-WINDOWS SW T))))
    748979                  (FUNCALL W ':MOUSE-SELECT))
    749                  ((TYPEP SELECTED-WINDOW (SECOND E))    ;Already got one, don't make more
     980                 ((AND (NOT MAKENEW)
     981                       (SETQ SW SELECTED-WINDOW)
     982                       (TYPEP (FUNCALL SW ':ALIAS-FOR-SELECTED-WINDOWS) FLAVOR-OR-WINDOW))
     983                  ;; There is only one window of this flavor, and this is it.
    750984                  (BEEP))
    751985                 ((NULL (FOURTH E)) (BEEP))     ;Cannot create
    752                  ((EQ (FOURTH E) T)
     986                 ((NLISTP (FOURTH E))
     987                  ;; Create a new window of this flavor.
    753988                  (AND (SETQ SW SELECTED-WINDOW) (FUNCALL SW ':DESELECT NIL))
    754                   (FUNCALL (WINDOW-CREATE (SECOND E)) ':MOUSE-SELECT))
     989                  (FUNCALL (MAKE-WINDOW (IF (EQ (FOURTH E) T) FLAVOR-OR-WINDOW (FOURTH E)))
     990                           ':MOUSE-SELECT))
    755991                 (T (EVAL (FOURTH E))))))
    756992        (( CH #\RUBOUT) (BEEP)))
     
    7661002
    7671003
     1004;;; Notification (call side)
     1005
     1006(DEFVAR NOTIFICATION-HISTORY NIL)       ;Each entry is list of time and string
     1007(ADD-INITIALIZATION "Forget old notifications"
     1008                    '(SETQ NOTIFICATION-HISTORY NIL)
     1009                    '(:BEFORE-COLD))
     1010
     1011;Reprint notifications, newest first
     1012(DEFUN PRINT-NOTIFICATIONS ()
     1013  (FORMAT T "~&~:[No notifications.~;Notifications, most recent first:~]~%"
     1014            NOTIFICATION-HISTORY)
     1015  (DOLIST (N NOTIFICATION-HISTORY)
     1016    (TIME:PRINT-BRIEF-UNIVERSAL-TIME (FIRST N))
     1017    (FORMAT T " ~A~%" (SECOND N))))
     1018
     1019(DEFUN NOTIFY (WINDOW-OF-INTEREST FORMAT-CONTROL &REST FORMAT-ARGS)
     1020  "Notify the user with an unsolicited message.
     1021The message is generated from FORMAT-CONTROL and FORMAT-ARGS.
     1022If WINDOW-OF-INTEREST is non-NIL, it is a window to be made available to
     1023Terminal-0-S and maybe another way depending on who prints the notification"
     1024  (LEXPR-FUNCALL #'CAREFUL-NOTIFY WINDOW-OF-INTEREST NIL FORMAT-CONTROL FORMAT-ARGS))
     1025
     1026(DEFUN CAREFUL-NOTIFY (WINDOW-OF-INTEREST CAREFUL-P FORMAT-CONTROL &REST FORMAT-ARGS)
     1027  "Like NOTIFY but will not hang up waiting for locks if CAREFUL-P is T.
     1028If locks are locked or there is no selected-window, returns NIL.  If succeeds
     1029in printing the notification, returns T."
     1030  (LET ((TIME (TIME:GET-UNIVERSAL-TIME))
     1031        (MESSAGE (LEXPR-FUNCALL #'FORMAT NIL FORMAT-CONTROL FORMAT-ARGS)))
     1032    (PUSH (LIST TIME MESSAGE) NOTIFICATION-HISTORY)
     1033    (COND (WINDOW-OF-INTEREST                   ;Make this window "interesting"
     1034           (WITHOUT-INTERRUPTS
     1035             (OR (MEMQ WINDOW-OF-INTEREST BACKGROUND-INTERESTING-WINDOWS)
     1036                 (PUSH WINDOW-OF-INTEREST BACKGROUND-INTERESTING-WINDOWS)))
     1037           (IF (SHEET-CAN-GET-LOCK WINDOW-OF-INTEREST)     ;Try to make available to sys menu
     1038               (FUNCALL WINDOW-OF-INTEREST ':ACTIVATE))))  ;but don't bother if locked
     1039    ;Get a selected-window to which to send the :print-notification message
     1040    (IF (NOT CAREFUL-P)
     1041        ;; What this piece of hair is all about is that we don't want to pick a window
     1042        ;; to print the notification on and then have that window deexposed out from
     1043        ;; under us, causing us to hang forever.  So we lock the window while printing
     1044        ;; the notification, which is assumed is going to be on either the window itself
     1045        ;; or one of its direct or indirect inferiors.  Any windows which don't print
     1046        ;; their notification this way must spawn a separate process to do the printing.
     1047        (LOOP AS INHIBIT-SCHEDULING-FLAG = T AS SW = SELECTED-WINDOW
     1048              WHEN (AND (NOT (NULL SW))
     1049                        (SHEET-CAN-GET-LOCK SW))
     1050                RETURN (LOCK-SHEET (SW)
     1051                         (SETQ INHIBIT-SCHEDULING-FLAG NIL)
     1052                         (FUNCALL SW ':PRINT-NOTIFICATION TIME MESSAGE WINDOW-OF-INTEREST))
     1053              DO (SETQ INHIBIT-SCHEDULING-FLAG NIL)
     1054                 (PROCESS-WAIT "A selected window"
     1055                               #'(LAMBDA (SW) (OR (NEQ SELECTED-WINDOW SW)
     1056                                                  (AND SW (SHEET-CAN-GET-LOCK SW))))
     1057                               SW))
     1058        ;; In this case, we simply want to punt if we don't seem to be able to acquire
     1059        ;; the necessary locks.  This doesn't use WITHOUT-INTERRUPTS and has a timing
     1060        ;; window which I don't think it is possible to close.
     1061        (LET ((SW SELECTED-WINDOW))
     1062          (COND ((OR (NULL SW)                  ;No one in charge
     1063                     (SHEET-OUTPUT-HELD-P SW)   ;Guy in charge locked or broken
     1064                     (NOT (SHEET-CAN-GET-LOCK   ;Anything locked, even by this process,
     1065                            (SHEET-GET-SCREEN SW) T)))  ; that would hang Terminal-0-S
     1066                 NIL)                           ;Lose, don't try to notify
     1067                (T                              ;Win, go ahead
     1068                 (FUNCALL SW ':PRINT-NOTIFICATION TIME MESSAGE WINDOW-OF-INTEREST)
     1069                 T))))))
     1070
     1071
    7681072;;; Background stream
    7691073
    7701074;(DEFVAR DEFAULT-BACKGROUND-STREAM 'BACKGROUND-STREAM)  ;in COLD
    771 (DEFVAR BACKGROUND-STREAM-BELL-COUNT 3)
    7721075(DEFVAR PROCESS-IS-IN-ERROR NIL)
    7731076(DEFVAR BACKGROUND-INTERESTING-WINDOWS NIL)
    7741077
    775 (DEFMACRO MAKE-SELF-INTERESTING ()     
    776   `(PROGN
    777      (WITHOUT-INTERRUPTS
    778        (OR (MEMQ SELF BACKGROUND-INTERESTING-WINDOWS)
    779            (PUSH SELF BACKGROUND-INTERESTING-WINDOWS)))
    780      (FUNCALL-SELF ':ACTIVATE)))
    781 
    7821078(DEFFLAVOR BACKGROUND-LISP-INTERACTOR () (LISP-INTERACTOR)
    783   (:DEFAULT-INIT-PLIST :DEEXPOSED-TYPEOUT-ACTION '(:BACKGROUND-TYPEOUT)))
     1079  (:DEFAULT-INIT-PLIST :DEEXPOSED-TYPEOUT-ACTION ':NOTIFY
     1080                       :DEEXPOSED-TYPEIN-ACTION ':NOTIFY))
    7841081
    7851082(DEFMETHOD (BACKGROUND-LISP-INTERACTOR :BEFORE :INIT) (PLIST)
     
    7901087  (SETQ PROCESS NP))
    7911088
    792 (DEFMETHOD (BACKGROUND-LISP-INTERACTOR :BACKGROUND-TYPEOUT) ()
    793   (MAKE-SELF-INTERESTING)
    794   (WITHOUT-INTERRUPTS
    795     (AND SCREEN-ARRAY (SETF (SHEET-OUTPUT-HOLD-FLAG) 0)))
    796   (NOTIFY-USER "wants the TTY" SELF))
    797 
    7981089(DEFMETHOD (BACKGROUND-LISP-INTERACTOR :AFTER :SELECT) (&REST IGNORE)
    7991090  (WITHOUT-INTERRUPTS
     
    8061097(DEFMETHOD (BACKGROUND-LISP-INTERACTOR :WAIT-UNTIL-SEEN) ()
    8071098  ;; If we have typed out since we were selected last, then wait until we get seen
    808   (PROCESS-WAIT "Seen" #'(LAMBDA (S)
    809                            (NOT (MEMQ S BACKGROUND-INTERESTING-WINDOWS)))
    810                 SELF)
    811   ;; Then wait until we are deselected
    812   (PROCESS-WAIT "No Longer Seen" #'(LAMBDA (S) (NEQ S SELECTED-WINDOW)) SELF))
    813 
    814 (DEFMETHOD (BACKGROUND-LISP-INTERACTOR :BEFORE :TYI) (&REST IGNORE)
    815   (COND ((OR (FUNCALL-SELF ':LISTEN)
    816              EXPOSED-P))
    817         (T (MAKE-SELF-INTERESTING)
    818            (NOTIFY-USER "wants typein" SELF))))
     1099  (COND ((MEMQ SELF BACKGROUND-INTERESTING-WINDOWS)
     1100         (PROCESS-WAIT "Seen" #'(LAMBDA (S)
     1101                                  (NOT (MEMQ S BACKGROUND-INTERESTING-WINDOWS)))
     1102                       SELF)
     1103         ;; Then wait until we are deselected
     1104         (PROCESS-WAIT "No Longer Seen" #'(LAMBDA (S) (NEQ S SELECTED-WINDOW)) SELF))))
    8191105
    8201106(DEFVAR BACKGROUND-STREAM-WHICH-OPERATIONS)
     
    8291115          ;; Get the which-operations once, but after the flavor has been compiled
    8301116          (OR (BOUNDP 'BACKGROUND-STREAM-WHICH-OPERATIONS)
    831               (SETQ BACKGROUND-STREAM-WHICH-OPERATIONS
    832                     (APPEND '(:NOTIFY :BEEP)
    833                             (FUNCALL (CAR BACKGROUND-LISP-INTERACTORS) ':WHICH-OPERATIONS))))
     1117              (USING-RESOURCE (WINDOW BACKGROUND-LISP-INTERACTORS)
     1118                (LET ((WO (FUNCALL WINDOW ':WHICH-OPERATIONS)))
     1119                  (SETQ BACKGROUND-STREAM-WHICH-OPERATIONS
     1120                        (IF (MEMQ ':BEEP WO) WO (CONS ':BEEP WO))))))
    8341121          BACKGROUND-STREAM-WHICH-OPERATIONS)
    8351122          ;; If the stream hasn't changed since the process was started, do default action
     
    8481135            (FUNCALL TERMINAL-IO ':CLEAR-SCREEN))
    8491136          (FUNCALL TERMINAL-IO ':ACTIVATE)
    850           (DOTIMES (I BACKGROUND-STREAM-BELL-COUNT) (BEEP))
    851           (IF (EQ OP ':NOTIFY)
    852               (NOTIFY-USER (CAR ARGS))
    853               (LEXPR-FUNCALL TERMINAL-IO OP ARGS))))
     1137          (LEXPR-FUNCALL TERMINAL-IO OP ARGS)))
    8541138      (SETQ TERMINAL-IO DEFAULT-BACKGROUND-STREAM)
    8551139      (LEXPR-FUNCALL TERMINAL-IO OP ARGS)))
    856 
    857 (DEFUN NOTIFY-USER (MESSAGE &OPTIONAL (WINDOW TERMINAL-IO) &AUX NOTIFY-STREAM ERROR-P)
    858   (COND ((EQ MESSAGE ':ERROR)
    859          (SETQ ERROR-P T)
    860          (SETQ MESSAGE "got an error")))
    861   (OR (AND ERROR-P (SHEET-EXPOSED-P WINDOW))
    862       (DO ((INHIBIT-SCHEDULING-FLAG T T))
    863           (SELECTED-WINDOW
    864             ;; Notify the user only if he didn't select our window
    865             (SETQ NOTIFY-STREAM (AND (OR (NOT ERROR-P) (NEQ SELECTED-WINDOW WINDOW))
    866                                      ;; Notify user if the specified window isn't selected,
    867                                      ;; or if it is a non-error notification
    868                                      (FUNCALL SELECTED-WINDOW
    869                                               ':NOTIFY-STREAM WINDOW))))
    870         (SETQ INHIBIT-SCHEDULING-FLAG NIL)
    871         (PROCESS-WAIT "A Selected Window" #'(LAMBDA () SELECTED-WINDOW))))
    872   (COND (NOTIFY-STREAM
    873          (TV:BEEP)
    874          (FORMAT NOTIFY-STREAM "~&[Process ~A ~A]~%" (PROCESS-NAME CURRENT-PROCESS) MESSAGE)))
    875   (AND ERROR-P
    876        (NOT (SHEET-EXPOSED-P WINDOW))
    877        ;; If notifying for an error, remain "in error" until selected
    878        (LET ((PROCESS-IS-IN-ERROR WINDOW))
    879          (PROCESS-WAIT "Selected" #'(LAMBDA (W) (EQ SELECTED-WINDOW W)) WINDOW))))
    880 
    881 ;;; This is like the above function, without the various extra
    882 ;;; features.  It just gives a background process a stream on
    883 ;;; which it may print something it has to say.  By convention
    884 ;;; we usually enclose such messages and brackets and do a beep.
    885 (DEFUN GET-NOTIFICATION-STREAM ()
    886  (DO ((INHIBIT-SCHEDULING-FLAG T T))
    887      (SELECTED-WINDOW
    888        (FUNCALL SELECTED-WINDOW ':NOTIFY-STREAM NIL))
    889    (SETQ INHIBIT-SCHEDULING-FLAG NIL)
    890    (PROCESS-WAIT "A Selected Window" #'(LAMBDA () SELECTED-WINDOW))))
    8911140
    8921141(DEFUN FIND-PROCESS-IN-ERROR (&AUX WINDOW SG)
  • trunk/lisp/lmwin/baswin.lisp

    r220 r275  
     1
    12;;; -*- Mode: LISP;  Package: TV; Base: 8 -*-
    23;;;     ** (c) Copyright 1980 Massachusetts Institute of Technology **
     
    5354                               (MINIMUM-HEIGHT (OR (GET INIT-PLIST ':MINIMUM-HEIGHT) 0)))
    5455                           (MULTIPLE-VALUE-LIST
    55                              (MOUSE-SPECIFY-RECTANGLE NIL NIL NIL NIL SUPERIOR
    56                                                       MINIMUM-WIDTH MINIMUM-HEIGHT))))
     56                             (MOUSE-SPECIFY-RECTANGLE-SET-SHEET NIL NIL NIL NIL SUPERIOR
     57                                                                MINIMUM-WIDTH
     58                                                                MINIMUM-HEIGHT))))
    5759                        ((TYPEP EDGES-FROM 'ESSENTIAL-WINDOW)
    5860                         ;; A window, use it's edges
     
    8183
    8284(DEFFLAVOR WINDOW-WITHOUT-LABEL () (STREAM-MIXIN BORDERS-MIXIN SELECT-MIXIN
    83                                     POP-UP-NOTIFICATION-MIXIN MINIMUM-WINDOW))
     85                                    POP-UP-NOTIFICATION-MIXIN GRAPHICS-MIXIN MINIMUM-WINDOW))
    8486
    8587(DEFFLAVOR WINDOW () (STREAM-MIXIN BORDERS-MIXIN LABEL-MIXIN SELECT-MIXIN
     
    190192  (OR (COND ((GET-HANDLER-FOR SELF ':LABEL)
    191193             (SETQ LABEL (FUNCALL-SELF ':LABEL))
    192              (IF (STRINGP LABEL)
    193                  LABEL
    194                  (LABEL-STRING LABEL))))
     194             (OR (STRINGP LABEL) (SETQ LABEL (LABEL-STRING LABEL)))
     195             (AND (STRING-SEARCH-NOT-CHAR #\SP LABEL) LABEL)))
    195196      NAME))
    196197
     
    237238  (FUNCALL WINDOW ':SELECT))
    238239
    239 (DEFMETHOD (SELECT-MIXIN :BREAK) (&AUX LAST-PROCESS)
    240   (AND (SETQ LAST-PROCESS (FUNCALL-SELF ':PROCESS))
    241        (FUNCALL LAST-PROCESS ':FORCE-BREAK)))
    242 
    243 (DEFMETHOD (SELECT-MIXIN :ABORT) (&AUX LAST-PROCESS)
    244   (AND (SETQ LAST-PROCESS (FUNCALL-SELF ':PROCESS))
    245        (FUNCALL LAST-PROCESS ':RESET)))
    246 
    247240(DEFMETHOD (SELECT-MIXIN :ARREST) (&AUX LAST-PROCESS)
    248241  (AND (SETQ LAST-PROCESS (FUNCALL-SELF ':PROCESS))
     
    263256  "Form of select used when 'mouseing' windows.  Clears all temp locks that are on the
    264257window, as well as failing if the window is not fully within its superior."
     258  (FUNCALL-SELF ':ACTIVATE)             ;Maybe our size has to get adjusted first
    265259  (COND ((SHEET-WITHIN-SHEET-P SELF SUPERIOR)
    266260         (SHEET-FREE-TEMPORARY-LOCKS SELF)      ;Flush all temp windows that cover us
     
    287281  (DO SHEET SUPERIOR (SHEET-SUPERIOR SHEET) (NULL SHEET)        ;Really onto the screen
    288282    (OR (SHEET-EXPOSED-P SHEET) (FUNCALL SHEET ':EXPOSE)))
    289   (AND OSW SAVE-SELECTED (NEQ SELF OSW)
    290        (ADD-TO-PREVIOUSLY-SELECTED-WINDOWS OSW)))
     283  (WITHOUT-INTERRUPTS
     284    (AND OSW SAVE-SELECTED (NEQ SELF OSW)
     285         (NEQ (FUNCALL OSW ':STATUS) ':DEACTIVATED)     ;Deexposing can deactivate
     286         (ADD-TO-PREVIOUSLY-SELECTED-WINDOWS OSW))))
    291287
    292288(DEFMETHOD (SELECT-MIXIN :AFTER :SELECT) (&REST IGNORE)
     
    440436and :CENTER-AROUND."))
    441437
     438(DEFMETHOD (ESSENTIAL-SET-EDGES :AFTER :INIT) (IGNORE)
     439  (LET ((ERROR-MESSAGE (FUNCALL-SELF ':VERIFY-NEW-EDGES X-OFFSET Y-OFFSET WIDTH HEIGHT)))
     440    (IF (NOT (NULL ERROR-MESSAGE))
     441        (FERROR NIL ERROR-MESSAGE))))
     442
    442443(DEFMETHOD (ESSENTIAL-SET-EDGES :SET-EDGES) (&REST ARGS) (APPLY #'SYSTEM-SET-EDGES ARGS))
    443444
     
    476477  (CENTER-WINDOW-AROUND SELF X Y))
    477478
     479(DEFMETHOD (ESSENTIAL-SET-EDGES :EXPOSE-NEAR) (MODE &OPTIONAL (WARP-MOUSE-P T))
     480  (EXPOSE-WINDOW-NEAR SELF MODE WARP-MOUSE-P))
     481
    478482(DEFUN CENTER-WINDOW-AROUND (WINDOW X Y &AUX (W (SHEET-WIDTH WINDOW))
    479483                                             (H (SHEET-HEIGHT WINDOW))
     
    483487        Y (MAX (SHEET-INSIDE-TOP SUPERIOR) (- Y (// H 2))))
    484488  (AND (> (+ X W) (SETQ SW (SHEET-INSIDE-RIGHT SUPERIOR)))
    485        (SETQ X (- SW W)))
     489       (SETQ X (MAX (SHEET-INSIDE-LEFT SUPERIOR) (- SW W))))
    486490  (AND (> (+ Y H) (SETQ SH (SHEET-INSIDE-BOTTOM SUPERIOR)))
    487        (SETQ Y (- SH H)))
     491       (SETQ Y (MAX (SHEET-INSIDE-TOP SUPERIOR) (- SH H))))
    488492  (FUNCALL WINDOW ':SET-POSITION X Y)
    489493  (PROG () (RETURN (+ X (// W 2)) (+ Y (// H 2)))))
     
    493497                         &AUX (NEW-WIDTH (- NEW-RIGHT NEW-LEFT))
    494498                              (NEW-HEIGHT (- NEW-BOTTOM NEW-TOP))
    495                               ERROR)
    496   ;; As long as the new edges are within the superior, let it get set
    497   (LOCK-SHEET (SELF)
    498     (COND ((SETQ ERROR (FUNCALL-SELF ':VERIFY-NEW-EDGES NEW-LEFT NEW-TOP
    499                                      NEW-WIDTH NEW-HEIGHT))
    500            ;; Can't put window there
    501            (SELECTQ OPTION
    502              (:VERIFY NIL)
    503              (OTHERWISE
    504                (FERROR NIL ERROR))))
    505           ((EQ OPTION ':VERIFY)
    506            ;; "Only want to know"
    507            T)
    508           ((AND (= NEW-WIDTH WIDTH)
    509                 (= NEW-HEIGHT HEIGHT)
    510                 (= NEW-LEFT X-OFFSET)
    511                 (= NEW-TOP Y-OFFSET))
    512            ;;Not changing size or position, just return T (we do the verify anyway in case
    513            ;; something in the environment has made the current size no longer "ok", such as
    514            ;; having the size of the superior change.)
    515            T)
    516           ((AND (= NEW-WIDTH WIDTH)
    517                 (= NEW-HEIGHT HEIGHT))
    518            ;; Only moving the window, move it's bits behind its back
    519            (LET ((OX X-OFFSET)
    520                  (OY Y-OFFSET)
    521                  (SUPERIOR-ARRAY (SHEET-SUPERIOR-SCREEN-ARRAY))
    522                  (CURRENT-RECTANGLE (LIST X-OFFSET Y-OFFSET
    523                                           (+ X-OFFSET WIDTH)
    524                                           (+ Y-OFFSET HEIGHT))))
    525              (DELAYING-SCREEN-MANAGEMENT
    526                (COND ((OR (NOT EXPOSED-P) (SHEET-TEMPORARY-P))
    527                       ;; In the case of temporary windows, this will deexpose/expose
    528                       (SHEET-SET-POSITION NEW-LEFT NEW-TOP))
    529                      (T
    530                       (PREPARE-SHEET (SELF)
    531                         (SHEET-SET-POSITION NEW-LEFT NEW-TOP)
    532                         (BITBLT ALU-SETA
    533                                 (IF (> OX NEW-LEFT) NEW-WIDTH (- NEW-WIDTH))
    534                                 (IF (> OY NEW-TOP) NEW-HEIGHT (- NEW-HEIGHT))
    535                                 SUPERIOR-ARRAY OX OY
    536                                 SUPERIOR-ARRAY NEW-LEFT NEW-TOP))
    537                       (SETQ MOUSE-RECONSIDER T)))
    538                (LEXPR-FUNCALL #'SCREEN-AREA-HAS-CHANGED SELF CURRENT-RECTANGLE)
    539                (SCREEN-CONFIGURATION-HAS-CHANGED SELF))))
    540           (T
    541            (DELAYING-SCREEN-MANAGEMENT
    542              (LET ((CURRENT-RECTANGLE (LIST X-OFFSET Y-OFFSET
    543                                             (+ X-OFFSET WIDTH)
    544                                             (+ Y-OFFSET HEIGHT))))
    545                 (WITH-SHEET-DEEXPOSED (SELF)
    546                   (AND BIT-ARRAY (SI:PAGE-IN-ARRAY BIT-ARRAY NIL (LIST WIDTH HEIGHT)))
    547                   (FUNCALL-SELF ':CHANGE-OF-SIZE-OR-MARGINS
    548                                 ':LEFT NEW-LEFT ':TOP NEW-TOP
    549                                 ':WIDTH NEW-WIDTH ':HEIGHT NEW-HEIGHT)
    550                   (SHEET-FORCE-ACCESS (SELF :NO-PREPARE)
    551                     (FUNCALL-SELF ':REFRESH ':SIZE-CHANGED)))
    552                 (AND BIT-ARRAY (SI:PAGE-OUT-ARRAY BIT-ARRAY))
    553                 (SETQ MOUSE-RECONSIDER T)
    554                 (LEXPR-FUNCALL #'SCREEN-AREA-HAS-CHANGED SELF CURRENT-RECTANGLE)
    555                 (SCREEN-CONFIGURATION-HAS-CHANGED SELF)))))))
     499                              ERROR WINDOW-TO-BE-DEEXPOSED)
     500  (DELAYING-SCREEN-MANAGEMENT
     501    (DO (DONE RESULT) (())
     502      (SETQ WINDOW-TO-BE-DEEXPOSED
     503          (*CATCH 'SET-EDGES
     504            (LOCK-SHEET (SELF)
     505              (SETQ RESULT
     506                (COND ((SETQ ERROR (FUNCALL-SELF ':VERIFY-NEW-EDGES NEW-LEFT NEW-TOP
     507                                                 NEW-WIDTH NEW-HEIGHT))
     508                       ;; Can't put window there
     509                       (SELECTQ OPTION
     510                         (:VERIFY NIL)
     511                         (OTHERWISE
     512                          (FERROR NIL ERROR))))
     513                      ((EQ OPTION ':VERIFY)
     514                       ;; "Only want to know"
     515                       T)
     516                      ((AND (= NEW-WIDTH WIDTH)
     517                            (= NEW-HEIGHT HEIGHT)
     518                            (= NEW-LEFT X-OFFSET)
     519                            (= NEW-TOP Y-OFFSET))
     520                       ;;Not changing size or position, just return T (we do the verify
     521                       ;; anyway in case something in the environment has made the current
     522                       ;; size no longer "ok", such as having the size of the
     523                       ;; superior change.)
     524                       T)
     525                      ((AND (= NEW-WIDTH WIDTH)
     526                            (= NEW-HEIGHT HEIGHT))
     527                       ;; Only moving the window, move it's bits behind its back
     528                       (LET ((CURRENT-RECTANGLE (LIST X-OFFSET Y-OFFSET
     529                                                      (+ X-OFFSET WIDTH)
     530                                                      (+ Y-OFFSET HEIGHT))))
     531                         (COND ((NOT EXPOSED-P)
     532                                (SHEET-SET-DEEXPOSED-POSITION NEW-LEFT NEW-TOP)
     533                                (LEXPR-FUNCALL #'SCREEN-AREA-HAS-CHANGED SELF
     534                                               CURRENT-RECTANGLE)
     535                                (SCREEN-CONFIGURATION-HAS-CHANGED SELF))
     536                               ((SHEET-TEMPORARY-P)
     537                                ;; For temporary windows, just deexpose and reexpose
     538                                (LET ((SELECT-P (EQ SELF SELECTED-WINDOW)))
     539                                  (FUNCALL-SELF ':DEEXPOSE)
     540                                  (FUNCALL-SELF ':EXPOSE NIL NIL NEW-LEFT NEW-TOP)
     541                                  (AND SELECT-P (FUNCALL-SELF ':SELECT))))
     542                               (T
     543                                (OR (SHEET-BOUNDS-WITHIN-SHEET-P NEW-LEFT NEW-TOP
     544                                                                 WIDTH HEIGHT
     545                                                                 SUPERIOR)
     546                                    (FERROR NIL
     547                                            "Attempt to move sheet ~S outside of superior"
     548                                            SELF))
     549                                ;; Make sure everyone under us is deexposed
     550                                (WITHOUT-INTERRUPTS
     551                                  (DOLIST (SISTER (SHEET-EXPOSED-INFERIORS SUPERIOR))
     552                                    (COND ((AND (NEQ SELF SISTER)
     553                                                (SHEET-OVERLAPS-P SISTER NEW-LEFT NEW-TOP
     554                                                                  WIDTH HEIGHT))
     555                                           (*THROW 'SET-EDGES SISTER)))))
     556                                (SHEET-SET-EXPOSED-POSITION NEW-LEFT NEW-TOP)
     557                                (LEXPR-FUNCALL #'SCREEN-AREA-HAS-CHANGED SELF
     558                                               CURRENT-RECTANGLE)
     559                                (SCREEN-CONFIGURATION-HAS-CHANGED SELF)))))
     560                      (T
     561                       (LET ((CURRENT-RECTANGLE (LIST X-OFFSET Y-OFFSET
     562                                                      (+ X-OFFSET WIDTH)
     563                                                      (+ Y-OFFSET HEIGHT))))
     564                         (WITH-SHEET-DEEXPOSED (SELF)
     565                           (AND BIT-ARRAY
     566                                (SI:PAGE-IN-ARRAY BIT-ARRAY NIL (LIST WIDTH HEIGHT)))
     567                           (FUNCALL-SELF ':CHANGE-OF-SIZE-OR-MARGINS
     568                                         ':LEFT NEW-LEFT ':TOP NEW-TOP
     569                                         ':WIDTH NEW-WIDTH ':HEIGHT NEW-HEIGHT)
     570                           (SHEET-FORCE-ACCESS (SELF :NO-PREPARE)
     571                             (FUNCALL-SELF ':REFRESH ':SIZE-CHANGED)))
     572                         (AND BIT-ARRAY (SI:PAGE-OUT-ARRAY BIT-ARRAY))
     573                         (SETQ MOUSE-RECONSIDER T)
     574                         (LEXPR-FUNCALL #'SCREEN-AREA-HAS-CHANGED SELF CURRENT-RECTANGLE)
     575                         (SCREEN-CONFIGURATION-HAS-CHANGED SELF)))))
     576              (SETQ DONE T))))
     577      (IF DONE
     578          (RETURN RESULT ERROR)
     579          (FUNCALL WINDOW-TO-BE-DEEXPOSED ':DEEXPOSE)))))
    556580)  ;End declare
    557581
     
    586610 (SHEET-INSIDE-BOTTOM SUPERIOR) (SETQ TEM (+ BOTTOM HEIGHT)))
    587611                (SETQ NTOP BOTTOM NBOTTOM TEM))
    588                (T (FERROR NIL "No screen space available")))))
     612               (T (SETQ NTOP (SHEET-INSIDE-TOP SUPERIOR)
     613                        NBOTTOM (+ NTOP HEIGHT))))))
    589614  (FUNCALL WINDOW ':SET-EDGES NLEFT NTOP NRIGHT NBOTTOM)
    590615  (AND EXPOSE-P (FUNCALL WINDOW ':EXPOSE))
    591616  (AND WARP-MOUSE-P (FUNCALL WINDOW ':SET-MOUSE-POSITION (// WIDTH 2) (// HEIGHT 2))))
    592617
    593 (DEFUN EXPOSE-WINDOW-NEAR (WINDOW MODE &OPTIONAL (WARP-MOUSE-P T))
     618(DEFUN EXPOSE-WINDOW-NEAR (WINDOW MODE &OPTIONAL (WARP-MOUSE-P T) (EXPOSE-P T))
    594619  (COND ((NOT (SHEET-EXPOSED-P WINDOW))
    595620         (SELECTQ (FIRST MODE)
     
    607632                                NIL WARP-MOUSE-P))
    608633           (:WINDOW
    609             (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
    610                 (FUNCALL (SECOND MODE) ':EDGES)
    611               (DOLIST (W (CDDR MODE))
    612                 (MULTIPLE-VALUE-BIND (LEFT1 TOP1 RIGHT1 BOTTOM1) (FUNCALL W ':EDGES)
    613                   (SETQ LEFT (MIN LEFT LEFT1)
    614                         TOP (MIN TOP TOP1)
    615                         RIGHT (MAX RIGHT RIGHT1)
    616                         BOTTOM (MAX BOTTOM BOTTOM1))))
    617               (MOVE-WINDOW-NEAR-RECTANGLE WINDOW LEFT TOP RIGHT BOTTOM NIL WARP-MOUSE-P)))
     634            (LOOP FOR NEAR-WINDOW IN (CDR MODE) WITH (LEFT1 RIGHT1 TOP1 BOTTOM1 X-OFF Y-OFF)
     635                  DO (MULTIPLE-VALUE (LEFT1 TOP1 RIGHT1 BOTTOM1)
     636                       (FUNCALL NEAR-WINDOW ':EDGES))
     637                     (MULTIPLE-VALUE-BIND (X-OFF-1 Y-OFF-1)
     638                         (SHEET-CALCULATE-OFFSETS (SHEET-SUPERIOR WINDOW)
     639                                                  (SHEET-GET-SCREEN WINDOW))
     640                       (MULTIPLE-VALUE-BIND (X-OFF-2 Y-OFF-2)
     641                           (SHEET-CALCULATE-OFFSETS (SHEET-SUPERIOR NEAR-WINDOW)
     642                                                    (SHEET-GET-SCREEN NEAR-WINDOW))
     643                         (SETQ X-OFF (- X-OFF-1 X-OFF-2)
     644                               Y-OFF (- Y-OFF-1 Y-OFF-2))))
     645                  MINIMIZE (- LEFT1 X-OFF) INTO LEFT
     646                  MINIMIZE (- TOP1 Y-OFF) INTO TOP
     647                  MAXIMIZE (- RIGHT1 X-OFF) INTO RIGHT
     648                  MAXIMIZE (- BOTTOM1 Y-OFF) INTO BOTTOM
     649                  FINALLY (MOVE-WINDOW-NEAR-RECTANGLE WINDOW LEFT TOP RIGHT BOTTOM
     650                                                      NIL WARP-MOUSE-P)))
    618651           (OTHERWISE (FERROR NIL "~S invalid mode" (FIRST MODE))))
    619          (FUNCALL WINDOW ':EXPOSE))))
     652         (AND EXPOSE-P (FUNCALL WINDOW ':EXPOSE)))))
    620653
    621654
     
    644677           (AND BIT-ARRAY (SI:PAGE-IN-ARRAY BIT-ARRAY))
    645678           (LET ((INSIDE-SIZE-CHANGED
    646                    (LEXPR-FUNCALL-SELF ':CHANGE-OF-SIZE-OR-MARGINS (CAR PLIST))))
     679                   (LEXPR-FUNCALL-SELF ':CHANGE-OF-SIZE-OR-MARGINS (CDR PLIST))))
    647680             (SHEET-FORCE-ACCESS (SELF :NO-PREPARE)
    648681               (FUNCALL-SELF ':REFRESH (IF INSIDE-SIZE-CHANGED
     
    714747  (SHEET-FORCE-ACCESS (SELF)
    715748    (DOLIST (BORDER BORDERS)
    716       (LET ((LEFT (SECOND BORDER))
    717             (TOP (THIRD BORDER))
    718             (RIGHT (FOURTH BORDER))
    719             (BOTTOM (FIFTH BORDER)))
    720         (FUNCALL (FIRST BORDER) SELF ALU
    721                  (IF (MINUSP LEFT) (+ LEFT WIDTH) LEFT)
    722                  (IF (MINUSP TOP) (+ TOP HEIGHT) TOP)
    723                  (IF (PLUSP RIGHT) RIGHT (+ RIGHT WIDTH))
    724                  (IF (PLUSP BOTTOM) BOTTOM (+ BOTTOM HEIGHT))))))))
     749      (AND BORDER
     750           (NEQ BORDER ':ZERO)
     751           (LET ((LEFT (SECOND BORDER))
     752                 (TOP (THIRD BORDER))
     753                 (RIGHT (FOURTH BORDER))
     754                 (BOTTOM (FIFTH BORDER)))
     755             (FUNCALL (FIRST BORDER) SELF ALU
     756                      (IF (MINUSP LEFT) (+ LEFT WIDTH) LEFT)
     757                      (IF (MINUSP TOP) (+ TOP HEIGHT) TOP)
     758                      (IF (PLUSP RIGHT) RIGHT (+ RIGHT WIDTH))
     759                      (IF (PLUSP BOTTOM) BOTTOM (+ BOTTOM HEIGHT)))))))))
    725760
    726761;;;This is called with the new border specification and the current (relative to this
     
    728763;;;margins.
    729764(DECLARE-FLAVOR-INSTANCE-VARIABLES (BORDERS-MIXIN)
    730 (DEFUN PARSE-BORDERS-SPEC (SPEC LM TM RM BM FUNCTION)
     765(DEFUN PARSE-BORDERS-SPEC (SPEC LM TM RM BM FUNCTION &OPTIONAL DEFAULT-SIZE)
    731766  (COND ;;NIL means no borders at all
    732767        (SPEC
     
    750785              (ITEM))
    751786             ((NULL SPEC))
    752            (COND ((NULL (SETQ ITEM (CAR SPEC))))
     787           (COND ((OR (NULL (SETQ ITEM (CAR SPEC)))
     788                      (EQ ITEM ':ZERO)))
    753789                 ;;A number means that width of the default function
    754790                 ((NUMBERP ITEM)
     
    757793                 ((SYMBOLP ITEM)
    758794                  (AND (EQ ITEM T) (SETQ ITEM FUNCTION))
    759                   (SETF (CAR SPEC) (CONS ITEM (GET ITEM 'DEFAULT-BORDER-SIZE))))))
     795                  (SETF (CAR SPEC) (CONS ITEM (OR DEFAULT-SIZE
     796                                                  (GET ITEM 'DEFAULT-BORDER-SIZE)))))))
    760797         (DO ((SPEC SPEC (CDR SPEC))
    761798              (TYPES '(:LEFT :TOP :RIGHT :BOTTOM) (CDR TYPES))
     
    765802             ((NULL SPEC))
    766803           ;;A cons of a symbol and a number is the CAR function with the CDR width
    767            (AND (SETQ ITEM (CAR SPEC)) (SETQ WIDTH (CDR ITEM))
     804           (AND (SETQ ITEM (CAR SPEC)) (LISTP ITEM) (SETQ WIDTH (CDR ITEM))
    768805                (IF (ATOM WIDTH)
    769806                    (SETF (CDR ITEM) (LIST (IF (EQ (SETQ TYPE (CAR TYPES)) ':RIGHT) WIDTH 0)
     
    781818         ;;Now adjust all non-NIL items for the current margins
    782819         (DO ((SPEC SPEC (CDR SPEC))
    783               (NEGATE-P '(NIL NIL T T) (CDR NEGATE-P))
    784820              (TYPES '(:LEFT :TOP :RIGHT :BOTTOM) (CDR TYPES))
    785821              (TYPE)
     
    788824              (HEIGHT))
    789825             ((NULL SPEC))
    790            (COND ((SETQ ITEM (CAR SPEC))
     826           (COND ((AND (SETQ ITEM (CAR SPEC)) (LISTP ITEM))
    791827                  (SETQ TYPE (CAR TYPES))
    792828                  (SETQ WIDTH (ABS (- (FOURTH ITEM) (SECOND ITEM)))
    793829                        HEIGHT (ABS (- (FIFTH ITEM) (THIRD ITEM))))
    794                   (SETF (SECOND ITEM)
    795                         (IF (EQ TYPE ':RIGHT) (- (+ (SECOND ITEM) RM)) (+ (SECOND ITEM) LM)))
    796                   (SETF (THIRD ITEM)
    797                         (IF (EQ TYPE ':BOTTOM) (- (+ (THIRD ITEM) BM)) (+ (THIRD ITEM) TM)))
    798                   (SETF (FOURTH ITEM)
    799                         (IF (EQ TYPE ':LEFT) (+ (FOURTH ITEM) LM) (- (+ (FOURTH ITEM) RM))))
    800                   (SETF (FIFTH ITEM)
    801                         (IF (EQ TYPE ':TOP) (+ (FIFTH ITEM) TM) (- (+ (FIFTH ITEM) BM))))
    802                   (SELECTQ TYPE
    803                     (:LEFT (SETQ LM (+ LM WIDTH)))
    804                     (:TOP (SETQ TM (+ TM HEIGHT)))
    805                     (:RIGHT (SETQ RM (+ RM WIDTH)))
    806                     (:BOTTOM (SETQ BM (+ BM HEIGHT)))))))
     830                  (COND ((SELECTQ TYPE
     831                           ((:LEFT :RIGHT) (ZEROP WIDTH))
     832                           ((:TOP :BOTTOM) (ZEROP HEIGHT)))
     833                         (SETF (CAR SPEC) ':ZERO))
     834                        (T ;; Order here is L R T B to give symmetry
     835                           (SETF (SECOND ITEM)
     836                                 (IF (EQ TYPE ':RIGHT)
     837                                     (- (+ (SECOND ITEM) RM))
     838                                     (+ (SECOND ITEM) LM)))
     839                           (SETF (FOURTH ITEM)
     840                                 (IF (EQ TYPE ':LEFT)
     841                                     (+ (FOURTH ITEM) LM)
     842                                     (- (+ (FOURTH ITEM) RM))))
     843                           (SETF (THIRD ITEM)
     844                                 (IF (EQ TYPE ':BOTTOM)
     845                                     (- (+ (THIRD ITEM) BM))
     846                                     (+ (THIRD ITEM) TM)))
     847                           (SETF (FIFTH ITEM)
     848                                 (IF (EQ TYPE ':TOP)
     849                                     (+ (FIFTH ITEM) TM)
     850                                     (- (+ (FIFTH ITEM) BM))))
     851                           (SELECTQ TYPE
     852                             (:LEFT (SETQ LM (+ LM WIDTH)))
     853                             (:TOP (SETQ TM (+ TM HEIGHT)))
     854                             (:RIGHT (SETQ RM (+ RM WIDTH)))
     855                             (:BOTTOM (SETQ BM (+ BM HEIGHT)))))))))
    807856         ;;Now account for the extra margin
    808857         (AND (FIRST SPEC) (SETQ LM (+ LM BORDER-MARGIN-WIDTH)))
     
    888937;;;into a list, onto which other things can then be added.
    889938(DECLARE-FLAVOR-INSTANCE-VARIABLES (ESSENTIAL-LABEL-MIXIN)
    890 (DEFUN PARSE-LABEL-SPEC (SPEC LM TM RM BM &OPTIONAL HEIGHT TOP-P)
     939(DEFUN PARSE-LABEL-SPEC (SPEC LM TM RM BM &OPTIONAL (HEIGHT NIL HEIGHT-P) TOP-P)
    891940  (OR HEIGHT (SETQ HEIGHT (FONT-CHAR-HEIGHT (SCREEN-DEFAULT-FONT (SHEET-GET-SCREEN SELF)))))
    892941  (COND (SPEC
     
    899948         (SETQ SPEC (IF (LISTP SPEC) (APPEND SPEC NIL) (MAKE-LIST NIL 4)))
    900949         (LET ((BOTTOM (LABEL-BOTTOM SPEC)) (TOP (LABEL-TOP SPEC)))
    901            (AND BOTTOM TOP (SETQ HEIGHT (- BOTTOM TOP))))
     950           (AND BOTTOM TOP (NOT HEIGHT-P) (SETQ HEIGHT (- BOTTOM TOP))))
    902951         (SETF (LABEL-LEFT SPEC) LM)
    903952         (SETF (LABEL-RIGHT SPEC) (- RM))
     
    908957  (PROG () (RETURN SPEC LM TM RM BM))))
    909958
    910 (DEFSTRUCT (LABEL-MIXIN :LIST (:INCLUDE ESSENTIAL-LABEL-MIXIN) (:CONSTRUCTOR NIL))
     959(DEFSTRUCT (LABEL-MIXIN :LIST (:INCLUDE ESSENTIAL-LABEL-MIXIN) (:CONSTRUCTOR NIL)
     960                        (:SIZE-SYMBOL LABEL-DEFSTRUCT-SIZE))
    911961  LABEL-FONT
    912962  LABEL-STRING)
     
    922972(DEFMETHOD (LABEL-MIXIN :PARSE-LABEL-SPEC) (SPEC LM TM RM BM &OPTIONAL TOP-P &AUX FONT NSPEC)
    923973  (COND (SPEC
    924          (SETQ FONT (OR (AND (EQ (TYPEP SPEC) 'FONT) SPEC)
     974         (AND (LISTP SPEC) (MEMQ (CAR SPEC) '(:STRING :FONT :TOP :BOTTOM))
     975              (DO ((LIST SPEC (CDR LIST))
     976                   (STRING NIL))
     977                  ((NULL LIST)
     978                   (SETQ SPEC (LIST NIL NIL NIL NIL FONT STRING)))
     979                (SELECTQ (CAR LIST)
     980                  (:STRING (SETQ STRING (CADR LIST)
     981                                 LIST (CDR LIST)))
     982                  (:FONT (SETQ FONT (CADR LIST)
     983                               LIST (CDR LIST)))
     984                  (:TOP (SETQ TOP-P T))
     985                  (:BOTTOM (SETQ TOP-P NIL))
     986                  (OTHERWISE (FERROR NIL "~S is not a recognized keyword" (CAR LIST))))))
     987         (SETQ FONT (OR (AND (EQ (TYPEP SPEC) 'FONT) (PROG1 SPEC (SETQ SPEC T)))
    925988                        (AND (LISTP SPEC) (LABEL-FONT SPEC))
    926989                        (SCREEN-DEFAULT-FONT (SHEET-GET-SCREEN SELF))))
     
    929992         (MULTIPLE-VALUE (NSPEC LM TM RM BM)
    930993           (PARSE-LABEL-SPEC SPEC LM TM RM BM (FONT-CHAR-HEIGHT FONT) TOP-P))
    931          (LET ((TEM (- (GET 'LABEL-MIXIN 'SI:DEFSTRUCT-SIZE) (LENGTH NSPEC))))
     994         (LET ((TEM (- LABEL-DEFSTRUCT-SIZE (LENGTH NSPEC))))
    932995           (AND (> TEM 0) (RPLACD (LAST NSPEC) (MAKE-LIST NIL TEM))))
    933996         (SETF (LABEL-FONT NSPEC) FONT)
     
    936999                                              ((AND (LISTP SPEC) (LABEL-STRING SPEC))
    9371000                                               (LABEL-STRING SPEC))
     1001                                              ((NEQ SPEC T) (STRING SPEC))
    9381002                                              (T NAME))))
    9391003         (SETQ SPEC NSPEC)))
     
    9431007  BOTTOM
    9441008  (AND SPEC
    945        (SHEET-STRING-OUT-EXPLICIT SELF (LABEL-STRING SPEC) LEFT TOP (- RIGHT LEFT)
     1009       (SHEET-STRING-OUT-EXPLICIT SELF (LABEL-STRING SPEC) LEFT TOP RIGHT
    9461010                                  (LABEL-FONT SPEC) CHAR-ALUF)))
    9471011
     
    9521016                      (- (LABEL-BOTTOM LABEL) (LABEL-TOP LABEL)))
    9531017              (RETURN 0 0))))
     1018
     1019(DEFMETHOD (LABEL-MIXIN :AFTER :CHANGE-OF-DEFAULT-FONT) (OLD-FONT NEW-FONT)
     1020  (COND ((AND LABEL (EQ (LABEL-FONT LABEL) OLD-FONT))
     1021         (SETF (LABEL-FONT LABEL) NEW-FONT)
     1022         (FUNCALL-SELF ':SET-LABEL LABEL))))
    9541023
    9551024(DEFFLAVOR DELAYED-REDISPLAY-LABEL-MIXIN ((LABEL-NEEDS-UPDATING NIL)) ()
     
    9761045
    9771046(DEFMETHOD (TOP-LABEL-MIXIN :PARSE-LABEL-SPEC) (SPEC LM TM RM BM)
    978   (LABEL-MIXIN-PARSE-LABEL-SPEC-METHOD ':PARSE-LABEL-SPEC SPEC LM TM RM BM T))
     1047  (FUNCALL #'(:METHOD LABEL-MIXIN :PARSE-LABEL-SPEC) ':PARSE-LABEL-SPEC SPEC LM TM RM BM T))
    9791048
    9801049(DEFFLAVOR TOP-BOX-LABEL-MIXIN () (LABEL-MIXIN)
     
    9851054(DEFMETHOD (TOP-BOX-LABEL-MIXIN :PARSE-LABEL-SPEC) (SPEC LM TM RM BM)
    9861055  (MULTIPLE-VALUE (SPEC LM TM RM BM)
    987     (LABEL-MIXIN-PARSE-LABEL-SPEC-METHOD ':PARSE-LABEL-SPEC SPEC LM TM RM BM T))
     1056    (FUNCALL #'(:METHOD LABEL-MIXIN :PARSE-LABEL-SPEC) ':PARSE-LABEL-SPEC
     1057             SPEC LM TM RM BM T))
    9881058  (AND SPEC (SETQ TM (1+ TM)))
    9891059  (PROG () (RETURN SPEC LM TM RM BM)))
     
    9931063  (SHEET-FORCE-ACCESS (SELF)
    9941064    (%DRAW-RECTANGLE (- RIGHT LEFT) 1 LEFT (1- BOTTOM) CHAR-ALUF SELF)))
     1065
     1066(DEFFLAVOR BOTTOM-BOX-LABEL-MIXIN () (LABEL-MIXIN)
     1067  (:DOCUMENTATION :MIXIN "Label at the bottom, with a line above.
     1068If the label is a string or defaults to the name, it is at the bottom.
     1069When combined with BORDERS-MIXIN, the label will be surrounded by a box."))
     1070
     1071(DEFMETHOD (BOTTOM-BOX-LABEL-MIXIN :PARSE-LABEL-SPEC) (SPEC LM TM RM BM)
     1072  (MULTIPLE-VALUE (SPEC LM TM RM BM)
     1073    (FUNCALL #'(:METHOD LABEL-MIXIN :PARSE-LABEL-SPEC) ':PARSE-LABEL-SPEC SPEC LM TM RM BM))
     1074  (AND SPEC (SETQ BM (+ 2 BM)))
     1075  (PROG () (RETURN SPEC LM TM RM BM)))
     1076
     1077(DEFMETHOD (BOTTOM-BOX-LABEL-MIXIN :AFTER :DRAW-LABEL) (SPEC LEFT TOP RIGHT BOTTOM)
     1078  SPEC BOTTOM
     1079  (SHEET-FORCE-ACCESS (SELF)
     1080    (%DRAW-RECTANGLE (- RIGHT LEFT) 1 LEFT (1- TOP) CHAR-ALUF SELF)))
    9951081
    9961082;;; Flavor that allows you to change the name of the window, and
     
    10551141                  (EQUAL FULL-SCREEN (MULTIPLE-VALUE-LIST (FUNCALL I ':SIZE)))
    10561142                  (RETURN I))))
    1057   (OR LL (WINDOW-CREATE 'LISP-LISTENER ':SUPERIOR SUPERIOR)))
     1143  (OR LL (MAKE-WINDOW 'LISP-LISTENER ':SUPERIOR SUPERIOR)))
    10581144
    10591145(DEFFLAVOR TEMPORARY-WINDOW-MIXIN () ()
     
    10851171           (GET-HANDLER-FOR WINDOW ':PROCESS)
    10861172           (PUTPROP INIT-PLIST (FUNCALL WINDOW ':PROCESS) ':PROCESS))
    1087       (SETQ NEW-WINDOW (LEXPR-FUNCALL #'WINDOW-CREATE NEW-TYPE (CAR INIT-PLIST)))
     1173      (SETQ NEW-WINDOW (LEXPR-FUNCALL #'MAKE-WINDOW NEW-TYPE (CAR INIT-PLIST)))
    10881174      (CHANGE-IN-PREVIOUSLY-SELECTED-WINDOWS WINDOW NEW-WINDOW)
    10891175      (FUNCALL WINDOW ':DEACTIVATE)
     
    11711257  (AND (LISTP PROCESS)
    11721258       (LET ((PRESET PROCESS))
    1173          (SETQ PROCESS (LEXPR-FUNCALL #'PROCESS-CREATE NAME (CDR PRESET)))
     1259         (SETQ PROCESS (LEXPR-FUNCALL #'MAKE-PROCESS NAME (CDR PRESET)))
    11741260         (PROCESS-PRESET PROCESS (CAR PRESET) SELF))))
    11751261
     1262;;; *** This is a horrible crock.  If the "program system" is ever implemented,
     1263;;; *** this should be flushed and replaced by the concept that selecting a program
     1264;;; *** does something appropriate to its processes.
    11761265;;; I dont know if this is really the right thing
    11771266(DEFMETHOD (PROCESS-MIXIN :BEFORE :EXPOSE) MAYBE-RESET-PROCESS)
    11781267(DEFMETHOD (PROCESS-MIXIN :BEFORE :SELECT) MAYBE-RESET-PROCESS)
    11791268(DECLARE-FLAVOR-INSTANCE-VARIABLES (PROCESS-MIXIN)
    1180 (DEFUN MAYBE-RESET-PROCESS (&REST IGNORE)
    1181   (COND ((AND PROCESS (= (%DATA-TYPE PROCESS) DTP-INSTANCE)
    1182               (EQ (PROCESS-WAIT-FUNCTION PROCESS) #'FALSE))
    1183          ;; Reset the process, then make sure it has a run reason
    1184          (FUNCALL PROCESS ':RESET)))
    1185   (AND PROCESS (FUNCALL PROCESS ':RUN-REASON SELF))))
     1269(DEFUN MAYBE-RESET-PROCESS (MESSAGE &REST IGNORE)
     1270  (COND ((OR (EQ MESSAGE ':SELECT)
     1271             (LOOP FOR SUP = SUPERIOR THEN (SHEET-SUPERIOR SUP) UNTIL (NULL SUP)
     1272                   ALWAYS (SHEET-EXPOSED-P SUP)))
     1273         ;; Only touch the process if the window is going to become visible.  This
     1274         ;; makes many of the processes in the initial cold-load not have run reasons
     1275         ;; until you first select their window.  This makes booting faster (pages less).
     1276         ;; Also this is necessary to make the editor work:
     1277         ;; What was happening was that when the editor created its first
     1278         ;; pane and exposed it within its deactivated frame, the editor's process was
     1279         ;; being prematurely started up when it didn't even have all its instance
     1280         ;; variables yet, never mind enough editor environment set up.  The editor
     1281         ;; process would thus immediately get an error, which would later be reset
     1282         ;; asynchronously, leaving a second-level error handler around forever.
     1283         (COND ((TYPEP PROCESS 'SI:PROCESS)
     1284                ;; If we really have a process (not just NIL or something),
     1285                ;; Reset the process if it is flushed, then make sure it has a run reason.
     1286                (IF (EQ (PROCESS-WAIT-FUNCTION PROCESS) #'FALSE)
     1287                    (FUNCALL PROCESS ':RESET))
     1288                (FUNCALL PROCESS ':RUN-REASON SELF)))))))
    11861289
    11871290;Don't kill the process until all methods
     
    11911294(DEFWRAPPER (PROCESS-MIXIN :KILL) (() . BODY)
    11921295  `(PROGN ,@BODY
    1193           (AND PROCESS (FUNCALL PROCESS ':KILL))))
    1194 
    1195 (DEFFLAVOR LISTENER-MIXIN () (PROCESS-MIXIN)
     1296          (AND PROCESS
     1297               (FUNCALL PROCESS ':KILL))))
     1298
     1299(DEFFLAVOR LISTENER-MIXIN-INTERNAL () (PROCESS-MIXIN)
    11961300  (:DOCUMENTATION :SPECIAL-PURPOSE "An actual LISP window
    1197 Includes a process that will run the lisp top level read-eval-print loop."))
    1198 
    1199 (DEFMETHOD (LISTENER-MIXIN :BEFORE :INIT) (IGNORE)
     1301Includes a process that will run the lisp top level read-eval-print loop.
     1302Use this rather than LISTENER-MIXIN when you want to be invisible to the SYSTEM L key."))
     1303
     1304(DEFMETHOD (LISTENER-MIXIN-INTERNAL :BEFORE :INIT) (IGNORE)
    12001305  (OR PROCESS (SETQ PROCESS '(SI:LISP-TOP-LEVEL1 :REGULAR-PDL-SIZE 40000
    12011306                                                 :SPECIAL-PDL-SIZE 4000))))
    12021307
    1203 
    1204 (DEFFLAVOR LISP-INTERACTOR () (NOTIFICATION-MIXIN LISTENER-MIXIN WINDOW)
     1308(DEFFLAVOR LISTENER-MIXIN () (LISTENER-MIXIN-INTERNAL)
     1309  (:DOCUMENTATION :SPECIAL-PURPOSE "An actual LISP window
     1310Includes a process that will run the lisp top level read-eval-print loop.
     1311Use this when you want to be visible to the SYSTEM L key."))
     1312
     1313
     1314(DEFFLAVOR LISP-INTERACTOR () (NOTIFICATION-MIXIN LISTENER-MIXIN-INTERNAL WINDOW)
    12051315  (:DEFAULT-INIT-PLIST :SAVE-BITS T)
    12061316  (:DOCUMENTATION :COMBINATION "LISP window, but not LISP-LISTENER-P"))
     
    12461356  (:DOCUMENTATION :COMBINATION "A pop up window what truncates lines"))
    12471357
     1358(DEFFLAVOR RESET-ON-OUTPUT-HOLD-FLAG-MIXIN () ()
     1359  (:DEFAULT-INIT-PLIST :DEEXPOSED-TYPEOUT-ACTION '(:RESET-ON-OUTPUT-HOLD-FLAG)))
     1360
     1361(DEFMETHOD (RESET-ON-OUTPUT-HOLD-FLAG-MIXIN :RESET-ON-OUTPUT-HOLD-FLAG) ()
     1362  (FUNCALL CURRENT-PROCESS ':RESET ':ALWAYS))
     1363
     1364(DEFFLAVOR TRUNCATING-POP-UP-TEXT-WINDOW-WITH-RESET ()
     1365           (RESET-ON-OUTPUT-HOLD-FLAG-MIXIN TRUNCATING-POP-UP-TEXT-WINDOW))
     1366
     1367;;; This mixin is useful for those windows that are created during the world-load.
     1368;;; It is disconcerting when you suddenly see them appearing after you reshape
     1369;;; some window.  This mixin causes them to be invisible and immune to autoexposure.
     1370;;; They don't appear on the screen until you explicitly ask for them.  However, they
     1371;;; are still active and appear on the Select menu.
     1372(DEFFLAVOR INITIALLY-INVISIBLE-MIXIN () ()
     1373  (:DEFAULT-INIT-PLIST :PRIORITY -2))
     1374
     1375(DEFMETHOD (INITIALLY-INVISIBLE-MIXIN :BEFORE :EXPOSE) (&REST IGNORE)
     1376  (FUNCALL-SELF ':SET-PRIORITY NIL))
     1377
     1378
     1379
    12481380;;; Some notification stuff
     1381
    12491382(DEFFLAVOR NOTIFICATION-MIXIN () ()
    1250   (:DOCUMENTATION :MIXIN "Prints :NOTIFY messages on itself
    1251 Windows such as a lisp-listener which can easily accomodate unsolicted typeout in a
    1252 more or less random place since they generally have the users attention at the end
    1253 should include this to print notification messages there."))
    1254 
    1255 (DEFMETHOD (NOTIFICATION-MIXIN :NOTIFY-STREAM) (&OPTIONAL IGNORE)
    1256   "Return a stream useable for notifing the user about some sort of condition.  Default
    1257 is to use the window itself.  Some things, such as the editor, may wish to shadow this."
    1258   SELF)
     1383  (:REQUIRED-METHODS :PROCESS)
     1384  (:INCLUDED-FLAVORS STREAM-MIXIN ESSENTIAL-WINDOW)
     1385  (:DOCUMENTATION :MIXIN "Prints notifications on itself when selected.
     1386A window which can easily accomodate unsolicited typeout, such as a Lisp listener,
     1387uses this mixin to cause notifications to be printed on it when it is selected.
     1388The user's attention is assumed to be at the cursor of the selected window.
     1389This mixin also interacts with the rubout-handler of STREAM-MIXIN."))
     1390
     1391;;; Note: this does not try to do anything smart with the prompt, because doing
     1392;;; that right requires resolving some hairy issues which simply are not worth it.
     1393(DEFMETHOD (NOTIFICATION-MIXIN :PRINT-NOTIFICATION) (TIME STRING WINDOW-OF-INTEREST)
     1394  WINDOW-OF-INTEREST ;ignored
     1395  (LET ((RUBOUT-X NIL) (RUBOUT-Y NIL)   ;Cursorpos of start of current rubout-handler input
     1396        PROCESS SG)
     1397    (LOCK-SHEET (SELF)
     1398      (WITHOUT-INTERRUPTS
     1399        (AND (SETQ PROCESS (FUNCALL-SELF ':PROCESS))
     1400             (SETQ SG (FUNCALL PROCESS ':STACK-GROUP))
     1401             (SYMEVAL-IN-STACK-GROUP 'RUBOUT-HANDLER-INSIDE SG)
     1402             (SETQ RUBOUT-X (SYMEVAL-IN-STACK-GROUP 'RUBOUT-HANDLER-STARTING-X SG)
     1403                   RUBOUT-Y (SYMEVAL-IN-STACK-GROUP 'RUBOUT-HANDLER-STARTING-Y SG))))
     1404      ;; If the process is in the rubout-handler, back up over the echoed input and erase it.
     1405      (COND (RUBOUT-X (FUNCALL-SELF ':SET-CURSORPOS RUBOUT-X RUBOUT-Y)
     1406                      (FUNCALL-SELF ':CLEAR-EOL)))
     1407      (FUNCALL-SELF ':FRESH-LINE)
     1408      (FUNCALL-SELF ':BEEP)
     1409      (FUNCALL-SELF ':TYO #/[)
     1410      (TIME:PRINT-BRIEF-UNIVERSAL-TIME TIME SELF)
     1411      (FUNCALL-SELF ':TYO #\SP)
     1412      (FUNCALL-SELF ':STRING-OUT STRING)
     1413      (FUNCALL-SELF ':TYO #/])
     1414      (FUNCALL-SELF ':TYO #\CR)
     1415      ;; Reprint rubout-handler buffer if necessary, and change the rubout-handler's
     1416      ;; starting cursorpos
     1417      (COND (RUBOUT-X (MULTIPLE-VALUE-BIND (X Y) (FUNCALL-SELF ':READ-CURSORPOS)
     1418                        (WITHOUT-INTERRUPTS
     1419                          (EH:REBIND-IN-STACK-GROUP 'RUBOUT-HANDLER-STARTING-X X SG)
     1420                          (EH:REBIND-IN-STACK-GROUP 'RUBOUT-HANDLER-STARTING-Y Y SG))
     1421                        (FUNCALL-SELF ':STRING-OUT RUBOUT-HANDLER-BUFFER)))))))
    12591422
    12601423(DEFFLAVOR POP-UP-NOTIFICATION-MIXIN () ()
    12611424  (:INCLUDED-FLAVORS ESSENTIAL-WINDOW)
    1262   (:DOCUMENTATION :MIXIN "Pops up a window for :NOTIFY messages
     1425  (:DOCUMENTATION :MIXIN "Pops up a window for notifications.
    12631426This is the default sort of notify, it pops up a small window with the notify message
    1264 in it.  See the basic-notification mixin for an alternative behaviour."))
    1265 
    1266 (DEFMETHOD (POP-UP-NOTIFICATION-MIXIN :NOTIFY-STREAM) (&OPTIONAL WINDOW-OF-INTEREST &AUX NOTE-WINDOW)
    1267   (SETQ NOTE-WINDOW (ALLOCATE-RESOURCE 'POP-UP-NOTIFICATION-WINDOW-RESOURCE))
    1268   (FUNCALL NOTE-WINDOW ':SET-SUPERIOR SUPERIOR)
    1269   (FUNCALL NOTE-WINDOW ':SET-WINDOW-OF-INTEREST WINDOW-OF-INTEREST)
    1270   (FUNCALL NOTE-WINDOW ':SET-EDGES
    1271            X-OFFSET Y-OFFSET
    1272            (+ X-OFFSET WIDTH) (+ Y-OFFSET (MIN HEIGHT (* (SHEET-LINE-HEIGHT NOTE-WINDOW) 5))))
    1273   (FUNCALL NOTE-WINDOW ':SET-LABEL (STRING-APPEND "Notification: "
    1274                                                   (COND ((GET-HANDLER-FOR SELF ':LABEL)
    1275                                                          (LET ((LABEL (FUNCALL-SELF ':LABEL)))
    1276                                                            (IF (STRINGP LABEL)
    1277                                                                LABEL
    1278                                                                (LABEL-STRING LABEL))))
    1279                                                         (T NAME))))
    1280   (IF (EQ SELF SELECTED-WINDOW)
    1281       (FUNCALL NOTE-WINDOW ':SELECT)
    1282       (FUNCALL NOTE-WINDOW ':EXPOSE))
    1283   NOTE-WINDOW)
    1284 
     1427in it.  See the NOTIFICATION-MIXIN for an alternative behaviour."))
     1428
     1429(DEFWINDOW-RESOURCE POP-UP-NOTIFICATION-WINDOW ()
     1430        :MAKE-WINDOW (POP-UP-NOTIFICATION-WINDOW)
     1431        :REUSABLE-WHEN :DEACTIVATED
     1432        :INITIAL-COPIES 0)      ;No initial copies, would bomb during system loading
     1433
     1434(DEFMETHOD (POP-UP-NOTIFICATION-MIXIN :PRINT-NOTIFICATION) (TIME STRING WINDOW-OF-INTEREST)
     1435  ;; Now we must spawn a process and return.  See comments in CAREFUL-NOTIFY.
     1436  (PROCESS-RUN-FUNCTION "Notify"
     1437    #'(LAMBDA (TIME STRING WINDOW-OF-INTEREST SLF START-TIME NOTE-WINDOW)
     1438        (FUNCALL NOTE-WINDOW ':SET-WINDOW-OF-INTEREST WINDOW-OF-INTEREST)
     1439                ;Above sets up for mouse click.  Caller has already set up for Terminal-0-S
     1440        (FUNCALL NOTE-WINDOW ':SET-LABEL (FORMAT NIL "Notification: ~A" SLF))
     1441        (MULTIPLE-VALUE-BIND (X Y) (SHEET-CALCULATE-OFFSETS SLF (SHEET-SUPERIOR NOTE-WINDOW))
     1442          (FUNCALL NOTE-WINDOW ':CENTER-AROUND (+ X (// (SHEET-WIDTH SLF) 2))
     1443                                               (+ Y (// (SHEET-HEIGHT SLF) 2))))
     1444        ;If window gets deexposed while we're typing out, typically because
     1445        ;user types Terminal-0-S before we finish cranking out our message, punt.
     1446        (*CATCH ':DEEXPOSE
     1447          (CONDITION-BIND ((OUTPUT-ON-DEEXPOSED-SHEET
     1448                             #'(LAMBDA (&REST IGNORE) (*THROW  ':DEEXPOSE NIL))))
     1449            (LET ((OSW SELECTED-WINDOW))                ;Almost certainly SLF
     1450              (FUNCALL NOTE-WINDOW ':SELECT)    ;Exposes blank with homed cursor
     1451              (TIME:PRINT-BRIEF-UNIVERSAL-TIME TIME NOTE-WINDOW)
     1452              (FUNCALL NOTE-WINDOW ':TYO #\SP)
     1453              (FUNCALL NOTE-WINDOW ':STRING-OUT STRING)
     1454              (FUNCALL NOTE-WINDOW ':TYO #\CR)
     1455              (FINISH-UNEXPECTED-SELECT START-TIME OSW)) ;By now user has seen what's up
     1456            (FUNCALL NOTE-WINDOW ':CLEAR-INPUT) ;Flush typeahead before inviting typein
     1457            (IF WINDOW-OF-INTEREST
     1458                (FORMAT NOTE-WINDOW
     1459                        "Select ~A by typing Terminal-0-S or by clicking the mouse here,~@
     1460                         or type any character to get rid of this notification."
     1461                        WINDOW-OF-INTEREST)
     1462                (FUNCALL NOTE-WINDOW ':STRING-OUT
     1463                         "Type any character to get rid of this notification."))
     1464            (FUNCALL NOTE-WINDOW ':TYI)))
     1465        (FUNCALL NOTE-WINDOW ':DEACTIVATE))
     1466    TIME STRING WINDOW-OF-INTEREST SELF
     1467    (START-UNEXPECTED-SELECT)
     1468    (ALLOCATE-RESOURCE 'POP-UP-NOTIFICATION-WINDOW (SHEET-GET-SCREEN SELF))))
     1469
     1470;;; These two functions are for unexpected pop-up selectable windows
     1471;;; They give the user a chance to get his typing straightened out
     1472
     1473(DEFVAR UNEXPECTED-SELECT-DELAY 180.)   ;Give user 3 seconds to notice beep and stop typing
     1474
     1475;Beep, return time to be passed back in to FINISH-UNEXPECTED-SELECT
     1476(DEFUN START-UNEXPECTED-SELECT ()
     1477  (BEEP)
     1478  (TIME))
     1479
     1480;Sleep until enough time has passed, then snarf typeahead into old-selected-window
     1481;which is no longer selected-window because by now the new thing has been exposed
     1482(DEFUN FINISH-UNEXPECTED-SELECT (START-TIME OLD-SELECTED-WINDOW &AUX BUF)
     1483  (PROCESS-WAIT "Sleep" #'(LAMBDA (START-TIME) (> (TIME-DIFFERENCE (TIME) START-TIME)
     1484                                                  UNEXPECTED-SELECT-DELAY))
     1485                        START-TIME)
     1486  (WITHOUT-INTERRUPTS
     1487    (AND OLD-SELECTED-WINDOW
     1488         (SETQ BUF (FUNCALL OLD-SELECTED-WINDOW ':IO-BUFFER))
     1489         (KBD-SNARF-INPUT BUF))))
    12851490
    12861491(DEFFLAVOR POP-UP-NOTIFICATION-WINDOW
    1287   ((WINDOW-OF-INTEREST NIL)
    1288    (RECURSION NIL))
     1492  ((WINDOW-OF-INTEREST NIL))
    12891493  (POP-UP-TEXT-WINDOW)
    12901494  (:SETTABLE-INSTANCE-VARIABLES WINDOW-OF-INTEREST)
    12911495  (:GETTABLE-INSTANCE-VARIABLES WINDOW-OF-INTEREST)
    1292   (:DOCUMENTATION :SPECIAL-PURPOSE "Pops down and selects window in error when clicked on
     1496  (:DEFAULT-INIT-PLIST :SAVE-BITS NIL  ;Thus will not come up with old garbage contents
     1497                       :CHARACTER-HEIGHT 5      ;5 lines.  Width is full width of sup.
     1498                       :DEEXPOSED-TYPEOUT-ACTION ':ERROR)
     1499  (:DOCUMENTATION :SPECIAL-PURPOSE "Pops down and selects window of interest when clicked on
    12931500One of these is created when a notify message is sent to a normal window, it pops up, prints
    12941501the notification, and when it is selected with the mouse, pops back down and exposes the
    12951502window that got the error, which for background processes will be a slightly larger
    12961503pop-up type window."))
     1504
     1505;;; When clicked on, always send a :MOUSE-SELECT message, even if already selected
     1506;;; so that WINDOW-OF-INTEREST will get selected.
     1507(DEFMETHOD (POP-UP-NOTIFICATION-WINDOW :MOUSE-CLICK) (BUTTON IGNORE IGNORE)
     1508  (COND ((= BUTTON #\MOUSE-1-1)
     1509         (MOUSE-SELECT SELF)
     1510         T)))
    12971511
    12981512(DEFMETHOD (POP-UP-NOTIFICATION-WINDOW :MOUSE-SELECT) (&REST ARGS)
     
    13031517       (LEXPR-FUNCALL WINDOW-OF-INTEREST ':MOUSE-SELECT ARGS)))
    13041518
     1519;This wakes up the process which is sitting around waiting for the user
     1520;to type something to flush the notification window.  It will deactivate us.
    13051521(DEFMETHOD (POP-UP-NOTIFICATION-WINDOW :AFTER :DEEXPOSE) (&REST IGNORE)
    1306   (WITHOUT-INTERRUPTS
    1307     (OR (MEMQ SELF POP-UP-NOTIFICATION-WINDOW-RESOURCE)
    1308         (DEALLOCATE-RESOURCE 'POP-UP-NOTIFICATION-WINDOW-RESOURCE SELF)))
    1309   (OR RECURSION
    1310       (LET-GLOBALLY ((RECURSION T))
    1311         (FUNCALL-SELF ':DEACTIVATE))))
    1312 
    1313 (DEFMETHOD (POP-UP-NOTIFICATION-WINDOW :NOTIFY-STREAM) (&REST IGNORE) SELF)
    1314 
    1315 (DEFRESOURCE (POP-UP-NOTIFICATION-WINDOW-RESOURCE T)
    1316   (WINDOW-CREATE 'POP-UP-NOTIFICATION-WINDOW
    1317                  ':HEIGHT (* (SHEET-LINE-HEIGHT DEFAULT-SCREEN) 5)))
     1522  (FUNCALL-SELF ':FORCE-KBD-INPUT ':DEEXPOSE))
     1523
     1524;While a notification window is up, additional notifications are printed on it.
     1525;I guess I don't need to reprint the self-documentation.
     1526(DEFMETHOD (POP-UP-NOTIFICATION-WINDOW :PRINT-NOTIFICATION) (TIME STRING WINDOW-OF-INTEREST)
     1527  WINDOW-OF-INTEREST ;ignored
     1528  (FUNCALL-SELF ':FRESH-LINE)
     1529  (FUNCALL-SELF ':BEEP)
     1530  (TIME:PRINT-BRIEF-UNIVERSAL-TIME TIME SELF)
     1531  (FUNCALL-SELF ':TYO #\SP)
     1532  (FUNCALL-SELF ':STRING-OUT STRING)
     1533  (FUNCALL-SELF ':TYO #\CR))
    13181534
    13191535
     
    13211537;;; for window-bind type windows that don't want to go through the overhead of
    13221538;;; creating a new bit array every time they get invoked
    1323 (DEFRESOURCE (BIT-ARRAYS T)
    1324   (MAKE-ARRAY NIL 'ART-1B
    1325               (LIST (SHEET-WIDTH DEFAULT-SCREEN) (SHEET-HEIGHT DEFAULT-SCREEN))))
     1539(DEFRESOURCE BIT-ARRAYS (&OPTIONAL (WIDTH (SHEET-WIDTH DEFAULT-SCREEN))
     1540                                   (HEIGHT (SHEET-HEIGHT DEFAULT-SCREEN)))
     1541  :CONSTRUCTOR (MAKE-ARRAY (LIST WIDTH HEIGHT) ':TYPE 'ART-1B)
     1542  :INITIAL-COPIES 0)
    13261543
    13271544(DEFUN AWAIT-WINDOW-EXPOSURE ()
  • trunk/lisp/lmwin/choice.lisp

    r220 r275  
    55;user choose things in various ways other than menus.
    66
     7(DEFFLAVOR MARGIN-SCROLLING-WITH-FLASHY-SCROLLING-MIXIN () ()
     8  (:INCLUDED-FLAVORS MARGIN-SCROLL-MIXIN MARGIN-REGION-MIXIN FLASHY-SCROLLING-MIXIN)
     9  (:DEFAULT-INIT-PLIST :FLASHY-SCROLLING-REGION '((32. 0.40s0 0.60s0) (32. 0.40s0 0.60s0))))
     10
     11(DEFMETHOD (MARGIN-SCROLLING-WITH-FLASHY-SCROLLING-MIXIN
     12             :OVERRIDE :WHO-LINE-DOCUMENTATION-STRING) ()
     13  (AND FLASHY-SCROLLING-BLINKER
     14       (IF (= (FUNCALL MOUSE-BLINKER ':CHARACTER) 10)
     15           ;; Character 10 is upward pointing arrow for top of window
     16
     17  "Bump blinker against top to scroll down by one line.  Any button to scroll one page."
     18  "Bump blinker against bottom to scroll up by one line.  Any button to scroll one page.")))
     19
    720(DEFFLAVOR SCROLL-STUFF-ON-OFF-MIXIN
    821        ((MAKING-SCROLL-DECISION NIL))  ;Internal, prevents infinite recursion
    9         (MARGIN-SCROLL-MIXIN
    10          MARGIN-REGION-MIXIN FLASHY-SCROLLING-MIXIN BASIC-SCROLL-BAR)
     22        (MARGIN-SCROLLING-WITH-FLASHY-SCROLLING-MIXIN
     23         MARGIN-SCROLL-MIXIN MARGIN-REGION-MIXIN FLASHY-SCROLLING-MIXIN
     24         BASIC-SCROLL-BAR)
    1125        (:REQUIRED-METHODS :SCROLL-BAR-P        ;T if scrolling needed
    1226                           :ADJUSTABLE-SIZE-P)  ;T if outside size can change
     
    1529        (:DOCUMENTATION :MIXIN "Scroll bar, flashy scrolling, and margin scrolling, which turn on and off with :SCROLL-BAR-P")
    1630        (:DEFAULT-INIT-PLIST :SCROLL-BAR 2  ;This 2 is unmodular, sigh.
    17                              :MARGIN-SCROLL-REGIONS '(:TOP :BOTTOM)
    18                              :FLASHY-SCROLLING-REGION
    19                                '((32. 0.40s0 0.60s0) (32. 0.40s0 0.60s0))))
     31                             :MARGIN-SCROLL-REGIONS '(:TOP :BOTTOM)))
    2032
    2133(DEFMETHOD (SCROLL-STUFF-ON-OFF-MIXIN :BEFORE :REDEFINE-MARGINS)
     
    88100  (ADJUST-MARGINS 'REGION-LIST ':PARSE-REGION-LIST INIT-PLIST NIL))
    89101
     102(DEFMETHOD (MARGIN-REGION-MIXIN :OVERRIDE :WHO-LINE-DOCUMENTATION-STRING) ()
     103  (AND CURRENT-REGION
     104       (FUNCALL (MARGIN-REGION-FUNCTION CURRENT-REGION)
     105                ':WHO-LINE-DOCUMENTATION-STRING CURRENT-REGION)))
     106
    90107(DEFMETHOD (MARGIN-REGION-MIXIN :SET-REGION-LIST) (NEW-REGION-LIST
    91108                                         &AUX (PLIST (LIST ':REGION-LIST NEW-REGION-LIST)))
     
    148165         )))
    149166
    150 (DEFWRAPPER (MARGIN-REGION-MIXIN :MOUSE-BUTTONS) (IGNORE . BODY)
    151   `(*CATCH 'REGION-HANDLED-MOUSE
    152      (PROGN . ,BODY)))
    153 
    154 (DEFMETHOD (MARGIN-REGION-MIXIN :BEFORE :MOUSE-BUTTONS) (BD X Y)
    155   (COND ((AND CURRENT-REGION (BIT-TEST BD 3))
    156          ;; Mouse in some region -- left or middle button
    157          ;; The right button is usually reserved for menus and the like so is not
    158          ;; intercepted here
    159          (FUNCALL (MARGIN-REGION-FUNCTION CURRENT-REGION) ':MOUSE-BUTTONS X Y
     167(DEFMETHOD (MARGIN-REGION-MIXIN :MOUSE-CLICK) (BUTTON X Y)
     168  (COND ((AND CURRENT-REGION ( BUTTON #\MOUSE-3-2))
     169         (FUNCALL (MARGIN-REGION-FUNCTION CURRENT-REGION) ':MOUSE-CLICK X Y
    160170                                                          CURRENT-REGION
    161                                                           (MOUSE-BUTTON-ENCODE BD))
    162          (*THROW 'REGION-HANDLED-MOUSE T))))
     171                                                          BUTTON)
     172         T)))
    163173
    164174(DEFMETHOD (MARGIN-REGION-MIXIN :MOUSE-ENTERS-REGION) ())
     
    184194;;; you click there
    185195(DEFFLAVOR MARGIN-SCROLL-MIXIN () ()
    186   (:INCLUDED-FLAVORS MARGIN-REGION-MIXIN BASIC-SCROLL-BAR)
     196  (:INCLUDED-FLAVORS MARGIN-REGION-MIXIN)
     197  (:REQUIRED-FLAVORS BASIC-SCROLL-BAR)
    187198  (:INIT-KEYWORDS :MARGIN-SCROLL-REGIONS)
    188199  (:DOCUMENTATION :MIXIN "Shows if there is more above or below"))
     
    233244         ((OR (NOT OLD-VALID) (NEQ MORE-P (MARGIN-SCROLL-REGION-MORE-P REGION)))
    234245          (SETF (MARGIN-SCROLL-REGION-MORE-P REGION) MORE-P)
    235           (AND OLD-VALID
    236                (PREPARE-SHEET (SELF)
    237                  (%DRAW-RECTANGLE (- RIGHT LEFT) (- BOTTOM TOP) LEFT TOP ERASE-ALUF SELF)))
    238           (SETQ MSG (IF MORE-P (MARGIN-SCROLL-REGION-MORE-MSG REGION)
    239                                (MARGIN-SCROLL-REGION-EMPTY-MSG REGION))
    240                 MSGL (SHEET-STRING-LENGTH SELF MSG 0 NIL NIL
    241                                           (MARGIN-SCROLL-REGION-MSG-FONT REGION)))
    242           (SHEET-STRING-OUT-EXPLICIT SELF MSG (MAX (// (- (+ RIGHT LEFT) MSGL) 2) LEFT)
    243                                      TOP RIGHT (MARGIN-SCROLL-REGION-MSG-FONT REGION)
    244                                      CHAR-ALUF))))
     246          (SHEET-FORCE-ACCESS (SELF)
     247            (AND OLD-VALID
     248                 (%DRAW-RECTANGLE (- RIGHT LEFT) (- BOTTOM TOP) LEFT TOP ERASE-ALUF SELF))
     249            (SETQ MSG (IF MORE-P (MARGIN-SCROLL-REGION-MORE-MSG REGION)
     250                          (MARGIN-SCROLL-REGION-EMPTY-MSG REGION))
     251                  MSGL (SHEET-STRING-LENGTH SELF MSG 0 NIL NIL
     252                                            (MARGIN-SCROLL-REGION-MSG-FONT REGION)))
     253            (SHEET-STRING-OUT-EXPLICIT SELF MSG (MAX (// (- (+ RIGHT LEFT) MSGL) 2) LEFT)
     254                                       TOP RIGHT (MARGIN-SCROLL-REGION-MSG-FONT REGION)
     255                                       CHAR-ALUF)))))
    245256  ((:MOUSE-ENTERS-REGION :MOUSE-LEAVES-REGION :MOUSE-MOVES) (&REST IGNORE))
    246   (:MOUSE-BUTTONS (IGNORE IGNORE REGION IGNORE)
     257  (:MOUSE-CLICK (IGNORE IGNORE REGION IGNORE)
    247258   (IF (MARGIN-SCROLL-REGION-MORE-P REGION)
    248259       (LET ((FROM (MARGIN-REGION-MARGIN REGION)))
    249260         (FUNCALL-SELF ':SCROLL-RELATIVE FROM (IF (EQ FROM ':TOP) ':BOTTOM ':TOP)))
    250        (BEEP)))))
    251 
     261       (BEEP)))
     262  (:WHO-LINE-DOCUMENTATION-STRING (IGNORE) "Any button to scroll one page.")))
    252263
    253264(DEFFLAVOR MARGIN-SCROLL-REGION-ON-AND-OFF-WITH-SCROLL-BAR-MIXIN () ()
     
    286297  (:MOUSE-LEAVES-REGION (IGNORE)
    287298    (MOUSE-STANDARD-BLINKER))
    288   (:MOUSE-BUTTONS (IGNORE Y IGNORE BD &AUX ITEM)
     299  (:MOUSE-CLICK (IGNORE Y IGNORE BD &AUX ITEM)
    289300   (IF (AND (
    290301 Y (SHEET-INSIDE-TOP))
     
    293304                   (SETQ ITEM (AREF ITEMS LINE)))))
    294305       (FUNCALL-SELF ':FORCE-KBD-INPUT `(:LINE-AREA ,ITEM ,SELF ,BD))
    295        (BEEP)))))
     306       (BEEP)))
     307  (:WHO-LINE-DOCUMENTATION-STRING (IGNORE) "Select a line.")))
    296308
    297309
     
    406418          (MULTIPLE-VALUE (LEFT TOP RIGHT BOTTOM)
    407419            (MARGIN-REGION-AREA REGION))
    408           (AND ERASE-P
    409                (%DRAW-RECTANGLE (- RIGHT LEFT) (- TOP BOTTOM) LEFT TOP ERASE-ALUF SELF))
    410           (%DRAW-RECTANGLE (- RIGHT LEFT) 1 LEFT TOP CHAR-ALUF SELF)
     420          (PREPARE-SHEET (SELF)
     421            (AND ERASE-P
     422                 (%DRAW-RECTANGLE (- RIGHT LEFT) (- TOP BOTTOM) LEFT TOP ERASE-ALUF SELF))
     423            (%DRAW-RECTANGLE (- RIGHT LEFT) 1 LEFT TOP CHAR-ALUF SELF))
    411424          (SETQ TOP (+ TOP 2))
    412425          (DO ((CHOICES MARGIN-CHOICES (CDR CHOICES))
     
    426439  (:MOUSE-MOVES (&REST IGNORE))
    427440  ((:MOUSE-ENTERS-REGION :MOUSE-LEAVES-REGION) (IGNORE))
    428   (:MOUSE-BUTTONS (X Y REGION IGNORE)
    429    (HANDLE-CHOICE-BUTTON MARGIN-CHOICES X Y REGION))))
     441  (:MOUSE-CLICK (X Y REGION IGNORE)
     442   (HANDLE-CHOICE-BUTTON MARGIN-CHOICES X Y REGION))
     443  (:WHO-LINE-DOCUMENTATION-STRING (IGNORE)
     444    (LET ((X (- MOUSE-X (SHEET-CALCULATE-OFFSETS SELF MOUSE-SHEET))))
     445      (DOLIST (BOX MARGIN-CHOICES)
     446        (AND (
     447 X (CHOICE-BOX-X1 BOX))
     448             (< X (CHOICE-BOX-X2 BOX))
     449             (RETURN "Any button to select choice.")))))))
    430450
    431451(DECLARE-FLAVOR-INSTANCE-VARIABLES (MARGIN-CHOICE-MIXIN)
     
    579599  (ASET ITEM DISPLAYED-ITEMS LINE-NO))
    580600
    581 (DEFMETHOD (BASIC-MULTIPLE-CHOICE :MOUSE-BUTTONS) (BD X Y &AUX LINE-NO ITEM)
    582   (SETQ LINE-NO (SHEET-LINE-NO NIL Y))
    583   (AND (
     601(DEFMETHOD (BASIC-MULTIPLE-CHOICE :MOUSE-CLICK) (BUTTON X Y &AUX LINE-NO ITEM)
     602  (COND ((OR (= BUTTON #\MOUSE-1-1) (= BUTTON #\MOUSE-3-1))
     603         (SETQ LINE-NO (SHEET-LINE-NO NIL Y))
     604         (COND ((AND (
    584605 Y (SHEET-INSIDE-TOP))
    585        (< Y (+ (SHEET-INSIDE-TOP) (* (SHEET-NUMBER-OF-INSIDE-LINES) LINE-HEIGHT)))
    586        (SETQ ITEM (AREF DISPLAYED-ITEMS LINE-NO)))
    587   (COND ((= (SETQ BD (MOUSE-BUTTON-ENCODE BD)) #\MOUSE-3-2)
    588          (MOUSE-CALL-SYSTEM-MENU))
    589         ((AND (= BD #\MOUSE-1-1) ITEM)
    590          (HANDLE-CHOICE-BUTTON (CHOICE-ITEM-BOXES ITEM) X Y ITEM))
    591         (T
    592          (BEEP))))
     606                     (< Y (+ (SHEET-INSIDE-TOP) (* (SHEET-NUMBER-OF-INSIDE-LINES)
     607                                                   LINE-HEIGHT)))
     608                     (SETQ ITEM (AREF DISPLAYED-ITEMS LINE-NO)))
     609                (HANDLE-CHOICE-BUTTON (CHOICE-ITEM-BOXES ITEM) X Y ITEM)
     610                T)))))
     611
     612(DEFMETHOD (BASIC-MULTIPLE-CHOICE :WHO-LINE-DOCUMENTATION-STRING) ()
     613  "Any button an a box to complement its state")
    593614
    594615(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-MULTIPLE-CHOICE)
     
    651672(COMPILE-FLAVOR-METHODS TEMPORARY-MULTIPLE-CHOICE-WINDOW)
    652673
    653 (DEFRESOURCE TEMPORARY-MULTIPLE-CHOICE-WINDOW
    654   (WINDOW-CREATE 'TEMPORARY-MULTIPLE-CHOICE-WINDOW))
    655 
    656 (SYSTEM-WINDOW-ADD-TYPE 'TEMPORARY-MULTIPLE-CHOICE-WINDOW
    657                         #'(LAMBDA (SUPERIOR)
    658                             (TV:WINDOW-CREATE 'TEMPORARY-MULTIPLE-CHOICE-WINDOW
    659                                               ':SUPERIOR SUPERIOR))
    660                         T ':DEACTIVATED)
    661 
    662 (DEFUN MULTIPLE-CHOOSE (ITEM-NAME ITEM-LIST KEYWORD-ALIST &OPTIONAL (NEAR-MODE '(:MOUSE)))
     674(DEFWINDOW-RESOURCE TEMPORARY-MULTIPLE-CHOICE-WINDOW ()
     675        :MAKE-WINDOW (TEMPORARY-MULTIPLE-CHOICE-WINDOW)
     676        :REUSABLE-WHEN :DEACTIVATED
     677        :INITIAL-COPIES 0)
     678
     679(DEFUN MULTIPLE-CHOOSE (ITEM-NAME ITEM-LIST KEYWORD-ALIST
     680                        &OPTIONAL (NEAR-MODE '(:MOUSE)) (MAXLINES 20.) SUP)
    663681  "ITEM-NAME is a string of the name of the type of item, e.g. /"Buffer/".
    664682   ITEM-LIST is an alist, (ITEM NAME CHOICES).  ITEM is the item itself, NAME a string
     
    670688   implications for when the keyword is selected, each one either a list of (other) keywords
    671689   or T for all other keywords.  The default for IMPLICATIONS is (NIL T NIL NIL)."
     690  ;; Decide what superior to use
     691  (OR SUP
     692      (SETQ SUP (IF (EQ (CAR NEAR-MODE) ':WINDOW) (SHEET-SUPERIOR (CADR NEAR-MODE))
     693                    MOUSE-SHEET)))
    672694  (DO L KEYWORD-ALIST (CDR L) (NULL L)
    673695    (AND (< (LENGTH (CAR L)) 3)
    674696         (SETF (CAR L) (NCONC (CAR L) (LIST NIL T NIL NIL)))))
    675   (LET ((WINDOW (GET-A-SYSTEM-WINDOW 'TEMPORARY-MULTIPLE-CHOICE-WINDOW)))
    676     (FUNCALL WINDOW ':SETUP ITEM-NAME KEYWORD-ALIST DEFAULT-FINISHING-CHOICES ITEM-LIST)
     697  (USING-RESOURCE (WINDOW TEMPORARY-MULTIPLE-CHOICE-WINDOW SUP)
     698    (FUNCALL WINDOW ':SETUP ITEM-NAME KEYWORD-ALIST
     699             DEFAULT-FINISHING-CHOICES ITEM-LIST MAXLINES)
    677700    (UNWIND-PROTECT
    678701      (FUNCALL WINDOW ':CHOOSE NEAR-MODE)
     
    719742;    :CHARACTER - value is a character, prints with ~:@C, reads as one keystroke
    720743;    :CHARACTER-OR-NIL - same but can also be NIL, displays as "none", inputs as CLEAR
     744;
     745; If :DOCUMENTATION appears where the keyword is expected, it is followed by
     746; a string to display when the mouse is pointing here, and then by the keyword.
     747; This is implemented by :DECODE-VARIABLE-TYPE (see below) so that you can
     748; change it.
     749;
    721750; Should there also be ones which are constrained to be lists of chars?
    722751; Keywords automatically forced into the keyword package?
     
    728757; the variable's value.  The argument to this message is
    729758; the tail of a VARIABLES element starting with the keyword, and it
    730 ; returns 5 values:
     759; returns 6 values:
    731760;  The print function (args are object and stream).
    732761;  The read function, or NIL if it works by pointing (arg is stream).
     
    739768;  The function which translates a value to the form
    740769;    which goes in the variable (NIL for identity).
    741 ; The last two only apply when there are choices.
    742 ; The default handler looks up the keyword in TV:CHOOSE-VARIABLE-VALUES-KEYWORDS,
    743 ;  which is (kwd . function-to-call) or (kwd print-func read-func choices ptransfn vtransfn)
     770;  The who-line mouse documentation string.  If this is a symbol, then NIL means
     771;    use the default documentation, and any other symbol is the name of a function
     772;    which translates a value to its documentation.
     773; The two functions only apply when there are choices.
     774; The default handler looks for a TV:CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION property which
     775; is a function to call or a TV:CHOOSE-VARIABLE-VALUES-KEYWORD property which is
     776; (print-func read-func choices ptransfn vtransfn mouse-documentation)
    744777
    745778;FUNCTION can be NIL or a function called on window, special-variable, old-value, new-value
     
    769802(DEFFLAVOR BASIC-CHOOSE-VARIABLE-VALUES
    770803        ((FUNCTION NIL) STACK-GROUP (LINE-OVERFLOW-ALLOWED T) (RECURSION NIL))
    771         (MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW)
     804        (MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW-WITHOUT-CLICK)
    772805  (:INCLUDED-FLAVORS ANY-TYI-MIXIN)
    773806  :GETTABLE-INSTANCE-VARIABLES
     
    855888  (FUNCALL-SELF ':SET-VARIABLES ELEMS))
    856889
    857 (DEFVAR CHOOSE-VARIABLE-VALUES-KEYWORDS
    858         '( (:SEXP PRIN1 READ)
    859            (:PRINC PRINC READ)
    860            (:STRING PRINC READLINE)
    861            (:NUMBER PRIN1 READ-NUMBER)
    862            (:CHOOSE . CHOOSE-VARIABLE-VALUES-DECODE-CHOOSE)
    863            (:ASSOC . CHOOSE-VARIABLE-VALUES-DECODE-CHOOSE)
    864            (:BOOLEAN CHOOSE-VARIABLE-VALUES-BOOLEAN-PRINT NIL (T NIL))
    865            (:CHARACTER CHOOSE-VARIABLE-VALUES-CHARACTER-PRINT (TYI))
    866            (:CHARACTER-OR-NIL CHOOSE-VARIABLE-VALUES-CHARACTER-OR-NIL-PRINT
    867                               (CHOOSE-VARIABLE-VALUES-CHARACTER-OR-NIL-READ)) ))
    868 
     890(DEFPROP :SEXP (PRIN1 READ) CHOOSE-VARIABLE-VALUES-KEYWORD)
     891(DEFPROP :PRINC (PRINC READ) CHOOSE-VARIABLE-VALUES-KEYWORD)
     892(DEFPROP :STRING (PRINC READLINE) CHOOSE-VARIABLE-VALUES-KEYWORD)
     893
     894(DEFPROP :CHOOSE CHOOSE-VARIABLE-VALUES-DECODE-CHOOSE CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION)
     895(DEFPROP :ASSOC CHOOSE-VARIABLE-VALUES-DECODE-CHOOSE CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION)
    869896(DEFUN CHOOSE-VARIABLE-VALUES-DECODE-CHOOSE (KWD-AND-ARGS)
    870   (PROG () (RETURN (OR (THIRD KWD-AND-ARGS) 'PRINC)
    871                    NIL
    872                    (SECOND KWD-AND-ARGS)
    873                    (AND (EQ (FIRST KWD-AND-ARGS) ':ASSOC) 'CAR)
    874                    (AND (EQ (FIRST KWD-AND-ARGS) ':ASSOC) 'CDR))))
    875 
     897  (VALUES (OR (THIRD KWD-AND-ARGS) 'PRINC)
     898          NIL
     899          (SECOND KWD-AND-ARGS)
     900          (AND (EQ (FIRST KWD-AND-ARGS) ':ASSOC) 'CAR)
     901          (AND (EQ (FIRST KWD-AND-ARGS) ':ASSOC) 'CDR)))
     902
     903(DEFPROP :BOOLEAN (CHOOSE-VARIABLE-VALUES-BOOLEAN-PRINT NIL (T NIL))
     904         CHOOSE-VARIABLE-VALUES-KEYWORD)
    876905(DEFUN CHOOSE-VARIABLE-VALUES-BOOLEAN-PRINT (VALUE STREAM)
    877906  (FUNCALL STREAM ':STRING-OUT (IF VALUE "Yes" "No")))
    878907
     908(DEFPROP :CHARACTER
     909         (CHOOSE-VARIABLE-VALUES-CHARACTER-PRINT (TYI) NIL
     910          NIL NIL "Click left to input a new character from the keyboard.")
     911         CHOOSE-VARIABLE-VALUES-KEYWORD)
    879912(DEFUN CHOOSE-VARIABLE-VALUES-CHARACTER-PRINT (VALUE STREAM)
    880913  (FORMAT STREAM "~:@C" VALUE))
    881914
     915(DEFPROP :CHARACTER-OR-NIL
     916         (CHOOSE-VARIABLE-VALUES-CHARACTER-OR-NIL-PRINT
     917          CHOOSE-VARIABLE-VALUES-CHARACTER-OR-NIL-READ
     918          NIL NIL NIL "Click left to input a new character from the keyboard.")
     919         CHOOSE-VARIABLE-VALUES-KEYWORD)
    882920(DEFUN CHOOSE-VARIABLE-VALUES-CHARACTER-OR-NIL-PRINT (VALUE STREAM)
    883921  (FORMAT STREAM (IF VALUE "~:@C" "none") VALUE))
     
    889927      (TYI STREAM)))
    890928
     929(DEFPROP :NUMBER
     930         (PRIN1 READ-NUMBER NIL NIL NIL "Click left to input a new number from the keyboard.")
     931         CHOOSE-VARIABLE-VALUES-KEYWORD)
    891932(DEFUN READ-NUMBER (STREAM)
    892933  (LET ((VAL (READ STREAM)))
     
    894935    VAL))
    895936
    896 (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :DECODE-VARIABLE-TYPE) (KWD-AND-ARGS &AUX TEM)
    897   (SETQ TEM (OR (ASSQ (CAR KWD-AND-ARGS) CHOOSE-VARIABLE-VALUES-KEYWORDS)
    898                 (FERROR NIL "~S bad keyword in a CHOOSE-VARIABLE-VALUES-WINDOW"
    899                             (CAR KWD-AND-ARGS))))
    900   (IF (ATOM (CDR TEM)) (FUNCALL (CDR TEM) KWD-AND-ARGS)
    901       (PROG () (RETURN-LIST (CDR TEM)))))
     937(DEFPROP :DATE
     938         (TIME:PRINT-UNIVERSAL-TIME READ-DATE NIL
     939          NIL NIL "Click left to input a new date from the keyboard.")
     940         CHOOSE-VARIABLE-VALUES-KEYWORD)
     941
     942(DEFUN READ-DATE (STREAM)
     943  (LET ((VAL (TIME:PARSE-UNIVERSAL-TIME (READLINE STREAM))))
     944    (AND (STRINGP VAL) (FERROR NIL "A date is required: ~A" VAL))
     945    VAL))
     946
     947(DEFPROP :DATE-OR-NEVER
     948         (PRINT-UNIVERSAL-TIME-OR-NEVER READ-DATE-OR-NEVER NIL
     949          NIL NIL "Click left to input a new date from the keyboard.")
     950         CHOOSE-VARIABLE-VALUES-KEYWORD)
     951
     952(DEFUN PRINT-UNIVERSAL-TIME-OR-NEVER (TIME STREAM)
     953  (IF (NULL TIME) (PRINC "never" STREAM)
     954      (TIME:PRINT-UNIVERSAL-TIME TIME STREAM)))
     955
     956(DEFUN READ-DATE-OR-NEVER (STREAM)
     957  (LET ((STRING (READLINE STREAM)))
     958    (IF (EQUAL STRING "never") NIL
     959        (LET ((VAL (TIME:PARSE-UNIVERSAL-TIME STRING)))
     960          (AND (STRINGP VAL) (FERROR NIL "A date is required: ~A" VAL))
     961          VAL))))
     962
     963(DEFPROP :NUMBER-OR-NIL
     964         (PRIN1 READ NIL
     965          NIL NIL "Click left to enter a new number, or NIL, from the keyboard.")
     966         CHOOSE-VARIABLE-VALUES-KEYWORD)
     967
     968(DEFUN (:MENU-ALIST CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION) (KWD-AND-ARGS)
     969  (VALUES 'PRINC
     970          NIL
     971          (SECOND KWD-AND-ARGS)
     972          'CAR
     973          'MENU-EXECUTE-NO-SIDE-EFFECTS
     974          'MENU-ITEM-WHO-LINE-DOCUMENTATION))
     975
     976(DEFPROP :STRING-LIST (PRINT-STRING-LIST READ-STRING-LIST) CHOOSE-VARIABLE-VALUES-KEYWORD)
     977
     978(DEFUN PRINT-STRING-LIST (STRING-LIST STREAM)
     979  (FORMAT STREAM "~{~A~^, ~}" STRING-LIST))
     980
     981(DEFUN READ-STRING-LIST (STREAM)
     982  (DO ((STRING (READLINE STREAM))
     983       (I 0 (1+ J))
     984       (J)
     985       (STRING-LIST NIL))
     986      (NIL)
     987    (SETQ J (STRING-SEARCH-CHAR #/, STRING I))
     988    (PUSH (STRING-TRIM '(#\SP #\TAB) (NSUBSTRING STRING I J)) STRING-LIST)
     989    (OR J (RETURN (NREVERSE STRING-LIST)))))
     990
     991(DEFPROP :PATHNAME-OR-NIL
     992         (PRINC READ-PATHNAME-OR-NIL NIL
     993          NIL NIL "Click left to enter a new pathname from the keyboard.")
     994         CHOOSE-VARIABLE-VALUES-KEYWORD)
     995
     996(DEFUN READ-PATHNAME-OR-NIL (STREAM &AUX STRING)
     997  (SETQ STRING (READLINE STREAM))
     998  (AND (PLUSP (STRING-LENGTH STRING))
     999       (STRING (FS:MERGE-PATHNAME-DEFAULTS STRING))))
     1000
     1001(DEFPROP :PATHNAME
     1002         (PRINC READ-PATHNAME NIL
     1003          NIL NIL "Click left to enter a new pathname from the keyboard.")
     1004         CHOOSE-VARIABLE-VALUES-KEYWORD)
     1005
     1006(DEFUN READ-PATHNAME (STREAM)
     1007  (STRING (FS:MERGE-PATHNAME-DEFAULTS (READLINE STREAM))))
     1008
     1009(DEFPROP :PATHNAME-LIST
     1010         (PRINT-STRING-LIST READ-PATHNAME-LIST NIL
     1011          NIL NIL "Click left to enter new pathnames from the keyboard.")
     1012         CHOOSE-VARIABLE-VALUES-KEYWORD)
     1013
     1014(DEFUN READ-PATHNAME-LIST (STREAM)
     1015  (MAPCAR #'STRING (PARSE-PATHNAME-LIST (READLINE STREAM))))
     1016
     1017(DEFUN PARSE-PATHNAME-LIST (STRING)
     1018  (DO ((I 0 (1+ J))
     1019       (J)
     1020       (STRING-LIST NIL))
     1021      (NIL)
     1022    (SETQ J (STRING-SEARCH-CHAR #/, STRING I))
     1023    (PUSH (FS:MERGE-PATHNAME-DEFAULTS (NSUBSTRING STRING I J))
     1024          STRING-LIST)
     1025    (OR J (RETURN (NREVERSE STRING-LIST)))))
     1026
     1027(DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :DECODE-VARIABLE-TYPE) (KWD-AND-ARGS &AUX KEY TEM)
     1028  (SETQ KEY (CAR KWD-AND-ARGS))
     1029  (COND ((EQ KEY ':DOCUMENTATION)
     1030         (MULTIPLE-VALUE-BIND (PF RF CHOICES GPVF GVVF)
     1031             (FUNCALL-SELF ':DECODE-VARIABLE-TYPE (OR (CDDR KWD-AND-ARGS) '(:SEXP)))
     1032           (VALUES PF RF CHOICES GPVF GVVF (CADR KWD-AND-ARGS))))
     1033        ((SETQ TEM (GET KEY 'CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION))
     1034         (FUNCALL TEM KWD-AND-ARGS))
     1035        ((SETQ TEM (GET KEY 'CHOOSE-VARIABLE-VALUES-KEYWORD))
     1036         (VALUES-LIST TEM))
     1037        (T
     1038         (FERROR NIL "~S bad keyword in a CHOOSE-VARIABLE-VALUES-WINDOW" KEY))))
    9021039
    9031040;So lines can wrap around when reading
    9041041(DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :END-OF-LINE-EXCEPTION) ()
    905   (IF LINE-OVERFLOW-ALLOWED (SHEET-END-OF-LINE-EXCEPTION-METHOD NIL) ;<-AS
     1042  (IF LINE-OVERFLOW-ALLOWED
     1043      (FUNCALL #'(:METHOD SHEET :END-OF-LINE-EXCEPTION) ':END-OF-LINE-EXCEPTION) ;<-AS
    9061044      (*THROW 'LINE-OVERFLOW T)))
    9071045
     
    9201058                                                        &AUX VAR VAL STR FONTNO
    9211059                                                             CHOICES PF RF K&A
    922                                                              GPVF GVVF PVAL)
     1060                                                             GPVF GVVF PVAL CVAL)
    9231061  LINE-NO ITEM-NO ;ignored
    9241062  ;; Parse ITEM into label string, font to print that in, variable, and keyword-&-arguments
     
    9371075         (SHEET-SET-FONT SELF (AREF FONT-MAP FONTNO))
    9381076         (SHEET-STRING-OUT SELF STR)
    939          (SHEET-STRING-OUT SELF ": ")))
     1077         (IF VAR (SHEET-STRING-OUT SELF ": "))))
    9401078  ;; If any variable, get its value and decide how to print it
    9411079  (COND (VAR
     
    9481086               (T (DOLIST (CHOICE CHOICES)
    9491087                    (SETQ PVAL (IF GPVF (FUNCALL GPVF CHOICE) CHOICE)
     1088                          CVAL (IF GVVF (FUNCALL GVVF CHOICE) CHOICE))
     1089                    (SHEET-SET-FONT SELF (AREF FONT-MAP (IF (EQUAL CVAL VAL) 4 3)))
     1090                    (FUNCALL-SELF ':ITEM CHOICE ':VARIABLE-CHOICE
     1091                                  'CHOOSE-VARIABLE-VALUES-PRINT-FUNCTION PF PVAL)
     1092                    (SHEET-SPACE SELF)))))))
     1093
     1094(DEFUN CHOOSE-VARIABLE-VALUES-PRINT-FUNCTION (ITEM WINDOW PF PVAL)
     1095  ITEM ;ignored
     1096  (FUNCALL PF PVAL WINDOW))
     1097
     1098;Modified from the :PRINT-ITEM method.  Hard to be completely modular about this.
     1099;Extra-width is amount of space to allow for non-menu items to grow
     1100(DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :ITEM-WIDTH) (ITEM &OPTIONAL (EXTRA-WIDTH 0)
     1101                                                       &AUX VAR VAL STR FONTNO
     1102                                                            CHOICES PF RF K&A
     1103                                                            GPVF GVVF PVAL (X 0))
     1104  ;; Parse ITEM into label string, font to print that in, variable, and keyword-&-arguments
     1105  (COND ((STRINGP ITEM)
     1106         (SETQ STR ITEM FONTNO 0))
     1107        ((SYMBOLP ITEM)
     1108         (SETQ VAR ITEM STR (GET-PNAME VAR) FONTNO 1))
     1109        (T (SETQ VAR (CAR ITEM)
     1110                 STR (IF (OR (STRINGP (CADR ITEM)) (NULL (CADR ITEM)))
     1111                         (CAR (SETQ ITEM (CDR ITEM)))
     1112                         (GET-PNAME VAR))
     1113                 FONTNO 1
     1114                 K&A (CDR ITEM))))
     1115  ;; If any label string, print it and a colon
     1116  (COND (STR
     1117         (SETQ X (FUNCALL-SELF ':STRING-LENGTH STR 0 NIL NIL (AREF FONT-MAP FONTNO) X))
     1118         (SETQ X (FUNCALL-SELF ':STRING-LENGTH ": " 0 NIL NIL (AREF FONT-MAP FONTNO) X))))
     1119  ;; If any variable, get its value and decide how to print it
     1120  (COND (VAR
     1121         (SETQ VAL (SYMEVAL-IN-STACK-GROUP VAR STACK-GROUP))
     1122         (MULTIPLE-VALUE (PF RF CHOICES GPVF GVVF)
     1123           (FUNCALL-SELF ':DECODE-VARIABLE-TYPE (OR K&A '(:SEXP))))
     1124         (COND ((NOT CHOICES)
     1125                (SETQ X (+ (FUNCALL-SELF ':STRING-LENGTH
     1126                                         (WITH-OUTPUT-TO-STRING (S) (FUNCALL PF VAL S))
     1127                                         0 NIL NIL (AREF FONT-MAP 2) X)
     1128                           EXTRA-WIDTH)))
     1129               (T (DOLIST (CHOICE CHOICES)
     1130                    (SETQ PVAL (IF GPVF (FUNCALL GPVF CHOICE) CHOICE)
    9501131                          CHOICE (IF GVVF (FUNCALL GVVF CHOICE) CHOICE))
    951                     (SHEET-SET-FONT SELF (AREF FONT-MAP (IF (EQUAL CHOICE VAL) 4 3)))
    952                     (FUNCALL-SELF ':ITEM PVAL ':VARIABLE-CHOICE PF)
    953                     (SHEET-SPACE SELF)))))))
    954 
    955 (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :MOUSE-BUTTONS) (BD X Y &AUX VALUE TYPE LINE-NO)
    956   (MULTIPLE-VALUE (VALUE TYPE) (FUNCALL-SELF ':MOUSE-SENSITIVE-ITEM X Y))
    957   (COND ((BIT-TEST 4 BD)                        ;Mouse right
    958          (MOUSE-CALL-SYSTEM-MENU))
    959         ((AND (BIT-TEST 1 BD) TYPE)             ;Mouse left
    960          (SETQ LINE-NO (// (- Y (SHEET-INSIDE-TOP)) LINE-HEIGHT))
    961          (FUNCALL-SELF ':FORCE-KBD-INPUT
    962                        (LIST TYPE SELF (AREF ITEMS (+ TOP-ITEM LINE-NO)) VALUE LINE-NO)))
    963         (T (BEEP))))
     1132                    (SETQ X (FUNCALL-SELF ':STRING-LENGTH
     1133                                          (WITH-OUTPUT-TO-STRING (S) (FUNCALL PF PVAL S))
     1134                                          0 NIL NIL
     1135                                          (AREF FONT-MAP (IF (EQUAL CHOICE VAL) 4 3)) X))
     1136                    (INCF X CHAR-WIDTH))))))
     1137  X)
     1138
     1139(DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :APPROPRIATE-WIDTH) (&OPTIONAL EXTRA-WIDTH)
     1140  "Returns the inside-width appropriate to accommodate the current set of variables
     1141   with their current values.  If EXTRA-WIDTH is specified that much room for expansion,
     1142   which can be a number of characters or a string, is left after non-menu items."
     1143  (SETQ EXTRA-WIDTH
     1144        (COND ((STRINGP EXTRA-WIDTH) (FUNCALL-SELF ':STRING-LENGTH EXTRA-WIDTH))
     1145              ((NUMBERP EXTRA-WIDTH) (* CHAR-WIDTH EXTRA-WIDTH))
     1146              (T 0)))
     1147  (MIN (MAX (FUNCALL-SELF ':LABEL-SIZE)
     1148            (LOOP FOR ITEM BEING THE ARRAY-ELEMENTS OF ITEMS
     1149                  MAXIMIZE (FUNCALL-SELF ':ITEM-WIDTH ITEM EXTRA-WIDTH)))
     1150       (+ (SHEET-INSIDE-WIDTH SUPERIOR) LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE)))
     1151
     1152;This is quite a bit slower than it needs to be.  However these windows aren't used much.
     1153(DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :WHO-LINE-DOCUMENTATION-STRING) ()
     1154  (MULTIPLE-VALUE-BIND (WINDOW-X-OFFSET WINDOW-Y-OFFSET)
     1155        (SHEET-CALCULATE-OFFSETS SELF MOUSE-SHEET)
     1156    (LET ((X (- MOUSE-X WINDOW-X-OFFSET))
     1157          (Y (- MOUSE-Y WINDOW-Y-OFFSET)))
     1158      (MULTIPLE-VALUE-BIND (VALUE TYPE) (FUNCALL-SELF ':MOUSE-SENSITIVE-ITEM X Y)
     1159        (AND TYPE
     1160             (LET ((ITEM (AREF ITEMS (+ TOP-ITEM (// (- Y (SHEET-INSIDE-TOP)) LINE-HEIGHT)))))
     1161               (IF (ATOM ITEM) "Click left to input a new value from the keyboard."
     1162                   (SETQ ITEM (CDR ITEM))
     1163                   (AND (OR (STRINGP (CAR ITEM)) (NULL (CAR ITEM)))
     1164                        (SETQ ITEM (CDR ITEM)))
     1165                   (MULTIPLE-VALUE-BIND (IGNORE RF IGNORE IGNORE IGNORE DOC)
     1166                       (FUNCALL-SELF ':DECODE-VARIABLE-TYPE (OR ITEM '(:SEXP)))
     1167                     (COND ((STRINGP DOC) DOC)
     1168                           ((AND DOC (FUNCALL DOC VALUE)))
     1169                           ((NULL RF) "Click left to change to this value.")
     1170                           (T "Click left to input a new value from the keyboard."))))))))))
     1171
     1172(DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :MOUSE-CLICK) (BUTTON X Y &AUX VALUE TYPE LINE-NO)
     1173  (COND ((= BUTTON #\MOUSE-1-1)
     1174         (MULTIPLE-VALUE (VALUE TYPE) (FUNCALL-SELF ':MOUSE-SENSITIVE-ITEM X Y))
     1175         (COND (TYPE
     1176                (SETQ LINE-NO (// (- Y (SHEET-INSIDE-TOP)) LINE-HEIGHT))
     1177                (FUNCALL-SELF ':FORCE-KBD-INPUT
     1178                              (LIST TYPE SELF (AREF ITEMS (+ TOP-ITEM LINE-NO))
     1179                                    VALUE LINE-NO))
     1180                T)))))
    9641181
    9651182;Called when a :VARIABLE-CHOICE message comes back through the io-buffer
     
    10071224                            (MULTIPLE-VALUE (NEWVAL FULL-RUBOUT)
    10081225                              (FUNCALL WINDOW ':RUBOUT-HANDLER '((:FULL-RUBOUT T))
    1009                                        #'(LAMBDA (RF STREAM &AUX VAL)
    1010                                            (IF (SETQ VAL (ERRSET (FUNCALL RF STREAM)))
    1011                                                (SETQ VAL (CAR VAL))
    1012                                                (SETQ REDISPLAY-FLAG T)
    1013                                                (*THROW 'EH:ERRSET-CATCH NIL)))
     1226                                       #'(LAMBDA (RF STREAM &AUX VAL ERROR)
     1227                                           (MULTIPLE-VALUE (VAL ERROR)
     1228                                             (CATCH-ERROR (FUNCALL RF STREAM)))
     1229                                           (COND (ERROR
     1230                                                  (SETQ REDISPLAY-FLAG T)
     1231                                                  (*THROW 'EH:ERRSET-CATCH NIL)))
     1232                                           VAL)
    10141233                                       RF WINDOW))
    10151234                            ;; If we got a read error, try to avoid garbage in the display
     
    10191238             (FUNCALL WINDOW ':SET-SENSITIVE-ITEM-TYPES T)
    10201239             (OR (EQ WS ':SELECTED) (FUNCALL WINDOW ':SET-STATUS WS)))))
    1021         ((NULL GPVF) (SETQ NEWVAL CHOICE))
    1022         (T (SETQ NEWVAL (DOLIST (X CHOICES)
    1023                           (AND (EQUAL (FUNCALL GPVF X) CHOICE)
    1024                                (RETURN X))))))
     1240        (T (SETQ NEWVAL CHOICE)))
    10251241  (AND GVVF (SETQ NEWVAL (FUNCALL GVVF NEWVAL)))
    10261242  (SETQ OLDVAL (SYMEVAL VAR))
     
    10651281           (RETURN)))))
    10661282
    1067 (DEFFLAVOR CHOOSE-VARIABLE-VALUES-PANE () (PANE-MIXIN CHOOSE-VARIABLE-VALUES-WINDOW))
     1283(DEFFLAVOR CHOOSE-VARIABLE-VALUES-PANE-MIXIN () (PANE-MIXIN))
     1284(DEFFLAVOR CHOOSE-VARIABLE-VALUES-PANE
     1285        ()
     1286        (CHOOSE-VARIABLE-VALUES-PANE-MIXIN CHOOSE-VARIABLE-VALUES-WINDOW))
    10681287
    10691288;;; Let it be determined by the superior
    1070 (DEFMETHOD (CHOOSE-VARIABLE-VALUES-PANE :ADJUSTABLE-SIZE-P) ()
     1289(DEFMETHOD (CHOOSE-VARIABLE-VALUES-PANE-MIXIN :ADJUSTABLE-SIZE-P) ()
    10711290  NIL)
    10721291
    1073 ;;; Doesn't need a :PANE-SIZE method since the horizontal and vertical dimensions
    1074 ;;; are not inter-dependent.
    1075 
     1292;;; Even though we the vertical and horizontal dimensions are independent, this gives
     1293;;; what we prefer.
     1294(DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :PANE-SIZE) (REM-WIDTH REM-HEIGHT
     1295                                                      IGNORE IGNORE STACKING)
     1296  (SELECTQ STACKING
     1297    (:VERTICAL (MIN REM-HEIGHT
     1298                    (+ TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE
     1299                       (* (ARRAY-ACTIVE-LENGTH ITEMS) LINE-HEIGHT))))
     1300    (:HORIZONTAL (MIN REM-WIDTH
     1301                      (+ LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE
     1302                         (FUNCALL-SELF ':APPROPRIATE-WIDTH))))))
    10761303
    10771304(DEFFLAVOR TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW ()
     
    10861313                        CHOOSE-VARIABLE-VALUES-PANE)
    10871314
    1088 (DEFRESOURCE TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW
    1089     (WINDOW-CREATE 'TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW))
     1315(DEFWINDOW-RESOURCE TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW ()
     1316        :MAKE-WINDOW (TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW)
     1317        :INITIAL-COPIES 0)
    10901318
    10911319;; This is the handy-dandy user interface to the above
     
    10941322;; :FUNCTION  Function called if user changes anything (default is NIL)
    10951323;; :NEAR-MODE  Where to appear the window (default is (:MOUSE))
     1324;; :WIDTH  Desired width of window.  Default is to set wide enough for items.
     1325;; :EXTRA-WIDTH  Amount of extra width to allow for growing items.  Default 10 characters.
     1326;;   Both of the above widths may be a number of characters or a string.
    10961327;; :MARGIN-CHOICES  List of elements.  A string is the label for the
    10971328;;              box which means "exit" (Default is "Exit"), cons of
    10981329;;              a string and a form means eval that form if box clicked upon.
     1330;; :SUPERIOR  Window to put under, default is MOUSE-SHEET or the superior
     1331;;            of the window it is supposed to be near, like MENU-CHOOSE
    10991332
    11001333(DEFUN CHOOSE-VARIABLE-VALUES (VARIABLES &REST OPTIONS
    11011334                               &AUX OP VAL (LABEL "Choose Variable Values") FUNCTION
    1102                                     MARGIN-CHOICES (NEAR-MODE '(:MOUSE)))
     1335                                    MARGIN-CHOICES (NEAR-MODE '(:MOUSE)) SUP OSW
     1336                                    WIDTH (EXTRA-WIDTH 10.))
    11031337  (DO OPTIONS OPTIONS (CDDR OPTIONS) (NULL OPTIONS)
    11041338    (SETQ OP (CAR OPTIONS) VAL (CADR OPTIONS))
     
    11071341      (:FUNCTION (SETQ FUNCTION VAL))
    11081342      (:NEAR-MODE (SETQ NEAR-MODE VAL))
     1343      (:WIDTH (SETQ WIDTH VAL))
     1344      (:EXTRA-WIDTH (SETQ EXTRA-WIDTH VAL))
    11091345      (:MARGIN-CHOICES (SETQ MARGIN-CHOICES VAL))
     1346      (:SUPERIOR (SETQ SUP VAL))
    11101347      (OTHERWISE (FERROR NIL "~S invalid option keyword" OP))))
     1348  ;; Decide what superior to use
     1349  (OR SUP
     1350      (SETQ SUP (IF (EQ (CAR NEAR-MODE) ':WINDOW) (SHEET-SUPERIOR (CADR NEAR-MODE))
     1351                    MOUSE-SHEET)))
    11111352  ;; MARGIN-CHOICES must always contain a "exit" box so user can stop choosing
    11121353  (DO ((L MARGIN-CHOICES (CDR L)))
     
    11231364    (AND (NOT (STRINGP ELEM))
    11241365         (SYMEVAL (IF (ATOM ELEM) ELEM (CAR ELEM)))))
    1125   (WITH-RESOURCE (TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW WINDOW)
     1366  (USING-RESOURCE (WINDOW TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW SUP)
    11261367    (FUNCALL WINDOW ':SETUP VARIABLES LABEL FUNCTION MARGIN-CHOICES)
     1368    (COND ((STRINGP WIDTH)
     1369           (SETQ WIDTH (FUNCALL WINDOW ':STRING-LENGTH WIDTH)))
     1370          ((NUMBERP WIDTH)
     1371           (SETQ WIDTH (* (SHEET-CHAR-WIDTH WINDOW) WIDTH)))
     1372          ((NULL WIDTH)
     1373           (SETQ WIDTH (FUNCALL WINDOW ':APPROPRIATE-WIDTH EXTRA-WIDTH))))
     1374    (FUNCALL WINDOW ':SET-INSIDE-SIZE WIDTH (SHEET-INSIDE-HEIGHT WINDOW))
     1375    (SETQ OSW SELECTED-WINDOW)
    11271376    (UNWIND-PROTECT
    11281377      (LET ((IOB (FUNCALL WINDOW ':IO-BUFFER)))
     
    11351384          (AND (CHOOSE-VARIABLE-VALUES-PROCESS-MESSAGE WINDOW (FUNCALL WINDOW ':ANY-TYI))
    11361385               (RETURN))))
     1386      (AND OSW (FUNCALL OSW ':SELECT NIL))
    11371387      (FUNCALL WINDOW ':DEACTIVATE))))
    11381388
     
    11971447                                                   VALUE `',VALUE))
    11981448                         95. STREAM))))
     1449
     1450;;; Site dependent versions
     1451(DEFMACRO DEFINE-SITE-USER-OPTION ((OPTION ALIST) KEYWORD &OPTIONAL TYPE NAME &REST ARGS)
     1452  `(PROGN 'COMPILE
     1453     (DEFINE-USER-OPTION-1 ',OPTION ',ALIST NIL ',(OR TYPE ':SEXP)
     1454                           ',(OR NAME (ZWEI:MAKE-COMMAND-NAME OPTION)) . ,ARGS)
     1455     (DEFVAR ,OPTION)
     1456     (ADD-INITIALIZATION ,(FORMAT NIL "SITE:~A" OPTION)
     1457                         `(RESET-USER-OPTION ',',OPTION (SI:GET-SITE-OPTION ',',KEYWORD))
     1458                         '(SITE))))
     1459
     1460;;; Change the default value of an option
     1461(DEFUN RESET-USER-OPTION (OPTION VALUE)
     1462  (SET OPTION VALUE)
     1463  (PUTPROP OPTION VALUE 'DEFAULT-VALUE))
     1464
     1465;;; A :MENU-ALIST type variable whose alist changes
     1466(DEFMACRO DEFINE-SITE-ALIST-USER-OPTION ((OPTION ALIST) NAME MENU-ALIST &OPTIONAL DEFAULT)
     1467  `(PROGN 'COMPILE
     1468     (DEFINE-USER-OPTION-1 ',OPTION ',ALIST NIL ':MENU-ALIST
     1469                           ',(OR NAME (ZWEI:MAKE-COMMAND-NAME OPTION))
     1470                           ,MENU-ALIST)
     1471     (DEFVAR ,OPTION)
     1472     (ADD-INITIALIZATION ,(FORMAT NIL "SITE:~A" OPTION)
     1473                         `(RESET-ALIST-USER-OPTION ',',OPTION ,',ALIST ,',MENU-ALIST
     1474                                                   ',',DEFAULT)
     1475                         '(SITE))))
     1476
     1477(DEFUN RESET-ALIST-USER-OPTION (OPTION ALIST MENU-ALIST DEFAULT)
     1478  (AND DEFAULT
     1479       (SETQ DEFAULT (SI:GET-SITE-OPTION DEFAULT)))
     1480  (LOOP FOR ELEM IN MENU-ALIST
     1481        AS SITE-KEYWORD = (OR (AND (LISTP (CDR ELEM)) (GET ELEM ':SITE-KEYWORD))
     1482                              (TV:MENU-EXECUTE-NO-SIDE-EFFECTS ELEM))
     1483        AS DEFAULT-SITE-KEYWORD = (OR (AND (LISTP (CDR ELEM))
     1484                                           (GET ELEM ':DEFAULT-SITE-KEYWORD))
     1485                                      SITE-KEYWORD)
     1486        WHEN (NOT (NULL (SI:GET-SITE-OPTION SITE-KEYWORD)))
     1487        COLLECT ELEM INTO NEW-ALIST
     1488        WITH DEFAULT-ELEM
     1489        WHEN (EQ DEFAULT-SITE-KEYWORD DEFAULT)
     1490        DO (SETQ DEFAULT-ELEM ELEM)
     1491        FINALLY (AND DEFAULT-ELEM (SETQ NEW-ALIST (CONS DEFAULT-ELEM
     1492                                                        (DELQ DEFAULT-ELEM NEW-ALIST))))
     1493                (SETQ MENU-ALIST NEW-ALIST))
     1494  (LET ((ELEM (ASSQ OPTION ALIST)))
     1495    (SETF (FOURTH ELEM) MENU-ALIST))
     1496  (RESET-USER-OPTION OPTION (AND MENU-ALIST
     1497                                 (TV:MENU-EXECUTE-NO-SIDE-EFFECTS (CAR MENU-ALIST)))))
     1498
     1499(DEFMACRO RESTRICT-USER-OPTION (OPTION RESTRICTION-TYPE &REST SITE-KEYWORDS &AUX IF IF-NOT)
     1500  (SETQ SITE-KEYWORDS (COPYLIST SITE-KEYWORDS))
     1501  (SELECTQ RESTRICTION-TYPE
     1502    (:IF (SETQ IF SITE-KEYWORDS))
     1503    (:UNLESS (SETQ IF-NOT SITE-KEYWORDS))
     1504    (:NEVER (SETQ IF-NOT T)))
     1505  `(DEFPROP ,OPTION ,(OR IF IF-NOT)
     1506            ,(IF IF 'SITE-KEYWORDS-RESTRICTION 'NOT-SITE-KEYWORDS-RESTRICTION)))
     1507
     1508;;; This removes all user options that are restricted or choices with less than two
     1509;;; possibilities.
     1510(DEFUN PRUNE-USER-OPTION-ALIST (ALIST)
     1511  (LOOP FOR ELEM IN ALIST
     1512        AS OPTION = (CAR ELEM)
     1513        WITH TEM
     1514        UNLESS (OR (AND (NOT (NULL (SETQ TEM (GET OPTION 'NOT-SITE-KEYWORDS-RESTRICTION))))
     1515                        (OR (EQ TEM T)
     1516                            (LOOP FOR KEY IN TEM
     1517                                  THEREIS (SI:GET-SITE-OPTION KEY))))
     1518                   (AND (NOT (NULL (SETQ TEM (GET OPTION 'SITE-KEYWORDS-RESTRICTION))))
     1519                        (NOT (LOOP FOR KEY IN TEM
     1520                                   ALWAYS (SI:GET-SITE-OPTION KEY))))
     1521                   (AND (MEMQ (THIRD ELEM) '(:ASSOC :MENU-ALIST))
     1522                        (NULL (CDR (FOURTH ELEM)))))
     1523        COLLECT ELEM))
  • trunk/lisp/lmwin/cold.lisp

    r220 r275  
    1313(DEFVAR WHO-LINE-RUN-LIGHT-LOC 51765)   ;Where the run-light goes, in Xbus I/O space
    1414(DEFVAR KBD-LAST-ACTIVITY-TIME 0)       ;Time user last typed a key or clicked mouse
    15 (DEFVAR ALU-SETA #.ALU-SETA)
    16 (DEFVAR ALU-XOR #.ALU-XOR)
    17 (DEFVAR ALU-ANDCA #.ALU-ANDCA)
    18 (DEFVAR ALU-IOR #.ALU-IOR)
    19 (DEFVAR ALU-SETZ #.ALU-SETZ)
     15(DEFVAR ALU-SETA 5)     ;Magic BOOLE numbers
     16(DEFVAR ALU-XOR 6)
     17(DEFVAR ALU-ANDCA 2)
     18(DEFVAR ALU-IOR 7)
     19(DEFVAR ALU-SETZ 0)
     20(DEFVAR ALU-AND 1)
    2021);TV:
    2122
     
    111112        BUFFER (GET PLIST ':BUFFER)
    112113        TV:CONTROL-ADDRESS (GET PLIST ':CONTROL-ADDRESS)
    113         ARRAY (MAKE-ARRAY NIL 'ART-1B (LIST WIDTH HEIGHT) BUFFER)
     114        ARRAY (MAKE-ARRAY (LIST WIDTH HEIGHT) ':TYPE 'ART-1B ':DISPLACED-TO BUFFER)
    114115        LOCATIONS-PER-LINE (// WIDTH 32.)
    115116        CHAR-WIDTH (FONT-CHAR-WIDTH FONT)
    116117        LINE-HEIGHT (+ 2 (FONT-CHAR-HEIGHT FONT))
    117         RUBOUT-HANDLER-BUFFER (MAKE-ARRAY NIL ART-STRING 1000 NIL '(0 0))))
     118        RUBOUT-HANDLER-BUFFER (MAKE-ARRAY 1000 ':TYPE ART-STRING ':LEADER-LIST '(0 0))))
    118119
    119120(DEFMETHOD-IMMEDIATE (COLD-LOAD-STREAM :READ-CURSORPOS) (&OPTIONAL (UNITS ':PIXEL)
     
    139140
    140141(DEFMETHOD-IMMEDIATE (COLD-LOAD-STREAM :TYO) (CH)
    141   (COND ((< CH 200)
    142          (LET ((CHAR-WIDTHS (FONT-CHAR-WIDTH-TABLE FONT))
    143                (FIT-ENTRY (FONT-INDEXING-TABLE FONT))
    144                (DELTA-X))
    145            (SETQ DELTA-X (IF CHAR-WIDTHS (AREF CHAR-WIDTHS CH) (FONT-CHAR-WIDTH FONT)))
    146            (AND (> (+ CURSOR-X DELTA-X) WIDTH)  ;End of line exception
    147                 (FUNCALL-SELF ':TYO #\CR))
    148            (IF (NULL FIT-ENTRY)
    149                (%DRAW-CHAR FONT CH CURSOR-X CURSOR-Y TV:ALU-IOR SELF)
    150                (DO ((CH (AREF FIT-ENTRY CH) (1+ CH))
    151                     (LIM (AREF FIT-ENTRY (1+ CH)))
    152                     (XPOS CURSOR-X (+ XPOS (FONT-RASTER-WIDTH FONT))))
    153                    ((= CH LIM))
    154                  (%DRAW-CHAR FONT CH XPOS CURSOR-Y TV:ALU-IOR SELF)))
    155            (SETQ CURSOR-X (+ CURSOR-X DELTA-X))))
    156         ((= CH #\CR)
    157          (SETQ CURSOR-X 0
    158                CURSOR-Y (+ CURSOR-Y LINE-HEIGHT))
    159          (COND ((
     142  (LET ((CURRENTLY-PREPARED-SHEET SELF))
     143    (COND ((< CH 200)
     144           (LET ((CHAR-WIDTHS (FONT-CHAR-WIDTH-TABLE FONT))
     145                 (FIT-ENTRY (FONT-INDEXING-TABLE FONT))
     146                 (DELTA-X))
     147             (SETQ DELTA-X (IF CHAR-WIDTHS (AREF CHAR-WIDTHS CH) (FONT-CHAR-WIDTH FONT)))
     148             (AND (> (+ CURSOR-X DELTA-X) WIDTH)        ;End of line exception
     149                  (FUNCALL-SELF ':TYO #\CR))
     150             (IF (NULL FIT-ENTRY)
     151                 (%DRAW-CHAR FONT CH CURSOR-X CURSOR-Y TV:ALU-IOR SELF)
     152                 (DO ((CH (AREF FIT-ENTRY CH) (1+ CH))
     153                      (LIM (AREF FIT-ENTRY (1+ CH)))
     154                      (XPOS CURSOR-X (+ XPOS (FONT-RASTER-WIDTH FONT))))
     155                     ((= CH LIM))
     156                   (%DRAW-CHAR FONT CH XPOS CURSOR-Y TV:ALU-IOR SELF)))
     157             (SETQ CURSOR-X (+ CURSOR-X DELTA-X))))
     158          ((= CH #\CR)
     159           (SETQ CURSOR-X 0
     160                 CURSOR-Y (+ CURSOR-Y LINE-HEIGHT))
     161           (COND ((
    160162 CURSOR-Y (- HEIGHT LINE-HEIGHT))       ;End of page exception
    161                 (FUNCALL-SELF ':STRING-OUT "**MORE**")
    162                 (FUNCALL-SELF ':TYI)
    163                 (SETQ CURSOR-X 0)
    164                 (FUNCALL-SELF ':CLEAR-EOL)
    165                 (SETQ CURSOR-Y 0)))
    166          (FUNCALL-SELF ':CLEAR-EOL))
    167         ((= CH #\TAB)
    168          (DOTIMES (I (- 8 (\ (// CURSOR-X CHAR-WIDTH) 8)))
    169            (FUNCALL-SELF ':TYO #\SP)))
    170         ((AND (< CH 240) (BOUNDP 'FONTS:5X5))
    171          ;; This won't work in the initial cold-load environment, hopefully no one
    172          ;; will touch those keys then, but if they do we just type nothing.
    173          ;; This code is like SHEET-DISPLAY-LOSENGED-STRING
    174          (LET* ((CHNAME (GET-PNAME (CAR (RASSOC CH XR-SPECIAL-CHARACTER-NAMES))))
    175                 (CHWIDTH (+ (* (ARRAY-ACTIVE-LENGTH CHNAME) 6) 10.)))
    176            (AND (> (+ CURSOR-X CHWIDTH) WIDTH)  ;Won't fit on line
    177                 (FUNCALL-SELF ':TYO #\CR))
    178            ;; Put the string then the box around it
    179            (LET ((X0 CURSOR-X)
    180                  (Y0 (1+ CURSOR-Y))
    181                  (X1 (+ CURSOR-X (1- CHWIDTH)))
    182                  (Y1 (+ CURSOR-Y 9)))
    183              (DO ((X (+ X0 5) (+ X 6))
    184                   (I 0 (1+ I))
    185                   (N (ARRAY-ACTIVE-LENGTH CHNAME)))
    186                  ((
     163                  (FUNCALL-SELF ':CLEAR-EOL)    ;In case wholine is there
     164                  (FUNCALL-SELF ':STRING-OUT "**MORE**")
     165                  (FUNCALL-SELF ':TYI)
     166                  (SETQ CURSOR-X 0)
     167                  (FUNCALL-SELF ':CLEAR-EOL)
     168                  (SETQ CURSOR-Y 0)))
     169           (FUNCALL-SELF ':CLEAR-EOL))
     170          ((= CH #\TAB)
     171           (DOTIMES (I (- 8 (\ (// CURSOR-X CHAR-WIDTH) 8)))
     172             (FUNCALL-SELF ':TYO #\SP)))
     173          ((AND (< CH 240) (BOUNDP 'FONTS:5X5))
     174           ;; This won't work in the initial cold-load environment, hopefully no one
     175           ;; will touch those keys then, but if they do we just type nothing.
     176           ;; This code is like SHEET-DISPLAY-LOSENGED-STRING
     177           (LET* ((CHNAME (GET-PNAME (CAR (RASSOC CH XR-SPECIAL-CHARACTER-NAMES))))
     178                  (CHWIDTH (+ (* (ARRAY-ACTIVE-LENGTH CHNAME) 6) 10.)))
     179             (AND (> (+ CURSOR-X CHWIDTH) WIDTH)        ;Won't fit on line
     180                  (FUNCALL-SELF ':TYO #\CR))
     181             ;; Put the string then the box around it
     182             (LET ((X0 CURSOR-X)
     183                   (Y0 (1+ CURSOR-Y))
     184                   (X1 (+ CURSOR-X (1- CHWIDTH)))
     185                   (Y1 (+ CURSOR-Y 9)))
     186               (DO ((X (+ X0 5) (+ X 6))
     187                    (I 0 (1+ I))
     188                    (N (ARRAY-ACTIVE-LENGTH CHNAME)))
     189                   ((
    187190 I N))
    188               (%DRAW-CHAR FONTS:5X5 (AREF CHNAME I) X (+ Y0 2) TV:ALU-IOR SELF))
    189              (%DRAW-RECTANGLE (- CHWIDTH 8) 1 (+ X0 4) Y0 TV:ALU-IOR SELF)
    190              (%DRAW-RECTANGLE (- CHWIDTH 8) 1 (+ X0 4) Y1 TV:ALU-IOR SELF)
    191              (%DRAW-LINE X0 (+ Y0 4) (+ X0 3) (1+ Y0) TV:ALU-IOR T SELF)
    192              (%DRAW-LINE (1+ X0) (+ Y0 5) (+ X0 3) (1- Y1) TV:ALU-IOR T SELF)
    193              (%DRAW-LINE X1 (+ Y0 4) (- X1 3) (1+ Y0) TV:ALU-IOR T SELF)
    194              (%DRAW-LINE (1- X1) (+ Y0 5) (- X1 3) (1- Y1) TV:ALU-IOR T SELF)
    195              (SETQ CURSOR-X (1+ X1))))))
    196   CH)
     191                (%DRAW-CHAR FONTS:5X5 (AREF CHNAME I) X (+ Y0 2) TV:ALU-IOR SELF))
     192               (%DRAW-RECTANGLE (- CHWIDTH 8) 1 (+ X0 4) Y0 TV:ALU-IOR SELF)
     193               (%DRAW-RECTANGLE (- CHWIDTH 8) 1 (+ X0 4) Y1 TV:ALU-IOR SELF)
     194               (%DRAW-LINE X0 (+ Y0 4) (+ X0 3) (1+ Y0) TV:ALU-IOR T SELF)
     195               (%DRAW-LINE (1+ X0) (+ Y0 5) (+ X0 3) (1- Y1) TV:ALU-IOR T SELF)
     196               (%DRAW-LINE X1 (+ Y0 4) (- X1 3) (1+ Y0) TV:ALU-IOR T SELF)
     197               (%DRAW-LINE (1- X1) (+ Y0 5) (- X1 3) (1- Y1) TV:ALU-IOR T SELF)
     198               (SETQ CURSOR-X (1+ X1))))))
     199    CH))
    197200
    198201(DEFMETHOD-IMMEDIATE (COLD-LOAD-STREAM :CLEAR-EOL) ()
    199   (%DRAW-RECTANGLE (- WIDTH CURSOR-X) LINE-HEIGHT CURSOR-X CURSOR-Y TV:ALU-ANDCA SELF))
     202  (LET ((CURRENTLY-PREPARED-SHEET SELF))
     203    (%DRAW-RECTANGLE (- WIDTH CURSOR-X) LINE-HEIGHT CURSOR-X CURSOR-Y TV:ALU-ANDCA SELF)))
    200204
    201205(DEFMETHOD-IMMEDIATE (COLD-LOAD-STREAM :CLEAR-SCREEN) ()
    202206  (SETQ CURSOR-X 0 CURSOR-Y 0)
    203   (%DRAW-RECTANGLE WIDTH HEIGHT 0 0 TV:ALU-ANDCA SELF))
     207  (LET ((CURRENTLY-PREPARED-SHEET SELF))
     208    (%DRAW-RECTANGLE WIDTH HEIGHT 0 0 TV:ALU-ANDCA SELF)))
    204209
    205210(DEFMETHOD-IMMEDIATE (COLD-LOAD-STREAM :FRESH-LINE) ()
    206   (OR (ZEROP CURSOR-X) (FUNCALL-SELF ':TYO #\CR)))
     211  (IF (ZEROP CURSOR-X) (FUNCALL-SELF ':CLEAR-EOL)
     212      (FUNCALL-SELF ':TYO #\CR)))
    207213
    208214(DEFMETHOD-IMMEDIATE (COLD-LOAD-STREAM :STRING-OUT) (STRING &OPTIONAL (START 0) END)
     
    244250         (COLD-LOAD-STREAM-RUBOUT-HANDLER))))
    245251
     252(DEFMETHOD-IMMEDIATE (COLD-LOAD-STREAM :TYI-NO-HANG) ()
     253  (AND (FUNCALL-SELF ':LISTEN)
     254       (FUNCALL-SELF ':TYI)))
     255
    246256(DEFVAR COLD-LOAD-STREAM-BLINKER-TIME 15.)
    247257(DEFVAR COLD-LOAD-STREAM-WAIT-TIME 1000.)
     
    249259(DEFUN COLD-LOAD-STREAM-WAIT-FOR-CHAR ()
    250260  (DO ((PHASE NIL)
    251        (BLINKER-COUNT 0))
     261       (BLINKER-COUNT 0)
     262       (CURRENTLY-PREPARED-SHEET SELF))
    252263      ((KBD-HARDWARE-CHAR-AVAILABLE)
    253264       (AND PHASE
     
    260271                 BLINKER-COUNT COLD-LOAD-STREAM-BLINKER-TIME)))
    261272    (DOTIMES (I COLD-LOAD-STREAM-WAIT-TIME)))))
     273
     274(DEFVAR RUBOUT-HANDLER-OPTIONS)
    262275
    263276;;; Give a single character, or do rubout processing, throws to RUBOUT-HANDLER on editting.
     
    278291           (FUNCALL-SELF ':TYO CH)              ;Echo it
    279292           (IF (= CH #\FORM) (FUNCALL-SELF ':CLEAR-SCREEN) (FUNCALL-SELF ':TYO #\CR))
     293           (LET ((PROMPT (OR (ASSQ ':REPROMPT RUBOUT-HANDLER-OPTIONS)
     294                             (ASSQ ':PROMPT RUBOUT-HANDLER-OPTIONS))))
     295             (AND PROMPT (FUNCALL (CADR PROMPT) SELF CH)))
    280296           (FUNCALL-SELF ':STRING-OUT RUBOUT-HANDLER-BUFFER))
    281297          ((= CH #\RUBOUT)
     
    292308          (T
    293309           (FUNCALL-SELF ':TYO CH)
    294            ;; This is not in the cold load, fake it until it gets loaded
    295            (OR (FBOUNDP 'ARRAY-PUSH-EXTEND)
    296                (FSET 'ARRAY-PUSH-EXTEND 'ARRAY-PUSH))
    297310           (ARRAY-PUSH-EXTEND RUBOUT-HANDLER-BUFFER CH)
    298311           (COND (RUBBED-OUT-SOME
     
    308321  (STORE-ARRAY-LEADER 0 RUBOUT-HANDLER-BUFFER 0)
    309322  (STORE-ARRAY-LEADER 0 RUBOUT-HANDLER-BUFFER 1)
     323  (LET ((PROMPT-OPTION (ASSQ ':PROMPT RUBOUT-HANDLER-OPTIONS)))
     324    (AND PROMPT-OPTION                          ;Prompt if desired
     325         (FUNCALL (CADR PROMPT-OPTION) SELF NIL)))
    310326  (COND (UNRCHF                         ;If there is unread input, force it in
    311327         (ARRAY-PUSH RUBOUT-HANDLER-BUFFER UNRCHF)
     
    317333    (*CATCH 'RUBOUT-HANDLER                     ;Throw here when rubbing out
    318334      (PROGN
    319         (ERRSET (RETURN (APPLY FUNCTION ARGS))) ;Call read type function
     335        (CATCH-ERROR (RETURN (APPLY FUNCTION ARGS)))    ;Call read type function
    320336        (FUNCALL-SELF ':STRING-OUT RUBOUT-HANDLER-BUFFER)       ;On error, retype buffered
    321337        (DO () (NIL) (FUNCALL-SELF ':TYI))))            ;and force user to edit it
     
    354370(DEFUN KBD-CONVERT-TO-SOFTWARE-CHAR (HARD-CHAR &AUX ASC SHIFT BUCKY)
    355371  "Convert hardware character to software character, or NIL to ignore"
    356   (IF (= (LDB 2003 HARD-CHAR) 1) (KBD-CONVERT-NEW HARD-CHAR)
     372  (SELECTQ (LDB 2003 HARD-CHAR)                 ;Source ID
     373    (1 (KBD-CONVERT-NEW HARD-CHAR))             ;New keyboard
     374    (6 (SET-MOUSE-MODE 'VIA-KBD)                ;Mouse via keyboard - turn on remote mouse
     375       NIL)                                     ; enable bit in IOB
     376    (7                                          ;Old keyboard
    357377      (SETQ SHIFT (COND ((BIT-TEST 1400 HARD-CHAR) 2)   ;TOP
    358378                        ((BIT-TEST 300 HARD-CHAR) 1)    ;SHIFT
     
    369389 ASC #/a) (
    370390 ASC #/z) (SETQ ASC (- ASC 40)))))
    371       (+ ASC BUCKY)))
    372 
    373 ;; Sys com locations 500-577 are reserved for the wired keyboard buffer:
    374 ;; Locations 501 through 511 contain the buffer header; 520-577 are the buffer (48. chars)
     391      (AND (NOT (ZEROP BUCKY)) (
     392 ASC #/a) (
     393 ASC #/z)
     394           (SETQ ASC (- ASC 40)))               ;Control characters always uppercase
     395      (+ ASC BUCKY))))
     396
     397;; Sys com locations 500-511 are reserved for the wired keyboard buffer:
     398;; Locations 501 through 511 contain the buffer header; the actual buffer
     399;; is in locations 200-377 (128. chars, 64. on new-keyboards)
    375400;;
    376401;; This is called when the machine is booted, warm or cold.  It's not an
    377402;; initialization because it has to happen before all other initializations.
    378403(DEFUN INITIALIZE-WIRED-KBD-BUFFER ()
    379   (DO I 500 (1+ I) (= I 600)
     404  (DO I 500 (1+ I) (= I 512)
     405    (%P-STORE-TAG-AND-POINTER I 0 0))
     406  (DO I 200 (1+ I) (= I 400)
    380407    (%P-STORE-TAG-AND-POINTER I 0 0))
    381408  (%P-DPB 260 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-VECTOR-ADDRESS))
     
    384411  (%P-DPB (VIRTUAL-UNIBUS-ADDRESS 764100) %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-DATA-ADDRESS))
    385412  (%P-DPB 1 %%Q-FLAG-BIT (+ 500 %UNIBUS-CHANNEL-DATA-ADDRESS))
    386   (%P-DPB 520 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-START))
    387   (%P-DPB 600 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-END))
    388   (%P-DPB 520 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-IN-PTR))
    389   (%P-DPB 520 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-OUT-PTR))
     413  (%P-DPB 200 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-START))
     414  (%P-DPB 400 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-END))
     415  (%P-DPB 1 %%Q-FLAG-BIT (+ 500 %UNIBUS-CHANNEL-BUFFER-END))    ;Enable seq breaks.
     416  (%P-DPB 200 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-IN-PTR))
     417  (%P-DPB 200 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-OUT-PTR))
    390418  (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-UNIBUS-INTERRUPT-LIST) 500)
    391   (%UNIBUS-WRITE 764112 4))     ;Keyboard interrupt enable, local mouse
     419  (SET-MOUSE-MODE 'DIRECT))
     420
     421(DEFUN SET-MOUSE-MODE (MODE)
     422  (SELECTQ MODE
     423    (DIRECT (%UNIBUS-WRITE 764112 4))   ;Keyboard interrupt enable, local mouse
     424    (VIA-KBD (%UNIBUS-WRITE 764112 5))
     425    (OTHERWISE (FERROR NIL "UNKNOWN MOUSE MDDE"))))
    392426
    393427;; Translate from a Unibus address to a Lisp machine virtual address, returning a fixnum.
     
    401435
    402436(DEFUN KBD-INITIALIZE ()
    403   (SETQ KBD-TRANSLATE-TABLE (MAKE-ARRAY WORKING-STORAGE-AREA 'ART-8B '(3 100)))
     437  (SETQ KBD-TRANSLATE-TABLE (MAKE-ARRAY '(3 100)
     438                                        ':AREA  WORKING-STORAGE-AREA
     439                                        ':TYPE 'ART-8B))
    404440  (DO ((I 0 (1+ I))  ;2ND DIMENSION
    405441       (L '(
     
    439475        #/\     #/|     #/|
    440476        #//     #/     #/
    441         #/Œ     #/     #/
    442         #/Š     #/‰     #/‰
     477        #/
     478        #/
     479        #/
     480        #/
     481        #/              #/     
    443482        #\FORM  #\FORM  #\FORM
    444483        #\VT    #\VT    #\VT
     
    464503        #/x     #/X     #/
    465504        #/c     #/C     #/
    466         #/v     #/V     #/ˆ
     505        #/v     #/V     #/
    467506        #/b     #/B     #/
    468507        #/n     #/N     #/
     
    546585                   ((BIT-TEST 1_8 CH)
    547586                    (ASET 0 KBD-KEY-STATE-ARRAY NCH0)
    548                     (AND (BIT-TEST 1_9 KBD-SHIFTS)       ;Mode lock
    549                          (SELECTQ NCH
    550                            (#\I (SETQ TV:KBD-BUTTONS (BOOLE 4 TV:KBD-BUTTONS 1)))
    551                            (#\II (SETQ TV:KBD-BUTTONS (BOOLE 4 TV:KBD-BUTTONS 2)))
    552                            (#\III (SETQ TV:KBD-BUTTONS (BOOLE 4 TV:KBD-BUTTONS 4)))))
     587                    (COND ((BIT-TEST 1_9 KBD-SHIFTS)     ;Mode lock
     588                           (SELECTQ NCH
     589                             (#\ROMAN-I (SETQ TV:KBD-BUTTONS (BOOLE 4 TV:KBD-BUTTONS 1)))
     590                             (#\ROMAN-II (SETQ TV:KBD-BUTTONS (BOOLE 4 TV:KBD-BUTTONS 2)))
     591                             (#\ROMAN-III (SETQ TV:KBD-BUTTONS (BOOLE 4 TV:KBD-BUTTONS 4))))
     592                           (SETQ MOUSE-WAKEUP T)))
    553593                    NIL)         ;Just an up-code
    554594                   ((AND (BIT-TEST 1_9 KBD-SHIFTS)       ;Mode lock
    555                          (MEMQ NCH '(#\I #\II #\III)))
     595                         (MEMQ NCH '(#\ROMAN-I #\ROMAN-II #\ROMAN-III)))
    556596                    (ASET 1 KBD-KEY-STATE-ARRAY NCH0)
    557597                    (SETQ TV:KBD-BUTTONS (LOGIOR TV:KBD-BUTTONS
    558                                                  (SELECTQ NCH (#\I 1) (#\II 2) (T 4))))
     598                                                 (SELECTQ NCH (#\ROMAN-I 1)
     599                                                          (#\ROMAN-II 2)
     600                                                          (T 4))))
     601                    (SETQ MOUSE-WAKEUP T)
    559602                    NIL)
    560603                   (T ;A real key depression.  Check for caps-lock.
    561604                    (ASET 1 KBD-KEY-STATE-ARRAY NCH0)
     605                    (SETQ NCH0 (LDB 0404 KBD-SHIFTS))   ;Hyper, Super, Meta, Control bits
     606                    (AND (BIT-TEST 3 NCH0)              ;Control/Shift/letter, Meta/Shift/let
     607                         (
     608 NCH #/A)
     609                         (
     610 NCH #/Z)
     611                         (SETQ NCH0 (+ NCH0 10)))       ;becomes Control/Hyper/Letter
    562612                    (AND (BIT-TEST 10 KBD-SHIFTS)       ;Caps lock
    563613                         (IF (AND SHIFT-LOCK-XORS (BIT-TEST 1 KBD-SHIFTS))
     
    568618 NCH #/a) (
    569619 NCH #/z) (SETQ NCH (- NCH 40)))))
    570                     (DPB (LDB 0404 KBD-SHIFTS) ;Hyper, Super, Meta, Control
    571                          %%KBD-CONTROL-META NCH))))))) ;A real character pushed down
     620                    (AND (NOT (ZEROP NCH0)) (
     621 NCH #/a) (
     622 NCH #/z)
     623                         (SETQ NCH (- NCH 40)))         ;Control characters always uppercase
     624                    (DPB NCH0 %%KBD-CONTROL-META NCH)))))))
    572625
    573626(DEFUN KBD-MAKE-NEW-TABLE ()
    574   (LET ((TBL (MAKE-ARRAY PERMANENT-STORAGE-AREA 'ART-16B '(5 200))))
     627  (LET ((TBL (MAKE-ARRAY '(5 200) ':AREA  PERMANENT-STORAGE-AREA ':TYPE 'ART-16B)))
    575628    (DO ((J 0 (1+ J))
    576629         (L '(
    577630        ()                                       ;0 not used
    578         #\II                                     ;1 Roman II
    579         #\IV                                     ;2 Roman IV
     631        #\ROMAN-II                               ;1 Roman II
     632        #\ROMAN-IV                               ;2 Roman IV
    580633        100011                                   ;3 Mode lock
    581634        ()                                       ;4 not used
     
    641694        (#/` #/~ #/~ #/)                        ;77 back quote
    642695        #\BACK-NEXT                              ;100 macro
    643         #\I                                      ;101 Roman I
    644         #\III                                    ;102 Roman III
     696        #\ROMAN-I                                ;101 Roman I
     697        #\ROMAN-III                              ;102 Roman III
    645698        ()                                       ;103 not used
    646699        100002                                   ;104 Left Top
     
    705758        (#// #/? #/? 177)                        ;174 Question/Integral
    706759        100047                                   ;175 Right Hyper
    707         (#\HAND-DOWN #\HAND-DOWN #\HAND-DOWN #/Š #/Š)   ;176 Down Thumb
     760        (#\HAND-DOWN #\HAND-DOWN #\HAND-DOWN #/
     761 #/
     762)       ;176 Down Thumb
    708763        ()                                       ;177 Not used
    709764              ) (CDR L)))
    710         ((= J 200) (SETQ KBD-NEW-TABLE TBL))
     765        ((= J 200) TBL)
    711766      (DO ((I 0 (1+ I))
    712767           (K (CAR L)))
     
    754809                 (SETQ ADR (FILL-SYNC (CDR X) ADR TV-ADR)))))))
    755810
    756 ;;; Set up sync for CPT monitor 768. x 896.
     811(DEFUN CHECK-SYNC (L &OPTIONAL (ADR 0)  (TV-ADR TV:(SCREEN-CONTROL-ADDRESS DEFAULT-SCREEN))
     812                   &AUX X)
     813  (DO ((L L (CDR L))) ((NULL L) ADR)
     814    (SETQ X (CAR L))
     815    (COND ((ATOM X)
     816           (CHECK-SYNC-WD ADR X TV-ADR)
     817           (SETQ ADR (1+ ADR)))
     818          (T (DO N (CAR X) (1- N) (ZEROP N)
     819               (SETQ ADR (CHECK-SYNC (CDR X) ADR TV-ADR)))))))
     820
     821(DEFUN CHECK-SYNC-WD (ADR DATA TV-ADR &AUX MACH)
     822  (COND ((NOT (= DATA (SETQ MACH (READ-SYNC ADR TV-ADR))))
     823         (FORMAT T "~%ADR:~S MACH: ~S should be ~S" ADR MACH DATA))))
     824
     825
     826;Initialize the TV.  Name of this function is obsolete.
     827;If FORCE-P is T, then SYNC-PROG is always loaded.
     828;Otherwise, it is a default to be loaded only if there is no prom.
    757829(DEFUN SETUP-CPT (&OPTIONAL (SYNC-PROG CPT-SYNC2)
    758                             (TV-ADR TV:(SCREEN-CONTROL-ADDRESS DEFAULT-SCREEN))
     830                            (TV-ADR NIL)
    759831                            (FORCE-P NIL))
     832  (IF (NULL TV-ADR) (SETQ TV-ADR TV:(SCREEN-CONTROL-ADDRESS DEFAULT-SCREEN)))
    760833  ;; Always turn on vertical sync interrupts if this is the first TV controller.
    761834  ;; The microcode relies on these as a periodic clock for various purposes.
     
    765838                                (LOGAND (%XBUS-READ TV-ADR) 10)))
    766839          (STATUS (%XBUS-READ TV-ADR)))
    767       (COND ((AND (NOT FORCE-P) (BIT-TEST STATUS 200))
    768              ;; Running in PROM, so stay there
     840      (COND ((AND (NOT FORCE-P)                 ;Unless forced, try to use the PROM
     841                  (OR (ZEROP (LOGAND STATUS 200))       ;Good, PROM already on
     842                      (PROGN (PROM-SETUP TV-ADR)        ;Try turning it on
     843                             (ZEROP (LOGAND (%XBUS-READ TV-ADR) 200)))))  ;On now?
     844             ;; The hardware at least claims the PROM is turned on.  Actually
     845             ;; checking for working sync does not work for some reason, so just
     846             ;; assume that any board which can have a PROM does have one, and
     847             ;; always use the PROM if it is there, since it is more likely to
     848             ;; be right than the default sync program.
     849             ;; Now turn on black-on-white mode, and interrupt enable if desired.
    769850             (%XBUS-WRITE TV-ADR (+ 4 INTERRUPT-ENABLE)))
    770             (T (STOP-SYNC TV-ADR)
     851            (T ;; Must be an ancient TV board at MIT, or else forced
     852               ;; Use default (or forced) sync program
     853               (STOP-SYNC TV-ADR)
    771854               (FILL-SYNC SYNC-PROG 0 TV-ADR)
    772855               (START-SYNC INTERRUPT-ENABLE 1 0 TV-ADR))))))  ;Clock 0, BOW 1, VSP 0
     
    774857(DEFUN PROM-SETUP (&OPTIONAL (TV-ADR TV:(SCREEN-CONTROL-ADDRESS DEFAULT-SCREEN)))
    775858  (%XBUS-WRITE (+ TV-ADR 3) 0))
     859
    776860
    777861;sync program bits
     
    860944                         &AUX SIZE BINDINGS INSTANCE DESCRIPTOR)
    861945  ;; Note that the length of this array must agree with INSTANCE-DESCRIPTOR-OFFSETS in QCOM
    862   (SETQ DESCRIPTOR (MAKE-ARRAY PERMANENT-STORAGE-AREA 'ART-Q 5))
     946  (SETQ DESCRIPTOR (MAKE-ARRAY 5 ':AREA PERMANENT-STORAGE-AREA))
    863947  (ASET (SETQ SIZE (1+ (LENGTH INSTANCE-VARIABLES)))
    864948        DESCRIPTOR (1- %INSTANCE-DESCRIPTOR-SIZE))
  • trunk/lisp/lmwin/color.lisp

    r220 r275  
    1010
    1111;sync program bits
    12 ;1  HSYNC
     12;1  HSYNC -- Note! This bit is inverted.
    1313;2  VSYNC
    1414;4  COMPOSITE - (not used really, encode on HSYNC)
     
    3232
    3333(DECLARE (SPECIAL SYNC))
     34
     35(COMMENT
     36;; This sync program is only CLOSE to NTSC video
    3437
    3538(SETQ SYNC '(
     
    5457   6 30 30 10 30 30 30 (10. 11) (74. 1) (8. 11) 211 11
    5558   1 30 30 10 30 30 30 (9. 11) (83. 11) 311 11
     59   (30 1))))
     60
     61;;; This is really NTSC standard video
     62(SETQ SYNC '(
     63   1 30 30 10 31 31 31 (45. 11) (3 10) (46. 11) 211 111 ;equalizing pulses, clr-tvma
     64   2 30 30 10 31 31 31 (45. 11) (3 10) (46. 11) 211 11  ;equalizing pulses
     65   3 32 32 12 32 32 32 (39. 12) (6 13) (45. 12) (4 13) 213 13   ;vert sync
     66   3 30 30 10 31 31 31 (45. 11) (3 10) (46. 11) 211 11  ;equalizing pulses
     67
     68   13. 30 30 10 30 30 30 (6 11) (88. 11) 211 11         ;vert retrace
     69   6 30 30 10 30 30 30 (12. 11) (74. 1) (8. 11) 211 11
     70   227. 30 30 10 30 30 30 (11. 11) 11 (36. 41 1) 1 1 (8. 11) 211 71   ;12 mhz video, 9x64 bits
     71   6 30 30 10 30 30 30 (12. 11) (74. 1) (8. 11) 211 11
     72   1 30 30 10 30 30 30 (11. 11) (83. 11) 211 11
     73
     74   1 30 30 10 30 30 30 (45. 11) (3 10) (46. 11) 211 111 ;equalizing pulses, clr-tvma
     75   2 30 30 10 31 31 31 (45. 11) (3 10) (46. 11) 211 11  ;equalizing pulses
     76   1 30 30 10 31 31 31 (45. 11) (45. 10) (4 11) 211 11  ;equalizing pulses
     77   1 30 30 10 30 30 30 (39. 10) (6 13) (45. 12) (4 13) 213 73  ;step-tvma
     78   1 32 32 12 32 32 32 (39. 12) (6 13) (45. 12) (4 11) 213 13   ;vert sync
     79   1 32 32 12 30 30 30 (39. 10) (6 11) (3 10) (46. 11) 211 11   ;equalizing
     80   3 30 30 10 31 31 31 (45. 11) (3 10) (46. 11) 211 11  ;equalizing pulses
     81
     82   13. 30 30 10 30 30 30 (6 11) (88. 11) 211 11         ;vert retrace
     83   6 30 30 10 30 30 30 (12. 11) (74. 1) (8. 11) 211 11
     84   227. 30 30 10 30 30 30 (11. 11) 11 (36. 41 1) 1 1 (8. 11) 211 71
     85   6 30 30 10 30 30 30 (12. 11) (74. 1) (8. 11) 211 11
     86   1 30 30 10 30 30 30 (11. 11) (83. 11) 311 11
     87
    5688   (30 1)))
    5789
     
    76108  (BIT-TEST BITS (XBUS-READ-NO-PARITY XBUS-ADDR)))
    77109
    78 (DEFUN COLOR-EXISTS-P ()
    79   (IF (NOT (BOUNDP 'COLOR-SCREEN))
    80       NIL
    81       (XBUS-LOCATION-EXISTS-P (LOGAND (TV:SCREEN-BUFFER COLOR-SCREEN) 377777) 1)))
     110(DEFUN COLOR-EXISTS-P (&OPTIONAL (SCREEN COLOR-SCREEN))
     111  (XBUS-LOCATION-EXISTS-P (LOGAND (TV:SCREEN-BUFFER SCREEN) 377777) 1))
    82112
    83113;; This stuff should be part of the color screen structure.
     
    223253
    224254;Make a color screen
    225 (DEFFLAVOR COLOR-SCREEN () (TV:SCREEN))
     255(DEFFLAVOR COLOR-SCREEN () (TV:STANDARD-SCREEN))
    226256
    227257(DEFMETHOD (COLOR-SCREEN :PARSE-FONT-DESCRIPTOR) (FD)
     
    234264  "Don't actually expose the color screen if there is no color monitor.  This
    235265function is a TOTAL KLUDGE."
    236   `(IF (NOT (COLOR-EXISTS-P))
    237        (SETQ TV:ALL-THE-SCREENS (DELQ SELF TV:ALL-THE-SCREENS))
    238        (OR (MEMQ SELF TV:ALL-THE-SCREENS)
    239            (PUSH SELF TV:ALL-THE-SCREENS))
    240        . ,BODY))
     266  `(COND ((COLOR-EXISTS-P SELF)
     267          (OR TV:EXPOSED-P (SETUP SYNC SELF))
     268          . ,BODY)
     269         (T (SETUP SYNC SELF))))
    241270
    242271(DEFUN MAKE-SCREEN (&OPTIONAL (NAME "COLOR") (XBUS-ADR -600000) (CONTROL-ADR 377750))
     
    245274    ':HEIGHT 454. ':WIDTH 576.
    246275    ':CONTROL-ADDRESS CONTROL-ADR
    247     ':DEFAULT-FONT FONTS:COLOR-CPTFONT
    248276    ':PROPERTY-LIST
    249277    `(:VIDEO :COLOR
     
    254282(DEFUN SETUP (&OPTIONAL (SYNC-PROG SYNC) (SCREEN COLOR-SCREEN)
    255283              &AUX (TV-COLOR-ADR (TV:SCREEN-CONTROL-ADDRESS SCREEN)))
    256   (COND ((COLOR-EXISTS-P)
     284  (COND ((COLOR-EXISTS-P SCREEN)
    257285         (SI:STOP-SYNC TV-COLOR-ADR)
    258286         (SI:FILL-SYNC SYNC-PROG 0 TV-COLOR-ADR)
    259287         (SI:START-SYNC 3 0 36. TV-COLOR-ADR)
    260288         ;; Make appropriate menu entries
    261          (OR (ASSOC "Color Window" TV:AUXILIARY-MENU-ITEM-LIST)
    262              (PUSH '("Color Window" :EVAL (TV:SYSTEM-MENU-CREATE-WINDOW COLOR-SCREEN))
    263                    TV:AUXILIARY-MENU-ITEM-LIST)))
     289         (OR (ASSOC "Color Window" TV:*SYSTEM-MENU-WINDOWS-COLUMN*)
     290             (SETQ TV:*SYSTEM-MENU-WINDOWS-COLUMN*
     291                   (APPEND TV:*SYSTEM-MENU-WINDOWS-COLUMN*
     292                           (NCONS '("Color Window"
     293                                    :EVAL (TV:SYSTEM-MENU-CREATE-WINDOW COLOR-SCREEN)
     294                                    :DOCUMENTATION "Create a window on the color screen"))))))
    264295        (T
    265          (SETQ TV:AUXILIARY-MENU-ITEM-LIST
    266                (DELQ (ASSOC "Color Window" TV:AUXILIARY-MENU-ITEM-LIST)
    267                      TV:AUXILIARY-MENU-ITEM-LIST)))))
    268 
    269 (ADD-INITIALIZATION "COLOR" '(SETUP) '(WARM))
     296         (SETQ TV:*SYSTEM-MENU-WINDOWS-COLUMN*
     297               (REMQ (ASSOC "Color Window" TV:*SYSTEM-MENU-WINDOWS-COLUMN*)
     298                     TV:*SYSTEM-MENU-WINDOWS-COLUMN*)))))
    270299
    271300
     
    473502
    474503
    475 ;;;Macros
    476 (DEFMACRO SWAP (A B)
    477    `(SETF ,A (PROG1 ,B (SETF ,B ,A))))
    478 
    479504;;Color line primitive - screen coords
    480505;; Probably should draw away from starting point
    481506(DEFUN COLOR-DRAW-LINE (X1 Y1 X2 Y2
    482507                        &OPTIONAL (COLOR 17) (ALU TV:ALU-SETA) (SCREEN COLOR-SCREEN))
    483     (AND (> X1 X2) (SWAP X1 X2) (SWAP Y1 Y2))
     508    (AND (> X1 X2) (SWAPF X1 X2) (SWAPF Y1 Y2))
    484509    (TV:PREPARE-SHEET (SCREEN)
    485510      (LET ((DX (- X2 X1))
     
    531556            (ASET COLOR SCREEN (+ X W) (+ Y H)))))))
    532557
    533 (DEFUN COLOR-PRINC (STRING X Y &OPTIONAL (COLOR 0) (FONT FONTS:CPTFONT)
     558(DEFUN COLOR-PRINC (STRING X Y &OPTIONAL (COLOR 0) (FONT TV:*DEFAULT-FONT*)
    534559                           (DEVICE COLOR-SCREEN)
    535560                           &AUX (WIDTH (FONT-CHAR-WIDTH FONT))
     
    545570
    546571;;; Color font hackery (convert a font to be usable on the color screen)
    547 (DEFUN MAKE-COLOR-FONT (BW-FONT)
     572(DEFUN MAKE-COLOR-FONT (BW-FONT &OPTIONAL (BIT-LIST '(1 1 1 1)) (FONT-NAME-SUFFIX ""))
     573  (COND ((FIXP BIT-LIST)
     574         (DO ((I 0 (1+ I))
     575              (X BIT-LIST)
     576              (L NIL))
     577             ((>= I 4)
     578              (SETQ BIT-LIST (NREVERSE L)))
     579           (PUSH (LDB 0001 X) L)
     580           (SETQ X (LSH X -1))))
     581        ((OR ( (LENGTH BIT-LIST) 4)
     582             (DOLIST (B BIT-LIST) (OR (NUMBERP B) (RETURN T))))
     583         (FERROR NIL "Illegal format for bit list ~S" BIT-LIST)))
    548584  (LET ((FIT) (MAXW 1) (SIZE 0) (RASTER-WIDTH) (WORDS-PER-CHAR) (RASTERS-PER-WORD)
    549585        (COLOR-FONT) (NEW-FIT)
    550         (FONT-NAME (INTERN (STRING-APPEND "COLOR-" (FONT-NAME BW-FONT)) 'FONTS)))
     586        (FONT-NAME (INTERN (STRING-APPEND "COLOR-" (FONT-NAME BW-FONT) FONT-NAME-SUFFIX)
     587                           'FONTS)))
    551588    (IF (SETQ FIT (FONT-INDEXING-TABLE BW-FONT))
    552589        (DOTIMES (CHAR 200)
     
    576613          (T (FERROR NIL "We don't need an indexing table, but black-and-white font did?")))
    577614    (SETQ COLOR-FONT
    578           (MAKE-ARRAY NIL 'ART-1B (* SIZE 32.) NIL (GET 'FONT 'SI:DEFSTRUCT-SIZE) NIL T))
     615          (MAKE-ARRAY NIL 'ART-1B (* SIZE 32.) NIL TV:FONT-LEADER-SIZE NIL T))
    579616    (SETF (ARRAY-LEADER COLOR-FONT 1) 'FONT)    ;Named structure symbol
    580617    (SETF (ARRAY-LEADER COLOR-FONT 0) 0)        ;Fill pointer
     
    616653                                           (* RW (\ RAS RAS-PER-W))     ;Num rasters in word
    617654                                           PIX))))                      ;Pixel within raster
    618                        (DOTIMES (I 4)
     655                       (DOLIST (B BIT-LIST)
    619656                         ;; Now store pixel four times
    620                          (ASET PIXEL COLOR-FONT
     657                         (ASET (* PIXEL B) COLOR-FONT
    621658                               (+ CBASE
    622659                                  (* 32. (// RAS RASTERS-PER-WORD))
     
    653690                                               (* RW (\ RAS RAS-PER-W))   ;Num rasters in word
    654691                                               PIX))))                    ;Pixel within raster
    655                            (DOTIMES (I 4)
     692                           (DOLIST (B BIT-LIST)
    656693                             ;; Now store pixel four times
    657694                             (SETQ CPIX (1+ CPIX))
     
    661698                                       CPIX 0
    662699                                       CBASE (* IDX WORDS-PER-CHAR 32.)))
    663                              (ASET PIXEL COLOR-FONT
     700                             (ASET (* PIXEL B) COLOR-FONT
    664701                                   (+ CBASE
    665702                                      (* 32. (// RAS RASTERS-PER-WORD))
  • trunk/lisp/lmwin/cometh.lisp

    r220 r275  
    44;This file is loaded after the kernel of the window system and
    55;before any windows are instantiated.  It contains the combined
    6 ;methods and such.  SHEET and SCREEN have been done already.
     6;methods and such.
    77
    88;WINDOW because those methods will get shared then, and
    99;because it may even be instantiated itself.  Plus all the
    1010;types of windows used in code loaded up til now.
    11 (COMPILE-FLAVOR-METHODS WINDOW LISP-LISTENER LISP-INTERACTOR BACKGROUND-LISP-INTERACTOR
     11(COMPILE-FLAVOR-METHODS WHO-LINE-SCREEN WHO-LINE-SHEET WHO-LINE-FILE-SHEET WHO-LINE-WINDOW
     12                        WINDOW LISP-LISTENER LISP-INTERACTOR BACKGROUND-LISP-INTERACTOR
    1213                        POP-UP-TEXT-WINDOW POP-UP-NOTIFICATION-WINDOW
    13                         TRUNCATING-POP-UP-TEXT-WINDOW)
     14                        TRUNCATING-POP-UP-TEXT-WINDOW
     15                        TRUNCATING-POP-UP-TEXT-WINDOW-WITH-RESET)
     16
     17(ADD-INITIALIZATION "Sheet" '(INITIALIZE) '(:ONCE))
     18(ADD-INITIALIZATION "Mouse" '(MOUSE-INITIALIZE) '(:WARM :FIRST))
    1419
    1520;Later modules generally have their own COMPILE-FLAVOR-METHODS at the
    1621;end of their own file.  This file exists for bootstrapping reasons.
    1722
    18 ;;; Resources
     23;Mustn't create any windows (including doing any DEFWINDOW-RESOURCEs) until
     24;here, because flavors aren't compiled yet and TV:DEFAULT-SCREEN isn't set up yet.
    1925
    20 ;;; These resources are intended so that it's easy to get a menu/pop up window for
    21 ;;; very short-term use.  Since they may be on any superior, it is advisable to do
    22 ;;; a :SET-SUPERIOR before you use them
    23 (DEFRESOURCE MOMENTARY-MENU-RESOURCE
    24   (WINDOW-CREATE 'MOMENTARY-MENU ':HEIGHT (// (SHEET-HEIGHT MOUSE-SHEET) 4.)))
     26(DEFWINDOW-RESOURCE POP-UP-FINGER-WINDOW ()
     27  :MAKE-WINDOW (TRUNCATING-POP-UP-TEXT-WINDOW-WITH-RESET)
     28  :REUSABLE-WHEN :DEACTIVATED)
    2529
    26 (DEFRESOURCE POP-UP-TEXT-WINDOW-RESOURCE
    27   (WINDOW-CREATE 'POP-UP-TEXT-WINDOW ':HEIGHT (// (SHEET-HEIGHT MOUSE-SHEET) 4.)))
     30;Resource of general-purpose momentary menus
     31(DEFWINDOW-RESOURCE MOMENTARY-MENU ()
     32        :MAKE-WINDOW (MOMENTARY-MENU)
     33        :REUSABLE-WHEN :DEEXPOSED)
    2834
    29 (OR (BOUNDP 'POP-UP-FINGER-WINDOW)
    30     (SETQ POP-UP-FINGER-WINDOW (WINDOW-CREATE 'TRUNCATING-POP-UP-TEXT-WINDOW)))
    31 
    32 (DEFRESOURCE BACKGROUND-LISP-INTERACTORS
    33   (WINDOW-CREATE 'BACKGROUND-LISP-INTERACTOR
    34                  ':PROCESS CURRENT-PROCESS
    35                  ':SUPERIOR DEFAULT-SCREEN
    36                  ':HEIGHT (// (SHEET-HEIGHT DEFAULT-SCREEN) 3)))
     35(DEFRESOURCE BACKGROUND-LISP-INTERACTORS ()
     36  :CONSTRUCTOR (MAKE-WINDOW 'BACKGROUND-LISP-INTERACTOR
     37                            ':PROCESS CURRENT-PROCESS   ;will be set later
     38                            ':SUPERIOR DEFAULT-SCREEN   ;always on this screen
     39                            ':HEIGHT (// (SHEET-HEIGHT DEFAULT-SCREEN) 3)))
    3740
    3841; It is now time to initialize the window system, which will create and expose
  • trunk/lisp/lmwin/csrpos.lisp

    r219 r275  
    99;Hmm, NEWIO seems to blow out rather than returning NIL now.  Change this?
    1010
    11 ;If the first argument is T (meaning TERMINAL-IO)
     11;If the last argument is T (meaning TERMINAL-IO)
    1212;or a stream, then it is applied to that stream.  Otherwise it is applied
    1313;to STANDARD-OUTPUT.  Anything other than a number or a 1-character long
     
    1515
    1616(DEFUN CURSORPOS (&REST ARGS)
    17   (LET ((ARG1 (CAR ARGS))
     17  (LET ((NARGS (LENGTH ARGS))
    1818        (STREAM STANDARD-OUTPUT)
    19         WO)
     19        ARG1 WO)
    2020    (COND ((NULL ARGS))                 ;If any args, look for stream as 1st arg
    21           ((NULL ARG1))
    22           ((EQ ARG1 T) (SETQ STREAM TERMINAL-IO ARGS (CDR ARGS)))
    23           ((NUMBERP ARG1))
     21          ((EQ (SETQ ARG1 (CAR (LAST ARGS))) T) (SETQ STREAM TERMINAL-IO NARGS (1- NARGS)))
     22          ((OR (NUMBERP ARG1) (NULL ARG1)))
    2423          ((OR (NOT (SYMBOLP ARG1)) (> (ARRAY-LENGTH (GET-PNAME ARG1)) 1))
    25            (SETQ STREAM ARG1 ARGS (CDR ARGS))))
     24           (SETQ STREAM ARG1 NARGS (1- NARGS))))
    2625    (SETQ ARG1 (CAR ARGS)
    2726          WO (FUNCALL STREAM ':WHICH-OPERATIONS))
    28     (COND ((NULL ARGS)
     27    (COND ((ZEROP NARGS)
    2928           (IF (MEMQ ':READ-CURSORPOS WO)
    3029               (MULTIPLE-VALUE-BIND (X Y) (FUNCALL STREAM ':READ-CURSORPOS ':CHARACTER)
    3130                 (CONS Y X))
    3231               (FERROR NIL "~S stream does not support cursor positioning" STREAM)))
    33           ((CDDR ARGS)
     32          ((> NARGS 2)
    3433           (FERROR NIL "Too many arguments"))   ;Why bother signalling the correct condition?
    35           ((OR (CDR ARGS) (NUMBERP ARG1))       ;2 arguments or one numeric argument
     34          ((OR (> NARGS 1) (NUMBERP ARG1))      ;2 arguments or one numeric argument
    3635           (IF (MEMQ ':SET-CURSORPOS WO)
    3736               (MULTIPLE-VALUE-BIND (X Y) (FUNCALL STREAM ':READ-CURSORPOS ':CHARACTER)
     
    6261           (COND ((MEMQ ':CLEAR-CHAR WO) (FUNCALL STREAM ':CLEAR-CHAR) T)))
    6362          ((= ARG1 #/X)                         ;X erase character backward
    64            (CURSORPOS STREAM 'B)
    65            (CURSORPOS STREAM 'K))
     63           (CURSORPOS 'B STREAM)
     64           (CURSORPOS 'K STREAM))
    6665          ((= ARG1 #/Z)                         ;Z home down
    6766           (IF (MEMQ ':HOME-DOWN WO) (FUNCALL STREAM ':HOME-DOWN)
  • trunk/lisp/lmwin/eh.lisp

    r220 r275  
    33(DEFVAR ERROR-MESSAGE-PRINLEVEL 2)      ;These are used when printing error messages
    44(DEFVAR ERROR-MESSAGE-PRINLENGTH 4)     ; and values of variables in frames.
    5 
    6 ;; The error table, read from LISPM1;UCADR nnnTBL into MICROCODE-ERROR-TABLE,
     5(DEFVAR FUNCTION-PRINLEVEL 3)           ; Used for printing LAMBDA expressions.
     6(DEFVAR FUNCTION-PRINLENGTH 5)
     7
     8;; The error table, read from SYS: UBIN; UCADR TBL nnn into MICROCODE-ERROR-TABLE,
    79;; describes the symbolic meaning of certain microcode pcs.
    810;; Its data is rearranged into other variables below.
     
    1517;; They are set up in the file LISPM2;EHR > (Error Handler Routines...)
    1618
    17 ;; Actual error table read in from LISPM1;LCADR nnnTBL.
     19;; Actual error table read in from file
    1820(DEFVAR MICROCODE-ERROR-TABLE)
    1921;; Ucode version number to which the loaded value of MICROCODE-ERROR-TABLE pertains.
     
    2426(DEFVAR CALLS-SUB-LIST)                 ;Alist of micropcs to symbols.
    2527(DEFVAR RESTART-LIST)                   ;Alist of symbols to micropcs.
     28(DEFVAR ARG-POPPED-LIST)                ;Alist of micropcs just after where
     29                                        ;misc insns pop their args.
     30                                        ;The cdr of the element says where the arg went:
     31                                        ;a place to find it if the error is after the pop.
     32(DEFVAR DEFAULT-ARG-LOCATIONS-LIST)     ;Alist of microfun symbols to where there args
     33                                        ;live in the absense of info to contrary.
     34(DEFVAR STACK-WORDS-PUSHED-LIST)        ;Alist of micropcs, of error or on stack at error,
     35                                        ;to how many words that subroutine had pushed
     36                                        ;on the stack since it was called, up to the time
     37                                        ;it called the next subroutine or got the error.
    2638(DEFVAR ERROR-TABLE)                    ;List of ETEs.
    2739(DEFVAR ERROR-TABLE-NUMBER -1)          ;Microcode version number for ERROR-TABLE.
     40(DEFVAR BEGIN-QARYR)                    ;See SG-ERRING-FUNCTION
     41(DEFVAR END-QARYR)                      ;..
    2842
    2943;; An error immediately runs the first level error handler stack group
     
    4155(DEFVAR LAST-SECOND-LEVEL-ERROR-HANDLER-SG NIL)
    4256;; This variable is bound to T in every second-level error handler to identify them.
    43 (DEFVAR ERROR-HANDLER-RUNNING T)
     57(DEFVAR ERROR-HANDLER-RUNNING NIL)
    4458;; Controls whether the error message is reprinted in RUN-SG
    4559(DEFVAR ERROR-HANDLER-REPRINT-ERROR T)
     
    6882(DEFVAR CURRENT-FRAME)          ;The SG-AP of the frame that the error handler is looking at.
    6983(DEFVAR ORIGINAL-FRAME)         ;The SG-AP of the frame that got the error.
     84(DEFVAR INNERMOST-VISIBLE-FRAME)  ;Frames on stack inside of this can't be moved to.
     85                                  ;Also, this can point at a frame that isn't really
     86                                  ;active (is inside of SG-AP), to allow that
     87                                  ;frame to be selected even though it isn't active.
     88;; T if we should regard the innermost frame as interesting
     89;; even if it is a call to a normally uninteresting function.
     90;; This is set when we break on entry to or exit from an uninteresting function.
     91(DEFVAR INNERMOST-FRAME-IS-INTERESTING NIL)
    7092
    7193;; This is a random gensymmed object which is returned
     
    78100;; Number of instructions to disassemble for M-L, etc., if we
    79101;; can't determine the amount of room on the screen.
    80 (DEFVAR DISASSEMBLE-INSTRUCTION-COUNT 20)
     102;; Also minimum number to be shown.
     103(DEFVAR DISASSEMBLE-INSTRUCTION-COUNT 10.)
    81104
    82105;; Calls to these functions should not be mentioned as frames
     
    84107;; This should include all functions that have &QUOTE args and are open-compiled.
    85108;; *EVAL and APPLY-LAMBDA are there for peculiar reasons.
    86 (DEFVAR UNINTERESTING-FUNCTIONS '(SI:*EVAL SI:APPLY-LAMBDA COND SETQ PROG GO DO DO-NAMED
     109(DEFVAR UNINTERESTING-FUNCTIONS '(SI:*EVAL SI:APPLY-LAMBDA SETQ PROG PROG* PROGN
     110                                  LET LET* DO DO-NAMED RETURN RETURN-FROM
    87111                                  MULTIPLE-VALUE MULTIPLE-VALUE-LIST
    88                                   MULTIPLE-VALUE-RETURN AND OR STORE))
     112                                  BREAKON-THIS-TIME COND AND OR STORE))
    89113
    90114;;; These datatypes are OK to call print on
     
    100124                        DTP-ENTITY))
    101125
     126;;; These are names of errors which should not be caught by ERRSET
     127(DEFVAR ERRSET-INVISIBLE-ETES '(:BREAK PDL-OVERFLOW MAR-BREAK BREAKPOINT STEP-BREAK
     128                                REGION-TABLE-OVERFLOW VIRTUAL-MEMORY-OVERFLOW AREA-OVERFLOW))
     129;;; Same except conditions signalled with FERROR/CERROR rather than microcode ETEs
     130(DEFVAR ERRSET-INVISIBLE-CONDITIONS '(:TRACE-ERROR-BREAK))
     131
    102132;;; Table of stack groups being stepped and stack groups stepping them
    103133(DEFVAR SG-STEPPING-TABLE NIL)
     
    114144;; You must call this before pushing a call block, even if calling SG-RUN-GOODBYE,
    115145;; in order to clean up the QBBFL and the U-STACK Q's.
    116 (DEFUN SG-SAVE-STATE (SG &AUX P NEW-AP RP PP)
    117   (SG-MAYBE-GROW-PDLS SG)               ;Make sure there is room to do this
     146(DEFUN SG-SAVE-STATE (SG &OPTIONAL SUPPRESS-PDL-GROWING &AUX P NEW-AP RP PP)
     147  (OR SUPPRESS-PDL-GROWING (SG-MAYBE-GROW-PDLS SG))     ;Make sure there is room to do this
    118148  (SETQ RP (SG-REGULAR-PDL SG)
    119149        PP (SG-REGULAR-PDL-POINTER SG))
     
    123153                  0))
    124154        RP (+ NEW-AP %LP-CALL-STATE))
    125   (ASET 0 RP (+ NEW-AP %LP-EXIT-STATE))
     155  (ASET (DPB (FEF-INITIAL-PC #'FOOTHOLD) %%LP-EXS-EXIT-PC 0)
     156        RP (+ NEW-AP %LP-EXIT-STATE))
    126157  (ASET 0 RP (+ NEW-AP %LP-ENTRY-STATE))
    127158  (ASET #'FOOTHOLD RP (+ NEW-AP %LP-FEF))
     
    141172  (SETF (SG-AP SG) NEW-AP))
    142173
    143 ;;; This function isn't called, it just exists to name state-save frames
    144 (DEFUN FOOTHOLD () NIL)
     174;;; This function isn't normally called, it just exists to name state-save frames.
     175;;; If this function is ever returned to (see (:METHOD PROCESS :INTERRUPT))
     176;;; then it will restore the saved state and resume it.
     177;;; Do not trace nor redefine this function!
     178(DEFUN FOOTHOLD () (FUNCALL %ERROR-HANDLER-STACK-GROUP '(RESUME-FOOTHOLD)))
    145179
    146180;; Pop the saved state from the pdl into the current state.
    147 (DEFUN SG-RESTORE-STATE (SG)
    148   (LET ((PP (SG-PREVIOUS-ACTIVE SG (SG-PREVIOUS-ACTIVE SG (SG-AP SG))))
     181(DEFUN SG-RESTORE-STATE (SG &OPTIONAL (N-FRAMES-BACK 2))
     182  (LET ((PP (SG-AP SG))
    149183        (RP (SG-REGULAR-PDL SG)))
     184    (LOOP REPEAT N-FRAMES-BACK DO (SETQ PP (SG-PREVIOUS-ACTIVE SG PP)))
    150185    (AND (NULL PP)
    151186         (FERROR NIL "~S state not saved" SG))
     
    223258  (SETQ LAST-SECOND-LEVEL-ERROR-HANDLER-SG %CURRENT-STACK-GROUP)
    224259  (SETF (SG-FLAGS-MAR-MODE SG) 0)                       ;Turn off the MAR (why??)
    225   (FUNCALL SG)
     260  (STACK-GROUP-RESUME SG NIL)
    226261  (SETQ RESULT (CAR %CURRENT-STACK-GROUP-CALLING-ARGS-POINTER))
    227262  (SG-RESTORE-STATE SG)
     
    229264         (COND ((NEQ %CURRENT-STACK-GROUP LAST-SECOND-LEVEL-ERROR-HANDLER-SG)
    230265                (TERPRI)
    231                 (PRINT-ERROR-MESSAGE SG (SG-TRAP-TAG SG) T)))
     266                (PRINT-ERROR-MESSAGE SG (SG-TRAP-TAG SG) 'RETURN)))
    232267         (SETQ LAST-SECOND-LEVEL-ERROR-HANDLER-SG %CURRENT-STACK-GROUP)))
    233268  (COND ((EQ RESULT 'LOSE)
     
    244279  (WITHOUT-INTERRUPTS
    245280    (AND ERROR-HANDLER-RUNNING (FREE-SECOND-LEVEL-ERROR-HANDLER-SG %CURRENT-STACK-GROUP))
    246     (FUNCALL SG)))
    247 
    248 ;;Smash a SG so that it reinvokes its current function with the same args when resumed.
    249 ;; For the time being, the function had better not have pushed a micro-stack.
    250 ;; Any binding block pushed will not get unwound immediately, but will be
    251 ;;  "concatenated."  For the moment, tho, PROCESS-WAIT is the only fctn this should
    252 ;; be used on, and these screws shouldnt affect it.
    253 (DEFUN SG-REINVOKE (SG &AUX RP AP NEW-AP NARGS)
    254   (PROG ()
    255       (SETQ RP (SG-REGULAR-PDL SG)
    256             AP (SG-AP SG)
    257             NEW-AP (SG-PREVIOUS-ACTIVE SG AP)
    258             NARGS (LDB %%LP-ENS-NUM-ARGS-SUPPLIED (AREF RP (+ AP %LP-ENTRY-STATE))))
    259     L (COND ((> (SG-REGULAR-PDL-POINTER SG) (+ AP NARGS))  ;Pop any extra stuff beyond args.
    260              (SG-REGPDL-POP SG)
    261              (GO L)))
    262       (SETF (SG-IPMARK SG) AP)
    263       (SETF (SG-AP SG) NEW-AP)
    264       (SETF (SG-CURRENT-STATE SG) SG-STATE-INVOKE-CALL-ON-RETURN)))
    265  
     281    (STACK-GROUP-RESUME SG NIL)))
     282
    266283;; Mark a second level error handler stack group as available for re-use.
    267284(DEFUN FREE-SECOND-LEVEL-ERROR-HANDLER-SG (SG)
     285  (COND ((NEQ SG %CURRENT-STACK-GROUP)
     286         ;; Freeing the error handler, but not current stack group, so cause it to
     287         ;; do a LEAVING-ERROR-HANDLER first
     288         (SG-FUNCALL SG #'LEAVING-ERROR-HANDLER)))
    268289  (WITHOUT-INTERRUPTS
    269290    (PUSH SG FREE-SECOND-LEVEL-ERROR-HANDLER-SG-LIST)
     
    274295;; If GOODBYE-P is T, it returns the specified value from that frame,
    275296;; otherwise it comes back to the EH.
    276 (DEFUN SG-UNWIND-TO-FRAME (SG DEST-AP GOODBYE-P &OPTIONAL VALUE (LABEL T) &AUX N)
    277   (SETQ N (DO ((AP (SG-AP SG) (SG-PREVIOUS-ACTIVE SG AP))
     297(DEFUN SG-UNWIND-TO-FRAME (SG DEST-FRAME GOODBYE-P &OPTIONAL VALUE (LABEL T) &AUX N)
     298  (IF (> INNERMOST-VISIBLE-FRAME (SG-AP SG))
     299      (SETF (SG-AP SG) INNERMOST-VISIBLE-FRAME))
     300  (SETQ N (DO ((FRAME (SG-AP SG) (SG-PREVIOUS-ACTIVE SG FRAME))
    278301               (N 1 (1+ N)))
    279               ((= AP DEST-AP) N)))
     302              ((= FRAME DEST-FRAME) N)))
    280303  (SG-UNWIND SG LABEL VALUE N (IF GOODBYE-P NIL %CURRENT-STACK-GROUP)
    281304             (IF GOODBYE-P 'FREE 'CALL))
    282   (COND ((NULL GOODBYE-P)               ;Flush the call back to this SG, and try to get
    283          (SETF (SG-AP SG)                       ; things in phase again.
    284                (SETQ CURRENT-FRAME
    285                      (SETQ ORIGINAL-FRAME (SG-PREVIOUS-ACTIVE SG (SG-AP SG)))))
    286          (DOTIMES (I 4)
    287            (SG-REGPDL-POP SG)))))
     305  (COND ((NULL GOODBYE-P)                       ;Flush the call back to this SG
     306         (LET ((RP (SG-REGULAR-PDL SG)) (FRAME (SG-AP SG)))
     307           (IF (NEQ (AREF RP FRAME) %CURRENT-STACK-GROUP)
     308               (FERROR NIL "Second-level EH stack-group not found on pdl where expected"))
     309           (IF ( (SG-REGULAR-PDL-POINTER SG) (1+ FRAME))
     310               (FERROR NIL "Second-level EH stack-group called with wrong number of args"))
     311           (SETF (SG-IPMARK SG) (SG-PREVIOUS-OPEN SG FRAME))
     312           (SETF (SG-AP SG)
     313                 (SETQ CURRENT-FRAME (SETQ ORIGINAL-FRAME (SG-PREVIOUS-ACTIVE SG FRAME))))
     314           (SETF (SG-FLAGS-QBBFL SG)            ; Must correspond to current frame to work!
     315                 (RP-BINDING-BLOCK-PUSHED RP CURRENT-FRAME))
     316           (DOTIMES (I 5)
     317             (SG-REGPDL-POP SG))))))
     318
     319(DEFUN SG-UNWIND-TO-FRAME-AND-REINVOKE (SG FRAME
     320                        &OPTIONAL (FORM (GET-FRAME-FUNCTION-AND-ARGS SG FRAME))
     321                        &AUX RP PP)
     322  ;; Unwind back to point where frame to be retried is about to return.
     323  ;; This gets rid of its unwind-protects but not its special bindings
     324  ;; and leaves any ADI associated with calling it on the stack too.
     325  (SG-UNWIND-TO-FRAME SG FRAME NIL)
     326  ;; Next line prevents total disaster if error in the code below
     327  (SETQ INNERMOST-VISIBLE-FRAME (SG-AP SG))
     328  ;; Now we would like to get rid of any associated special bindings
     329  ;; but unfortunately we can't distinguish closure/instance bindings
     330  ;; made before function entry with those made by the function itself.
     331  ;; So leave them all and hope for the best.
     332  ;; Get rid of the saved microstack for that frame.  There will at least
     333  ;; be an entry for XUWR1+1.
     334  (SETQ RP (SG-REGULAR-PDL SG)
     335        PP (SG-REGULAR-PDL-POINTER SG))
     336  (AND (ZEROP (RP-MICRO-STACK-SAVED RP FRAME))
     337       (FERROR NIL "Where's my saved microstack?"))
     338  (DO ((SP (SG-SPECIAL-PDL SG))
     339       (SPP (SG-SPECIAL-PDL-POINTER SG) (1- SPP))
     340       (P))
     341      (NIL)
     342    (SETQ P (ALOC SP SPP))
     343    (OR (= (%P-DATA-TYPE P) DTP-FIX) (FERROR NIL "Where's my saved microstack?"))
     344    (AND (%P-FLAG-BIT P)
     345         (RETURN (SETF (SG-SPECIAL-PDL-POINTER SG) (1- SPP)))))
     346  (SETF (RP-MICRO-STACK-SAVED RP FRAME) 0)
     347  ;; Now rebuild the frame as if it was an open call block about to be called
     348  (SETF (SG-PDL-PHASE SG)               ;PP gets M-AP minus one
     349        (LOGAND (- (SG-PDL-PHASE SG) (- PP (SETQ PP (1- FRAME)))) 1777))
     350  (SETF (SG-REGULAR-PDL-POINTER SG) PP)
     351  ;Put back the function.  Convert from a name to a function.
     352  (SG-REGPDL-PUSH (FUNCALL #'FUNCTION (CAR FORM)) SG)
     353  (DOLIST (X (CDR FORM))                ;Put args back
     354    (SG-REGPDL-PUSH X SG))
     355  (%P-STORE-CDR-CODE (ALOC RP (SG-REGULAR-PDL-POINTER SG)) CDR-NIL)
     356  (SETF (SG-IPMARK SG) FRAME)
     357  (SETF (SG-AP SG) (SG-PREVIOUS-ACTIVE SG FRAME))
     358  ;; Now send the SG on its way
     359  (SETF (SG-CURRENT-STATE SG) SG-STATE-INVOKE-CALL-ON-RETURN))
    288360
    289361;; The CONTINUATION is a function called with one argument in the newly-reset
     
    300372          (T    ;SG has not been run, don't unwind, but do leave in same state
    301373           (STACK-GROUP-PRESET SG CONTINUATION ARGUMENT)
    302            (OR PROCESS-P (FUNCALL SG))))
     374           (OR PROCESS-P (STACK-GROUP-RESUME SG NIL))))
    303375    (OR PROCESS-P (SETF (SG-CURRENT-STATE SG) SG-STATE-EXHAUSTED))))
    304376
     
    357429    (AND ERROR-HANDLER-RUNNING (EQ DISPOSAL 'FREE)
    358430         (FREE-SECOND-LEVEL-ERROR-HANDLER-SG %CURRENT-STACK-GROUP))
    359     (OR (EQ DISPOSAL 'SETUP) (FUNCALL SG))))
     431    (OR (EQ DISPOSAL 'SETUP) (STACK-GROUP-RESUME SG NIL))))
    360432
    361433;; The FH- functions are those intended to run in the other stack group.
     
    374446(DEFUN FH-APPLIER (FN ARGS NEW-+ NEW-* SG EH-P PREV-FH)
    375447  (UNWIND-PROTECT
    376     (LET ((+ NEW-+) (* NEW-*) EVALHOOK)
    377       (*CATCH 'FOOTHOLD
     448    (LET ((+ NEW-+) (* NEW-*) (EVALHOOK NIL) (ERRSET-STATUS NIL))
     449      (*CATCH 'SYS:COMMAND-LEVEL
    378450              (FUNCALL SG (MULTIPLE-VALUE-LIST (APPLY FN ARGS))))
    379451      ;; This is in case the catch catches.
     
    385457(DEFUN FH-EVALER (FORM NEW-+ NEW-* SG EH-P PREV-FH)
    386458  (UNWIND-PROTECT
    387     (LET ((+ NEW-+) (* NEW-*) EVALHOOK)
    388       (*CATCH 'FOOTHOLD
     459    (LET ((+ NEW-+) (* NEW-*) (EVALHOOK NIL) (ERRSET-STATUS NIL))
     460      (*CATCH 'SYS:COMMAND-LEVEL
    389461              (FUNCALL SG (MULTIPLE-VALUE-LIST (EVAL FORM))))
    390462      ;; This is in case the catch catches.
     
    398470    (LET ((OLD-TERMINAL-IO TERMINAL-IO)
    399471          (OLD-STANDARD-OUTPUT STANDARD-OUTPUT) (OLD-STANDARD-INPUT STANDARD-INPUT)
    400           (+ NEW-+) (* NEW-*) EVALHOOK WIN-P RESULT)
     472          (+ NEW-+) (* NEW-*) (EVALHOOK NIL) (ERRSET-STATUS NIL)
     473          WIN-P RESULT)
    401474      (LET ((TERMINAL-IO EH-TERMINAL-IO)
    402475            (STANDARD-INPUT 'SI:TERMINAL-IO-SYN-STREAM)
    403476            (STANDARD-OUTPUT 'SI:TERMINAL-IO-SYN-STREAM))
    404         (*CATCH 'FOOTHOLD
     477        (*CATCH 'SYS:COMMAND-LEVEL
    405478                (SETQ RESULT (MULTIPLE-VALUE-LIST (EVAL FORM))
    406479                      WIN-P T)))
     
    423496;; Various utility ANALYSIS functions.
    424497
    425 ;; These functions take an SG and an AP, and return the AP
    426 ;; for the previous open or active stack frame.
     498;; These functions take an SG and a FRAME, and return the
     499;; previous open or active stack frame.
    427500;Result is NIL if this is the bottom frame
    428 (DEFUN SG-PREVIOUS-OPEN (SG AP)
    429   (LET ((DELTA (RP-DELTA-TO-OPEN-BLOCK (SG-REGULAR-PDL SG) AP)))
    430     (IF (ZEROP DELTA) NIL (- AP DELTA))))
     501(DEFUN SG-PREVIOUS-OPEN (SG FRAME)
     502  (LET ((DELTA (RP-DELTA-TO-OPEN-BLOCK (SG-REGULAR-PDL SG) FRAME)))
     503    (IF (ZEROP DELTA) NIL (- FRAME DELTA))))
    431504
    432505;Result is NIL if this is the bottom frame
    433 (DEFUN SG-PREVIOUS-ACTIVE (SG AP)
    434   (LET ((DELTA (RP-DELTA-TO-ACTIVE-BLOCK (SG-REGULAR-PDL SG) AP)))
    435     (IF (ZEROP DELTA) NIL (- AP DELTA))))
     506(DEFUN SG-PREVIOUS-ACTIVE (SG FRAME)
     507  (LET ((DELTA (RP-DELTA-TO-ACTIVE-BLOCK (SG-REGULAR-PDL SG) FRAME)))
     508    (IF (ZEROP DELTA) NIL (- FRAME DELTA))))
    436509
    437510;; Returns NIL if there is no next.
    438 (DEFUN SG-NEXT-OPEN (SG AP)
    439   (DO ((THIS-AP (SG-AP SG) (SG-PREVIOUS-OPEN SG THIS-AP))
    440        (NEXT-AP NIL THIS-AP))
    441       ((= THIS-AP AP) NEXT-AP)))
     511(DEFUN SG-NEXT-OPEN (SG FRAME)
     512  (DO ((THIS-FRAME (SG-IPMARK SG) (SG-PREVIOUS-OPEN SG THIS-FRAME))
     513       (NEXT-FRAME NIL THIS-FRAME))
     514      ((= THIS-FRAME FRAME) NEXT-FRAME)))
    442515
    443516;; Returns NIL if there is no next.
    444 (DEFUN SG-NEXT-ACTIVE (SG AP)
    445   (DO ((THIS-AP (SG-AP SG) (SG-PREVIOUS-ACTIVE SG THIS-AP))
    446        (NEXT-AP NIL THIS-AP))
    447       ((= THIS-AP AP) NEXT-AP)))
     517;; Given NIL as arg, returns the bottom frame (whose SG-PREVIOUS-ACTIVE is NIL).
     518(DEFUN SG-NEXT-ACTIVE (SG FRAME)
     519  (DO ((THIS-FRAME INNERMOST-VISIBLE-FRAME (SG-PREVIOUS-ACTIVE SG THIS-FRAME))
     520       (NEXT-FRAME NIL THIS-FRAME))
     521      ((COND (FRAME (<= THIS-FRAME FRAME))
     522             (T (NULL THIS-FRAME)))
     523       NEXT-FRAME)))
     524
     525;; Returns T if specified frame is an active frame.
     526(DEFUN SG-FRAME-ACTIVE-P (SG FRAME)
     527  (EQ FRAME (SG-NEXT-ACTIVE SG (SG-PREVIOUS-ACTIVE SG FRAME))))
     528
     529;; Scan several open frames up or down from a given one.
     530;; We return two values; the first is the offset of the frame found,
     531;; and the second is T if the specified number of frames were found
     532;; before the top or bottom of the stack.
     533(DEFUN SG-NEXT-NTH-OPEN (SG FRAME &OPTIONAL (COUNT 1))
     534  (COND ((= COUNT 0) FRAME)
     535        ((MINUSP COUNT)
     536         (DO ((P FRAME (SG-PREVIOUS-OPEN SG P))
     537              (I 0 (1- I))
     538              (PP NIL P))
     539             (())
     540           (AND (OR (NULL P) (= I COUNT))
     541                (RETURN (OR P PP) P))))
     542        (T (DO ((P FRAME (SG-NEXT-OPEN SG P))
     543                (I 0 (1+ I))
     544                (PP NIL P))
     545               (())
     546             (AND (OR (NULL P) (= I COUNT))
     547                  (RETURN (OR P PP) P))))))
    448548
    449549;; Scan several active frames up or down from a given one.
     
    478578    (DTP-FEF-POINTER (FEF-NAME FUNCTION))
    479579    (DTP-U-ENTRY (MICRO-CODE-ENTRY-NAME-AREA (%POINTER FUNCTION)))
    480     (DTP-LIST (COND ((EQ (CAR FUNCTION) 'NAMED-LAMBDA)
     580    (DTP-LIST (COND ((MEMQ (CAR FUNCTION) '(NAMED-LAMBDA NAMED-SUBST))
    481581                     (IF (ATOM (CADR FUNCTION)) (CADR FUNCTION)
    482582                         (CAADR FUNCTION)))
     
    511611;; Return the next frame, counting all the actual frames of parts of an
    512612;; interpreted function as if they were one frame.
    513 (DEFUN SG-NEXT-INTERESTING-ACTIVE (SG AP &AUX (RP (SG-REGULAR-PDL SG)))
    514   (COND ((ATOM (RP-FUNCTION-WORD RP AP))
    515          (SG-NEXT-ACTIVE SG AP))
    516         (T (DO ((NEW-AP (SG-NEXT-ACTIVE SG AP) (SG-NEXT-ACTIVE SG NEW-AP)))
    517                ((OR (NULL NEW-AP)
    518                     (NOT (MEMQ (FUNCTION-NAME (RP-FUNCTION-WORD RP NEW-AP))
     613(DEFUN SG-NEXT-INTERESTING-ACTIVE (SG FRAME &AUX (RP (SG-REGULAR-PDL SG)))
     614  (COND ((ATOM (RP-FUNCTION-WORD RP FRAME))
     615         (SG-NEXT-ACTIVE SG FRAME))
     616        (T (DO ((NEW-FRAME (SG-NEXT-ACTIVE SG FRAME) (SG-NEXT-ACTIVE SG NEW-FRAME)))
     617               ((OR (NULL NEW-FRAME)
     618                    (NOT (MEMQ (FUNCTION-NAME (RP-FUNCTION-WORD RP NEW-FRAME))
    519619                               UNINTERESTING-FUNCTIONS)))
    520                 NEW-AP)))))
    521 
    522 (DEFUN SG-PREVIOUS-INTERESTING-ACTIVE (SG AP)
    523   (SG-OUT-TO-INTERESTING-ACTIVE SG (SG-PREVIOUS-ACTIVE SG AP)))
     620                NEW-FRAME)
     621             ;; Make provisions for showing uninteresting fns
     622             ;; when we are stepping thru them.
     623             (AND (= NEW-FRAME INNERMOST-VISIBLE-FRAME)
     624                  INNERMOST-FRAME-IS-INTERESTING
     625                  (RETURN (SG-NEXT-ACTIVE SG FRAME)))))))
     626
     627(DEFUN SG-PREVIOUS-INTERESTING-ACTIVE (SG FRAME)
     628  (COND ((MEMQ (FUNCTION-NAME (RP-FUNCTION-WORD (SG-REGULAR-PDL SG) FRAME))
     629               UNINTERESTING-FUNCTIONS)
     630         (SG-PREVIOUS-ACTIVE SG FRAME))
     631        (T (SG-OUT-TO-INTERESTING-ACTIVE SG (SG-PREVIOUS-ACTIVE SG FRAME)))))
    524632
    525633;; Given a frame, find out if it is one of the frames of a call to an interpreted function.
    526634;; If so, return the outermost frame of this call to the interpreted function.
    527635;; If not, return the original frame.
    528 (DEFUN SG-OUT-TO-INTERESTING-ACTIVE (SG AP &AUX (RP (SG-REGULAR-PDL SG)))
    529   (COND ((NULL AP) NIL)
    530         ((NOT (MEMQ (FUNCTION-NAME (RP-FUNCTION-WORD RP AP)) UNINTERESTING-FUNCTIONS))
    531          AP)
    532         (T (DO ((NEW-AP AP (SG-PREVIOUS-ACTIVE SG NEW-AP)))
    533                ((OR (NULL NEW-AP)
    534                     (NOT (MEMQ (FUNCTION-NAME (RP-FUNCTION-WORD RP NEW-AP))
     636(DEFUN SG-OUT-TO-INTERESTING-ACTIVE (SG FRAME &AUX (RP (SG-REGULAR-PDL SG)))
     637  (COND ((NULL FRAME) NIL)
     638        ((AND (= FRAME INNERMOST-VISIBLE-FRAME)
     639              INNERMOST-FRAME-IS-INTERESTING)
     640         FRAME)
     641        ((NOT (MEMQ (FUNCTION-NAME (RP-FUNCTION-WORD RP FRAME)) UNINTERESTING-FUNCTIONS))
     642         FRAME)
     643        (T (DO ((NEW-FRAME FRAME (SG-PREVIOUS-ACTIVE SG NEW-FRAME)))
     644               ((OR (NULL NEW-FRAME)
     645                    (NOT (MEMQ (FUNCTION-NAME (RP-FUNCTION-WORD RP NEW-FRAME))
    535646                               UNINTERESTING-FUNCTIONS)))
    536                 (COND ((NULL NEW-AP) AP)
    537                       ((ATOM (RP-FUNCTION-WORD RP NEW-AP)) AP)
    538                       (T NEW-AP)))))))
    539 
    540 ;; Assuming that AP points to the outermost actual frame
    541 ;; of a call to an interpreted function, return its innermost active *EVAL frame.
    542 (DEFUN SG-INNERMOST-UNINTERESTING-ACTIVE-EVAL (SG AP &AUX (RP (SG-REGULAR-PDL SG)))
    543   (DO ((NEW-AP AP FOLLOWING-AP)
    544        (FOLLOWING-AP) (LAST-EVAL-AP))
    545       (())
    546     (AND (EQ (RP-FUNCTION-WORD RP NEW-AP) #'SI:*EVAL)
    547          (SETQ LAST-EVAL-AP NEW-AP))
    548     (SETQ FOLLOWING-AP (SG-NEXT-ACTIVE SG NEW-AP))
    549     (OR (AND FOLLOWING-AP
    550              (MEMQ (FUNCTION-NAME (RP-FUNCTION-WORD RP FOLLOWING-AP))
    551                    UNINTERESTING-FUNCTIONS))
    552         (RETURN LAST-EVAL-AP))))
     647                (COND ((NULL NEW-FRAME) FRAME)
     648                      ((ATOM (RP-FUNCTION-WORD RP NEW-FRAME)) FRAME)
     649                      (T NEW-FRAME)))))))
    553650
    554651
     
    556653;; corresponding to the macro instruction in which an error happened.
    557654(DEFUN SG-ERRING-FUNCTION (SG)
    558   (LET ((AP (SG-AP SG))
     655  (LET ((CURRENT-UPC (SG-TRAP-MICRO-PC SG))
     656        (FRAME (SG-AP SG))
    559657        (RP (SG-REGULAR-PDL SG)))
    560     (LET ((FUNCTION (RP-FUNCTION-WORD RP AP))
    561           (PC (1- (RP-EXIT-PC RP AP))))
    562       (SELECT (%DATA-TYPE FUNCTION)
    563         (DTP-U-ENTRY
    564           (MICRO-CODE-ENTRY-NAME-AREA (%POINTER FUNCTION)))
    565         (DTP-FEF-POINTER
    566           (LET ((INST (FEF-INSTRUCTION FUNCTION PC)))
    567             (LET ((OP (LDB 1104 INST))
    568                   (DEST (LDB 1503 INST))
    569                   (DISP (LDB 0011 INST)))
    570               (COND ((< OP 11)
    571                      (NTH OP '(FUNCALL FUNCALL MOVE-INSTRUCTION CAR CDR CADR CDDR CDAR CAAR)))
    572                     ((= OP 11)
    573                      (NTH DEST '(ND1-UNUSED *PLUS *DIF *TIMES   ;*'s to avoid confusion with
    574                                  *QUO *LOGAND *LOGXOR *LOGIOR)));argument-number
    575                     ((= OP 12)
    576                      (NTH DEST '(= > < EQ CDR CDDR 1+ 1-)))
    577                     ((= OP 13)
    578                      (NTH DEST '(ND3-UNUSED BIND BIND SET-NIL SET-ZERO PUSH-E MOVEM POP)))
    579                     ((= OP 14)
    580                      'A-BRANCH-INSTRUCTION)
    581                     ((< DISP 100) 'LIST)
    582                     ((< DISP 200) 'LIST-IN-AREA)
    583                     ((< DISP 220) 'UNBIND)
    584                     ((< DISP 240) 'A-POP-PDL-INSTRUCTION)
    585                     (T (MICRO-CODE-SYMBOL-NAME-AREA (- DISP 200)))))))
    586         (OTHERWISE FUNCTION)))))
     658    (IF (AND (
     659 BEGIN-QARYR CURRENT-UPC) (< CURRENT-UPC END-QARYR))
     660        ;; Not in a function at all.  Return the array it is in.
     661        (RP-FUNCTION-WORD RP (SG-IPMARK SG))
     662        ;; Normal case.  If in a compiled function, see if it "called" an open-coded fcn.
     663        (LET ((FUNCTION (RP-FUNCTION-WORD RP FRAME))
     664              (PC (1- (RP-EXIT-PC RP FRAME))))
     665          (SELECT (%DATA-TYPE FUNCTION)
     666            (DTP-U-ENTRY
     667              (MICRO-CODE-ENTRY-NAME-AREA (%POINTER FUNCTION)))
     668            (DTP-FEF-POINTER
     669              (LET ((INST (FEF-INSTRUCTION FUNCTION PC)))
     670                (LET ((OP (LDB 1104 INST))
     671                      (DEST (LDB 1503 INST))
     672                      (DISP (LDB 0011 INST)))
     673                  (COND ((< OP 11)
     674                         (NTH OP '(FUNCALL FUNCALL MOVE-INSTRUCTION CAR
     675                                   CDR CADR CDDR CDAR CAAR)))
     676                        ((= OP 11)
     677                         (NTH DEST '(ND1-UNUSED *PLUS *DIF *TIMES ;*'s to avoid confusion
     678                                     *QUO *LOGAND *LOGXOR *LOGIOR))) ;with argument-number
     679                        ((= OP 12)
     680                         (NTH DEST '(= > < EQ CDR CDDR 1+ 1-)))
     681                        ((= OP 13)
     682                         (NTH DEST '(ND3-UNUSED BIND BIND SET-NIL
     683                                     SET-ZERO PUSH-E MOVEM POP)))
     684                        ((= OP 14)
     685                         'A-BRANCH-INSTRUCTION)
     686                        ((< DISP 100) 'LIST)
     687                        ((< DISP 200) 'LIST-IN-AREA)
     688                        ((< DISP 220) 'UNBIND)
     689                        ((< DISP 240) 'A-POP-PDL-INSTRUCTION)
     690                        (T (MICRO-CODE-SYMBOL-NAME-AREA (- DISP 200)))))))
     691            (OTHERWISE FUNCTION))))))
    587692
    588693;; Return the name of the localno'th local of function, or nil if unavailable or none such.
     
    594699         (COMPILER:DISASSEMBLE-LOCAL-NAME FUNCTION LOCALNO))
    595700        ((AND (ZEROP LOCALNO)
    596               (SETQ ARGL (COND ((LISTP FUNCTION)
    597                                 (SELECTQ (CAR FUNCTION)
    598                                   (LAMBDA (CADR FUNCTION))
    599                                   (NAMED-LAMBDA (CADDR FUNCTION))))
    600                                (T (ARGLIST FUNCTION T)))))
     701              (LISTP (SETQ ARGL (COND ((LISTP FUNCTION)
     702                                       (SELECTQ (CAR FUNCTION)
     703                                         (LAMBDA (CADR FUNCTION))
     704                                         (NAMED-LAMBDA (CADDR FUNCTION))))
     705                                      ((LEGITIMATE-FUNCTION-P FUNCTION)
     706                                       (ARGLIST FUNCTION T))))))
    601707         (CADR (MEMQ '&REST ARGL)))))
    602708
     
    607713  (COND ((= (%DATA-TYPE FUNCTION) DTP-FEF-POINTER)
    608714         (COMPILER:DISASSEMBLE-ARG-NAME FUNCTION ARGNO))
    609         ((SETQ ARGL (COND ((LISTP FUNCTION)
    610                            (SELECTQ (CAR FUNCTION)
    611                              (LAMBDA (CADR FUNCTION))
    612                              (NAMED-LAMBDA (CADDR FUNCTION))))
    613                           (T (ARGLIST FUNCTION T))))
     715        ((LISTP (SETQ ARGL (COND ((LISTP FUNCTION)
     716                                  (SELECTQ (CAR FUNCTION)
     717                                    ((LAMBDA SUBST) (CADR FUNCTION))
     718                                    ((NAMED-LAMBDA NAMED-SUBST) (CADDR FUNCTION))))
     719                                 ((LEGITIMATE-FUNCTION-P FUNCTION)
     720                                  (ARGLIST FUNCTION T)))))
    614721         (DO ((ARGL ARGL (CDR ARGL))
    615722              (I ARGNO))
    616              ((OR (NULL ARGL) (EQ (CAR ARGL) '&AUX) (EQ (CAR ARGL) '&REST)))
     723             ((OR (NULL ARGL)
     724                  (EQ (CAR ARGL) '&AUX)
     725                  (EQ (CAR ARGL) '&REST)
     726                  (EQ (CAR ARGL) '&KEY)))
    617727           (OR (MEMQ (CAR ARGL) LAMBDA-LIST-KEYWORDS)
    618728               (COND ((
     
    620730                      (RETURN (CAR ARGL)))
    621731                     (T (SETQ I (1- I)))))))))
     732
     733
     734;; Functions for finding the special pdl info associated with a stack frame.
     735
     736;;;Return the range of the special pdl bound by this frame, or NIL if does not hack any
     737;;;specials.
     738(DEFUN SG-FRAME-SPECIAL-PDL-RANGE (SG FRAME &AUX (RP (SG-REGULAR-PDL SG)))
     739  (AND (NOT (ZEROP (RP-BINDING-BLOCK-PUSHED RP FRAME)))
     740       (LET ((SP (SG-SPECIAL-PDL SG)))
     741         (DO ((FRAME1 (SG-AP SG) (SG-PREVIOUS-ACTIVE SG FRAME1))
     742              (J (SG-SPECIAL-PDL-POINTER SG))
     743              (I))
     744             ((NULL FRAME1))
     745           (COND ((NOT (ZEROP (RP-BINDING-BLOCK-PUSHED RP FRAME1)))
     746                  (DO () ((= (%P-DATA-TYPE (ALOC-CAREFUL SP J)) DTP-LOCATIVE))
     747                    ;; Space back over a random non-binding frame
     748                    (DO () ((NOT (ZEROP (%P-FLAG-BIT (ALOC-CAREFUL SP J)))))
     749                      (SETQ J (1- J)))
     750                    (SETQ J (1- J)))
     751                  ;; Make I and J inclusive brackets for this binding frame
     752                  (SETQ I (1- J))
     753                  (DO () ((NOT (ZEROP (%P-FLAG-BIT (ALOC-CAREFUL SP I)))))
     754                    (SETQ I (- I 2)))
     755                  (AND (= FRAME1 FRAME) (RETURN I J))
     756                  (SETQ J (1- I))))))))
     757
     758;Return special pdl index corresponding to beginning of this frame's data.
     759;If no specials in this frame, return index pointing after last data from
     760;outside this frame.
     761(DEFUN SG-FRAME-SPECIAL-PDL-INDEX (SG FRAME &AUX (RP (SG-REGULAR-PDL SG)))
     762  (LET ((SP (SG-SPECIAL-PDL SG)))
     763    (DO ((FRAME1 (SG-AP SG) (SG-PREVIOUS-ACTIVE SG FRAME1))
     764         (J (SG-SPECIAL-PDL-POINTER SG)))
     765        ((NULL FRAME1))
     766      (COND ((NOT (ZEROP (RP-BINDING-BLOCK-PUSHED RP FRAME1)))
     767             (DO () ((= (%P-DATA-TYPE (ALOC-CAREFUL SP J)) DTP-LOCATIVE))
     768               ;; Space back over a random non-binding frame
     769               (DO () ((NOT (ZEROP (%P-FLAG-BIT (ALOC-CAREFUL SP J)))))
     770                 (SETQ J (1- J)))
     771               (SETQ J (1- J)))
     772             ;; Space back to beginning of a binding block.
     773             (SETQ J (1- J))
     774             (DO () ((NOT (ZEROP (%P-FLAG-BIT (ALOC-CAREFUL SP J)))))
     775               (SETQ J (- J 2)))
     776             (SETQ J (1- J))))
     777      (AND (= FRAME1 FRAME) (RETURN J)))))
     778
     779
     780;Functions to extract the argument and local variable values from a frame.
     781
     782;Return list of the function and args that were invoked (as best as it can).
     783;Doesn't work, of course, for functions which modify their arguments.
     784;Note that this tries to get the original name of the function so that
     785;if it has been redefined and you are doing c-m-R the new version will be called.
     786(DEFUN GET-FRAME-FUNCTION-AND-ARGS (SG FRAME &AUX FUNCTION NARGS-SUPPLIED
     787                                    (RP (SG-REGULAR-PDL SG))
     788                                    LEXPR-CALL REST-ARG-VALUE ANS)
     789      (SETQ FUNCTION (RP-FUNCTION-WORD RP FRAME)
     790            NARGS-SUPPLIED (RP-NUMBER-ARGS-SUPPLIED RP FRAME))  ;Really slots on stack
     791      (MULTIPLE-VALUE (REST-ARG-VALUE NIL LEXPR-CALL)
     792        (SG-REST-ARG-VALUE SG FRAME))
     793      ;; Analyze the function
     794      (SETQ FUNCTION (FUNCTION-NAME FUNCTION))
     795      ;; Get the individual args.
     796      (DO ((I NARGS-SUPPLIED (1- I)))           ;Cons them up in reverse order
     797          ((ZEROP I))
     798        (SETQ ANS (CONS (AREF RP (+ FRAME I)) ANS)))   ;+1 -1
     799      ;; NCONC the rest arg if any was supplied separately from the regular args
     800      (AND LEXPR-CALL (SETQ ANS (NCONC ANS (COPYLIST REST-ARG-VALUE))))
     801      (CONS FUNCTION ANS))
     802
     803;; Get the value of the ARGNUMth arg of the specified frame, and its location.
     804(DEFUN SG-FRAME-ARG-VALUE (SG FRAME ARGNUM)
     805  (DECLARE (RETURN-LIST VALUE LOCATION))
     806  (PROG FUNCTION ((ARG-NAME (ARG-NAME (FUNCTION-NAME (RP-FUNCTION-WORD (SG-REGULAR-PDL SG)
     807                                                                       FRAME))
     808                                      ARGNUM)))
     809        (MULTIPLE-VALUE-BIND (START END)
     810            (SG-FRAME-SPECIAL-PDL-RANGE SG FRAME)
     811          (COND (START
     812                 (DO ((SP (SG-SPECIAL-PDL SG))
     813                      (I START (+ 2 I)))
     814                     ((>= I END))
     815                   (AND (EQ (SYMBOL-FROM-VALUE-CELL-LOCATION (AREF SP (1+ I)))
     816                            ARG-NAME)
     817                        (RETURN-FROM FUNCTION (AREF SP I) (ALOC SP I)))))))
     818        (RETURN (AREF (SG-REGULAR-PDL SG) (+ FRAME ARGNUM 1))
     819                (ALOC (SG-REGULAR-PDL SG) (+ FRAME ARGNUM 1)))))
     820
     821;; Get the value of the LOCALNUMth local variable of the specified frame, and its location.
     822(DEFUN SG-FRAME-LOCAL-VALUE (SG FRAME LOCALNUM)
     823  (DECLARE (RETURN-LIST VALUE LOCATION))
     824  (PROG FUNCTION ((LOCAL-NAME (LOCAL-NAME (RP-FUNCTION-WORD (SG-REGULAR-PDL SG) FRAME)
     825                                          LOCALNUM)))
     826        (MULTIPLE-VALUE-BIND (START END)
     827            (SG-FRAME-SPECIAL-PDL-RANGE SG FRAME)
     828          (COND (START
     829                 (DO ((SP (SG-SPECIAL-PDL SG))
     830                      (I START (+ 2 I)))
     831                     ((>= I END))
     832                   (AND (EQ (SYMBOL-FROM-VALUE-CELL-LOCATION (AREF SP (1+ I)))
     833                            LOCAL-NAME)
     834                        (MULTIPLE-VALUE-BIND (VALUE LOC)
     835                            (SYMEVAL-IN-STACK-GROUP LOCAL-NAME SG FRAME)
     836                          (RETURN-FROM FUNCTION VALUE LOC)))))))
     837        (LET* ((RP (SG-REGULAR-PDL SG))
     838               (RPIDX (+ LOCALNUM CURRENT-FRAME (RP-LOCAL-BLOCK-ORIGIN RP CURRENT-FRAME))))
     839          (RETURN (AREF RP RPIDX) (ALOC RP RPIDX)))))
    622840
    623841
     
    631849                             (RP (SG-REGULAR-PDL SG))
    632850                             (AP FRAME)
    633                              LEXPR-CALL ARGS-INFO REST-ARG NARGS-EXPECTED
     851                             LEXPR-CALL ARGS-INFO REST-ARG
    634852                             (FUNCTION (RP-FUNCTION-WORD RP AP))
    635                              (NARGS-SUPPLIED (RP-NUMBER-ARGS-SUPPLIED RP AP)))
    636   (COND ((OR (= (%DATA-TYPE FUNCTION) DTP-FEF-POINTER) (LISTP FUNCTION))
     853                             (NARGS-SUPPLIED (RP-NUMBER-ARGS-SUPPLIED RP AP))
     854                             (NARGS-EXPECTED NARGS-SUPPLIED))
     855  (COND ((LEGITIMATE-FUNCTION-P FUNCTION)
    637856         (SETQ ARGS-INFO (ARGS-INFO FUNCTION))
    638857         (SETQ REST-ARG (LDB-TEST 2402 ARGS-INFO))
     
    656875             LEXPR-CALL)))
    657876
     877;; T if things like ARGS-INFO will work for this function.
     878(DEFUN LEGITIMATE-FUNCTION-P (FUNCTION)
     879  (OR (= (%DATA-TYPE FUNCTION) DTP-FEF-POINTER)
     880      (= (%DATA-TYPE FUNCTION) DTP-U-ENTRY)
     881      (AND (LISTP FUNCTION) (MEMQ (CAR FUNCTION) '(LAMBDA NAMED-LAMBDA SUBST NAMED-SUBST)))))
     882
    658883;; Return the number of spread args present in a given frame.
    659884;; This will not count any args which are part of a rest arg.
     
    663888                                    (FUNCTION (RP-FUNCTION-WORD RP AP))
    664889                                    (NARGS-SUPPLIED (RP-NUMBER-ARGS-SUPPLIED RP AP)))
    665   (COND ((OR (= (%DATA-TYPE FUNCTION) DTP-FEF-POINTER) (LISTP FUNCTION))
     890  (COND ((LEGITIMATE-FUNCTION-P FUNCTION)
    666891         (SETQ ARGS-INFO (ARGS-INFO FUNCTION))
    667892         (SETQ REST-ARG-P (LDB-TEST 2402 ARGS-INFO))
     
    686911       (SETQ NARGS-VISIBLE NARGS-EXPECTED))
    687912  NARGS-VISIBLE)
    688 
    689 ;; Return the value of the argno'th spread arg in a given frame, or nil if there is none.
    690 ;; The second value is T if that number arg is present in the frame.
    691 (DEFUN SG-ARG-VALUE (SG FRAME ARGNO &AUX (RP (SG-REGULAR-PDL SG)) (AP FRAME))
    692   (PROG () (OR (MINUSP ARGNO) (
    693  ARGNO (SG-NUMBER-OF-SPREAD-ARGS SG FRAME))
    694                (RETURN (AREF RP (+ AP ARGNO 1)) T))))
    695913
    696914
     
    7881006                        (+ INDEX 1 (%P-LDB-OFFSET %%ARRAY-LONG-LENGTH-FLAG ARRAY 0))))
    7891007
     1008;;; Find out whether this is a pointer to an unbound value or function cell.
     1009(DEFUN LOCATIVE-BOUNDP (LOCATIVE)
     1010  (LOOP FOR DTP = (%P-DATA-TYPE LOCATIVE)
     1011        DO (SELECT DTP
     1012             (DTP-NULL
     1013              (RETURN NIL))
     1014             ((DTP-EXTERNAL-VALUE-CELL-POINTER
     1015               DTP-ONE-Q-FORWARD)
     1016              (SETQ LOCATIVE (%P-CONTENTS-AS-LOCATIVE LOCATIVE)))
     1017             (OTHERWISE
     1018              (RETURN T)))))
     1019
     1020(DEFUN SYMBOL-FROM-VALUE-CELL-LOCATION (LOC &AUX SYM)
     1021  (COND ((AND (
     1022 (%POINTER LOC) A-MEMORY-VIRTUAL-ADDRESS)       ;Microcode location
     1023              (< (%POINTER LOC) IO-SPACE-VIRTUAL-ADDRESS))      ; forwarded from value cell
     1024         (OR (DOLIST (SYM A-MEMORY-LOCATION-NAMES)
     1025               (AND (= (%POINTER LOC) (%P-LDB-OFFSET %%Q-POINTER SYM 1)) (RETURN SYM)))
     1026             (DOLIST (SYM M-MEMORY-LOCATION-NAMES)
     1027               (AND (= (%POINTER LOC) (%P-LDB-OFFSET %%Q-POINTER SYM 1)) (RETURN SYM)))
     1028             LOC))
     1029        ((AND (SYMBOLP (SETQ SYM (%FIND-STRUCTURE-HEADER LOC))) ;Regular symbol's
     1030              (= (%POINTER-DIFFERENCE LOC SYM) 1))              ; internal value-cell
     1031         SYM)
     1032        (T LOC)))                                               ;not a symbol
     1033
    7901034;;; Find the value of a symbol in the binding environment of a specified stack group.
    7911035;;; Note that this cannot get an error even if the sg is in some funny state, unlike
    792 ;;; SG-EVAL.
    793 (DEFUN SYMEVAL-IN-STACK-GROUP (SYM SG)
    794   (COND ((EQ SG %CURRENT-STACK-GROUP) (SYMEVAL SYM))
    795         (T
    796          (DO-NAMED RESULT
    797                    ((VCL (VALUE-CELL-LOCATION SYM))
    798                     (SP (SG-SPECIAL-PDL SG))
    799                     (SPP (SG-SPECIAL-PDL-POINTER SG)))
    800                    ()
    801            (OR  (
     1036;;; SG-EVAL.  Don't call this if the stack-group could be running in another process
     1037;;; and thus changing its state.  If the variable is unbound, the first value is NIL.
     1038;;; The second value is th elocation of the binding, or NIL if there is none.
     1039;;; If FRAME is specified, we get the value visible in that frame.
     1040(DEFUN SYMEVAL-IN-STACK-GROUP (SYM SG &OPTIONAL FRAME)
     1041  (DECLARE (RETURN-LIST VALUE LOCATION))
     1042  (IF (EQ SG %CURRENT-STACK-GROUP)
     1043      (SYMEVAL SYM)
     1044      ;ELSE
     1045      (DO-NAMED RESULT
     1046                ((VCL (VALUE-CELL-LOCATION SYM))
     1047                 (SP (SG-SPECIAL-PDL SG))
     1048                 (SPP (OR (AND FRAME (SG-NEXT-INTERESTING-ACTIVE SG FRAME)
     1049                               (SG-FRAME-SPECIAL-PDL-INDEX
     1050                                 SG (SG-NEXT-INTERESTING-ACTIVE SG FRAME)))
     1051                          (SG-SPECIAL-PDL-POINTER SG))))
     1052                ()
     1053        (OR (ZEROP (SG-IN-SWAPPED-STATE SG))    ;If its bindings are swapped out
     1054            (
    8021055 SPP 0)
    803                 (ZEROP (SG-IN-SWAPPED-STATE SG))        ;If its bindings are swapped out
    804                 (DO ((I SPP (1- I))             ;then search through them
    805                      (P))
    806                     ((
     1056            (DO ((I SPP (1- I))                 ;then search through them
     1057                 (P))
     1058                ((
    8071059 I 0))
    808                   (SETQ P (ALOC-CAREFUL SP I))
    809                   (SELECT (%P-DATA-TYPE P)
    810                     (DTP-LOCATIVE               ;If this is a binding pair
    811                      (SETQ P (%MAKE-POINTER-OFFSET DTP-LOCATIVE P -1))
    812                      (IF (EQ (AREF SP I) VCL)   ;and is for this variable, then return
    813                          (RETURN-FROM RESULT (CAR P))   ;the saved value, invz'ing if necc
    814                          (SETQ I (1- I))))      ;Space over second Q of binding pair
    815                     (OTHERWISE ))))             ;Ignore non-binding blocks
    816            ;; The variable isn't bound in that stack group, so we want its global value.
    817            ;; Must ignore bindings in our own stack group.
    818            (SETQ SP (SG-SPECIAL-PDL %CURRENT-STACK-GROUP)
    819                  SPP (GET-OWN-SPECIAL-PDL-POINTER SP))
    820            (DO ((VAL (SYMEVAL SYM))
    821                 (I SPP (1- I))
    822                 (P))
    823                ((
    824  I 0) (RETURN-FROM RESULT VAL))
    825              (SETQ P (ALOC-CAREFUL SP I))
    826              (SELECT (%P-DATA-TYPE P)
    827                (DTP-LOCATIVE
    828                 (SETQ P (%MAKE-POINTER-OFFSET DTP-LOCATIVE P -1))
    829                 (IF (EQ (AREF SP I) VCL)
    830                     (SETQ VAL (CAR P)))
    831                 (SETQ I (1- I)))
    832                (OTHERWISE )))))))
     1060              (SETQ P (ALOC-CAREFUL SP I))
     1061              (SELECT (%P-DATA-TYPE P)
     1062                (DTP-LOCATIVE                   ;If this is a binding pair
     1063                 (SETQ P (%MAKE-POINTER-OFFSET DTP-LOCATIVE P -1))
     1064                 (IF (EQ (AREF SP I) VCL)       ;and is for this variable, then return
     1065                     (IF (LOCATIVE-BOUNDP P)    ;the saved value, invz'ing if necc
     1066                         (RETURN-FROM RESULT (CAR P) P)
     1067                         (RETURN-FROM RESULT NIL NIL))
     1068                     (SETQ I (1- I))))          ;Space over second Q of binding pair
     1069                (OTHERWISE ))))                 ;Ignore non-binding blocks
     1070        ;; The variable isn't bound in that stack group, so we want its global value.
     1071        ;; Must ignore bindings in our own stack group.
     1072        (SETQ SP (SG-SPECIAL-PDL %CURRENT-STACK-GROUP)
     1073              SPP (GET-OWN-SPECIAL-PDL-POINTER SP))
     1074        (LET ((LOCATION (AND (BOUNDP SYM) (LOCF (SYMEVAL SYM)))))
     1075          (DO ((VAL (AND LOCATION (SYMEVAL SYM)))
     1076               (I SPP (1- I))
     1077               (P))
     1078              ((
     1079 I 0) (RETURN-FROM RESULT VAL LOCATION))
     1080            (SETQ P (ALOC-CAREFUL SP I))
     1081            (SELECT (%P-DATA-TYPE P)
     1082              (DTP-LOCATIVE
     1083               (SETQ P (%MAKE-POINTER-OFFSET DTP-LOCATIVE P -1))
     1084               (COND ((EQ (AREF SP I) VCL)
     1085                      (SETQ LOCATION (AND (LOCATIVE-BOUNDP P) P))
     1086                      (SETQ VAL (AND LOCATION (CAR P)))))
     1087               (SETQ I (1- I)))
     1088              (OTHERWISE )))))))
     1089
     1090;;; Not a fully general SET-IN-STACK-GROUP, this quite deliberately only allows
     1091;;; you to change the value of a binding extant in that stack group, not the
     1092;;; global value.  Returns T if it succeeds, NIL if it fails.
     1093;;; Don't call this if the stack-group could be running in another process
     1094;;; and thus changing its state.
     1095(DEFUN REBIND-IN-STACK-GROUP (SYM VALUE SG)
     1096  (LET ((VCL (VALUE-CELL-LOCATION SYM))
     1097        (SP (SG-SPECIAL-PDL SG))
     1098        (SPP (SG-SPECIAL-PDL-POINTER SG)))
     1099    (COND ((EQ SG %CURRENT-STACK-GROUP) (SET SYM VALUE) T)
     1100          ((OR (ZEROP (SG-IN-SWAPPED-STATE SG)) (
     1101 SPP 0)) NIL)   ;Abnormal binding state
     1102          (T (DO ((I SPP (1- I))                ;Search through bindings
     1103                  (P))
     1104                 ((
     1105 I 0))
     1106               (SETQ P (ALOC-CAREFUL SP I))
     1107               (SELECT (%P-DATA-TYPE P)
     1108                 (DTP-LOCATIVE                  ;If this is a binding pair
     1109                  (SETQ P (%MAKE-POINTER-OFFSET DTP-LOCATIVE P -1))
     1110                  (COND ((EQ (AREF SP I) VCL)   ; and is for this variable, then win.
     1111                         (RPLACA P VALUE)       ;RPLACA invz's if necessary
     1112                         (RETURN T)))
     1113                  (SETQ I (1- I)))              ;Space over second Q of binding pair
     1114                (OTHERWISE )))))))              ;Ignore non-binding blocks
    8331115
    8341116(DEFUN USE-COLD-LOAD-STREAM (STRING)
     
    8381120  (FORMAT TERMINAL-IO "--> ~A, using the cold load stream <--~2%" STRING))
    8391121
    840 (DEFMACRO PRINT-CAREFULLY (TYPE . BODY)
    841   `(OR (ERRSET (PROGN . ,BODY) NIL)
    842        (OR (ERRSET (FORMAT T "<<Error printing ~A>>" ,TYPE) NIL)
    843            (USE-COLD-LOAD-STREAM (FORMAT NIL "<<Error printing ~A>>" ,TYPE)))))
     1122(DEFMACRO PRINT-CAREFULLY (TYPE &BODY BODY)
     1123  `(MULTIPLE-VALUE-BIND (NIL .ERROR.)
     1124       (CATCH-ERROR (PROGN . ,BODY) NIL)
     1125     (COND (.ERROR.
     1126            (MULTIPLE-VALUE (NIL .ERROR.)
     1127              (CATCH-ERROR (FORMAT T "<<Error printing ~A>>" ,TYPE) NIL))
     1128            (IF .ERROR. (USE-COLD-LOAD-STREAM (FORMAT NIL "<<Error printing ~A>>" ,TYPE)))))))
    8441129
    8451130
    8461131;; Various initialization routines.
    8471132
    848 (DEFUN ASSURE-TABLE-LOADED ()
     1133(DEFUN ASSURE-TABLE-LOADED (&AUX (IBASE 8) (BASE 8))
    8491134  (COND ((NOT (= MICROCODE-ERROR-TABLE-VERSION-NUMBER %MICROCODE-VERSION-NUMBER))
    8501135         (LOAD-ERROR-TABLE)
     
    8521137             (BREAK 'CANNOT-GET-ERROR-TABLE T)))))
    8531138
    854 (DEFUN LOAD-ERROR-TABLE (&AUX (FUDGED-USER-ID-FLAG NIL))
     1139(DEFUN LOAD-ERROR-TABLE (&AUX LOGIN-HOST)
     1140  (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-DESIRED-MICROCODE-VERSION)
     1141         %MICROCODE-VERSION-NUMBER)
    8551142  (COND ((OR (NULL USER-ID) (STRING-EQUAL USER-ID ""))
    856          (SETQ FUDGED-USER-ID-FLAG T)
    857          (LOGIN "ERROR" T)))
    858   (LOAD (FORMAT NIL "DSK:LISPM1;UCADR ~DTBL" %MICROCODE-VERSION-NUMBER) "EH")
    859   (AND FUDGED-USER-ID-FLAG (LOGOUT)))
     1143         (SETQ LOGIN-HOST (FUNCALL (FS:GET-PATHNAME-HOST "SYS") ':HOST))
     1144         (LOGIN "LISPM" LOGIN-HOST NIL)))
     1145  (LOAD (FUNCALL (FS:PARSE-PATHNAME "SYS: UBIN; UCADR")
     1146                 ':NEW-TYPE-AND-VERSION "TBL" %MICROCODE-VERSION-NUMBER)
     1147        "EH")
     1148  (AND LOGIN-HOST (LOGOUT)))
    8601149
    8611150;; Divides up MICROCODE-ERROR-TABLE into CALLS-SUB-LIST, RESTART-LIST, and ERROR-TABLE.
     
    8641153         (SETQ ERROR-TABLE NIL
    8651154               CALLS-SUB-LIST NIL
    866                RESTART-LIST NIL)
     1155               RESTART-LIST NIL
     1156               STACK-WORDS-PUSHED-LIST NIL
     1157               ARG-POPPED-LIST NIL
     1158               DEFAULT-ARG-LOCATIONS-LIST NIL)
    8671159         (DO ET MICROCODE-ERROR-TABLE (CDR ET) (NULL ET)
    8681160             (SELECTQ (CADAR ET)
    8691161               (RESTART (PUSH (CONS (CADDAR ET) (1+ (CAAR ET))) RESTART-LIST))
    8701162               (CALLS-SUB (PUSH (CONS (CAAR ET) (CADDAR ET)) CALLS-SUB-LIST))
     1163               (ARG-POPPED (PUSH (CONS (CAAR ET) (CDDAR ET)) ARG-POPPED-LIST))
     1164               (DEFAULT-ARG-LOCATIONS (PUSH (CDDAR ET) DEFAULT-ARG-LOCATIONS-LIST))
     1165               (STACK-WORDS-PUSHED
     1166                (PUSH (CONS (CAAR ET) (CADDAR ET)) STACK-WORDS-PUSHED-LIST))
    8711167               (OTHERWISE (PUSH (CAR ET) ERROR-TABLE))))
    872          (SETQ ERROR-TABLE-NUMBER MICROCODE-ERROR-TABLE-VERSION-NUMBER))))
     1168         (SETQ BEGIN-QARYR (OR (CDR (ASSQ 'BEGIN-QARYR RESTART-LIST)) 0)
     1169               END-QARYR (OR (CDR (ASSQ 'END-QARYR RESTART-LIST)) 0)
     1170               ERROR-TABLE-NUMBER MICROCODE-ERROR-TABLE-VERSION-NUMBER))))
    8731171
    8741172;; Call this when it is apparent that some hacker set things up wrong.
     
    9081206(DEFUN LISP-ERROR-HANDLER (&AUX M SG SG2 ETE CONDITION (INHIBIT-SCHEDULING-FLAG T))
    9091207  ;; Return to boot code.  We are called back by the first error.
    910   (SETQ M (FUNCALL %CURRENT-STACK-GROUP-PREVIOUS-STACK-GROUP NIL))
     1208  (SETQ M (STACK-GROUP-RESUME %CURRENT-STACK-GROUP-PREVIOUS-STACK-GROUP NIL))
    9111209  (DO ((ERRSET-FLAG NIL NIL)    ;These must be reinitialized each time through the loop!
    9121210       (ERRSET-PRINT-MSG NIL NIL))
     
    9211219    (SETQ CONDITION (GET (CAR ETE) 'SIGNAL))
    9221220    (AND CONDITION (SETQ CONDITION (FUNCALL CONDITION SG ETE)))
    923     ;; All branches of this COND must end in funcalling some other SG.
     1221    ;; Every error should signal SOMETHING, except for a few specific exceptions.
     1222    (OR CONDITION
     1223        (EQ (CAR ETE) 'FERROR)
     1224        (SETQ CONDITION `(:ERROR . ,ETE)))
     1225    ;; All branches of this COND must end in resuming some other SG.
    9241226    (SETQ M
    9251227          (COND ((AND (EQ (CAR ETE) 'STEP-BREAK)
    9261228                      (SETQ SG2 (CDR (ASSQ SG SG-STEPPING-TABLE))))
    927                  (SETF (SG-CURRENT-STATE SG) SYS:SG-STATE-RESUMABLE)
     1229                 (SETF (SG-CURRENT-STATE SG) SG-STATE-RESUMABLE)
    9281230                 (FUNCALL SG2 SG))
    929                 ((AND (NOT (SYMEVAL-IN-STACK-GROUP 'ERRSET SG))
     1231                ((EQ (CAR ETE) 'RESUME-FOOTHOLD)
     1232                 (SG-RESTORE-STATE SG 1)
     1233                 (SETF (SG-CURRENT-STATE SG) SG-STATE-RESUMABLE)
     1234                 (STACK-GROUP-RESUME SG NIL))
     1235                ((AND (NOT (MEMQ (CAR ETE) ERRSET-INVISIBLE-ETES))
     1236                      (NOT (AND (EQ (CAR ETE) 'FERROR)
     1237                                (MEMQ (CADR ETE) ERRSET-INVISIBLE-CONDITIONS)))
     1238                      (NOT (SYMEVAL-IN-STACK-GROUP 'ERRSET SG))
    9301239                      (SETQ ERRSET-FLAG (SYMEVAL-IN-STACK-GROUP 'ERRSET-STATUS SG))
    9311240                      (NOT (SETQ ERRSET-PRINT-MSG
     
    9651274(DEFUN EH (&OPTIONAL PROCESS
    9661275           &AUX PKG SG ARREST-REASON
    967                 ORIGINAL-FRAME CURRENT-FRAME CONDITION-PROCEED-VALUE CONDITION-PROCEED-FLAG)
    968 
     1276                ORIGINAL-FRAME CURRENT-FRAME INNERMOST-VISIBLE-FRAME
     1277                INNERMOST-FRAME-IS-INTERESTING
     1278                CONDITION-PROCEED-VALUE CONDITION-PROCEED-FLAG
     1279                (ERROR-HANDLER-RUNNING NIL))
    9691280  (AND (NULL PROCESS)
    9701281       (SETQ PROCESS (TV:FIND-PROCESS-IN-ERROR)))
     
    9811292               (T (SETQ SG PROCESS PROCESS NIL)))
    9821293         (OR (TYPEP SG ':STACK-GROUP) (FERROR NIL "~S not a stack group" SG))
    983          (SETQ ORIGINAL-FRAME (SG-AP SG))
     1294         (SETQ INNERMOST-VISIBLE-FRAME (SG-AP SG))
     1295         (SETQ ORIGINAL-FRAME INNERMOST-VISIBLE-FRAME)
    9841296         (SETQ CURRENT-FRAME (SG-OUT-TO-INTERESTING-ACTIVE SG ORIGINAL-FRAME))
    9851297         ;; Although we get the package each time around the r-e-p loop, we must get it
     
    9891301         (UNWIND-PROTECT
    9901302           (*CATCH 'QUIT
    991              (*CATCH 'SI:TOP-LEVEL
     1303             (*CATCH 'SYS:COMMAND-LEVEL
    9921304               (PKG-BIND (IF (EQ (TYPEP PKG) 'PACKAGE) PKG "USER")
    9931305                 (PRINT-CAREFULLY "frame"
     
    10021314;; which may have bound it to NIL.
    10031315(DEFVAR REAL-CURRENT-PROCESS)
    1004 (DEFVAR ERRSET-INSIDE-ERROR NIL)
     1316(DEFVAR ERRSET-INSIDE-ERROR NIL)        ;Setting this to T allows debugging inside EH
     1317                                        ;by disabling the error handler's own ERRSETs
    10051318 
     1319;This is a list of variables whose values are to be inherited from the stack group
     1320;in error by portions of the error handler inside an INHERITING-VARIABLES-FROM special
     1321;form.  Each element can be just a variable, or a list of the variable and a
     1322;validate function, which receives the value as its argument and returns either
     1323;the same value or a corrected value if it doesn't like that one.
     1324(DEFVAR *INHERITED-VARIABLES*
     1325    '((PACKAGE VALIDATE-PACKAGE)
     1326      (READTABLE VALIDATE-READTABLE)
     1327      (BASE VALIDATE-BASE)
     1328      (IBASE VALIDATE-BASE)
     1329      *NOPOINT))
     1330
     1331(DEFMACRO INHERITING-VARIABLES-FROM ((SG) &BODY BODY)
     1332  `(PROG ((.L. *INHERITED-VARIABLES*) .VAR. .VAL.)
     1333     LP (SETQ .VAR. (IF (ATOM (CAR .L.)) (CAR .L.) (CAAR .L.))
     1334              .VAL. (SYMEVAL-IN-STACK-GROUP .VAR. ,SG))
     1335        (BIND (VALUE-CELL-LOCATION .VAR.)
     1336              (IF (ATOM (CAR .L.)) .VAL. (FUNCALL (CADAR .L.) .VAL.)))
     1337        (OR (ATOM (SETQ .L. (CDR .L.))) (GO LP))
     1338        (RETURN (PROGN . ,BODY))))
     1339
     1340(DEFUN VALIDATE-PACKAGE (P)
     1341  (IF (TYPEP P 'PACKAGE) P SI:PKG-USER-PACKAGE))
     1342
     1343(DEFUN VALIDATE-BASE (B)
     1344  (IF (MEMQ B '(8 10.)) B 8))           ;These are the only reasonable bases for debugging
     1345
     1346(DEFUN VALIDATE-READTABLE (R)
     1347  (IF (EQ (TYPEP R) 'READTABLE) R SI:INITIAL-READTABLE))
     1348
    10061349;; This is the function at the top level in each second level error handler sg.
    10071350(DEFUN SECOND-LEVEL-ERROR-HANDLER (SG M ERRSET-FLAG ERRSET-PRINT-MSG CONDITION MSG
    1008                                    &AUX PKG (ERRSET ERRSET-INSIDE-ERROR)
    1009                                    (PACKAGE SI:PKG-USER-PACKAGE)
     1351                                   &AUX (ERRSET ERRSET-INSIDE-ERROR)
     1352                                        (PACKAGE SI:PKG-USER-PACKAGE)
     1353                                        (INHIBIT-SCHEDULING-FLAG
     1354                                          (EQUAL MSG "Error in the scheduler"))
    10101355                                        (ERROR-HANDLER-RUNNING T)
    10111356                                        (ERROR-HANDLER-REPRINT-ERROR T)
     
    10131358                                        (TERMINAL-IO (OR ERROR-HANDLER-IO
    10141359                                                         (SYMEVAL-IN-STACK-GROUP
    1015                                                            'TERMINAL-IO SG)))
     1360                                                           'TERMINAL-IO SG)
     1361                                                         TV:COLD-LOAD-STREAM))
    10161362                                        (STANDARD-INPUT SI:SYN-TERMINAL-IO)
    10171363                                        (STANDARD-OUTPUT SI:SYN-TERMINAL-IO)
     
    10221368                                        (REAL-CURRENT-PROCESS CURRENT-PROCESS)
    10231369                                        ORIGINAL-FRAME CURRENT-FRAME
     1370                                        INNERMOST-VISIBLE-FRAME INNERMOST-FRAME-IS-INTERESTING
    10241371                                        CONDITION-PROCEED-VALUE CONDITION-PROCEED-FLAG)
    1025   (COND ((EQ (CAR M) ':BREAK)
    1026          (SG-RESTORE-STATE SG)          ;Restore state saved at FORCE-BREAK
    1027          (COND ((CADR M)                ;If re-invoke, do so.
    1028                 (SG-REINVOKE SG)))
    1029          (SETF (SG-TRAP-TAG SG) M)))    ;Remember that we are handling a break
     1372  (IF (MEMQ (CAR M) '(FERROR :BREAK))           ;Get rid of call to error-handler sg
     1373      (LET ((RP (SG-REGULAR-PDL SG)) (AP (SG-AP SG)) (TT (SG-TRAP-TAG SG)))
     1374        (IF (NEQ (AREF RP AP) %ERROR-HANDLER-STACK-GROUP)
     1375            (FERROR NIL "%ERROR-HANDLER-STACK-GROUP not found on pdl where expected"))
     1376        (IF ( (RP-DESTINATION RP AP) 0)        ;D-IGNORE
     1377            (FERROR NIL "%ERROR-HANDLER-STACK-GROUP called with bad destination"))
     1378        (IF ( (SG-REGULAR-PDL-POINTER SG) (1+ AP))
     1379            (FERROR NIL "%ERROR-HANDLER-STACK-GROUP called with wrong number of args"))
     1380        (SETF (SG-IPMARK SG) (SG-PREVIOUS-OPEN SG AP))
     1381        (SETF (SG-AP SG) (SETQ AP (SG-PREVIOUS-ACTIVE SG AP)))
     1382        (SETF (SG-FLAGS-QBBFL SG)               ;Must correspond to current frame to work!
     1383              (RP-BINDING-BLOCK-PUSHED RP AP))
     1384        (DOTIMES (I 5)                          ;Pop p3zero, function, and arg
     1385          (SG-REGPDL-POP SG))
     1386        ;; Now, if current frame is a foothold, restore to the previous state.  This will
     1387        ;; normally be the case for :BREAK
     1388        (IF (EQ (AREF RP AP) #'FOOTHOLD) (SG-RESTORE-STATE SG 0))
     1389        (SETF (SG-TRAP-TAG SG) TT)))
     1390  ;; These catches are so that quitting out of the condition handler restores the
     1391  ;; normal flow of the error handler rather than quitting out of the whole program.
    10301392  (*CATCH 'QUIT
    1031     (*CATCH 'SI:TOP-LEVEL
    1032       (PROG (CONDITION-RESULT)
    1033         ;; If we have a condition to signal, do so (in the debugged stack group)
    1034         ;; and maybe return or restart if it says so.
    1035         (AND CONDITION
    1036              (LET ((CONDITION-PROCEED-FLAG T)
    1037                    CONDITION-PROCEED-VALUE)
     1393    (*CATCH 'SYS:COMMAND-LEVEL
     1394      ;; If we have a condition to signal, do so (in the debugged stack group)
     1395      ;; and maybe return or restart if it says so.
     1396      (AND CONDITION
     1397           (LET ((CONDITION-PROCEED-FLAG T)
     1398                 (TRAP-ON-CALL (SG-FLAGS-TRAP-ON-CALL SG))
     1399                 CONDITION-PROCEED-VALUE CONDITION-RESULT)
     1400             (SETF (SG-FLAGS-TRAP-ON-CALL SG) 0)
     1401             (UNWIND-PROTECT
    10381402               (SETQ CONDITION-RESULT (SG-APPLY SG #'SIGNAL CONDITION))
    1039                (COND ((EQ (CAR CONDITION-RESULT) 'RETURN)
    1040                       (SETQ CONDITION-PROCEED-VALUE (CADR CONDITION-RESULT))
    1041                       (COM-PROCEED SG ETE))
    1042                      ((EQ (CAR CONDITION-RESULT) 'ERROR-RESTART)
    1043                       (COM-ERROR-RESTART SG ETE))
    1044                      ((EQ (CAR CONDITION-RESULT) 'RETURN-VALUE)
    1045                       (SG-UNWIND-TO-FRAME SG (SG-AP SG) T (CADR CONDITION-RESULT))))))
    1046         ;; If non-printing errset, throw to it once condition is processed.
    1047         (AND ERRSET-FLAG (NOT ERRSET-PRINT-MSG) (NEQ (CAR M) ':BREAK)
    1048              (NEQ (CAR ETE) 'PDL-OVERFLOW)      ;Shouldn't be caught by ERRSET, and mustn't
    1049              (SG-THROW SG 'ERRSET-CATCH NIL))   ; type out yet.
    1050         ;; Otherwise, decide whether to break or to go to top level.
    1051         (SETQ BREAK-FLAG (SG-BREAK-P SG ETE CONDITION))
    1052         (SETQ ORIGINAL-FRAME (SG-AP SG))
    1053         (SETQ CURRENT-FRAME
    1054               (SG-NEXT-NTH-ACTIVE SG ORIGINAL-FRAME
    1055                                   (- (OR (GET (CAR M) 'BACKTRACE-SKIP) 0))))
    1056         (SETQ CURRENT-FRAME (SG-OUT-TO-INTERESTING-ACTIVE SG CURRENT-FRAME))
    1057         (AND MSG (USE-COLD-LOAD-STREAM MSG))
    1058         ;; If not running in the scheduler, give us a run reason in case we died after
    1059         ;; becoming inactive, before getting back to the scheduler.
    1060         (OR (NULL CURRENT-PROCESS)
    1061             (FUNCALL CURRENT-PROCESS ':RUN-REASON %CURRENT-STACK-GROUP))
    1062         ;; Try to see if TERMINAL-IO is reasonable and if not fix it.
    1063         (LET ((WO (ERRSET (FUNCALL TERMINAL-IO ':WHICH-OPERATIONS) NIL))
    1064               (ERROR-HANDLER-REPRINT-ERROR NIL))
    1065           (IF (NULL WO) (USE-COLD-LOAD-STREAM "TERMINAL-IO clobbered")
    1066               (COND ((MEMQ ':NOTIFY (CAR WO))
    1067                      (LET ((OLD-TIO TERMINAL-IO))       ;:NOTIFY can change it
    1068                        (FUNCALL TERMINAL-IO ':NOTIFY ':ERROR)   ;Do this in non-erring stack
    1069                        (COND ((NEQ TERMINAL-IO OLD-TIO)
    1070                               (SG-FUNCALL SG #'SET 'TERMINAL-IO TERMINAL-IO))))))))
    1071         ;; Although we get the package each time around the r-e-p loop, we must get it
    1072         ;; here as well, so that when the error message is printed it will be in the
    1073         ;; right package.
    1074         (SETQ PKG (SYMEVAL-IN-STACK-GROUP 'PACKAGE SG))
    1075         (PKG-BIND (IF (EQ (TYPEP PKG) 'PACKAGE) PKG SI:PKG-USER-PACKAGE)
    1076           (PRINT-CAREFULLY "error message"
    1077             ;; Print a brief message if not going to eh command level, else a long msg
    1078             (IF (OR (EQ (CAR M) ':BREAK) (AND BREAK-FLAG (NOT ERRSET-FLAG)))
    1079                 (SHOW SG ETE)
    1080                 (PRINT-ERROR-MESSAGE SG ETE T))))
    1081         (AND ERRSET-FLAG (NEQ (CAR M) ':BREAK)  ;Should PDL-OVERFLOW be catchable by ERRSET?
    1082              (SG-THROW SG 'ERRSET-CATCH NIL))
    1083         ;; If this error isn't interesting to break on,
    1084         ;; return to top level, or to innermost error break loop.
    1085         (OR BREAK-FLAG (COM-THROW-ONE-ERROR SG ETE)))))
     1403               (SETF (SG-FLAGS-TRAP-ON-CALL SG) TRAP-ON-CALL))
     1404             (COND ((EQ (CAR CONDITION-RESULT) 'RETURN)
     1405                    (SETQ CONDITION-PROCEED-VALUE (CADR CONDITION-RESULT))
     1406                    (COM-PROCEED SG ETE))
     1407                   ((EQ (CAR CONDITION-RESULT) 'ERROR-RESTART)
     1408                    (COM-ERROR-RESTART SG ETE))
     1409                   ((EQ (CAR CONDITION-RESULT) 'RETURN-VALUE)
     1410                    (SG-UNWIND-TO-FRAME SG (SG-AP SG) T (CADR CONDITION-RESULT))))))))
     1411  ;; If non-printing errset, throw to it once condition is processed.
     1412  (AND ERRSET-FLAG (NOT ERRSET-PRINT-MSG)
     1413       (SG-THROW SG 'ERRSET-CATCH NIL))
     1414  ;; Otherwise, decide whether to break or to go to top level.
     1415  (SETQ BREAK-FLAG (SG-BREAK-P SG ETE CONDITION))
     1416  (SETQ INNERMOST-VISIBLE-FRAME (SG-AP SG))
     1417  (SETQ ORIGINAL-FRAME INNERMOST-VISIBLE-FRAME)
     1418  (SETQ CURRENT-FRAME ORIGINAL-FRAME)
     1419  (DO ((RP (SG-REGULAR-PDL SG)))
     1420      ((NOT (LET ((F (FUNCTION-NAME (RP-FUNCTION-WORD RP CURRENT-FRAME))))
     1421              (AND (SYMBOLP F) (GET F ':ERROR-REPORTER)))))
     1422    (SETQ CURRENT-FRAME (SG-PREVIOUS-ACTIVE SG CURRENT-FRAME)))
     1423  (SETQ CURRENT-FRAME (SG-OUT-TO-INTERESTING-ACTIVE SG CURRENT-FRAME))
     1424  (AND MSG (USE-COLD-LOAD-STREAM MSG))
     1425  ;; If not running in the scheduler, give us a run reason in case we died after
     1426  ;; becoming inactive, before getting back to the scheduler.
     1427  (OR (NULL CURRENT-PROCESS)
     1428      (FUNCALL CURRENT-PROCESS ':RUN-REASON %CURRENT-STACK-GROUP))
     1429  ;; Try to see if TERMINAL-IO is reasonable and if not fix it.
     1430  ;; Don't do this if being caught by an errset, since only going to print,
     1431  ;; not going to do anything interactive.
     1432  (IF (NOT ERRSET-FLAG)
     1433      (LET ((WO (ERRSET (FUNCALL TERMINAL-IO ':WHICH-OPERATIONS) NIL))
     1434            (ERROR-HANDLER-REPRINT-ERROR NIL))
     1435        (IF (NULL WO) (USE-COLD-LOAD-STREAM "TERMINAL-IO clobbered")
     1436            (COND ((MEMQ ':NOTICE (CAR WO))
     1437                   (LET (;; :NOTICE can change TERMINAL-IO of a background process
     1438                         (OLD-TIO TERMINAL-IO)
     1439                         ;; Send this message in non-erring stack
     1440                         (WINDOW-BAD (FUNCALL TERMINAL-IO ':NOTICE ':ERROR)))
     1441                     (IF (NEQ TERMINAL-IO OLD-TIO)
     1442                         (SG-FUNCALL SG #'SET 'TERMINAL-IO TERMINAL-IO))
     1443                     (IF (EQ WINDOW-BAD 'TV:COLD-LOAD-STREAM)
     1444                         (USE-COLD-LOAD-STREAM "window-system problems"))))))))
     1445  ;; These catches are so that quitting out of the printing of the error message
     1446  ;; or out of the special commands leaves you in the error handler at its
     1447  ;; normal command level rather than quitting out of the whole program.
     1448  (*CATCH 'QUIT
     1449    (*CATCH 'SYS:COMMAND-LEVEL
     1450      ;; Print the error message, using appropriate package, base, etc.
     1451      (INHERITING-VARIABLES-FROM (SG)
     1452        (PRINT-CAREFULLY "error message"
     1453          ;; Print a brief message if not going to eh command level, else a long msg
     1454          (COND ((AND BREAK-FLAG (NOT ERRSET-FLAG))
     1455                 (SHOW SG ETE)
     1456                 (OR (EQ BASE IBASE)
     1457                     (FORMAT T "~& Warning: BASE is ~D. but IBASE is ~D.~%" BASE IBASE)))
     1458                (T (PRINT-ERROR-MESSAGE SG ETE T)))))
     1459      (AND ERRSET-FLAG (SG-THROW SG 'ERRSET-CATCH NIL))
     1460      ;; Discard type-ahead
     1461      (FUNCALL STANDARD-INPUT ':CLEAR-INPUT)
     1462      ;; Offer any special commands, such as wrong-package correction.
     1463      (IF (SETQ M (GET (CAR ETE) 'OFFER-SPECIAL-COMMANDS))
     1464          (FUNCALL M SG ETE))))
     1465  ;; Setting this causes the previous error to be reprinted if BREAK-FLAG is NIL
    10861466  (SETQ LAST-SECOND-LEVEL-ERROR-HANDLER-SG %CURRENT-STACK-GROUP)
     1467  ;; If this error isn't interesting to break on,
     1468  ;; return to previous error break loop rather than going to EH command level.
     1469  (OR BREAK-FLAG (SG-THROW SG 'SYS:COMMAND-LEVEL NIL))
    10871470  ;;SG-TRAP-TAG is part of the state restored by SG-RESTORE-STATE in case of BREAK.
    10881471  ;;Thus, it does not win to have COMMAND-LOOP refetch it.
     
    10961479      (NOT (SELECTQ (CAR CONDITION)
    10971480             (:WRONG-NUMBER-OF-ARGUMENTS
    1098                (EQ (LET ((AP (SG-PREVIOUS-ACTIVE SG (SG-PREVIOUS-ACTIVE SG (SG-AP SG))))
     1481               (EQ (LET ((FRAME (SG-PREVIOUS-ACTIVE SG (SG-PREVIOUS-ACTIVE SG (SG-AP SG))))
    10991482                         (RP (SG-REGULAR-PDL SG)))
    1100                      (RP-FUNCTION-WORD RP AP))
     1483                     (RP-FUNCTION-WORD RP FRAME))
    11011484                   #'FH-STREAM-BINDING-EVALER))
    11021485             ((:UNDEFINED-VARIABLE :UNDEFINED-FUNCTION)
    1103               (EQ (LET ((AP (SG-PREVIOUS-ACTIVE SG (SG-AP SG)))
     1486              (EQ (LET ((FRAME (SG-PREVIOUS-ACTIVE SG (SG-AP SG)))
    11041487                        (RP (SG-REGULAR-PDL SG)))
    1105                     (RP-FUNCTION-WORD RP AP))
     1488                    (RP-FUNCTION-WORD RP FRAME))
    11061489                  #'FH-STREAM-BINDING-EVALER))))))
     1490
     1491
  • trunk/lisp/lmwin/ehc.lisp

    r220 r275  
    11;;;The error handler commands -*- Mode:LISP; Package:EH -*-
    22
     3;; Commands in the dispatch table are given the SG and the ETE,
     4;; and a third arg which is the numeric argument may or may not be passed.
     5
     6;; Any command which wants to return out of the error handler should
     7;; do a throw to FINISHED after restarting the erring stack group.
     8
    39(DEFVAR WINDOW-ERROR-HANDLER NIL)                       ;Flag when inside window error handler
    410
    511(DEFUN COMMAND-LOOP (ERROR-SG ETE &AUX FUNCTION SEXP
    6                                        (EVALHOOK NIL) PKG
    7                                        (BASE 8) (IBASE 8)
    8                                        (*NOPOINT NIL) (PACKAGE PACKAGE)
     12                                       (EVALHOOK NIL)
    913                                       (WINDOW-ERROR-HANDLER NIL)
    1014                                       IO-BUFFER)
    11   ;; Discard type-ahead
    1215  (COND ((MEMQ ':IO-BUFFER (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))
    1316         (SETQ IO-BUFFER (FUNCALL STANDARD-INPUT ':IO-BUFFER))
    1417         (BIND (LOCF (TV:IO-BUFFER-OUTPUT-FUNCTION IO-BUFFER)) 'IO-BUFFER-OUTPUT-FUNCTION)
    1518         (BIND (LOCF (TV:IO-BUFFER-INPUT-FUNCTION IO-BUFFER)) NIL)))
    16   (FUNCALL STANDARD-INPUT ':CLEAR-INPUT)
    17   (DO ((NUMERIC-ARG)
     19  (DO ((NUMERIC-ARG NIL NIL)
    1820       (-)
    1921       (+ (SYMEVAL-IN-STACK-GROUP '- ERROR-SG))
    2022       (* (SYMEVAL-IN-STACK-GROUP '* ERROR-SG)))
    2123      (())
    22     (SETQ PKG (SYMEVAL-IN-STACK-GROUP 'PACKAGE ERROR-SG))
    23     (SETQ PACKAGE (IF (EQ (TYPEP PKG) 'PACKAGE) PKG SI:PKG-USER-PACKAGE))
    24     (*CATCH 'SI:TOP-LEVEL
    25       (*CATCH 'QUIT
    26         (PROGN
    27           (OR NUMERIC-ARG
    28               (FORMAT T "~&"))
    29           ;; Read the next command or sexp, with combined rubout processing.
    30           (MULTIPLE-VALUE (FUNCTION SEXP)
    31             (COMMAND-LOOP-READ))
    32           ;; If it's a character, execute the definition or complain.
    33           (COND ((NUMBERP FUNCTION)
    34                  (SETQ NUMERIC-ARG
    35                        (IF (NULL NUMERIC-ARG) FUNCTION (+ FUNCTION (* 10. NUMERIC-ARG)))))
    36                 (FUNCTION
    37                  (IF (NOT NUMERIC-ARG)
    38                      (FUNCALL FUNCTION ERROR-SG ETE)
    39                      (FUNCALL FUNCTION ERROR-SG ETE NUMERIC-ARG)
    40                      (SETQ NUMERIC-ARG NIL)))
    41                 ;; If there was no command, there was a sexp, so eval it.
    42                 (T
    43                  (LET ((RESULTS (SG-EVAL ERROR-SG (SETQ - SEXP) T)))
    44                    (SETQ + -)
    45                    (COND ((NEQ RESULTS ERROR-FLAG)
    46                           (SETQ * (CAR RESULTS))
    47                           (MAPC 'PRINT RESULTS))))))
    48           )))))
     24    (INHERITING-VARIABLES-FROM (ERROR-SG)  ;Do this every time around the loop in case of setq
     25      (*CATCH 'SYS:COMMAND-LEVEL
     26        (*CATCH 'QUIT
     27          (FORMAT T "~&")
     28          (DO () (NIL)                  ;This loop processes numeric args
     29            ;; Read the next command or sexp, with combined rubout processing.
     30            (MULTIPLE-VALUE (FUNCTION SEXP)
     31              (COMMAND-LOOP-READ))
     32            ;; If it's a character, execute the definition or complain.
     33            (COND ((NUMBERP FUNCTION)
     34                   (SETQ NUMERIC-ARG
     35                         (IF (NULL NUMERIC-ARG) FUNCTION (+ FUNCTION (* 10. NUMERIC-ARG)))))
     36                  (FUNCTION
     37                   (PRINC " ")  ;Print a space after the echo in case it prints something
     38                   (RETURN (IF (NOT NUMERIC-ARG)
     39                               (FUNCALL FUNCTION ERROR-SG ETE)
     40                               (FUNCALL FUNCTION ERROR-SG ETE NUMERIC-ARG))))
     41                  ;; If there was no command, there was a sexp, so eval it.
     42                  (T
     43                   (LET ((// (SG-EVAL ERROR-SG (SETQ - SEXP) T)))
     44                     (SETQ + -)
     45                     (COND ((NEQ // ERROR-FLAG)
     46                            (SETQ * (CAR //))
     47                            (DOLIST (VALUE //)
     48                              (TERPRI)
     49                              (FUNCALL (OR PRIN1 #'PRIN1) VALUE)))))
     50                   (RETURN)))
     51            ))))))
     52
     53(DEFVAR READING-COMMAND NIL)    ;This is bound to T while reading a command char, for the
     54                                ;io-buffer function.
    4955
    5056;; Read from STANDARD-INPUT either a control-character (or ? or Help)
     
    5460    RETRY
    5561     ;; Read a character.
    56      (SETQ CHAR (FUNCALL STANDARD-INPUT ':TYI))
     62     (LET ((READING-COMMAND T))
     63       (SETQ CHAR (FUNCALL STANDARD-INPUT ':TYI)))
    5764     ;; Now, if the char is special, echo and return it.
    5865     (COND ((OR (LDB-TEST %%KBD-CONTROL-META CHAR)
    59                 (= CHAR #\RESUME)
    60                 (= CHAR #\HELP)
    61                 (= CHAR #/?))
     66                (COMMAND-LOOKUP CHAR))
    6267            (COND ((SETQ FUNCTION (COMMAND-LOOKUP CHAR))
    6368                   (AND (EQ FUNCTION 'COM-NUMBER)
     
    7984
    8085(DEFUN IO-BUFFER-OUTPUT-FUNCTION (IGNORE CHAR)
    81   (PROG ()
    82     (SELECTQ CHAR
    83       ((#/G #/g)
    84        (FORMAT T "~C" CHAR)
    85        (*THROW 'SI:TOP-LEVEL NIL))
    86       (#\BREAK
    87        (BREAK BREAK T)
    88        (RETURN CHAR T)))
    89     (RETURN CHAR NIL)))
     86  (COND ((NOT (NUMBERP CHAR)) CHAR)             ;Blips shouldn't get here, but don't die
     87        ((AND READING-COMMAND (COMMAND-LOOKUP CHAR)) CHAR)      ;Don't intercept commands
     88        ((MEMQ CHAR TV:KBD-INTERCEPTED-CHARACTERS)      ;Standard character processing
     89         (TV:KBD-INTERCEPT-CHARACTER CHAR)
     90         (FORMAT T "~&Back to error handler.~%")
     91         (VALUES CHAR T))
     92        ((EQ CHAR #/G)                         ;Compatibility with ancient history
     93         (TV:KBD-INTERCEPT-CHARACTER #\ABORT))
     94        (T CHAR)))
    9095
    9196(DEFUN COMMAND-LOOKUP (CHAR)
     
    101106                                        (PRINLENGTH ERROR-MESSAGE-PRINLENGTH)
    102107                                        INFORM)
    103   (FORMAT T "~&>>")                             ;Flag beginning of error message
    104   (PRINT-DEBUGGING-ERROR-MESSAGE SG ETE)        ;Give type of error & microcode info
     108  (FORMAT T (IF (EQ BRIEF-FLAG 'RETURN)         ;Flag beginning of error message
     109                "~&Back to " "~&>>"))
     110  (PRINT-DEBUGGING-ERROR-MESSAGE SG ETE BRIEF-FLAG) ;Give type of error & microcode info
    105111  (COND ((SETQ INFORM (GET (CAR ETE) 'INFORM))  ;Give actual text of error message
    106112         (FUNCALL INFORM SG ETE))
     
    110116  (COND ((NOT BRIEF-FLAG)                       ;If not suppressed give backtrace
    111117         (FORMAT T "~&While in the function ")
    112          (SHORT-BACKTRACE SG NIL (OR (GET (CAR ETE) 'BACKTRACE-LENGTH)
    113                                      ERROR-MESSAGE-BACKTRACE-LENGTH)
    114                           (OR (GET (CAR ETE) 'BACKTRACE-SKIP)
    115                               0))
     118         (SHORT-BACKTRACE SG NIL ERROR-MESSAGE-BACKTRACE-LENGTH
     119                          (IF (NEQ (FIRST ETE) 'FERROR)
     120                              0
     121                              (DO ((FRAME ORIGINAL-FRAME (SG-PREVIOUS-ACTIVE SG FRAME))
     122                                   (RP (SG-REGULAR-PDL SG))
     123                                   (I 0 (1+ I)))
     124                                  ((NULL FRAME) 0)
     125                                (OR (GET (FUNCTION-NAME (RP-FUNCTION-WORD RP FRAME))
     126                                         ':ERROR-REPORTER)
     127                                    (RETURN I)))))
    116128         (TERPRI)
    117129         (AND                                   ;Check for user message hook
     
    122134;;; This function just prints the introduction telling you the type of error,
    123135;;; and where it was in the microcode in the case of a microcode error
    124 (DEFUN PRINT-DEBUGGING-ERROR-MESSAGE (SG ETE &AUX TEM FLAG)
     136(DEFUN PRINT-DEBUGGING-ERROR-MESSAGE (SG ETE &OPTIONAL BRIEF &AUX TEM FLAG)
    125137  (COND ((EQ (CAR ETE) 'BREAK)
    126138         (PRINC "BREAK"))
    127139        ((EQ (CAR ETE) 'FERROR)
    128140         (PRINC "ERROR: "))
     141        (BRIEF
     142         (PRINC "TRAP: "))
    129143        (T
    130144         (FORMAT T ">>TRAP ~A ~A"
     
    154168;; of a condition handler, this function arranges to get the
    155169;; object supplied by the handler instead of asking.
    156 (DEFUN READ-OBJECT (PROMPT &AUX FORM OBJECT)
     170(DEFUN READ-OBJECT (PROMPT &OPTIONAL (FRESH-LINE T) &AUX FORM OBJECT)
    157171  (COND ((EQ CONDITION-PROCEED-FLAG T)
    158172         (SETQ CONDITION-PROCEED-FLAG 'GOBBLED)
     
    166180         (DO ()
    167181             ((PROGN
    168                 (FORMAT T "~A~%" PROMPT)
     182                (PRINC PROMPT)
     183                (AND FRESH-LINE (TERPRI))
    169184                (SETQ FORM (SI:READ-FOR-TOP-LEVEL))
    170185                (SETQ OBJECT (CAR (SG-EVAL ERROR-SG FORM)))
    171186                (TERPRI)
    172                 (COND ((CONSTANT-FORM-P FORM) T)
    173                       (T (FORMAT T "The object is ~S, ok? " OBJECT)
    174                          (Y-OR-N-P))))
     187                (OR (CONSTANT-FORM-P FORM)
     188                    (LET ((PRINLEVEL ERROR-MESSAGE-PRINLEVEL)
     189                          (PRINLENGTH ERROR-MESSAGE-PRINLENGTH))
     190                      (FQUERY '(:LIST-CHOICES NIL) "The object is ~S, ok? " OBJECT))))
    175191              OBJECT)))))
    176192
     
    186202             (FUNCALL ERROR-HANDLER-WINDOW ':BURY)))))
    187203
    188 ;;;Continue the stack group, returning VAL if VAL-P is specified
    189 (DEFUN PROCEED-SG (SG VAL-P &OPTIONAL VAL)
     204;;;Continue the stack group, returning VAL if specified
     205(DEFUN PROCEED-SG (SG &OPTIONAL VAL)
    190206  (LEAVING-ERROR-HANDLER)
    191207  (WITHOUT-INTERRUPTS
    192208    (FREE-SECOND-LEVEL-ERROR-HANDLER-SG %CURRENT-STACK-GROUP)
    193     (IF VAL-P (FUNCALL SG VAL) (FUNCALL SG))))
    194 
    195 
    196 ;; Backtrace.
    197 ;; These initial implementations make no attempt to censor the stack,
    198 ;; but clearly something will be needed for interpreted functions.
    199 
     209    (STACK-GROUP-RESUME SG VAL)))
     210
     211
     212;; Backtrace commands.
     213
     214;; Short backtraces contain only function names.  Full ones contain arg names and values.
    200215;; Both versions take arguments the same way.  The first is the SG, and the
    201216;; second is ignored so that the functions may be used as commands.
     
    207222;; This prints out like the Maclisp BAKTRACE, and does not TERPRI at beginning
    208223;; nor end.
     224
     225(DEFUN COM-SHORT-BACKTRACE (SG IGNORE &OPTIONAL (N 777777))
     226  (SHORT-BACKTRACE SG NIL N))
     227
    209228(DEFUN SHORT-BACKTRACE (SG IGNORE &OPTIONAL (N 777777) (SKIP 0) UNINTERESTING-FLAG)
    210   (DO ((AP (SG-AP SG) (SG-PREVIOUS-ACTIVE SG AP))
    211        (RP (SG-REGULAR-PDL SG)))
    212       ((OR (NULL AP) (MINUSP (SETQ SKIP (1- SKIP))))
    213        (DO ((AP AP (FUNCALL (IF UNINTERESTING-FLAG #'SG-PREVIOUS-ACTIVE
    214                                 #'SG-PREVIOUS-INTERESTING-ACTIVE)
    215                             SG AP))
    216             (I 0 (1+ I)))
    217            ((OR (>= I N) (NULL AP)) NIL)
    218          (OR (ZEROP I) (PRINC " "))
    219          (PRIN1 (FUNCTION-NAME (RP-FUNCTION-WORD RP AP)))))))
     229  (PRINT-BACKTRACE SG N SKIP UNINTERESTING-FLAG
     230                   #'(LAMBDA (SG FRAME COUNT)
     231                       (OR (ZEROP COUNT) (PRINC " "))
     232                       (PRIN1 (FUNCTION-NAME (RP-FUNCTION-WORD (SG-REGULAR-PDL SG) FRAME))))))
    220233
    221234(DEFUN FULL-BACKTRACE (SG IGNORE &OPTIONAL (N 777777) (SKIP 0) UNINTERESTING-FLAG)
    222   (DO ((AP (SG-AP SG) (SG-PREVIOUS-ACTIVE SG AP)))
    223       ((OR (NULL AP) (MINUSP (SETQ SKIP (1- SKIP))))
    224        (DO ((AP AP (FUNCALL (IF UNINTERESTING-FLAG #'SG-PREVIOUS-ACTIVE<