perm filename DIDL[MAC,LSP] blob
sn#523325 filedate 1980-07-12 generic text, type T, neo UTF8
;;;-*-Lisp-*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DIDL: A LISP debugger for display terminals
;;;
;;; Copyright 1978 by Daniel C. Halbert (DCH@ML)
;;;
;;; This project was undertaken as an S.B thesis.
;;; The thesis is entitled "A LISP Debugger for Display Terminals"
;;; and can be found in the Barker Engineering Library
;;; Microreproduction Center.
;;; Thesis Advisor: Peter Szolovits
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(eval-when (eval)
(cond ((or (not (= ibase 8.))
(not (= base 8.)))
(format T '|}&Setting the base to eight.}&|)
(setq base 8)
(setq ibase 8))))
;;; I just want vanilla, cheap-to-run macros, hence the below.
(setq macro-expansion-use 'displace)
(eval-when (compile)
(setq defmacro-check-args nil))
;;; Macros and useful functions taken from DCH;LISP! >.
;;; (allbutlast '(1 2 3 4)) => (1 2 3)
(eval-when (compile load)
(defun allbutlast (list)
(if (null (cdr list))
nil
(cons (car list) (allbutlast (cdr list))))))
;;; (nillist 4) => (nil nil nil nil)
(eval-when (compile load)
(defun nillist (num)
(if (zerop num)
nil
(cons nil (nillist (1- num))))))
(defmacro 1st (l)
`(car ,l))
(defmacro 2nd (l)
`(cadr ,l))
(defmacro 3rd (l)
`(caddr ,l))
(defmacro 4th (l)
`(cadddr ,l))
(defmacro do-forever (&rest forms)
`(do () (nil) ,@forms))
(defmacro for (var start end &rest forms)
`(do ,var ,start (1+ ,var)
(> ,var ,end) ,@forms))
(defmacro vars (names &rest forms)
`((lambda ,names ,@forms)
,@(nillist (length names))))
(defmacro <= (a b)
`(not (> ,a ,b)))
(defmacro >= (a b)
`(not (< ,a ,b)))
;;; (defstructure <structure> <item-1> <item-2> ...)
;;;
;;; (defstructure pkt address data) defines many macros:
;;; (create-pkt) => (hunk nil nil 'pkt)
;;; [Thus (cdr <structure>) gives the structure's type.]
;;; (pkt↑address a-pkt) => (cxr 1 a-pkt)
;;; (store-pkt↑address a-pkt 45) => (rplacx 0 a-pkt 45)
;;; (pkt↑data a-pkt) => (cxr 2 a-pkt)
;;; (store-pkt↑data a-pkt 32) => (rplacx 1 a-pkt 32)
(defmacro defstructure (structure-name &rest structure-fields)
`(progn
'compile
(defmacro ,(implode (append '(c r e a t e -)
(explode structure-name)))
()
`(hunk . ,(append (nillist ,(length structure-fields))
'(',structure-name))))
. ,(do ((item-list structure-fields (cdr item-list))
(item-name-chars)
(structure-name-chars (explode structure-name))
(item-number 1 (1+ item-number))
(item-defs))
((null item-list) item-defs)
(setq item-name-chars (explode (car item-list)))
(push `(defmacro
,(implode (append structure-name-chars
'(↑)
item-name-chars))
(structure)
`(cxr ,,item-number ,structure))
item-defs)
(push `(defmacro
,(implode (append '(s t o r e -)
structure-name-chars
'(↑)
item-name-chars))
(structure value)
`(rplacx ,,item-number ,structure ,value))
item-defs))))
;;; array macros and functions
(defmacro arraystore (array &rest args)
`(store (arraycall t ,array ,@(allbutlast args)) ,@(last args)))
(defmacro arrayget (array &rest args)
`(arraycall t ,array ,@args))
(defmacro newarray (&rest args)
`(*array nil t ,@args))
(declare (*lexpr didl
stuff-line
window-set-status-line
echo-area-prompt-and-read
echo-area-prompt-and-read-with-default
unsplit-screen))
;;; "See DS" means see the data structure description page below.
(declare (special didl ; NIL if DIDL not yet initialized.
tyi ; Standard input and output.
tyo
errlist ; progn eval'd on ↑G.
$window-tty ; TTY channels for DIDL. See Open-TTYS.
$echo-area-tty
$is-screen-split? ; Is echo area set up?
$screen-width ; Effective width of display screen.
$hash-table ; SX hash table. See data structure
; description below.
$echo-area-length ; Number of lines in the echo area.
$window-length ; Number of lines in the window.
$info-area-length ; Number of lines in the info area,
; between the window and echo area.
$status-line ; Current status ("info") line.
$ht-size ; Size of $hash-table.
$breakpoint-list ; List of current breakpoints.
; For use by DIDL-Evalhook (q.v.)
$global-when-condition; Global predicate set by user
; to break on.
$global-when-condition-enable
; The when-condition is checked for.
$local-when-condition ; Local predicate, lambda-bound
; by each invocation of DIDL.
$local-when-condition-enable
$unique-number ; To get a unique breakpoint name.
$unique-symbol ; Used where such a thing is needed.
$last-screen ; A Screen. See DS.
; The last one displayed.
$last-screen-type ; See Screen in DS.
$last-pos ; Where cursor was last. See DS.
$last-top-window-line ; Line of Screen that is at top of
; Window.
;; These symbols are bound to the characters that
;; correspond to the commands.
$command-first-window $command-last-window
$command-next-or-previous-window $command-rewindow
$command-show-left-paren $command-show-right-paren
$command-look-at-frames
$command-jump-to-frame
$command-show-frame
$command-into-sx $command-out-of-sx
$command-next $command-previous
$command-examine-user-function
$command-grind-function
$command-evaluate-in-frame
$command-force-return-from-frame
$command-continue $command-show-value $command-step-deeper
$command-help
$command-quit
;; All the breakpoint commands.
$command-breakpoint
$bkpt-command-set-breakpoint $bkpt-command-clear-breakpoint
$bkpt-command-tell-about-breakpoint
$bkpt-command-list-all-breakpoints
$bkpt-command-goto-breakpoint
$bkpt-command-set-if
$bkpt-command-set-action
$bkpt-command-set-patch
;; The When-Condition commands.
$command-when
$when-command-local
$when-command-global
$when-command-tell-about-when-conditions
;; Chars to ignore when trying to read commands (space, etc.)
$command-chars-to-ignore))
;;; Structures for DIDL
;;; Pos:
;;; A pos is a two-element list: (<line> <col>). Its components are
;;; screen co-ordinates.
;;; Screen:
;;; A screen is an array of lines. (arrayget screen 0) is the
;;; last used line in the screen. Screens are grown if necessary. They
;;; may have unused components at the end which are NIL.
;;; Screens are used to hold text which the user needs to peruse, and which
;;; may not fit in one display window. Ground function-forms and stack
;;; traces are stored in screens.
;;; Screens have types: No-Screen = no Screen is being displayed.
;;; User-Function-Screen = Ground user function.
;;; Frame-Screen = Stackframe trace.
;;; Window:
;;; The tox ($window-length + 1 + $info-area-length) lines on the user's
;;; display terminal are the window. The window is used mostly for displaying
;;; parts of screens, and for displaying static information.
;;; The status line is just below the main window.
;;; The two lines below it are the info-area which is
;;; used for displaying "Stepping", etc. messages.
;;; Line:
;;; A line is an array that is $screen-width+1 long.
;;; Characters are stored as fixnums. Some elements are markers (see below).
;;; (arrayget line 0) indicates the last used char on the line.
;;; Lines do not have CRLF at the end. When a line is created it is filled
;;; with spaces (40's).
;;; Loc:
;;; loc's contain information about where things are on a screen,
;;; and are usually stored in markers (see below).
;;; atomloc's are not stored on screen, but are just returned by put-atom.
(defstructure atomloc
begin-pos ; Where is first char of atom?
end-pos ; Where is last char?
the-atom) ; The atom itself.
(defstructure leftparenloc ; Information about where an sx is, stored at
; the left paren.
begin-pos ; Where is the left paren?
end-pos ; Where is right paren?
sx) ; The sx itself which this loc is for.
(defstructure rightparenloc ; Information about where an sx is, stored at
; the right paren.
begin-pos ; Where is the left paren?
end-pos ; Where is right paren?
sx) ; The sx itself which this loc is for.
;;; marker:
;;; A marker is a cons that sometimes substitutes for
;;; just a char (a fixnum) in a line. A marker is:
;;; (<char> . <loc>), where <loc> is a leftparenloc or rightparenloc.
;;; Markers are used for finding out where sx's begin and end on screens.
(defstructure breakpoint ; Info about a breakpoint.
name ; An atom, can be set by user.
function ; The function in which this breakpoint is set.
if ; Break to user only if this eval's to not NIL.
if-enable ; T to indicate that action should be used.
action ; Eval this whenever the breakpoint is hit,
; even if it doesn't break to the user.
action-enable ; T to indicate that action should be used.
patch ; force return of (eval patch).
patch-enable) ; T to indicate that patch should be used.
;;; Breakpoints are stored on $breakpoint list in the format:
;;; ( (sx . breakpoint) ...) where sx is the form to be broken on.
;;; Set up.
(setq didl nil ; DIDL is not yet initialized.
$breakpoint-list nil ; No breakpoints yet.
$global-when-condition nil ; No when-conditions yet.
$global-when-condition-enable nil
$local-when-condition nil
$local-when-condition-enable nil
$ht-size 997. ; Should be a prime number.
$unique-number 0
$unique-symbol (gensym)
$is-screen-split? nil
$info-area-length 2
$echo-area-length 9.)
;;; Set up all the command characters.
(setq $command-first-window 74 ; <
$command-last-window 76 ; >
$command-next-or-previous-window 126 ; V
$command-rewindow 114 ; L
$command-show-left-paren 50 ; (
$command-show-right-paren 51 ; )
$command-look-at-frames 106 ; F
$command-jump-to-frame 112 ; J
$command-show-frame 56 ; .
$command-into-sx 111 ; I
$command-out-of-sx 117 ; O
$command-next 116 ; N
$command-previous 120 ; P
$command-examine-user-function 130 ; X
$command-grind-function 107 ; G
$command-evaluate-in-frame 105 ; E
$command-force-return-from-frame 122 ; R
$command-continue 103 ; C
$command-show-value 54 ; ,
$command-step-deeper 73 ; ;
$command-help 77 ; ?
$command-quit 121 ; Q
$command-breakpoint 102 ; B
$bkpt-command-set-breakpoint 123 ; S
$bkpt-command-clear-breakpoint 103 ; C
$bkpt-command-tell-about-breakpoint 124 ; T
$bkpt-command-list-all-breakpoints 114 ; L
$bkpt-command-goto-breakpoint 107 ; G
$bkpt-command-set-if 111 ; I
$bkpt-command-set-action 101 ; A
$bkpt-command-set-patch 120 ; P
$command-when 127 ; W
$when-command-local 114 ; L
$when-command-global 107 ; G
$when-command-tell-about-when-conditions 124
; T
$command-chars-to-ignore '(15 12 13 14 40) ; cr lf ↑K ↑L space
)
;;; These functions are ground specially, so indicate so on their
;;; property lists.
(putprop 'lambda 'put-miser 'didl-put-format)
(putprop 'cond 'put-miser 'didl-put-format)
(putprop 'do 'put-miser 'didl-put-format)
(putprop 'prog 'put-miser 'didl-put-format)
(putprop 'progn 'put-miser 'didl-put-format)
;;; Put the interrupt function that calls DIDL on Control-E.
(or (status ttyint 5)
(sstatus ttyint 5 (function enter-didl)))
;;; Function to enter DIDL.
;;; (didl) is the way the user calls it. didl-evalhook or
;;; didl-evalhook-step call it as
;;; (didl 'stepping form) if we're stepping,
;;; (didl '$local-when-condition form) if the local when-condition
;;; evaluated to non-NIL, or
;;; (didl '$global-when-condition form) if the global when-condition
;;; evaluated to non-NIL, or
;;; (didl 'breakpoint form breakpoint) if a breakpoint was hit.
(defun didl numbargs
(unwind-protect
(let
((evalhook nil) ; Don't enable DIDL-Evalhook now.
(value) ; Value to quick-return.
(quick-return) ; Don't read commands, just return.
; For use in cases like (didl <atom>).
($local-when-condition $local-when-condition)
; Lambda-bind $local-when-condition to itself
; so that previous $local-when-conditions will
; be retained, but a new one may be set.
($local-when-condition-enable $local-when-condition-enable)
(frame-array) ; Backtrace created by Framearray.
; NIL if no frames.
(frame-screen) ; Display of frame-array.
(current-frame) ; Frame being looked at now, as returned by
; EVALFRAME.
(current-frame-number) ; Number of current frame. Index into
; current-frame. 1=top frame.
(force-redisplay) ; Force the display to be redisplayed.
(current-screen) ; Screen that is currently being displayed.
(current-screen-type 'no-screen) ; No screen yet.
(current-pos '(1 1)) ; Upper left hand corner.
(current-loc) ; Loc being used.
(current-function) ; Name of function being displayed.
(current-sx) ; Bound to SX currently being pointed to
(broke-at-frame) ; If we broke, frame broken on.
; NIL if we didn't break.
(broke-at-loc) ; Similarly...
(broke-at-function)
(broke-at-sx)
(broke-at-breakpoint)
(breakpoint) ; The current breakpoint itself
(current-screen-length) ; Length of current-screen.
(command-arg) ; A number.
(command-char) ; As typed by user.
(how-many-frames) ; How many in frame-array.
)
(or didl ; Is DIDL initialized yet?
(progn ; No.
(setq terpri t) ; Turn off auto-terpri.
(open-ttys) ; Set up the new TTY channels.
;; Make Control-A undo the echo area.
(or (status ttyint 1)
(sstatus ttyint 1 (function unsplit-screen)))
;; Screen width must be one less so we avoid automatic wrapping.
(setq $screen-width (1- (cdr (cond ((sfap tyo)
(sfa-call tyo 'ttysize nil))
(t (status ttysize))))))
(setq $window-length (- (car (cond ((sfap tyo)
(sfa-call tyo 'ttysize nil))
(T (status ttysize))))
$echo-area-length
1 ; 1 for status line.
$info-area-length))
(setq $breakpoint-list nil)
(let ((didl-errlist ; Make Control-G enable DIDL-Evalhook.
'(progn
(setq evalhook (function didl-evalhook))
(unsplit-screen)))) ; Also restore full screen.
(or (memq didl-errlist errlist)
(push didl-errlist errlist)))
(setq $status-line (create-line))
(ht-setup $ht-size) ; Set up $hash-table.
(setq didl t))) ; Now DIDL is initialized.
;;; Always do the following upon entering DIDL.
(or $is-screen-split? ; Resplit screen if necessary.
(progn
(split-screen)
(echo-area-clear)
(setq $last-screen nil
$last-screen-type 'no-screen
$last-top-window-line nil
$last-pos '(1 1))))
(setq force-redisplay t) ; The first time, must redisplay.
(setq current-frame (evalframe nil)) ; Get top stack frame.
(setq frame-array (framearray current-frame)) ; Get backtrace.
;; Grind all the user functions referred to in frame-array.
(and frame-array
(progn
(put-frame-array-user-functions frame-array)
(setq current-frame
(setq broke-at-frame (arrayget frame-array 1)))))
(setq current-frame-number 1) ; Start at top frame.
(window-set-status-line 'DIDL)
;;; See if we were entered by the user, or by a breakpoint or stepping.
(and (> numbargs 0) ; Not entered by user.
(progn
(setq broke-at-sx (setq current-sx (arg 2)))
;; Try to display where we broke.
(let ((ht-entry (ht-find broke-at-sx)))
(setq broke-at-function ; These could be NIL.
(setq current-function (2nd ht-entry)))
(setq broke-at-loc (setq current-loc (3rd ht-entry)))
(cond
((null broke-at-loc) ; Didn't break in a user func.
(setq current-screen nil)
(setq current-screen-type 'no-screen)
(setq force-redisplay t))
(t ; Did break in a user function.
(setq force-redisplay nil)
(setq current-screen (get broke-at-function 'didl-screen))
(setq current-screen-type 'user-function-screen)
(setq current-pos (loc↑begin-pos broke-at-loc)))))
(cond
((eq (arg 1) 'breakpoint) ; Broke at a breakpoint.
(setq breakpoint (setq broke-at-breakpoint (arg 3)))
(info-area-clear)
(info-area-princ '|Hit breakpoint |) ; Say where.
(info-area-princ (breakpoint↑name breakpoint))
(and (breakpoint↑patch-enable breakpoint)
(info-area-princ '|, but has an enabled patch!|)))
; Warn user about patches.
((or
(eq (arg 1) 'stepping)
(eq (arg 1) '$global-when-condition)
(eq (arg 1) '$local-when-condition))
(cond
;; If stepping on atom or 'foo, just show what we're eval'ing
;; and wait for user to indicate we can continue.
((or (atom broke-at-sx)
(eq (car broke-at-sx) (function quote)))
(info-area-clear)
(info-area-prin1 broke-at-sx)
(info-area-princ '| => |)
(let ((prinlevel 3) (prinlength 4))
(setq value (evalhook broke-at-sx nil))
(info-area-prin1t value))
(info-area-princ '|--Continue--|)
(tyi)
(setq quick-return t))
(t
(info-area-clear)
(cond
((eq (arg 1) 'stepping)
(info-area-princt '|Stepping |))
((eq (arg 1) '$global-when-condition)
(info-area-princ '|Global when-condition |)
(info-area-print $global-when-condition)
(info-area-princt '| satisfied |))
((eq (arg 1) '$local-when-condition)
(info-area-princ '|Local when-condition |)
(info-area-print $local-when-condition)
(info-area-princt '|satisfied|)))))))))
;;; Main command loop
(do-forever
(and quick-return ; Used when eval'ing atom or 'foo.
(return value))
;; Do redisplay of screen if necessary.
(didl-redisplay current-screen current-screen-type current-pos
current-sx current-function force-redisplay
current-frame-number how-many-frames)
(or $is-screen-split?
(split-screen)) ; In case someone has unsplit it e.g. a higher
; invocation of DIDL.
(setq force-redisplay nil)
;; Now that redisplay is done, update display info.
(setq $last-screen current-screen)
(setq $last-screen-type current-screen-type)
(setq $last-pos current-pos)
(and current-screen
(setq current-screen-length (arrayget current-screen 0)))
(and (eq current-screen-type 'frame-screen)
(progn
(setq current-frame-number (1st current-pos))
(setq current-frame (arrayget frame-array current-frame-number))
))
;;Read an arg and command.
(setq command-arg (read-command-arg))
(setq command-char (read-command-char))
;;This catch catches on Abort-Command, so various commands
;; can be aborted.
(and
(eq
'abort-command
(catch
(cond
;;; Display manipulation commands.
;; Display first windowful of current-screen.
((= $command-first-window command-char)
(if (eq current-screen-type 'no-screen)
(didl-error '|No window to scroll.|)
(setq current-pos '(1 1))))
;; Display last screenful.
((= $command-last-window command-char)
(if (eq current-screen-type 'no-screen)
(didl-error '|No window to scroll.|)
(setq current-pos (list current-screen-length 1))))
;; Go forward or backward one or several windows, but
;; don't go too far.
((= $command-next-or-previous-window command-char)
(if (eq current-screen-type 'no-screen)
(didl-error '|No window to scroll.|)
(setq current-pos
(list
(force-into-range 1 current-screen-length
(+ $last-top-window-line
(if (> command-arg 0) -1 1)
(// $window-length 2)
(* $window-length command-arg)))
1))))
;; Force the display to be redone.
((= $command-rewindow command-char)
(setq force-redisplay t))
;; Point to the left paren of the current sx.
((= $command-show-left-paren command-char)
(if (eq current-screen-type 'user-function-screen)
(setq current-pos (loc↑begin-pos current-loc))
(didl-error '|Not looking at a user form.|)))
;; Point to the right paren of the current sx.
((= $command-show-right-paren command-char)
(if (eq current-screen-type 'user-function-screen)
(setq current-pos (loc↑end-pos current-loc))
(didl-error '|Not looking at a user form.|)))
;;; Frame selection commands.
;; Display the frame backtrace.
((= $command-look-at-frames command-char)
(cond
(frame-array
(or frame-screen
(setq frame-screen (make-frame-screen frame-array)))
(setq current-screen frame-screen)
(setq current-screen-type 'frame-screen)
(setq current-pos (list current-frame-number 1))
(setq how-many-frames (arrayget frame-array 0)))
(t (didl-error '|No frames to display.|))))
;; Jump directly to the frame whose number is command-arg.
((= $command-jump-to-frame command-char)
(if (eq current-screen-type 'frame-screen)
(setq current-pos
(list (force-into-range 1 how-many-frames command-arg)
1))
(didl-error '|Not looking at frames.|)))
;; Show the user function and sx associated with the current
;; frame if possible, else just show the sx.
;; If we broke, frame #1 is (DIDL-EVALHOOK[-STEP] ...), and
;; is not really the frame of what is about to be EVAL'd.
;; But we'd like to make it appear this way, so we check for
;; specially below. (This subsumes the old "/" command.)
((= $command-show-frame command-char)
(cond
((and (= command-arg 1) (> numbargs 0))
; If we broke, first frame is not really a frame,
; but is the DIDL-Evalhook or DIDL-Evalhook-Step
; frame. But make it look like a real frame.
(setq current-sx broke-at-sx)
(let ((ht-entry (ht-find current-sx)))
(setq current-function (2nd ht-entry))
(setq current-loc (3rd ht-entry)))
(cond
((null current-loc)
(setq current-screen nil)
(setq current-screen-type 'no-screen)
(setq force-redisplay t))
(t
(setq current-screen (get current-function 'didl-screen))
(setq current-screen-type 'user-function-screen)
(setq current-pos (loc↑begin-pos current-loc)))))
(frame-array
(setq current-sx (3rd current-frame))
(let ((ht-entry (ht-find current-sx)))
(setq current-function (2nd ht-entry))
(setq current-loc (3rd ht-entry)))
(cond
((null current-loc)
(setq current-screen nil)
(setq current-screen-type 'no-screen)
(setq force-redisplay t))
(t
(setq current-screen (get current-function 'didl-screen))
(setq current-screen-type 'user-function-screen)
(setq current-pos (loc↑begin-pos current-loc)))))
(t
(didl-error '|No frame to show.|))))
;;; Moving-around commands.
;; Move forward one or several left parens, ignoring the
;; structure of the code.
((= $command-into-sx command-char)
(cond
((eq current-screen-type 'user-function-screen)
(setq current-loc (screen-go-into-sx current-screen
current-loc
command-arg))
(setq current-pos (loc↑begin-pos current-loc))
(setq current-sx (leftparenloc↑sx current-loc)))
(t
(didl-error '|Not looking at a user function.|))))
;; Move backward one or several left parens.
((= $command-out-of-sx command-char)
(cond
((eq current-screen-type 'user-function-screen)
(setq current-loc (screen-go-out-of-sx current-screen
current-loc
command-arg))
(setq current-pos (loc↑begin-pos current-loc))
(setq current-sx (leftparenloc↑sx current-loc)))
(t
(didl-error '|Not looking at a user function.|))))
;; Move forward one or several left parens on the same
;; structural level as the current sx, if in a
;; user-function-screen. If looking at frames, go deeper
;; one or several frames.
((= $command-next command-char)
(cond
((eq current-screen-type 'user-function-screen)
(setq current-loc (screen-next-sx current-screen
current-loc
command-arg))
(setq current-pos (loc↑begin-pos current-loc))
(setq current-sx (leftparenloc↑sx current-loc)))
((eq current-screen-type 'frame-screen)
(setq current-pos
(list (force-into-range 1 how-many-frames
(+ current-frame-number
command-arg))
1)))
(t
(didl-error '|Not looking at frames or a user function.|))))
;; Move backward one or several left parens on this level,
;; if looking at a user-function-screen. If looking at frames,
;; go up one or more frames.
((= $command-previous command-char)
(cond
((eq current-screen-type 'user-function-screen)
(setq current-loc (screen-previous-sx current-screen
current-loc
command-arg))
(setq current-pos (loc↑begin-pos current-loc))
(setq current-sx (leftparenloc↑sx current-loc)))
((eq current-screen-type 'frame-screen)
(setq current-pos
(list (force-into-range 1 how-many-frames
(- current-frame-number
command-arg))
1)))
(t
(didl-error '|Not looking at frames or a user function.|))))
;; Select and display a user function.
((= $command-examine-user-function command-char)
(let ((func (echo-area-prompt-and-read '|Function: |)))
(cond
((user-function func)
(put-defun-if-necessary func)
(setq current-screen (get func 'didl-screen))
(setq current-screen-type 'user-function-screen)
(setq current-loc (get func 'didl-toploc))
(setq current-function func)
(setq current-sx (leftparenloc↑sx current-loc))
(setq current-pos (loc↑begin-pos current-loc)))
(t
(didl-error '|Not a user function.|)))))
;; Force a user function to be ground, though not displayed.
((= $command-grind-function command-char)
(let ((func (echo-area-prompt-and-read '|Function: |)))
(if (user-function func)
(put-defun func)
(didl-error '|Not a user function.|))))
;;; Manipulating frame values.
;; Do an EVAL in the environment of the current frame,
;; if there is one, or just do an EVAL if there isn't.
((= $command-evaluate-in-frame command-char)
(let ((what-to-eval (echo-area-prompt-and-read '|Evaluate: |)))
(if frame-array
(echo-area-print
(car (errset (evalhook what-to-eval
(4th current-frame)
(function didl-evalhook)))))
(echo-area-print
(car (errset (evalhook what-to-eval
(function didl-evalhook))))))
(echo-area-terpri)))
;; Force a return from the current frame, returning a
;; given value.
((= $command-force-return-from-frame command-char)
(let ((what-to-return (echo-area-prompt-and-read '|Return: |)))
(cond
(frame-array
(setq what-to-return (errset (eval what-to-return
(4th current-frame))))
(if what-to-return
(freturn (2nd current-frame) (car what-to-return))
(didl-error '|Error while eval'ing value.|)))
(t
(didl-error '|Nothing to return to.|)))))
;;; Stepping-type commands.
;; Continue from where we broke.
((= $command-continue command-char)
(cond
(broke-at-frame ; Did we really break?
(return (evalhook (if (and broke-at-breakpoint
(breakpoint↑patch-enable
broke-at-breakpoint))
(breakpoint↑patch broke-at-breakpoint)
broke-at-sx) ; Do breakpoint patch
; if it has one.
;;;doesn't work (4th broke-at-frame)
(function didl-evalhook))))
(t
(didl-error '|Nothing to continue.|))))
;; Continue from where we broke, but display the eventual
;; value of the form we broke on.
((= $command-show-value command-char)
(cond
(broke-at-frame
(vars (value)
(setq value
(evalhook (if (and broke-at-breakpoint
(breakpoint↑patch-enable
broke-at-breakpoint))
(breakpoint↑patch broke-at-breakpoint)
broke-at-sx)
;;; doesn't work (4th broke-at-frame)
(function didl-evalhook)))
;; Must redisplay, since much may have happened
;; in the meantime.
(didl-redisplay current-screen current-screen-type
current-pos current-sx current-function
force-redisplay current-frame-number
how-many-frames)
(setq force-redisplay nil)
(setq $last-screen current-screen)
(setq $last-screen-type current-screen-type)
(setq $last-pos current-pos)
(and current-screen
(setq current-screen-length
(arrayget current-screen 0)))
(info-area-clear)
(info-area-princ '|Returned: |)
(info-area-prin1t value)
(info-area-princ '|--Continue--|)
(window-set-cursor-with-pos $last-top-window-line
current-pos)
(tyi)
(return value)))
(t
(didl-error '|Nothing to continue.|))))
;; Continue from where we broke, but enable DIDL-Evalhook-Step
;; so we'll break on deeper EVAL's. Eventually, show the value
;; of the form we broke on.
((= $command-step-deeper command-char)
(cond
(broke-at-frame
(vars (value)
(setq value
(evalhook (if (and broke-at-breakpoint
(breakpoint↑patch-enable
broke-at-breakpoint))
(breakpoint↑patch broke-at-breakpoint)
broke-at-sx)
;;; doesn't work (4th broke-at-frame)
(function didl-evalhook-step)))
(didl-redisplay current-screen current-screen-type
current-pos current-sx
current-function force-redisplay
current-frame-number how-many-frames)
(setq force-redisplay nil)
(setq $last-screen current-screen)
(setq $last-screen-type current-screen-type)
(setq $last-pos current-pos)
(and current-screen
(setq current-screen-length
(arrayget current-screen 0)))
(info-area-clear)
(info-area-princ '|Returned: |)
(info-area-prin1t value)
(info-area-princ '|--Continue--|)
(info-area-terpri)
(window-set-cursor-with-pos $last-top-window-line
current-pos)
(tyi)
(return value)))
(t
(didl-error '|Nothing to continue.|))))
;;; Breakpoint commands.
;; Breakpoint commands are all two letters, so enter here
;; and read the next letter.
((= $command-breakpoint command-char)
(setq command-char (read-command-char))
(cond
;; Set a breakpoint, and give it a default or a user-assigned
;; name.
((= $bkpt-command-set-breakpoint command-char)
(cond
((not (atom current-sx))
(setq breakpoint
(breakpoint-enter current-sx current-function))
(store-breakpoint↑name
breakpoint
(echo-area-prompt-and-read-with-default
(breakpoint↑name breakpoint)
'|Breakpoint name [type space for default name: |
(breakpoint↑name breakpoint)
`|]: |))
(info-area-clear)
(info-area-princ '|Breakpoint set, named |)
(info-area-prin1t (breakpoint↑name breakpoint)))
(t
(didl-error '|Can't set a breakpoint now.|))))
;; Clear a breakpoint.
((= $bkpt-command-clear-breakpoint command-char)
(cond
(breakpoint
(let ((breakpoint-name
(echo-area-prompt-and-read-with-default
(breakpoint↑name breakpoint)
'|Breakpoint to clear [type space for default: |
(breakpoint↑name breakpoint)
'|]: |)))
(cond
((breakpoint-remove breakpoint-name)
(and (eq breakpoint-name (breakpoint↑name breakpoint))
(setq breakpoint nil))
(info-area-clear)
(info-area-princ '|Breakpoint |)
(info-area-prin1 breakpoint-name)
(info-area-princt '| cleared.|))
(t
(didl-error '|No breakpoint has that name.|)))))
(t
(didl-error '|No breakpoint to clear.|))))
;; Set an if on the current breakpoint, which must
;; be non-NIL for the breakpoint to force a break. If
;; command-arg is negative, disable the if,
;; which will force a break always. Prompting for an if
;; defaults to the old if.
((= $bkpt-command-set-if command-char)
(cond
((not (atom current-sx))
(setq breakpoint
(breakpoint-enter current-sx current-function))
(cond
((< command-arg 0)
(store-breakpoint↑if-enable breakpoint nil)
(info-area-clear)
(info-area-princ '|Disabled if on breakpoint |)
(info-area-princt (breakpoint↑name breakpoint)))
(t
(store-breakpoint↑if
breakpoint
(echo-area-prompt-and-read-with-default
(breakpoint↑if breakpoint)
(breakpoint↑name breakpoint)
'| If [type space for old if]: |))
(store-breakpoint↑if-enable breakpoint t))))
(t
(didl-error '|Can't set a breakpoint now.|))))
;; Set an action on the current breakpoint, which will always
;; be EVAL'd, even if the breakpoint does not break. If
;; command-arg is negative, disable the action.
;; The prompt for an action defaults to the old action.
((= $bkpt-command-set-action command-char)
(cond
((not (atom current-sx))
(setq breakpoint
(breakpoint-enter current-sx current-function))
(cond
((< command-arg 0)
(store-breakpoint↑action-enable breakpoint nil)
(info-area-clear)
(info-area-princ '|Disabled action on breakpoint |)
(info-area-princt (breakpoint↑name breakpoint)))
(t
(store-breakpoint↑action
breakpoint
(echo-area-prompt-and-read-with-default
(breakpoint↑action breakpoint)
(breakpoint↑name breakpoint)
'| Action [type space for old action]: |))
(store-breakpoint↑action-enable breakpoint t))))
(t
(didl-error '|Can't set a breakpoint now.|))))
;; Set a patch on the current breakpoint, which will be
;; EVAL'd INSTEAD of the sx the breakpoint is set on, when
;; the breakpoint is hit. If command-arg is negative, disable
;; the patch. The prompt for the patch defaults to the
;; old patch.
((= $bkpt-command-set-patch command-char)
(cond
((not (atom current-sx))
(setq breakpoint
(breakpoint-enter current-sx current-function))
(cond
((< command-arg 0)
(store-breakpoint↑patch-enable breakpoint nil)
(info-area-clear)
(info-area-princ '|Disabled patch on breakpoint |)
(info-area-princt (breakpoint↑name breakpoint)))
(t
(store-breakpoint↑patch
breakpoint
(echo-area-prompt-and-read-with-default
(breakpoint↑patch breakpoint)
(breakpoint↑name breakpoint)
'| Patch [type space for old patch]: |))
(store-breakpoint↑patch-enable breakpoint t))))
(t
(didl-error '|Can't set a breakpoint now.|))))
;; List all the breakpoints on the $breakpoint-list.
((= $bkpt-command-list-all-breakpoints command-char)
(window-clear-line 1)
(window-princ '|Breakpoints:|)
(window-terpri)
(mapc (function
(lambda (pair)
(window-prin1 (breakpoint↑name (cdr pair)))
(window-princ '| in |)
(window-prin1 (breakpoint↑function (cdr pair)))
(window-terpri)))
$breakpoint-list)
(or $breakpoint-list
(window-princ '|No breakpoints have been set|)
(window-terpri)))
;; Give the name, condition, action, and patch of the
;; current breakpoint.
((= $bkpt-command-tell-about-breakpoint command-char)
(cond
(breakpoint
(window-clear-line 1)
(window-princ (breakpoint↑name breakpoint))
(window-princ '|: in |)
(window-prin1 (breakpoint↑function breakpoint))
(window-terpri)
(or (breakpoint↑if-enable breakpoint)
(window-princ '|[Disabled] |))
(window-princ '|If: |)
(window-prin1 (breakpoint↑if breakpoint))
(window-terpri)
(or (breakpoint↑action-enable breakpoint)
(window-princ '|[Disabled] |))
(window-princ '|Action: |)
(window-prin1 (breakpoint↑action breakpoint))
(window-terpri)
(or (breakpoint↑patch-enable breakpoint)
(window-princ '|[Disabled] |))
(window-princ '|Patch: |)
(window-prin1 (breakpoint↑patch breakpoint))
(window-terpri))
(t
(didl-error '|No current breakpoint.|))))
;; Ask for a breakpoint name from the user, and display
;; the user function in which the breakpoint is set,
;; pointing to where the breakpoint is set.
((= $bkpt-command-goto-breakpoint command-char)
(do ((name (echo-area-prompt-and-read '|Breakpoint name: |))
(ht-entry)
(bkpts $breakpoint-list (cdr bkpts)))
((null bkpts)
(didl-error '|No such breakpoint.|))
(and (eq name (breakpoint↑name (cdar bkpts)))
(progn
(setq current-sx (caar bkpts))
(setq ht-entry (ht-find current-sx))
(setq current-function (2nd ht-entry))
(setq current-loc (3rd ht-entry))
(setq current-pos (loc↑begin-pos current-loc))
(setq current-screen
(get current-function 'didl-screen))
(setq breakpoint (cdar bkpts))
(setq current-screen-type 'user-function-screen)
(return nil)))))
;; The user typed an unknown second letter for a breakpoint
;; command.
(t
(didl-error '|Not a breakpoint command.|))))
;;; When-condition commands.
;; When-condition commands are all two letters, so enter here
;; and read the next letter.
((= $command-when command-char)
(setq command-char (read-command-char))
(cond
;; Operate on the global when-condition.
((= $when-command-global command-char)
(cond
((< command-arg 0)
(setq $global-when-condition-enable nil)
(info-area-clear)
(info-area-princt '|Disabled global when-condition |))
(t
(setq $global-when-condition
(echo-area-prompt-and-read-with-default
$global-when-condition
'|Global when-condition [type space for old one]: |))
(setq $global-when-condition-enable t))))
;; Operate on the local when-condition.
((= $when-command-local command-char)
(cond
((< command-arg 0)
(setq $local-when-condition-enable nil)
(info-area-clear)
(info-area-princt '|Disabled local when-condition |))
(t
(setq $local-when-condition
(echo-area-prompt-and-read-with-default
$local-when-condition
'|Local when-condition [type space for old one]: |))
(setq $local-when-condition-enable t))))
;; Tell about the global and local when-conditions.
((= $when-command-tell-about-when-conditions command-char)
(window-clear-line 1)
(or $local-when-condition-enable
(window-princ '|[Disabled] |))
(window-princ '|Local when-condition: |)
(window-prin1 $local-when-condition)
(window-terpri)
(or $global-when-condition-enable
(window-princ '|[Disabled] |))
(window-princ '|Global when-condition: |)
(window-prin1 $global-when-condition)
(window-terpri))
(t
(didl-error '|Not a when-condition command.|))))
;;; Miscellaneous commands.
;; The Help command displays libdoc;didl help.
((= $command-help command-char)
(let ((help-file (open '((dsk libdoc) didl help) 'in)))
(window-clear)
(do ((char (tyi help-file -1) (tyi help-file -1)))
((= char -1)
(window-terpri)
(window-princ '|End of help. --Redisplay--|)
(close help-file))
(or (member char '(14 3))
(window-tyo char))))
(tyi)
(setq force-redisplay t))
;; Quit from DIDL, enabling DIDL-Evalhook.
((= $command-quit command-char)
(eval '(setq evalhook (function didl-evalhook)) nil)
(unsplit-screen)
(return 'QUIT-FROM-DIDL))
;; Ignore certain characters.
((memq command-char $command-chars-to-ignore))
;; All other characters are errors.
(t
(didl-error '||)
(tyo 7)))
abort-command))
(progn
(echo-area-clear)
(didl-error '|Command aborted.|)))
;End of catch for aborting commands
))
(unsplit-screen)))
;;; DIDL-Evalhook is the evalhook function, which looks at every call
;;; to eval when it is enabled. It calls didl if we're stepping or a
;;; breakpoint has been hit. The call to didl returns with the value
;;; of the form.
(defun didl-evalhook (form)
(let ((breakpoint (assq form $breakpoint-list)))
(cond
((and $local-when-condition-enable
(car (errset (eval $local-when-condition) nil)))
(didl '$local-when-condition form))
((and $global-when-condition-enable
(car (errset (eval $global-when-condition) nil)))
(didl '$global-when-condition form))
(breakpoint ; We hit a breakpoint.
(setq breakpoint (cdr breakpoint))
(and (breakpoint↑action-enable breakpoint)
(eval (breakpoint↑action breakpoint)))
(let ((should-break (if (breakpoint↑if-enable breakpoint)
(eval (breakpoint↑if breakpoint))
t)))
(cond ; Eval patch if there is one.
((breakpoint↑patch-enable breakpoint)
(and should-break
(didl 'breakpoint form breakpoint))
(eval (breakpoint↑patch breakpoint)))
(t
(if should-break
(didl 'breakpoint form breakpoint)
(evalhook form (function didl-evalhook)))))))
;; No breakpoint, so just continue.
(t
(evalhook form (function didl-evalhook))))))
;;; Didl-Evalhook-Step is for single-stepping, and always calls
;;; didl before evaluating a form. But it does check for breakpoints
;;; first.
(defun didl-evalhook-step (form)
(let ((breakpoint (assq form $breakpoint-list)))
(cond
((and $local-when-condition-enable
(car (errset (eval $local-when-condition) nil)))
(didl '$local-when-condition form))
((and $global-when-condition-enable
(car (errset (eval $global-when-condition) nil)))
(didl '$global-when-condition form))
(breakpoint
(setq breakpoint (cdr breakpoint))
(eval (breakpoint↑action breakpoint))
(let ((should-break (if (breakpoint↑if-enable breakpoint)
(eval (breakpoint↑if breakpoint))
t)))
(cond
((breakpoint↑patch-enable breakpoint)
(and should-break
(didl 'breakpoint form breakpoint))
(eval (breakpoint↑patch breakpoint)))
(t
(if should-break
(didl 'breakpoint form breakpoint)
(evalhook form (function didl-evalhook)))))))
;; Break to DIDL, since we're stepping.
(t
(didl 'stepping form)))))
;;; DStep is to be called by the user. It is for stepping a form from
;;; the beginning, without entering DIDL first.
(defun dstep (form)
(evalhook form (function didl-evalhook-step)))
;;; Enter-DIDL is the interrupt function put on Control-E. It effectively
;;; does "(didl)".
(defun enter-didl (tty char)
(nointerrupt nil)
(tyi tty)
(print (didl))
(terpri))
;;; DIDL-Redisplay compares $last-screen, etc. with its arguments, to
;;; determine if a redisplay should be done.
(defun didl-redisplay (current-screen current-screen-type current-pos
current-sx current-function force-redisplay
current-frame-number how-many-frames)
(vars (old-top-window-line)
(cond
((not (eq current-screen-type 'no-screen))
(setq old-top-window-line $last-top-window-line)
(cond
((or force-redisplay (not (eq current-screen $last-screen)))
(setq $last-top-window-line
(window-redisplay current-screen (1st current-pos))))
(t (setq $last-top-window-line
(window-redisplay-if-necessary current-screen
$last-top-window-line
(1st current-pos)))))
(and (or force-redisplay
(not (eq current-screen $last-screen))
(not (equal old-top-window-line
$last-top-window-line)))
;; Set up status line and display what needs to
;; be displayed.
(cond
((eq current-screen-type 'user-function-screen)
(window-set-status-line
current-function
'| (Frame #| current-frame-number
'|) [Top line: | $last-top-window-line
(cond
((= $last-top-window-line 1)
(if
(<= (arrayget current-screen 0)
(+ $last-top-window-line $window-length -1))
'| ] --All--|
'| ] --Top--|))
((> (arrayget current-screen 0)
(+ $last-top-window-line $window-length -1))
'| ] --Middle--|)
(t
'| ] --Bottom--|)))
(window-display-status-line))
((eq current-screen-type 'frame-screen)
(window-set-status-line '|Frame display [|
how-many-frames '| frames]|)
(window-display-status-line))))
(window-set-cursor-with-pos $last-top-window-line current-pos))
(force-redisplay
(cond
((and (atom current-sx) (not (null current-sx)))
(window-clear-and-print current-sx)
(window-set-status-line '|Atom|)
(window-display-status-line))
(current-sx
(window-clear-and-print current-sx)
(window-set-status-line '|Non-user-form|)
(window-display-status-line))
(t
(window-clear)
(window-set-status-line 'DIDL)
(window-display-status-line)))))))
;;; DIDL-Error reports the error in the echo area.
(defun didl-error (error-message)
(info-area-clear)
(tyo 7)
(info-area-princ error-message))
;;; Functions for adding and removing breakpoints from $breakpoint-list.
;;; Breakpoint-Enter looks for a breakpoint for the given sx on
;;; $breakpoint-list. It returns that breakpoint if found, otherwise
;;; it creates a fresh new breakpoint.
(defun breakpoint-enter (sx function)
(cond
((cdr (assq sx $breakpoint-list)))
(t
(let ((breakpoint (create-breakpoint)))
(push (cons sx breakpoint) $breakpoint-list)
(store-breakpoint↑name breakpoint (breakpoint-new-name))
(store-breakpoint↑function breakpoint function)
(store-breakpoint↑if-enable breakpoint nil)
(store-breakpoint↑if breakpoint t)
(store-breakpoint↑action-enable breakpoint nil)
(store-breakpoint↑action breakpoint nil)
(store-breakpoint↑patch-enable breakpoint nil)
(store-breakpoint↑patch breakpoint nil)
breakpoint))))
;;; Breakpoint-Remove splices the breakpoint entry of the breakpoint with the
;;; name breakpoint-name out of $breakpoint-list.
;;; If there is no breakpoint by that name, Breakpoint-Remove returns nil;
;;; if it succeeds, it returns t.
(defun breakpoint-remove (breakpoint-name)
(do ((rest $breakpoint-list (cdr rest)))
((null rest) nil)
(cond
((eq breakpoint-name (breakpoint↑name (cdr (1st rest))))
(setq $breakpoint-list (delq (1st rest) $breakpoint-list))
(return t)))))
;;; Breakpoint-New-Name generates a new interned name for a breakpoint.
(defun breakpoint-new-name ()
(let ((base 10.) (*nopoint t))
(implode (append '(B P T) (explode (setq $unique-number
(1+ $unique-number)))))))
;;; Functions for moving around in screens, using locs.
;;; Screen-Go-Into-SX tries to go into the next non-atomic sx.
;;; It scans forward from the current-loc, looking for a marker
;;; containing a leftparenloc. If it finds one, it stops at the next
;;; loc after that. If it doesn't find one, it doesn't move.
;;; It returns the loc it stops at.
;;; count indicates how many times to do this. If count < 0, it will call
;;; screen-go-out-of-sx instead.
(defun screen-go-into-sx (screen current-loc count)
(if (< count 0)
(screen-go-out-of-sx screen current-loc (- count))
(catch
(do ((i 1 (1+ i)))
((> i count) current-loc)
(do ((next-loc current-loc))
(nil)
(setq next-loc
(screen-next-loc screen next-loc))
(if (null next-loc)
(throw current-loc)
(and (eq (cdr next-loc) 'leftparenloc)
(return (setq current-loc next-loc)))))))))
;;; Screen-Go-Out-Of-SX searches backwards for a leftparenloc.
(defun screen-go-out-of-sx (screen current-loc count)
(if (< count 0)
(screen-go-into-sx screen current-loc (- count))
(catch
(do ((i 1 (1+ i)))
((> i count) current-loc)
(do ((previous-loc current-loc))
(nil)
(setq previous-loc
(screen-previous-loc screen previous-loc))
(if (null previous-loc)
(throw current-loc)
(and (eq (cdr previous-loc) 'leftparenloc)
(return (setq current-loc previous-loc)))))))))
;;; Screen-Next-SX searches forward from the end of the current-loc
;;; (after its corresponding rightparenloc), looking for a leftparenloc.
;;; If it doesn't find one, it stays where it was.
(defun screen-next-sx (screen current-loc count)
(if (< count 0)
(screen-previous-sx screen current-loc (- count))
(catch
(do ((i 1 (1+ i)))
((> i count) current-loc)
(do ((next-loc current-loc))
(nil)
(setq next-loc
(screen-next-loc screen
(cdr (screen-char-or-marker
screen
(loc↑end-pos next-loc)))))
(if (or (null next-loc) (eq (cdr next-loc) 'rightparenloc))
(throw current-loc)
(and (eq (cdr next-loc) 'leftparenloc)
(return (setq current-loc next-loc)))))))))
;;; Screen-Previous-SX searches backwards, looking for a leftparenloc,
;;; skipping left parens at levels deeper than the current-loc.
(defun screen-previous-sx (screen current-loc count)
(if (< count 0)
(screen-next-sx screen current-loc (- count))
(catch
(do ((i 1 (1+ i)))
((> i count) current-loc)
(do ((previous-loc current-loc))
(nil)
(setq previous-loc
(screen-previous-loc screen previous-loc))
(if (or (null previous-loc) (eq (cdr previous-loc)
'leftparenloc))
(throw current-loc)
(and (eq (cdr previous-loc) 'rightparenloc)
(return
(setq current-loc
(cdr (screen-char-or-marker
screen
(rightparenloc↑begin-pos
previous-loc))))))))))))
;;; Screen-Next-Loc returns the next loc it finds after current-loc.
;;; It returns NIL if there is no next loc.
(defun screen-next-loc (screen current-loc)
(do ((pos (screen-next-pos screen
(if (eq (cdr current-loc) 'rightparenloc)
(rightparenloc↑end-pos current-loc)
(leftparenloc↑begin-pos current-loc)))
(screen-next-pos screen pos))
(char))
((null pos) nil)
(setq char (screen-char-or-marker screen pos))
(or (atom char)
(return (cdr char)))))
;;; Screen-Previous-Loc goes the other way.
(defun screen-previous-loc (screen current-loc)
(do ((pos
(screen-previous-pos screen
(if (eq (cdr current-loc) 'rightparenloc)
(rightparenloc↑end-pos current-loc)
(leftparenloc↑begin-pos current-loc)))
(screen-previous-pos screen pos))
(char))
((null pos) nil)
(setq char (screen-char-or-marker screen pos))
(or (atom char)
(return (cdr char)))))
;;; Screen-Next-Pos and Screen-Previous-Pos return the next meaningful
;;; pos after/before current-pos. They return NIL if there is none.
(defun screen-next-pos (screen pos)
(let ((last-line-num (arrayget screen 0))
(last-char-num (arrayget (arrayget screen (1st pos)) 0)))
(if (< (2nd pos) last-char-num)
(list (1st pos) (1+ (2nd pos)))
(if (< (1st pos) last-line-num)
(list (1+ (1st pos)) 1)
nil))))
(defun screen-previous-pos (screen pos)
(if (> (2nd pos) 1)
(list (1st pos) (1- (2nd pos)))
(if (> (1st pos) 1)
(list (1- (1st pos))
(arrayget (arrayget screen (1- (1st pos))) 0))
nil)))
;;; Screen-Char-Or-Marker, unlike Line-Char, returns exactly what is at pos.
(defun screen-char-or-marker (screen pos)
(arrayget (arrayget screen (1st pos)) (2nd pos)))
;;; Functions for stack frame operations.
;;; Framearray returns an array of results from evalframe, starting at
;;; first-frame-to-use. It returns NIL if there are no frames.
;;; Frame indexing starts at 1; (arrayget frame-array 0) is how many
;;; frames there are.
;;; Occurrences of DIDL, Enter-DIDL,
;;; EVALHOOK and +INTERNAL-TTYSCAN-SUBR are deleted.
;;; Occurrences of DIDL-Evalhook and DIDL-Evalhook step are also deleted,
;;; except if they would be the first entries in the frame array.
(defun framearray (first-frame-to-use)
(do ((frame-list)
(frame-list-length 0)
(frame first-frame-to-use (evalframe (2nd frame)))
(form))
((null frame)
(if (null frame-list)
nil
(fillarray (newarray (1+ frame-list-length))
(cons frame-list-length
(nreverse frame-list)))))
(setq form (3rd frame))
(cond
((and (not (atom form))
(or (memq (car form)
'(didl evalhook enter-didl +internal-ttyscan-subr))
(and (not (= frame-list-length 0))
(memq (car form)
'(didl-evalhook didl-evalhook-step))))))
(t
(setq frame-list-length (1+ frame-list-length))
(push frame frame-list)))))
;;; Put-Frame-Array-User-Functions scans the whole frame-array, and
;;; Puts the user functions it finds, if they haven't been Put already.
(defun put-frame-array-user-functions (frame-array)
(do ((last-frame (arrayget frame-array 0))
(frame-form)
(frame-index 1 (1+ frame-index)))
((> frame-index last-frame))
(setq frame-form (3rd (arrayget frame-array frame-index)))
(and (not (atom frame-form))
(user-function (car frame-form))
(put-defun-if-necessary (car frame-form)))))
;;; Find-User-Frame starting at start-at in frame-array, and searches
;;; upwards or downwards, depending on inc,
;;; looking for a form that is in a user function.
;;; It returns an index into frame-array, or NIL if no user function was found.
(defun find-user-frame (frame-array start-at inc)
(do ((last-frame (arrayget frame-array 0))
(frame-index start-at (+ inc frame-index)))
((or (> frame-index last-frame) (< frame-index 1)) nil)
(and (ht-find (3rd (arrayget frame-array frame-index)))
(return frame-index))))
;;; User-Function says if the function is an expr, fexpr, or macro.
(defun user-function (func)
(and (symbolp func)
(find-fun func))) ;find any DIDL-hackable functional property
;;; Make-Frame-Screen creates a screen that has the information
;;; of frame-array in it.
;;; A frame-screen line looks like:
;;; <frame number>: <user function>: <frame form> e.g.
;;; 7: FUNC: (CAR FOO)
;;; The <user function> may be blank if the <frame form> is not
;;; found in $hash-table. For instance, it may be an atom or a subr form.
;;; (DIDL-EVALHOOK ...) and (DIDL-EVALHOOK-STEP ...) frames are special,
;;; and look like:
;;; 1: Broke at FUNC: (CAR FOO)
;;; where (CAR FOO) is the frame that is ABOUT to be created.
(defun make-frame-screen (frame-array)
(let ((how-many-frames (arrayget frame-array 0))
(form) (in-what-func) (broke-at nil)
(exploded-broke-at (exploden '|Broke at |))
(frame-screen (newarray (cadr (arraydims frame-array)))))
(arraystore frame-screen 0 how-many-frames)
(for i 1 how-many-frames
(setq broke-at nil)
(arraystore frame-screen i (create-line))
(setq form (3rd (arrayget frame-array i)))
(and (not (symbolp form))
(memq (car form) '(didl-evalhook didl-evalhook-step))
(setq broke-at exploded-broke-at)
(setq form (2nd form)))
(if (setq in-what-func (2nd (ht-find form)))
(stuff-line (arrayget frame-screen i)
(explodendec i) '(72 40) ;; ": "
broke-at
(exploden in-what-func) '(72 40) ;; ": "
(exploden form))
(stuff-line (arrayget frame-screen i)
(explodendec i) '(72 40)
broke-at
(exploden form))))
frame-screen))
;;; Utility functions for command readers.
;;; Force-Into-Range forces a number into being in a certain range.
;;; E.g.: (force-into-range 1 3 4) => 3.
(defun force-into-range (low high num)
(max low (min high num)))
;;; Read-Command-Arg tyipeek's to see if there is a digit present.
;;; Ifso, it builds a decimal number from that and subsequent digits.
;;; Ifnot, it returns 1.
(defun read-command-arg ()
(do ((char (tyipeek) (tyipeek))
(no-arg t)
(neg 1)
(argument 0))
(nil)
(cond
((and (<= char 71) (>= char 60)) ;a digit?
(setq argument (+ (* argument 10.) (- char 60)))
(setq no-arg nil))
((= char 55)
(setq neg (- neg)) ; a - ?
(setq no-arg t))
(t
(return (* neg (if no-arg 1 argument)))))
(tyi)))
;;; Read-Command-Char inputs a char and uppercases it.
(defun read-command-char ()
(let ((char (tyi)))
(if (or (< char 141) (> char 172))
char
(- char 40))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Put- functions are for grinding s-expressions (sx's), and producing:
;;; an array which is the printed representation of the result, and
;;; containing markers which indicate where sx's are.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Put-Defun-If-Necessary does a put-defun only if the function has
;;; not already been put.
(defun put-defun-if-necessary (func)
(or (and (get func 'didl-screen)
(ht-find (find-fun func)))
(progn
(echo-area-princ '|Grinding |)
(echo-area-prin1 func)
(put-defun func)
(echo-area-princt '|.|))))
;;; Find-Fun finds any functional that DIDL can print, or returns nil if none
(defun find-fun (function)
(let ((function (cadr (getl function '(expr fexpr macro)))))
(cond ((null function) nil)
((symbolp function) (find-fun function))
(t function))))
;;; Put-Defun takes a function name, and produces the put-ground result, using
;;; lower functions.
(defun put-defun (func)
(vars (screen sx)
(setq sx (find-fun func))
(and (atom sx) (error '|has no reasonable functional property|
func))
(setq screen (newarray 20.)) ; can expand
(arraystore screen 0 0)
(putprop func (put-sx sx screen '(1 1) func) 'didl-toploc)
(putprop func screen 'didl-screen)))
;;; Put-SX looks at an sx, decides how it should be put, and calls the right
;;; routine.
(defun put-sx (sx screen pos in-function)
(vars (put-format)
(cond
;; If an atom, just put it out.
((atom sx) (put-atom sx screen pos))
;; If function wants to be put a special way, acquiesce.
((and (atom (car sx))
(setq put-format (get (car sx) 'didl-put-format)))
(cond
((eq put-format 'put-miser)
(put-miser sx screen pos in-function))
((eq put-format 'put-block)
(put-block sx screen pos in-function))
((eq put-format 'put-function-call)
(put-function-call sx screen pos in-function))
(t (error '|does not have a legal DIDL-Put-Format|
(car sx)))))
;; If it fits on a line, put it on one line.
((fits-on-line (flatsize sx) pos)
(put-block sx screen pos in-function))
;; If it's a function, put it in function format.
((and (symbolp (car sx))
(getl (car sx) '(subr fsubr lsubr expr fexpr macro)))
(put-function-call sx screen pos in-function))
;; Else, put it in miser format.
(t (put-miser sx screen pos in-function)))))
;;; Put-Miser puts lists in the form:
;;; (A
;;; B
;;; C)
;;; It calls put-sx for each element of the list.
;;; It puts markers at the left-paren and right-paren.
(defun put-miser (sx screen start-pos in-function)
(vars
(leftparenloc rightparenloc
ht-entry indent-column next-pos)
(setq ht-entry (ht-enter sx))
(setq leftparenloc (create-leftparenloc))
(setq rightparenloc (create-rightparenloc))
(rplacd ht-entry (list in-function leftparenloc))
(store-leftparenloc↑begin-pos leftparenloc start-pos)
(store-rightparenloc↑begin-pos rightparenloc start-pos)
(store-leftparenloc↑sx leftparenloc sx)
(store-rightparenloc↑sx rightparenloc sx)
(setq indent-column (2nd (setq next-pos (pos+1 start-pos))))
(putscreen-char screen start-pos (cons 50 leftparenloc))
(do ((sx-left sx (if (atom sx-left) nil (cdr sx-left)))
(element) (element-loc) (atomic-cdrp) (last-elementp)
(element-index 0 (1+ element-index)))
((null sx-left))
;; atomic-cdrp checks for (... . <atom>).
(setq atomic-cdrp (atom sx-left))
(setq element (if atomic-cdrp sx-left (car sx-left)))
(setq last-elementp (or atomic-cdrp (null (cdr sx-left))))
(and atomic-cdrp
(progn
(putscreen-char screen next-pos 56) ; period
(setq next-pos (pos+1 (pos+1 next-pos)))))
(setq element-loc (put-sx element screen next-pos in-function))
(setq next-pos
(if last-elementp
(pos+1-with-indent (loc↑end-pos element-loc)
indent-column)
(list (1+ (1st (loc↑end-pos element-loc)))
indent-column))))
(putscreen-char screen next-pos (cons 51 rightparenloc))
(store-leftparenloc↑end-pos leftparenloc next-pos)
(store-rightparenloc↑end-pos rightparenloc next-pos)
leftparenloc))
;;; Put-Block puts lists in the form:
;;; (A B C
;;; D E F)
;;; by calling Put-Block-Indent with 0 indentation.
(defun put-block (sx screen start-pos in-function)
(put-block-indent sx screen start-pos in-function 0))
;;; Put-Function-Call puts lists in the form:
;;; (FUNC A B C
;;; D E F)
;;; by calling Put-Block-Indent with an indentation of 2.
(defun put-function-call (sx screen start-pos in-function)
(put-block-indent sx screen start-pos in-function 2))
;;; Put-Block-Indent puts lists in the form:
;;; (A B C
;;; <indentation spaces>D E F)
;;; It will wrap the first atom on a line onto the next line if necessary,
;;; but not subsequent atoms or sx's.
;;; It puts a marker for the sx when it puts the left-paren on the screen.
(defun put-block-indent (sx screen start-pos in-function indentation)
(vars (leftparenloc rightparenloc
ht-entry indent-column next-pos)
(setq ht-entry (ht-enter sx))
(setq leftparenloc (create-leftparenloc))
(setq rightparenloc (create-rightparenloc))
(rplacd ht-entry (list in-function leftparenloc))
(store-leftparenloc↑begin-pos leftparenloc start-pos)
(store-rightparenloc↑begin-pos rightparenloc start-pos)
(store-leftparenloc↑sx leftparenloc sx)
(store-rightparenloc↑sx rightparenloc sx)
(setq indent-column (+ indentation
(2nd (setq next-pos (pos+1 start-pos)))))
(putscreen-char screen start-pos (cons 50 leftparenloc))
(do ((sx-left sx (if (atom sx-left) nil (cdr sx-left)))
(element) (element-loc) (atomic-cdrp) (last-elementp)
(element-index 0 (1+ element-index)))
((null sx-left))
(setq atomic-cdrp (atom sx-left))
(setq element (if atomic-cdrp sx-left (car sx-left)))
(setq last-elementp (or atomic-cdrp (null (cdr sx-left))))
(and atomic-cdrp
(progn
(putscreen-char screen next-pos 56) ; period
(setq next-pos
(compute-next-block-pos indent-column next-pos
next-pos
(1+ (flatsize element)))))
)
(setq element-loc
(put-sx element screen next-pos in-function))
(setq next-pos
(if last-elementp
(pos+1-with-indent (loc↑end-pos element-loc)
(1+ indent-column))
(compute-next-block-pos indent-column next-pos
(loc↑end-pos element-loc)
(flatsize
(if (atom (cdr sx-left))
(cdr sx-left)
(cadr sx-left)))))))
(putscreen-char screen next-pos (cons 51 rightparenloc))
(store-leftparenloc↑end-pos leftparenloc next-pos)
(store-rightparenloc↑end-pos rightparenloc next-pos)
leftparenloc))
;;; Compute-Next-Block-Pos sees if what is to be printed will fit on the
;;; current line. Ifso, it returns a pos of where to start printing on the
;;; line, including the necessary space before. Ifnot, it returns a pos that
;;; is at the proper indentation on the next line. It also forces printing
;;; on the next line if the previous form was not completely put on the same
;;; line.
;;; start-pos and end-pos are where the last form was put.
(defun compute-next-block-pos (indent-column start-pos end-pos size)
(if (and (fits-on-line (+ 2 size) end-pos)
(= (1st start-pos) (1st end-pos)))
(list (1st end-pos) (+ 2 (2nd end-pos)))
(list (1+ (1st end-pos)) indent-column)))
;;; Put-Atom puts the chars that are in an atom's pname onto the screen,
;;; starting at pos.
(defun put-atom (the-atom screen pos)
(let ((atomloc (create-atomloc)))
(store-atomloc↑begin-pos atomloc pos)
(store-atomloc↑the-atom atomloc the-atom)
(do ((chars (explode the-atom) (cdr chars))
(next-pos pos (pos+1 next-pos))
(first t nil)
(last-pos pos next-pos))
((null chars)
(store-atomloc↑end-pos atomloc last-pos)
atomloc)
(putscreen-char screen next-pos (getcharn (car chars) 1)))))
;;; Putscreen-char grows the screen if necessary, and then calls putline-char.
(defun putscreen-char (screen pos char)
(let ((screen-length (1- (cadr (arraydims screen)))))
(and (> (1st pos) screen-length)
(*rearray screen t (+ (1st pos) screen-length)))
(putline-char screen pos char)))
;;; Putline-Char actually does the storing on the line array, and also updates
;;; the last-line-used (arrayget screen 0) and last-char-used
;;; (arrayget <line> 0) indices. It creates a new line array if there was
;;; not one in the screen array, and fills it with spaces.
(defun putline-char (screen pos char)
(let ((line (1st pos))
(col (2nd pos))
(line-array))
(setq line-array (arrayget screen line))
(cond
((null line-array)
(arraystore screen line (setq line-array (create-line)))
(for i 1 $screen-width (arraystore line-array i 40)))) ;space
(arraystore line-array col char)
(arraystore line-array 0 (max (arrayget line-array 0) col))
(arraystore screen 0 (max (arrayget screen 0) line))))
;;; Line-Char fetches a char from a line, taking it out of a marker
;;; if necessary.
(defun line-char (line index)
(let ((char-or-marker (arrayget line index)))
(if (atom char-or-marker)
char-or-marker
(car char-or-marker))))
;;; Loc↑Begin-Pos looks like a structure ref, but really sees what kind of
;;; loc it is given, and then fetches the right Begin-Pos.
;;; Loc↑End-Pos is similar.
(defun loc↑begin-pos (loc)
(cond
((eq (cdr loc) 'leftparenloc) (leftparenloc↑begin-pos loc))
((eq (cdr loc) 'rightparenloc) (rightparenloc↑begin-pos loc))
((eq (cdr loc) 'atomloc) (atomloc↑begin-pos loc))
(t (error '|is not a loc [loc↑begin-pos]| loc))))
(defun loc↑end-pos (loc)
(cond
((eq (cdr loc) 'leftparenloc) (leftparenloc↑end-pos loc))
((eq (cdr loc) 'rightparenloc) (rightparenloc↑end-pos loc))
((eq (cdr loc) 'atomloc) (atomloc↑end-pos loc))
(t (error '|is not a loc [loc↑end-pos]| loc))))
;;; Fits-On-Line says whether there is room on the rest of a line for
;;; something of a given size. It assumes starting at pos.
(defun fits-on-line (size pos)
(not (> (+ size (2nd pos) -1) $screen-width)))
;;; Create-Line creates a new array of length $screen-width+1, and stores
;;; 0 in its 0th element, to create a blank line.
(defun create-line ()
(let ((line (newarray (1+ $screen-width))))
(arraystore line 0 0)
line))
;;; Pos+1-with-indent adds 1 column to a pos, wrapping onto the next line if
;;; necessary, and indenting to indent-column.
(defun pos+1-with-indent (pos indent-col)
(if (>= (2nd pos) $screen-width)
(list (1+ (1st pos)) indent-col)
(list (1st pos) (1+ (2nd pos)))))
;;; Pos+1 wraps to the left side of the next line by using an indent-col of 1.
(defun pos+1 (pos)
(pos+1-with-indent pos 1))
;;; Debugging functions for dumping a screen.
(defun dump-screen (screen)
(for line 1 (arrayget screen 0)
(terpri)
(let ((line-array (arrayget screen line)))
(if (null line-array)
(princ nil)
(for col 1 (arrayget line-array 0)
(tyo (line-char line-array col)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Hash table functions for DIDL.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The HT (hash table) is used for finding the loc of a particular
;;; sx. The hashing is on (maknum sx), which is faster than (sxhash sx).
;;; The HT is an array with a prime number of elements (for good hashing).
;;; Each entry in the HT is a bucket list, which is an assq-type
;;; of list, for fast searching. Each bucket looks like:
;;; ( (<sx> <func> <leftparenloc>)) ... [repeated], or NIL if there
;;; are no entries. Func is the function the form is found in, and
;;; <leftparenloc> points to the <sx> on the didl-screen for <func>.
;;; HT-Setup should be called when DIDL is first entered. It initializes
;;; the $hash-table array.
(defun ht-setup (size)
(setq $hash-table (newarray size)))
;;; HT-Bucket-Index returns the array slot number for a particular sx.
(defun ht-bucket-index (sx)
(\ (abs (maknum sx)) (cadr (arraydims $hash-table))))
;;; HT-Enter looks up an sx in the HT. If found, it returns
;;; which is (sx func leftparenloc), if it already existed.
;;; If the sx is new, it enters it in the HT, and returns (sx . nil).
(defun ht-enter (sx)
(vars (bucket-index bucket pair)
(setq bucket-index (ht-bucket-index sx))
(setq bucket (arrayget $hash-table bucket-index))
(setq pair (assq sx bucket))
(if (null pair)
(prog1 (setq pair (ncons sx))
(push pair bucket)
(arraystore $hash-table bucket-index bucket))
pair)))
;;; HT-Find just looks for an sx like ht-enter, but just returns NIL
;;; if the sx is not found, and does not add it.
(defun ht-find (sx)
(assq sx (arrayget $hash-table (ht-bucket-index sx))))
;;; Window functions for displaying parts of a screen onto the user's
;;; terminal.
;;; Window-Clear erases everything in the window.
(defun window-clear ()
(for window-line 0 (+ $window-length $info-area-length)
(cursorpos window-line 0 $window-tty)
(cursorpos 'L $window-tty))
(cursorpos (1+ $window-length) 0 $window-tty))
;;; Window-Display fills the window with screen starting at first-screen-line.
(defun window-display (screen first-screen-line)
(window-display-part screen first-screen-line 1 $window-length))
;;; Window-Display-Part only changes part of the window and does
;;; not bother the rest of the window. Top-screen-line is the line
;;; corresponding to window-line 1, not to first-window-line.
(defun window-display-part (screen top-screen-line first-window-line
last-window-line)
(do ((screen-line (+ top-screen-line first-window-line -1)
(1+ screen-line))
(window-line first-window-line (1+ window-line))
(last-screen-line (arrayget screen 0)))
((> window-line last-window-line))
(if (> screen-line last-screen-line)
(window-clear-line window-line)
(window-output-line (arrayget screen screen-line)
window-line))))
;;; Window-Redisplay repaints the window, putting line at the middle
;;; of the window if reasonable. It returns the number of the screen
;;; line that is at the top of the window.
(defun window-redisplay (screen line)
(cond
((<= line (// $window-length 2))
(window-display screen 1)
1)
(t
(let ((top-line (- line (// $window-length 2))))
(window-display screen top-line)
top-line))))
;;; Window-Redisplay-If-Necessary does a Window-Redisplay with the
;;; given screen only if line is not on the current window, given that
;;; top-line is at the top of window. It returns the new top-line.
(defun window-redisplay-if-necessary (screen top-line line)
(if (or (< line top-line)
(> line (+ top-line $window-length -1)))
(window-redisplay screen line)
top-line))
;;; Window-Output-Line does a clear-to-end-of-line on the window line,
;;; and then puts the screen line onto it.
(defun window-output-line (screen-line window-line)
(window-clear-line window-line)
(do ((char-index 1 (1+ char-index))
(last-char-index (arrayget screen-line 0)))
((> char-index last-char-index))
(tyo (line-char screen-line char-index) $window-tty)))
;;; Window-Clear-Line goes to the beginning of a window line, and
;;; then does a clear-to-end-of-line.
(defun window-clear-line (window-line)
(window-set-cursor window-line 1)
(cursorpos 'L $window-tty))
;;; Stuff-Line puts its exploden'd arguments into line.
(defun stuff-line expr numbargs
(do ((arg-num 2 (1+ arg-num))
(line (arg 1))
(char-num 1)
(chars))
((or (> char-num $screen-width) (> arg-num numbargs))
(arraystore line 0 (1- char-num)))
(setq chars (arg arg-num))
(do ()
((or (> char-num $screen-width) (null chars)))
(arraystore line char-num (car chars))
(setq chars (cdr chars))
(setq char-num (1+ char-num)))))
;;; ExplodenDec does an explode with base=10. and *nopoint=t, so
;;; numbers will come out in decimal.
(defun explodendec (x)
(let ((base 10.) (*nopoint t))
(exploden x)))
;;; Window-Set-Status-Line does a Stuff-Line into $status-line.
(defun window-set-status-line expr numbargs
(apply (function stuff-line)
(cons $status-line
(mapcar 'explodendec (listify numbargs)))))
;;; Window-Display-Status-Line displays $status-line at the line that
;;; is 1 greater than $window-length. But this line is really included
;;; in the window area.
(defun window-display-status-line ()
(window-output-line $status-line (1+ $window-length)))
;;; Window-Set-Cursor does a cursorpos in the window. The window is 1-origin
;;; indexing, and cursorpos is 0-origin.
(defun window-set-cursor (line col)
(cursorpos (1- line) (1- col) $window-tty))
;;; Window-Set-Cursor-With-Pos uses info about the top window line
;;; to set the cursor to a pos.
(defun window-set-cursor-with-pos (top-screen-line-on-window pos)
(window-set-cursor (- (1st pos) top-screen-line-on-window -1)
(2nd pos)))
;;; Window-Clear-And-Print just does a print into the window region
;;; after clearing it.
(defun window-clear-and-print (what-to-print)
(window-clear)
(window-print what-to-print)
(window-terpri))
;;; Other window-printing functions.
(defun window-print (x)
(print x $window-tty))
(defun window-princ (x)
(princ x $window-tty))
(defun window-prin1 (x)
(prin1 x $window-tty))
(defun window-terpri ()
(terpri $window-tty))
(defun window-tyo (char)
(tyo char $window-tty))
;;; Following are various Info-Area printing functions.
;;; Info-Area-Clear clears the info area, which is the two lines below
;;; the status line.
(defun info-area-clear ()
(for info-line 1 $info-area-length
(cursorpos (+ $window-length info-line) 0 $window-tty)
(cursorpos 'L $window-tty))
(cursorpos (1+ $window-length) 0 $window-tty))
(defun info-area-terpri ()
(terpri $window-tty))
(defun info-area-princ (x)
(princ x $window-tty))
(defun info-area-print (x)
(print x $window-tty))
(defun info-area-prin1 (x)
(prin1 x $window-tty))
;;; These functions do various terpri's before and after printing
;;; for convenience.
(defun info-area-printc (x)
(info-area-terpri)
(princ x $window-tty))
(defun info-area-princt (x)
(princ x $window-tty)
(info-area-terpri)))
(defun info-area-prin1t (x)
(prin1 x $window-tty)
(info-area-terpri)))
;;; Following are various Echo-Area printing functions.
;;; Echo-Area-Clear clears the echo area, which also sets the cursor
;;; to the top left of the area.
(defun echo-area-clear ()
(cursorpos 'C $echo-area-tty))
(defun echo-area-terpri ()
(terpri $echo-area-tty))
(defun echo-area-princ (x)
(princ x $echo-area-tty))
(defun echo-area-print (x)
(print x $echo-area-tty))
(defun echo-area-prin1 (x)
(prin1 x $echo-area-tty))
;;; These functions do various terpri's before and after printing
;;; for convenience.
(defun echo-area-printc (x)
(echo-area-terpri)
(princ x $echo-area-tty))
(defun echo-area-princt (x)
(princ x $echo-area-tty)
(echo-area-terpri)))
(defun echo-area-prin1t (x)
(prin1 x $echo-area-tty)
(echo-area-terpri)))
;;; Echo-Area-Prompt-And-Read clears the echo area, then princ's all its
;;; arguments to prompt the user. It then does a (read) and returns its value.
;;; If the user over-rubouts, causing an end-of-file condition on tyi,
;;; Echo-Area-Prompt-And-Read throws back to Abort-Command.
(defun echo-area-prompt-and-read numbargs
(echo-area-clear)
(for i 1 numbargs
(echo-area-princ (arg i)))
(let ((thing-read (read $unique-symbol))) ;(read) returns $unique-symbol
(and (eq thing-read $unique-symbol) ; if user over-rubouts
(throw 'abort-command abort-command))
(echo-area-terpri)
thing-read))
;;; Echo-Area-Prompt-And-Read-With-Default is like Echo-Area-Prompt-And-Read,
;;; but (arg 1) is a default to use if the user just types space.
(defun echo-area-prompt-and-read-with-default numbargs
(echo-area-clear)
(for i 2 numbargs
(echo-area-princ (arg i)))
(caseq (tyipeek)
(40 ; If just a space is typed, return the default.
(arg 1))
(177
(throw 'abort-command abort-command)) ; Rubout will abort it.
(t
(let ((thing-read (read $unique-symbol)))
; (read) returns $unique-symbol
; if user over-rubouts.
(and (eq thing-read $unique-symbol)
(throw 'abort-command abort-command))
(echo-area-terpri)
thing-read))))
;;; Open-TTYS sets up $window-tty and $echo-area-tty, making $window-tty
;;; the normal full-screen tty, and opens a new tty called $echo-area-tty.
(defun open-ttys ()
(setq $echo-area-tty (open '((tty)) '(tty out echo)))
(setq $window-tty tyo)
(endpagefn $window-tty (function didl-endpagefn))
(endpagefn $echo-area-tty (function didl-endpagefn)))
;;; Split-Screen does a SCML on $echo-area-tty.
(defun split-screen ()
(syscall 0 'scml $echo-area-tty $echo-area-length)
(sstatus ttycons $echo-area-tty tyi)
(setq tyo $echo-area-tty)
(setq $is-screen-split? t))
;;; Unsplit-screen undoes the SCML.
(defun unsplit-screen numbargs
(and (= numbargs 2)
(tyi))
(syscall 0 'scml $echo-area-tty 0)
(setq tyo $window-tty)
(sstatus ttycons tyo tyi)
(setq $is-screen-split? nil))
;;; DIDL-Endpagefn is a simple-minded one, unlike the +INTERNAL-TTY-ENDPAGEFN,
;;; which requires the channel it is on to be TTYCONS'd with TYI.
(defun didl-endpagefn (output-tty)
(nointerrupt nil) ; Make sure the guy can ↑G (etc..)
(princ '|##More##| output-tty)
(tyi) ; Eat a character
(cursorpos 'Z output-tty) ; Clear the ##More##
(cursorpos 'L output-tty)
(cursorpos 'TOP output-tty))
β