Added INQUIR, the user account management program.

src/libdoc/comrd.kmp1

@@ -0,0 +1,462 @@
+;;; -*- LISP -*-
+;;; COMRD: A library that implements a completing reader.
+;;; Written by KMP some time ago, (obviously before # readmacro
+;;; and defmacro were in use in maclisp), moved to LIBDOC by GJC
+;;; as this is of general use as a command reader for
+;;; interactive programs.
+;;; The simplest and most common call will be
+;;; (completing-read "prompt-> " '(foo bar baz bomb))
+
+(herald comrd)
+
+(DECLARE (SPECIAL COMPLETING-READER-OBJECT-HEADER)
+	 (*LEXPR *COMPLETING-READ-OPTIONS
+		 *COMPLETING-READ-PROMPT
+		 *COMPLETING-READ-INSTREAM
+		 *COMPLETING-READ-OUTSTREAM
+		 *COMPLETING-READ-AMBIGUITY-ERROR
+		 *COMPLETING-READ-NULL-ERROR
+		 *COMPLETING-READ-COMPLETION-CHARS
+		 *COMPLETING-READ-RETURN-CHARS
+		 *COMPLETING-READ-CASE-CONVERT
+		 *COMPLETING-READ-LAST-CASE
+		 *COMPLETING-READ-OVERRUBOUT-RETURN
+		 *COMPLETING-READ-CHARS-READ))
+
+(SSTATUS TTYINT 23. NIL) ; Turn off ^W as a tty interrupt
+(SSTATUS TTYINT 21. NIL) ; Turn off ^U as a tty interrupt
+
+(EVAL-WHEN (EVAL COMPILE)
+  (OR (GET 'TTY 'VERSION)
+      (LOAD (CASEQ (STATUS OPSYS)
+	      ((ITS) '((DSK LIBLSP) TTY))
+	      (T '((LISP)TTY))))))
+
+(DEFUN LAMBDA MACRO (FORM) (LIST 'FUNCTION FORM))
+
+;;; *COMPLETING-READ and *COMPLETING-READ1
+;;;
+;;; *COMPLETING-READ prints a newline and a prompt.
+;;; *COMPLETING-READ1 starts in cold (this is good for if completion
+;;;   has been done and user rubs back out into the read)
+;;;
+;;; Args are:
+;;;
+;;;  PROMPT: What to type out as a prompt if anything.
+;;;  CHARS-PENDING: What characters have already been read (won't echo).
+;;;  INSTREAM: Where to read more chars from.
+;;;  OUTSTREAM: Where to do type-out to.
+;;;  AMBIGUITY-ERROR: If T, then beep instead of return if result is ambiguous.
+;;;  NULL-ERROR: If T, then beep instead of return if result is null.
+;;;  COMPLETION-CHARS: List of fixnums for chars that show completion.
+;;;  RETURN-CHARS: List of fixnums for chars that return value(s).
+;;;  CASE-CONVERT: If T, then lowercase stuff input gets canonicalized.
+;;;  OVER-RUBOUT-RETURN-FLAG: Should form return if over-rubout?
+;;;			      If non-NIL returns OVER-RUBOUT for too many
+;;;			      rubouts, WORD-RUBOUT for ^W, and LINE-RUBOUT 
+;;;			      for ^U.
+;;;
+;;; Returns a list whose CAR is the list of characters read and the
+;;; CDR of which is the set of still-possible completions at the end of the
+;;; read.
+
+(DEFUN *COMPLETING-READ (PROMPT OPTIONS INSTREAM OUTSTREAM
+				AMBIGUITY-ERROR NULL-ERROR
+				COMPLETION-CHARS RETURN-CHARS
+				CASE-CONVERT OVER-RUBOUT-RETURN-FLAG)
+       (TERPRI OUTSTREAM)
+       (PRINC PROMPT OUTSTREAM)
+       (*COMPLETING-READ1 PROMPT OPTIONS () INSTREAM OUTSTREAM
+			  AMBIGUITY-ERROR NULL-ERROR
+			  COMPLETION-CHARS RETURN-CHARS
+			  CASE-CONVERT OVER-RUBOUT-RETURN-FLAG))
+
+(DEFUN *COMPLETING-READ1 (PROMPT OPTIONS CHARS-PENDING INSTREAM OUTSTREAM
+				 AMBIGUITY-ERROR NULL-ERROR
+				 COMPLETION-CHARS RETURN-CHARS
+				 CASE-CONVERT OVER-RUBOUT-RETURN-FLAG)
+       (LET ((COMPLETION-OBJECT (*COMPLETING-READ-OBJECT
+				 OPTIONS
+				 PROMPT
+				 INSTREAM
+				 OUTSTREAM
+				 AMBIGUITY-ERROR
+				 NULL-ERROR
+				 COMPLETION-CHARS
+				 RETURN-CHARS
+				 CASE-CONVERT
+				 OVER-RUBOUT-RETURN-FLAG)))
+	    (MAPC (LAMBDA (X) (*COMPLETING-READ-PUSH-COMPLETION
+			       X
+			       COMPLETION-OBJECT))
+		  CHARS-PENDING)
+	    (*CATCH 'COMPLETING-READ-EXIT
+		    (DO-WITH-TTY-OFF
+		     (DO ()
+			 (NIL)
+			 (*COMPLETING-READ-TYI COMPLETION-OBJECT))))))
+
+;;; (COMPLETING-READ <prompt> <options>)
+;;; I/O default is to/from tty
+;;; ambiguous or null response acceptable
+;;; return or space causes return
+;;; altmode causes completion
+;;; no initial character
+;;;
+;;; Sample:  (COMPLETING-READ '> '(THIS THAT THOSE))
+;;;
+
+(DEFUN COMPLETING-READ (PROMPT OPTIONS)
+       (CDR (*COMPLETING-READ PROMPT OPTIONS TYI TYO
+			      T T
+			      '(27.) '(13. 32.)
+			      T NIL)))
+
+(DEFUN *COMPLETING-READ-SOFT-TYI (COMPLETION CHAR)
+       (LET ((OUTSTREAM (*COMPLETING-READ-OUTSTREAM COMPLETION)))
+	    (TYO CHAR OUTSTREAM)
+	    (*COMPLETING-READ-PUSH-COMPLETION CHAR COMPLETION)))
+
+(DEFUN *COMPLETING-READ-CASE-FUNCTION (CHAR)
+       (COND ((AND (> CHAR 96.) (< CHAR 123.))
+	      '*COMPLETING-READ-LOWERCASIFY)
+	     (T
+	      '*COMPLETING-READ-UPPERCASIFY)))
+
+(DEFUN *COMPLETING-READ-TYI (COMPLETION)
+       (LET ((INSTREAM         (*COMPLETING-READ-INSTREAM COMPLETION))
+	     (OUTSTREAM        (*COMPLETING-READ-OUTSTREAM COMPLETION)))
+	    (LET ((CHAR (TYI INSTREAM)))
+		 (COND ((= CHAR 12.)
+			(CURSORPOS 'C OUTSTREAM)
+			(*COMPLETING-READ-REDISPLAY-LINE COMPLETION))
+		       ((= CHAR 18.)
+			(*COMPLETING-READ-REDISPLAY-LINE COMPLETION))
+		       ((MEMBER CHAR '(63. 2120.))
+			(*COMPLETING-READ-DISPLAY-OPTIONS COMPLETION)
+			(*COMPLETING-READ-REDISPLAY-LINE COMPLETION))
+		       ((MEMBER CHAR (*COMPLETING-READ-COMPLETION-CHARS
+				      COMPLETION))
+			(*COMPLETING-READ-ATTEMPT-COMPLETION COMPLETION))
+		       ((MEMBER CHAR (*COMPLETING-READ-RETURN-CHARS
+				      COMPLETION))
+			(*COMPLETING-READ-RETURN COMPLETION CHAR))
+		       ((= CHAR 23.)
+			(PRINC '|/| TYO)
+			(COND
+			 ((*COMPLETING-READ-OVERRUBOUT-RETURN COMPLETION)
+			  (*THROW 'COMPLETING-READ-EXIT 'WORD-RUBOUT))
+			 (T
+			  (*COMPLETING-READ-RESET-COMPLETION COMPLETION)
+			  (*COMPLETING-READ-REDISPLAY-LINE COMPLETION))))
+		       ((= CHAR 21.)
+			(PRINC '|/| TYO)
+			(COND
+			 ((*COMPLETING-READ-OVERRUBOUT-RETURN COMPLETION)
+			  (*THROW 'COMPLETING-READ-EXIT 'LINE-RUBOUT))
+			 (T
+			  (*COMPLETING-READ-RESET-COMPLETION COMPLETION)
+			  (*COMPLETING-READ-REDISPLAY-LINE COMPLETION))))
+		       ((= CHAR 127.)
+			(LET ((CHAR
+			       (*COMPLETING-READ-POP-COMPLETION COMPLETION)))
+			     (COND (CHAR
+				    (COND ((MEMQ 'RUBOUT
+						 (STATUS FILEM OUTSTREAM))
+					   (RUBOUT CHAR OUTSTREAM))
+					  (T
+					   (TYO 92. OUTSTREAM)
+					   (TYO CHAR OUTSTREAM))))
+				   ((*COMPLETING-READ-OVERRUBOUT-RETURN
+				     COMPLETION)
+				    (*THROW 'COMPLETING-READ-EXIT
+					    'OVER-RUBOUT)))))
+		       (T
+			(TYO CHAR (*COMPLETING-READ-OUTSTREAM COMPLETION))
+			(*COMPLETING-READ-LAST-CASE
+			 COMPLETION
+			 (*COMPLETING-READ-CASE-FUNCTION CHAR))
+			(*COMPLETING-READ-PUSH-COMPLETION CHAR COMPLETION))))))
+
+(DEFUN *COMPLETING-READ-REDISPLAY-LINE (COMPLETION)
+       (LET ((OUTSTREAM (*COMPLETING-READ-OUTSTREAM COMPLETION)))
+	    (CURSORPOS 'A OUTSTREAM)
+	    (PRINC (*COMPLETING-READ-PROMPT COMPLETION) OUTSTREAM)
+	    (DO ((L (REVERSE (*COMPLETING-READ-CHARS-READ COMPLETION))
+		    (CDR L))
+		 (CASE-FUN (*COMPLETING-READ-LAST-CASE COMPLETION)))
+		((NULL L))
+		(TYO (FUNCALL CASE-FUN (CAR L)) OUTSTREAM))))
+
+(DEFUN *COMPLETING-READ-RETURN (COMPLETION CHAR)
+       (LET ((OPTIONS (CAR (*COMPLETING-READ-OPTIONS COMPLETION)))
+	     (NUMBER-OF-CHARS)
+	     (CHARS))
+	    (COND ((OR (AND (NULL OPTIONS)
+			    (NOT (*COMPLETING-READ-NULL-ERROR COMPLETION)))
+		       (= (LENGTH OPTIONS) 1.)
+		       (NOT (*COMPLETING-READ-AMBIGUITY-ERROR COMPLETION)))
+		   (COND ((AND (NOT (= CHAR 13.))
+			       (= (LENGTH OPTIONS) 1.))
+			  (*COMPLETING-READ-SHOW-COMPLETION COMPLETION)))
+		   (TYO CHAR (*COMPLETING-READ-OUTSTREAM COMPLETION))
+		   (*THROW 'COMPLETING-READ-EXIT
+			   (CONS (CONS
+				  CHAR
+				  (*COMPLETING-READ-CHARS-READ COMPLETION))
+				 OPTIONS))))
+	    (SETQ NUMBER-OF-CHARS
+		  (LENGTH (SETQ CHARS
+				(*COMPLETING-READ-CHARS-READ COMPLETION))))
+	    (MAPC (LAMBDA (X)
+			  (COND ((= (FLATC X) NUMBER-OF-CHARS)
+				 (TYO CHAR
+				      (*COMPLETING-READ-OUTSTREAM COMPLETION))
+				 (*THROW 'COMPLETING-READ-EXIT
+					 (LIST (CONS CHAR CHARS) X)))))
+		  OPTIONS)
+	    (TYO 7. (*COMPLETING-READ-OUTSTREAM COMPLETION))
+	    (*COMPLETING-READ-ATTEMPT-COMPLETION COMPLETION)))
+
+(DEFUN *COMPLETING-READ-DISPLAY-OPTIONS (COMPLETION)
+       (LET ((OUTSTREAM (*COMPLETING-READ-OUTSTREAM COMPLETION))
+	     (OPTIONS (CAR (*COMPLETING-READ-OPTIONS COMPLETION))))
+	    (CURSORPOS 'A OUTSTREAM)
+	    (COND ((NOT OPTIONS)
+		   (PRINC '|No options match.| OUTSTREAM))
+		  ((= (LENGTH OPTIONS) 1.)
+		   (PRINC '|Unambiguous match: | OUTSTREAM)
+		   (PRINC (CAR OPTIONS) OUTSTREAM))
+		  (T
+		   (PRINC '|Options are: | OUTSTREAM)
+		   (PRINC (CAR OPTIONS) OUTSTREAM)
+		   (DO ((L (CDR OPTIONS) (CDR L)))
+		       ((NULL L))
+		       (PRINC '|, | OUTSTREAM)
+		       (COND ((> (+ (FLATC (CAR L)) (CHARPOS OUTSTREAM)) 67.)
+			      (TERPRI OUTSTREAM)
+			      (TYO 9. OUTSTREAM)))
+		       (PRINC (CAR L) OUTSTREAM))))))
+
+(DEFUN *COMPLETING-READ-ATTEMPT-COMPLETION (COMPLETION)
+       (LET ((OUTSTREAM       (*COMPLETING-READ-OUTSTREAM  COMPLETION))
+	     (OPTIONS    (CAR (*COMPLETING-READ-OPTIONS    COMPLETION)))
+	     (LEN (1+ (LENGTH (*COMPLETING-READ-CHARS-READ COMPLETION)))))
+	    (COND ((NULL OPTIONS)
+		   (TYO 7. OUTSTREAM))
+		  (T
+		   (DO ((I LEN (1+ I))
+			(CASE-FUN (*COMPLETING-READ-LAST-CASE COMPLETION))
+			(END (FLATC (CAR OPTIONS))))
+		       ((OR (> I END)
+			    (NOT (*COMPLETING-READ-MATCH-ALL OPTIONS I)))
+			(COND ((= I LEN)
+			       (TYO 7. OUTSTREAM))))
+		       (*COMPLETING-READ-SOFT-TYI
+			COMPLETION
+			(FUNCALL CASE-FUN (GETCHARN (CAR OPTIONS) I))))))))
+							    
+(DEFUN *COMPLETING-READ-SHOW-COMPLETION (COMPLETION)
+       (LET ((OPTION (CAAR (*COMPLETING-READ-OPTIONS COMPLETION)))
+	     (LEN (1+ (LENGTH (*COMPLETING-READ-CHARS-READ COMPLETION)))))
+	    (DO ((I LEN (1+ I))
+		 (CASE-FUN (*COMPLETING-READ-LAST-CASE COMPLETION))
+		 (END (FLATC OPTION)))
+		((> I END))
+		(*COMPLETING-READ-SOFT-TYI
+		 COMPLETION
+		 (FUNCALL CASE-FUN (GETCHARN OPTION I))))))
+
+(DEFUN *COMPLETING-READ-MATCH-ALL (OPTIONS I)
+       (DO ((C (GETCHARN (CAR OPTIONS) I))
+	    (O (CDR OPTIONS) (CDR O)))
+	   ((NULL O) T)
+	   (COND ((NOT (= C (GETCHARN (CAR O) I)))
+		  (RETURN NIL)))))
+
+(EVAL-WHEN (EVAL LOAD)
+	(SETQ COMPLETING-READER-OBJECT-HEADER
+	      (MAKNAM '(/# C O M P L E T I O N))))
+
+(DEFUN *COMPLETING-READ-OBJECT? (X)
+       (AND (NOT (ATOM X))
+	    (EQ (CAR X) COMPLETING-READER-OBJECT-HEADER)))
+
+(DEFUN *COMPLETING-READ-OBJECT (OPTIONS PROMPT INSTREAM OUTSTREAM
+					AMBIGUITY-ERROR NULL-ERROR
+					COMPLETION-CHARS RETURN-CHARS
+					CASE-CONVERT OVER-RUBOUT-RETURN-FLAG)
+       (HUNK COMPLETING-READER-OBJECT-HEADER
+	     (NCONS OPTIONS) ; Options stack
+	     PROMPT          ; How to prompt
+	     INSTREAM        ; Where to get input from
+	     OUTSTREAM       ; Where to output echo
+	     AMBIGUITY-ERROR ; Is ambiguity an error?
+	     NULL-ERROR      ; Is null choice an error?
+	     COMPLETION-CHARS; Chars that complete 
+	     RETURN-CHARS    ; Chars that cause a return
+	     CASE-CONVERT    ; Should lowercase chars convert?
+	     (LAMBDA (X) X)  ; What case to do completions in 
+	     OVER-RUBOUT-RETURN-FLAG   ; Return if over-rubout occurs?
+	     ()              ; Stack of chars read
+	     ))
+
+(DEFUN *COMPLETING-READ-OPTIONS X
+       (COND ((= X 1.) (CXR 2. (ARG 1.)))
+	     (T (RPLACX 2. (ARG 1.) (ARG 2.)))))
+
+(DEFUN *COMPLETING-READ-PROMPT X
+       (COND ((= X 1.) (CXR 3. (ARG 1.)))
+	     (T (RPLACX 3. (ARG 1.) (ARG 2.)))))
+
+(DEFUN *COMPLETING-READ-INSTREAM X
+       (COND ((= X 1.) (CXR 4. (ARG 1.)))
+	     (T (RPLACX 4. (ARG 1.) (ARG 2.)))))
+
+(DEFUN *COMPLETING-READ-OUTSTREAM X
+       (COND ((= X 1.) (CXR 5. (ARG 1.)))
+	     (T (RPLACX 5. (ARG 1.) (ARG 2.)))))
+
+(DEFUN *COMPLETING-READ-AMBIGUITY-ERROR X
+       (COND ((= X 1.) (CXR 6. (ARG 1.)))
+	     (T (RPLACX 6. (ARG 1.) (ARG 2.)))))
+
+(DEFUN *COMPLETING-READ-NULL-ERROR X
+       (COND ((= X 1.) (CXR 7. (ARG 1.)))
+	     (T (RPLACX 7. (ARG 1.) (ARG 2.)))))
+
+(DEFUN *COMPLETING-READ-COMPLETION-CHARS X
+       (COND ((= X 1.) (CXR 8. (ARG 1.)))
+	     (T (RPLACX 8. (ARG 1.) (ARG 2.)))))
+
+(DEFUN *COMPLETING-READ-RETURN-CHARS X
+       (COND ((= X 1.) (CXR 9. (ARG 1.)))
+	     (T (RPLACX 9. (ARG 1.) (ARG 2.)))))
+
+(DEFUN *COMPLETING-READ-CASE-CONVERT X
+       (COND ((= X 1.) (CXR 10. (ARG 1.)))
+	     (T (RPLACX 10. (ARG 1.) (ARG 2.)))))
+
+(DEFUN *COMPLETING-READ-LAST-CASE X
+       (COND ((= X 1.) (CXR 11. (ARG 1.)))
+	     (T (RPLACX 11. (ARG 1.) (ARG 2.)))))
+
+(DEFUN *COMPLETING-READ-OVERRUBOUT-RETURN X
+       (COND ((= X 1.) (CXR 12. (ARG 1.)))
+	     (T (RPLACX 12. (ARG 1.) (ARG 2.)))))
+
+(DEFUN *COMPLETING-READ-CHARS-READ X
+       (COND ((= X 1.) (CXR 0. (ARG 1.)))
+	     (T (RPLACX 0. (ARG 1.) (ARG 2.)))))
+
+(DEFUN *COMPLETING-READ-RESET-COMPLETION (OBJECT)
+       (*COMPLETING-READ-OPTIONS    OBJECT
+				    (LAST (*COMPLETING-READ-OPTIONS OBJECT)))
+       (*COMPLETING-READ-CHARS-READ OBJECT ()))
+
+(DEFUN *COMPLETING-READ-PUSH-COMPLETION (CHAR OBJECT)
+       (LET ((OPTS  (*COMPLETING-READ-OPTIONS    OBJECT))
+	     (CHARS (*COMPLETING-READ-CHARS-READ OBJECT)))
+	    (COND ((*COMPLETING-READ-CASE-CONVERT OBJECT)
+		   (SETQ CHAR (*COMPLETING-READ-UPPERCASIFY CHAR))))
+	    (*COMPLETING-READ-OPTIONS OBJECT
+				      (CONS
+				       (*COMPLETING-READ-PROCESS-OPTIONS
+					CHAR
+					(CAR OPTS)
+					(1+ (LENGTH CHARS)))
+				       OPTS))
+	    (*COMPLETING-READ-CHARS-READ OBJECT (CONS CHAR CHARS))))
+
+(DEFUN *COMPLETING-READ-UPPERCASIFY (X)
+       (COND ((AND (> X 96.) (< X 123.)) (- X 32.))
+	     (T X)))
+
+(DEFUN *COMPLETING-READ-LOWERCASIFY (X)
+       (COND ((AND (> X 64.) (< X 91.)) (+ X 32.))
+	     (T X)))
+
+(DEFUN *COMPLETING-READ-POP-COMPLETION (OBJECT)
+       (LET ((CHARS (*COMPLETING-READ-CHARS-READ OBJECT)))
+	    (COND (CHARS
+		   (*COMPLETING-READ-OPTIONS
+		    OBJECT
+		    (CDR (*COMPLETING-READ-OPTIONS OBJECT)))
+		   (*COMPLETING-READ-CHARS-READ OBJECT (CDR CHARS))
+		   (CAR CHARS))
+		  (T
+		   NIL))))
+
+(DEFUN *COMPLETING-READ-PROCESS-OPTIONS (CHAR OPTIONS N)
+       (DO ((L OPTIONS (CDR L))
+	    (NEW-L ()))
+	   ((NULL L) (NREVERSE NEW-L))
+	   (COND ((= (GETCHARN (CAR L) N) CHAR)
+		  (PUSH (CAR L) NEW-L)))))
+
+;;; (COMPLETING-READ-LINE (<prompt1> <option1[1]> <option1[2]> ...)
+;;;			  (<prompt2> <option2[1]> <option2[2]> ...) ...)
+;;; Prints <prompt1> and reads words on a single line returning NIL if
+;;; over-rubout and (<option1-choice> <option2-choice> ... <optionN-choice>)
+;;; if sucessful. <prompt2> ... <promptN> are only used if the user types
+;;; <CR> to terminate the option before that. If he types <space> instead
+;;; he will not be prompted. Ambiguous or null responses are not allowed.
+
+(DEFUN (COMPLETING-READ-LINE MACRO) (X)
+       `(*COMPLETING-READ-LINE1 ',(CDR X)))
+
+(DEFUN *COMPLETING-READ-LINE1 (PROMPT-ALIST)
+       (CURSORPOS 'A TYO)
+       (*CATCH 'COMPLETING-READ-LINE-EXIT
+	       (*COMPLETING-READ-LINE1-AUX (CAAR PROMPT-ALIST)
+					   PROMPT-ALIST
+					   NIL
+					   T)))
+
+(DEFUN *COMPLETING-READ-LINE1-AUX (PROMPT PROMPT-ALIST VALUES PROMPTFLAG)
+       (COND ((NULL PROMPT-ALIST)
+	      (*THROW 'COMPLETING-READ-LINE-EXIT
+		      (NREVERSE VALUES)))
+	     (T
+	      (COND (PROMPTFLAG (PRINC (CAAR PROMPT-ALIST) TYO)))
+	      (DO ((VAL)
+		   (CHARS NIL))
+		  (NIL)
+		  (SETQ VAL
+			(*COMPLETING-READ1 PROMPT		; Prompt
+					   (CDAR PROMPT-ALIST)  ; Options
+					   CHARS		; Chars read
+					   TYI			; Instream
+					   TYO			; Outstream
+					   T			; Ambiguity 
+					   T			; Null 
+					   '(27.)		; Completion
+					   '(32. 13.)		; Return chars
+					   T			; Case
+					   T))			; Over-rubout
+		  (COND ((EQ VAL 'OVER-RUBOUT)
+			 (RETURN NIL))
+			((EQ VAL 'LINE-RUBOUT)
+			 (*THROW 'COMPLETING-READ-LINE-EXIT NIL))
+			((EQ VAL 'WORD-RUBOUT)
+			 (CURSORPOS 'A TYO)
+			 (PRINC PROMPT TYO)
+			 (RETURN NIL)))
+		  (SETQ CHARS (REVERSE (CAR VAL)))
+		  (*COMPLETING-READ-LINE1-AUX
+		   (MAKNAM (NCONC (EXPLODEN PROMPT) CHARS))
+		   (CDR PROMPT-ALIST)
+		   (CONS (CADR VAL) VALUES)
+		   (= (CAAR VAL) 13.))
+		  (SETQ CHARS (REVERSE (CDAR VAL)))
+		  (COND ((= (CAAR VAL) 13.)
+			 (CURSORPOS 'A TYO)
+			 (PRINC PROMPT TYO)
+			 (MAPC (LAMBDA (X) (TYO X TYO)) CHARS))
+			(T
+			 (COND ((MEMQ 'RUBOUT (STATUS FILEM TYO))
+				(CURSORPOS 'X TYO))
+			       (T
+				(PRINC '|\ | TYO)))))))))
+
+(SSTATUS FEATURE COMPLETING-READER-PACKAGE)

src/libdoc/dbg.rwk1

@@ -0,0 +1,639 @@
+; -*- Mode:LISP;Lowercase:T-*-
+
+;;; DEBUG ==> Allows user to inspect LISP stack
+;;; BT ==> Prints out an indented list of the user functions called
+;;; Debugging function for examining stack.
+;;; (DEBUG ARG) sets *RSET and NOUUO to arg, thus typical usage is:
+;;;	(DEBUG T)
+;;;	  T
+;;;	(FOO BAR BAZ)
+;;;	  ;BKPT *RSET-TRAP
+;;;	(DEBUG)
+;;;	  ( ...) ==> Top of stack
+;;;	D	 ==> Command to debug
+;;;	  ( ...) ==> Next to last expression evaluated
+;;;	Q	 ==> Back to lisp
+;;;	  NIL	 ==> Remember you are still inside breakloop
+;;;  Since having *RSET on is innefficient you might want it off, so
+;;;	(DEBUG NIL)
+;;;  DEBUG of no arguments prints (with the PRINLEVEL set to 4. and
+;;; 	PRINDEPTH to 3.)  Last S-Expression evaluated and 
+;;;     waits for character input (no need to type SPACE after characters).
+;;; Options are:
+;;; D -- Down stack
+;;; U -- Up stack
+;;; B -- Enter break loop
+;;; T -- Go to top of stack
+;;; Z -- Go to bottom of stack
+;;; P -- Print current level.  If given arg, always print.
+;;; S -- Sprinter current level.  If given non-zero arg, always sprinter.
+;;; > -- Sets debug-prinlength to arg
+;;; ^ -- Sets debug-prinlevel to arg
+;;; A -- Print indented list of all user calls, compiled or no.  Uses BAKLIST
+;;; V -- Print indented list of all visible calls. (from current loc down).
+;;; E -- Evaluate and print an S-expression.
+;;; C -- Continue execution from current level (asks for verification)
+;;; R -- return value (asks for verification)
+;;; Q -- Quit
+;;; ^S -- Flush output at interrupt level, turn it on at top-level
+;;; ? -- Type this stuff
+;;; <number> -- argument for following command.
+;;;
+;;; The form under evaluation is the value of the special variable
+;;; *CURSOR*, and may be modified in a break loop to cause the continue
+;;; command to continue with it, or may be output to be edited, etc...
+;;; The entire EVALFRAME is the value of the variable *FRAME*
+;;;
+;;; There are a few options which can be controlled, say in your init file:
+;;; DEBUG-PRINLEVEL	default 3	-- Initial value for PRINLEVEL
+;;; DEBUG-PRINLENGTH	default 4	-- Initial value for PRINLENGTH
+;;; DEBUG-PRIN1		default ()	-- If non-null, alternate printer
+;;; DEBUG-SPRINTER-MODE default ()	-- If non-null, GRIND sexpressions
+;;; DEBUG-INDENT-MAX	default 50.	-- Max depth for A, V options
+;;; DEBUG-PROMPT	default DBG>	-- What to prompt with
+;;; DEBUG-FRAME-SUPPRESSION-ALIST
+;;;			default ()	-- An alist of functions-names and
+;;;					   functions of one argument.  The
+;;;					   one argument will be an internal
+;;;					   frame-object, which can be given
+;;;					   a SUPPRESSED property if it is to
+;;;					   be suppressed.  Any number of frames
+;;;					   can be suppressed by this mechanism.
+;;;					   The function should return the last
+;;;					   frame suppressed.
+
+(herald DEBUG /69)
+
+(eval-when (eval load)			;We need GRINDEF now
+  (or (get 'grindef 'version)
+      (funcall autoload `(grindef . ,(get 'grindef 'autoload))))
+  (or (get 'FORMAT 'version)
+      (funcall autoload `(FORMAT . ,(get 'FORMAT 'AUTOLOAD))))
+)
+
+(declare (own-symbol debug back-trace	;We load DEBUG into the compiler
+		     bt debug-printer *readch2 back-trace print-frame))
+
+(declare (*lexpr debug back-trace bt sprin1 debug-printer debug-print-frame
+		 debug-frame-printer
+		 y-or-n-p))
+
+(eval-when (eval compile)
+   (or (get 'umlmac 'version)
+       (load '((LISP) umlmac))))
+
+(or (get 'yesnop 'version)
+    (load '((LISP) YESNOP)))
+
+(eval-when (eval compile)
+  (or (get 'debmac 'version)
+      (load '((rwk) debmac))))
+
+(defprop debug-frame (next previous) suppressed-component-names)
+
+(defvar query-io 't)				;should be set up by YESNOP
+
+(defvar error-io query-io)
+
+(defvar debug-command-list ())
+
+(defvar debug-prinlevel 3)
+(defvar debug-prinlength 4)
+(defvar debug-prin1 ())
+(defvar debug-sprinter-mode ())
+(defvar debug-indent-max 50.)
+(defvar debug-prompt '|DBG>|)
+
+(defvar debug-frame-suppression-alist ())
+
+(defvar debug-suppression-reasons
+	'(LET GARBAGE DEBUG-INTERNAL))
+
+(defvar si:ignored-error-funs ())
+
+;; The following function is defined for compile time by DEBMAC, make any
+;; chanes there as well.
+
+(defun debug-name-char (ch)
+  (caseq ch
+    (#\HELP "Help")
+    (#\RETURN "Return")
+    (#\TAB "Tab")
+    (#\SPACE "Space")
+    (#\LINEFEED "Linefeed")
+    (#\BACKSPACE "Backspace")
+    (#\RUBOUT "Rubout")
+    (#\FORM "Form")
+    (T (if (> ch #\SPACE)
+	   (format () "~C" ch)
+	   (format () "^~C" (+ ch #o100))))))
+
+
+(defun enter-debug-command (character command-fun-symbol documentation)
+  (push (cons-a-debug-command-spec
+		    CHARS character
+		    FUN command-fun-symbol
+		    DOC documentation)
+	debug-command-list))
+
+(defun debug-find-command-spec (char)
+  (dolist (spec debug-command-list)
+    (if (member char (debug-command-spec-chars spec))
+	(return spec))))
+
+(defun debug-next-valid-frame (frame)
+  (do ((frame (debug-frame-next frame) (debug-frame-next frame)))
+      ((null frame))
+    (if (not (memq (get (debug-frame-plist frame) 'SUPPRESSED)
+		   debug-suppression-reasons))
+	(return frame))))
+
+(defun debug-previous-valid-frame (frame)
+  (do ((frame (debug-frame-previous frame) (debug-frame-previous frame)))
+      ((null frame))
+    (if (not (memq (get (debug-frame-plist frame) 'SUPPRESSED)
+		   debug-suppression-reasons))
+	(return frame))))
+
+(def-debug-command #/D			;Move down (backwards in time)
+  "Down to next frame."
+  (do ((i (or **arg** 1) (1- i))
+       (frame *frame* next)
+       (next (debug-next-valid-frame *frame*) (debug-next-valid-frame *frame*)))
+      ((or (= i 0) (null next)))
+    (declare (fixnum i))
+    (setq *frame* next))
+  (debug-print-frame *frame* debug-sprinter-mode))
+
+(def-debug-command #/U		;Move up 
+  "Up to previous frame."
+  (do ((i (or **arg** 1) (1- i))
+       (frame *frame* previous)
+       (previous (debug-previous-valid-frame *frame*) (debug-previous-valid-frame *frame*)))
+      ((or (= i 0) (null previous)))
+    (declare (fixnum i))
+    (setq *frame* previous))
+  (debug-print-frame *frame* debug-sprinter-mode))
+
+(def-debug-command #/T			;Jump back to the top of stack
+  "Go to the top of the stack."
+  (setq *frame* *top-frame*)
+  (debug-print-frame *frame* debug-sprinter-mode))
+
+(def-debug-command #/Z			;Bottom of the stack
+  "Go to the bottom of the stack."
+  (setq *frame* *bottom-frame*)
+  (debug-print-frame *frame* debug-sprinter-mode))
+
+(def-debug-command #/B			;Break in current environment 
+  "Enter break loop in the environment of the current frame."
+  (eval '(break debug t)
+	(debug-frame-bindstk *frame*))
+  (debug-print-frame *frame* debug-sprinter-mode))
+
+(def-debug-command #/E			;EVAL!
+  "Evaluate and print an S-expression."
+  (princ '|valuate:  | error-io)
+  (let* ((infile t)
+	 (form (errset (eval (read t)
+			     (debug-frame-bindstk *frame*))
+		       t)))
+    (when form
+	  (format error-io "~&==>  ")
+	  (debug-printer (car form) () ())
+	  (terpri error-io))
+    (cond ((not (zerop (listen error-io)))
+	   (let ((character (tyipeek () error-io)))
+	     (if (or (= character #\SPACE)
+		     (= character #\RETURN))
+		 (tyi error-io)))))))
+
+(def-debug-command #/R			;Force a return from this point
+  "Return a value from the current frame."
+  (cond ((and (y-or-n-p error-io '|~&>>>RETURN ??|)
+	      (progn
+		(format error-io
+			"~&>>>What should this S-Expression return?  ")
+		'T)
+	      (errset
+		(let* ((infile t)
+		       (ret (read T))
+		       (ERRSET 'CAR))
+		  (freturn (debug-frame-callstk *frame*)
+			   (eval ret (debug-frame-bindstk *frame*))))
+		T)))
+	(t (format error-io "Try again!~%"))))
+
+(def-debug-command #/C			;Just re-evaluates the current S-Exp
+  "Continue execution by re-evaluating current frame."
+  (cond ((and (y-or-n-p error-io '|~&>>>Continue ??|)
+	      (let ((ERRSET 'CAR))
+		(fretry (debug-frame-callstk *frame*)
+			(debug-frame-frame-list *frame*)))))
+	(t  (format error-io '|~&Try again~%|))))
+
+(def-debug-command #/A
+  "Print indented list of all user calls, compiled or no."
+  (BT 'DEBUG))
+
+(def-debug-command #/V
+  "Print indented list of all visible calls, from current frame down"
+  (back-trace *frame*))
+
+(def-debug-command #/P
+  "Print current level.  If given arg, print without abbreviation."
+  (debug-printer (debug-frame-form *frame*)
+		 (if (null **arg**) 'long ())))
+
+(def-debug-command #/S
+  "SPRINT (grind) current level.  If given non-zero arg, always SPRINT."
+  (if (null **arg**) (debug-printer (debug-frame-form *frame*) t)
+      (cond ((zerop **arg**)
+	     (setq debug-sprinter-mode ())
+	     (format error-io "  SPRINT mode OFF~%"))
+	    (t (setq debug-sprinter-mode t)
+	       (format error-io "  SPRINT mode ON~%")))))
+
+(def-debug-command (#\SPACE #\RETURN #\RUBOUT #^S #^X #^W #^V #^D #^C)	;Let's win!)
+  "No-ops."
+  (setq ^W ()))  ;No-ops
+
+(def-debug-command #\FORM
+  "Clear screen."
+  (cursorpos 'c error-io))
+
+(def-debug-command #/^
+  "Set DEBUG-PRINLEVEL to argument (or () if no argument)."
+  (setq debug-prinlevel **arg**)
+  (format error-io "  DEBUG-PRINLEVEL set to ~S~%" **arg**))
+
+(def-debug-command #/>
+  "Set DEBUG-PRINLEVEL to argument (or () if no argument)."
+  (setq debug-prinlength **arg**)
+  (format error-io "  DEBUG-PRINLENGTH set to ~S~%" **arg**))
+
+(def-debug-command #/=
+  "Display status of DEBUG-PRINLEVEL, DEBUG-PRINLENGTH, DEBUG-GRIND."
+  (format error-io
+	  "  ~5TSPRINT mode is ~:[OFF~;ON~]~@
+			      ~5TDEBUG-PRINLEVEL = ~S~@
+			      ~5TDEBUG-PRINLENGTH = ~S~%"
+	  debug-sprinter-mode debug-prinlevel debug-prinlength))
+
+(def-debug-command #/Q
+  "Quit DEBUG."
+  (*throw 'END-DEBUG 'END-DEBUG))
+
+(def-debug-command (#/? #\HELP)
+  "Document DEBUG."
+  (cursorpos 'A error-io)
+  (princ "Type a character to document, * for all, or ? for general help." error-io)
+  (let ((char (debug-upcase (tyi error-io))))
+    (caseq char
+      (#/* (cursorpos 'C error-io)
+	   (debug-print-all-help))
+      ((#/? #\HELP)
+       (cursorpos 'C error-io)
+       (princ "The DEBUG package is entered by calling the DEBUG function with
+no arguments, or automatically on error if the SIGNAL package is loaded.
+It takes single-character commands to examine the environment of an error.
+With it you can determine what functions have called what functions with
+what arguments, and what the values of special variables were when those
+functions were on the stack.
+
+To use DEBUG, *RSET must be set to T.  In addition, NOUUO should be set
+to T and (SSTATUS UUOLINKS) should be done, or many calls to compiled
+functions will not be seen by DEBUG.
+
+The basic commands are:
+  U -- Up, D -- Down, T -- Top, Z -- Bottom, P -- Print, S -- SPRINT
+  Q -- Quit DEBUG
+The following operate in the context of the current frame:
+  R -- Return a value from the current frame
+  C -- Continue (reexecute current frame),
+  B -- Break loop, E -- Evaluate
+The following control how frames are printed:
+  ^ -- set PRINLEVEL, > -- set PRINLENGTH, S -- set use of SPRINTER,
+  = -- show switches.
+The following provide a brief backtrace listing:
+  V -- Calls visible to DEBUG
+  A -- All calls, including those not seen due to NOUUO.
+The X command works only with SIGNAL to continue or restart from errors.
+"
+	      error-io))
+      (T (cursorpos 'A error-io)
+	 (princ (debug-name-char char) error-io)
+	 (princ " -- " error-io)
+	 (if (debug-digitp char)
+	     (princ "Numerical argument to a command" error-io)
+	     (let ((cmd (debug-find-command-spec char)))
+	       (if cmd
+		   (princ (debug-command-spec-doc cmd)
+			  error-io)
+		   (princ "Not a defined command." error-io))))))))
+
+
+(defun debug-print-all-help ()
+  (dolist (spec (reverse debug-command-list))
+    (lexpr-funcall #'format error-io
+	"~&~A~@{, ~A~}:"
+	(mapcar #'debug-name-char
+		(debug-command-spec-chars spec)))
+    (if (> (charpos error-io) 7.) (terpri error-io))
+    (format error-io "~5T  ~A~%" (debug-command-spec-doc spec))))
+
+(defun debug (&optional (*rset-new () *RSET-p) (ignore-funs '(debug) ignore-funs-p)
+			&aux **arg** *top-frame* *bottom-frame*
+			(debug-prinlevel debug-prinlevel)
+			(debug-prinlength debug-prinlength))
+  (cond ((and *rset-p (null ignore-funs-p))	;hack for call from NIL
+	 (*rset (nouuo *rset-new))
+	 (if *rset-new (sstatus uuolinks)))
+	((null (evalframe () )) 'try-setting-*rset)
+	('T
+	 (setq *top-frame* (debug-parse-all-frames))
+	 (debug-analyze-stack *top-frame* ignore-funs)
+	 (setq *frame* (or (debug-next-valid-frame *top-frame*) *top-frame*))
+	 (do ((frame *top-frame* (debug-frame-next frame)))	;Find bottom frame
+	     ((null frame))
+	   (setq *bottom-frame* frame))
+	 (debug-print-frame *frame* () 'T)	;don't say at top or bottom of stack
+	 (*catch 'END-DEBUG
+	   (errset
+	     (do ((char (*readch2) (*readch2))
+		  (spec))
+		 (())
+	       (declare (fixnum (char)))
+	       (if (setq spec (debug-find-command-spec char))
+		   (funcall (debug-command-spec-fun spec))
+		   (princ '|???| error-io)))
+	     T)))))
+
+;;; Reads a character and returns that character as either a 
+;;;	number or a symbol.
+;;;	It also converts small letters into capitals
+
+(defun *readch2 (&aux help-p)
+  (let ((debug-infile infile)
+	(infile error-io))			;LISP bug
+    (cursorpos 'A error-io)
+    (format error-io debug-prompt)
+    (do ((char (tyipeek () error-io) (tyipeek () error-io)))
+	((not (= char #/())
+	 (when (= char #\HELP)  ;Get around LISP bug, TYPEEK forgets HELP
+	       (tyi error-io)
+	       (setq help-p T)))
+	(declare (fixnum char))
+      (cursorpos 'x error-io)		;try to erase it
+      (cursorpos 'a error-io)
+      (tyo #/( error-io)
+      (errset
+	(let* ((errset 'CAR)
+	       (form (read error-io))	;READ with INFILE rebound
+	       (infile debug-infile)	;but undo that for the eval (SMURF)
+	       (val (eval form (debug-frame-bindstk *frame*))))
+	  (when val
+		(format error-io "~&==> ")
+		(debug-printer val t)))
+	T)
+      (format error-io debug-prompt))
+    (setq **arg** ())
+    (do ((char (if help-p #\HELP	;Get around LISP bug, TYIPEEK sucks.
+		   (tyi error-io))
+	       (tyi error-io)))
+	((not (debug-digitp char))  ;Return first non-digit
+	 (debug-upcase char))
+	(declare (fixnum char))
+      (setq **arg** (+ (* (or **arg** 0) 10.) (- char #/0))))))
+
+(defun debug-upcase (char)
+  (declare (fixnum char))
+  (if (lessp #.(1- #/a) char #.(1+ #/z))
+      (- char #.(- #/a #/A))
+      char))
+
+(defun debug-digitp (char)
+  (declare (fixnum char))
+  (lessp #.(1- #/0) char #.(1+ #/9)))
+
+
+;;;TO GET AROUND JONL'S WEIRD SPELLING
+
+(defprop backtrace baktrace expr) 
+
+;;; This function prints an indented list of functions from the frame
+;;; provided
+
+(defun back-trace (&optional (frame (debug-parse-all-frames)))
+  (cursorpos 'a error-io)
+  (do ((spaces 0 (1+ spaces))
+       (frame frame (debug-frame-next frame)))
+      ((null frame) 'end)
+      (declare (fixnum spaces))
+    (debug-frame-printer frame () t spaces)))
+
+;;; THIS FUNCTION PRINTS THE BAKLIST, A LIST OF THE USER FUNCTIONS
+;;; CALLED, IN A NICE FORMAT I.E. INDENTED
+
+(defun bt (&optional (until 'BT) &aux (btlist (baklist)))
+  (do nil
+      ((or (null btlist) (eq (caar btlist) until)))
+    (setq btlist (cdr btlist)))
+  (cursorpos 'A error-io)
+  (do ((btlist (cdr btlist) (cdr btlist))
+       (spaces 0 (1+ spaces)))
+      ((null btlist) 'END)
+      (declare (fixnum spaces))
+      (debug-n-spaces spaces)
+    (debug-printer (caar btlist) t () )
+    (cursorpos 'a error-io)))
+
+;;; This just prints using the user's special print function if
+;;; he has one.
+
+(defun debug-printer (X sprinter-mode &optional (terpri-p t) (n-spaces 0))
+  (let ((prinlevel (if (eq sprinter-mode 'long) () debug-prinlevel))
+	(prinlength (if (eq sprinter-mode 'long) () debug-prinlength)))
+     (errset (progn (when terpri-p
+			  (cursorpos 'a error-io)
+			  (debug-n-spaces n-spaces))
+		    (cond ((eq sprinter-mode T) (sprin1 x error-io))
+			  (debug-prin1 (funcall debug-prin1 x error-io))
+			  (prin1 (funcall prin1 x error-io))
+			  (T (prin1 x error-io))))
+	     t)
+     (if terpri-p (terpri error-io))))
+
+;; Takes a frame pointer, and prints it.
+
+(defun debug-print-frame (frame sprinter-p &optional suppress)
+  (when (and (not suppress)
+	     (or (null frame) (null (debug-next-valid-frame frame))))
+	(format error-io "~&You are at the bottom of the stack.~%"))
+  (when (and (not suppress)
+	     (or (null frame) (null (debug-previous-valid-frame frame))))
+	(format error-io "~&You are at the top of the stack.~%"))
+  (setq *frame* frame)
+  (setq *cursor* (debug-frame-form frame))
+  (debug-frame-printer frame sprinter-p))
+
+(defun debug-n-spaces (n)
+  (dotimes (\\ n debug-indent-max)
+    (tyo #\SPACE error-io)))
+
+
+(defun debug-frame-printer (frame sprinter-p
+				  &optional (terpri-p 'T) (n-spaces 0)
+				  &aux (form (debug-frame-form frame)))
+  (when (get (debug-frame-plist frame) 'elided-count)
+     (if terpri-p (cursorpos 'a error-io))
+     (princ ";Elided ")
+     (let ((base 10.))
+       (prin1 (get (debug-frame-plist frame) 'elided-count) error-io))
+     (princ " times.")
+     (setq terpri-p t))
+  (if (and (not (atom form))
+	   (eq (car form) 'apply)		;APPLY form
+	   (not (atom (cdr form)))		;of constant
+	   (not (atom (cadr form)))		;#'function format
+	   (eq (caadr form) 'FUNCTION)	;prints nicely
+	   (not (atom (cddr form)))		;but be sure it is a legal
+	   (null (cdddr form)))			;APPLY call
+      (let (( ( () (() function) arguments third) form))
+	(if terpri-p (cursorpos 'A error-io))
+	(debug-n-spaces n-spaces)
+	(princ "(APPLY #'" error-io)
+	(debug-printer function sprinter-p () (+ 9. n-spaces))
+	(terpri error-io)
+	(debug-n-spaces (+ 7 n-spaces))
+	(when (and (not (atom arguments))
+		   (eq (car arguments) 'QUOTE)
+		   (not (atom (cdr arguments)))
+		   (null (cddr arguments)))
+	      (tyo #/' error-io)
+	      (setq arguments (cadr arguments)))
+	(debug-printer arguments sprinter-p () (+ 8. n-spaces))
+	(when third
+	      (terpri error-io)
+	      (debug-n-spaces (+ 7 n-spaces))
+	      (debug-printer third sprinter-p () (+ 7 n-spaces)))
+	(tyo #/) error-io)
+	(if terpri-p (terpri error-io)))
+      (debug-printer form sprinter-p terpri-p n-spaces)))
+
+(defun debug-parse-frame (previous frame)
+  (debug-link-frames previous
+    (let (( (type callstk form bindstk) frame)
+	  (plist (ncons 'DEBUG-FRAME-PLIST)))
+      (caseq (car frame)
+	(APPLY (let (( (function arguments) form))
+		 (cons-a-debug-frame
+		  TYPE type
+		  FUNCTION function
+		  ARGUMENTS arguments
+		  FORM `(apply #',function
+			       ',arguments)
+		  CALLSTK callstk
+		  BINDSTK bindstk
+		  PLIST plist
+		  FRAME-LIST frame)))
+	(EVAL (cons-a-debug-frame
+	       TYPE type
+	       FORM (debug-mexp-check form)
+	       CALLSTK callstk
+	       BINDSTK bindstk
+	       PLIST plist
+	       FRAME-LIST frame))))))
+
+
+(defun debug-mexp-check (form)
+  (if (eq (car form) 'MACROEXPANDED)
+      (cadddr form)
+    form))
+
+(defun debug-parse-all-frames ()
+  (loop for evf = (evalframe ()) then (evalframe (cadr evf))
+	with frame
+	for top-frame = () then (or top-frame frame)
+	until (null evf)
+	when (eq (caaddr evf) '+internal-pdl-break)
+	  do
+	  (loop for check-evf = evf then (evalframe (cadr check-evf))
+	        with elidable-frames
+		for match = (debug-frame-match check-evf elidable-frames)
+		until match
+		unless check-evf
+		  do (setq top-frame (or top-frame frame))
+		     (setq evf ())
+		     (return ())
+		do (setq frame (debug-parse-frame frame check-evf))
+		   (push frame elidable-frames)
+		finally
+		(setq top-frame (or top-frame frame))
+		(loop for elide-evf = check-evf
+				    then (evalframe (cadr elide-evf))
+		      for match = (debug-frame-match elide-evf elidable-frames)
+		      while match
+		      unless elide-evf do (loop-finish)
+		      do (increment-elided-count match)
+		      finally (setq evf elide-evf)))
+	unless evf do (loop-finish)
+	do (setq frame (debug-parse-frame frame evf))
+	finally (return (or top-frame frame))))
+
+(defun debug-frame-match (evf frames)
+  (loop with form = (debug-mexp-check (caddr evf))
+	for frame in frames
+	when (equal form (caddr (debug-frame-frame-list frame)))
+	     return frame
+	finally (return ()) ))
+
+(defun debug-link-frames (previous frame)
+  (setf (debug-frame-previous frame) previous)
+  (if previous
+      (setf (debug-frame-next previous) frame))
+  frame)
+
+(defun increment-elided-count (frame)
+  (setf (get (debug-frame-plist frame) 'elided-count)
+	(1+ (or (get (debug-frame-plist frame) 'elided-count)
+		0))))
+
+(defun debug-analyze-stack (top-frame ignore-frames)
+  (do ((frame top-frame (debug-frame-next frame))
+       (prev top-frame frame))
+      ((null frame)				;start at bottom
+       (do ((frame prev (debug-frame-previous frame))
+	    (fun) (suppressor-fun))
+	   ((null frame))
+	 (caseq (debug-frame-type frame)
+	   (EVAL (setq fun (if (not (atom (debug-frame-form frame)))
+			       (car (debug-frame-form frame)))))
+	   (APPLY (setq fun (debug-frame-function frame))))
+	 (if (or (memq fun ignore-frames)
+		 (memq fun SI:IGNORED-ERROR-FUNS)
+		 (eq fun 'debug-parse-all-frames))
+	     (putprop (debug-frame-plist frame) 'DEBUG-INTERNAL 'SUPPRESSED)
+	     (if (setq suppressor-fun (cdr (assq fun DEBUG-FRAME-SUPPRESSION-ALIST)))
+		 (setq frame (funcall suppressor-fun frame))))))))
+
+
+(defun debug-let-suppressor (frame)
+  (let ((previous (debug-frame-previous frame)))
+    (if (not (and (eq (debug-frame-type frame) 'EVAL)
+		  (eq (debug-frame-type previous) 'EVAL)
+		  (not (atom (debug-frame-form previous)))
+		  (not (atom (car (debug-frame-form previous))))
+		  (eq (caar (debug-frame-form previous)) 'LAMBDA)))
+	frame
+	(putprop (debug-frame-plist previous) 'LET 'SUPPRESSED)
+	previous)))
+
+(push '(LET . debug-let-suppressor) DEBUG-FRAME-SUPPRESSION-ALIST)
+
+(defun debug-garbage-suppressor (frame)
+  (putprop (debug-frame-plist frame) 'GARBAGE 'SUPPRESSED)
+  frame)
+
+(push '(+INTERNAL-TTYSCAN-SUBR . DEBUG-GARBAGE-SUPPRESSOR)
+      DEBUG-FRAME-SUPPRESSION-ALIST)

src/libdoc/lispm.8

@@ -0,0 +1,315 @@
+;;; -*- Mode:Lisp; Fonts:MEDFNB; -*-
+
+;;; LISPM: A library of LispM compatibility software for Maclisp
+
+;;; Created by KMP@MC, 12:30am September 2, 1982
+;;; The master copy of this file is MC:LIBDOC;LISPM >.
+;;; Please do not edit this file. Contact KMP@MC with bugs/comments.
+
+;;; The following are defined by this file:
+;;; 
+;;; Name		Description			LispM Doc Reference
+;;;
+;;; DEFSUBST		macro definition facility	Manual, 4th ed, p215
+;;; DOLIST		iteration construct		Manual, 4th ed, p42
+;;; DOTIMES		iteration construct		Manual, 4th ed, p42
+;;; DO*			iteration construct		(undocumented)
+;;; MEXP		macro expansion utility		Manual, 4th ed, p226
+;;; ONCE-ONLY		macro building utility		Manual, 4th ed, p223
+;;; WITH-OPEN-FILE	file i/o binding abstraction	Manual, 4th ed, p365
+;;; WITH-OPEN-STREAM	stream i/o binding abstraction  (undocumented)
+
+(herald LISPM-COMPATIBILITY /6)
+
+(sstatus feature LISPM-COMPATIBILITY) ; So people can do #+LISPM-COMPATIBILITY
+
+
+;;; (DOLIST (item list) . body)		LispM Manual, 4th ed, p 42
+;;;
+;;; DOLIST is a convenient abbreviation for the most common list iteration.
+;;; DOLIST performs body once for each element in the list which is the 
+;;; value of LIST, with ITEM bound to the successive elements...
+;;; You can use RETURN and GO and PROG-tags inside the body, as with DO.
+;;; DOLIST forms return NIL unless returned from explicitly with RETURN....
+
+(defmacro dolist (spec . body)
+  (cond ((or (atom spec)
+	     (atom (cdr spec))
+	     (cddr spec)
+	     (not (symbolp (car spec))))
+	 (error "Invalid binding spec for DOLIST" spec)))
+  (let ((l (gensym))
+	(item (car spec))
+	(list (cadr spec)))
+    `(do ((,l ,list (cdr ,l))
+	  (,item))
+	 ((null ,l))
+       (setq ,item (car ,l))
+       ,@body)))
+
+
+;;;					LispM Manual, 4th ed, p 223
+;;;
+;;; (ONCE-ONLY (var-list) form1 form2 ...)
+;;;
+;;; VAR-LIST is a list of variables. The FORMs are a lisp program that
+;;; presumably uses the values of those variables. When the form resulting 
+;;; from the expansion of the ONCE-ONLY is evaluated, the first thing it 
+;;; does is to inspect the values of each of the variables in VAR-LIST;
+;;; these values are assumed to be Lisp forms. For each of the variables, it
+;;; binds that variable to either its current value, if the current value is
+;;; a trivial form, or to a generated symbol. Next, once-only evalutes the
+;;; forms in this new binding environment, and when they have been
+;;; evaluated, it undoes the bindings. The result of the evaluation of the
+;;; last FORM is presumed to be a Lisp form, typically the expansion of a
+;;; maro. If all of the variables had been bound to trivial forms, the
+;;; ONCE-ONLY just returns that result. Otherwise, ONCE-ONLY returns the
+;;; result wrapped in a lambda-combination that binds the generated symbols
+;;; to the result of evaluating the respective non-trivial forms.
+
+(defmacro once-only (varlist &body forms)
+  (cond ((or (atom varlist)
+	     (dolist (var varlist) (if (not (symbolp var)) (return t))))
+	 (error "bad variable list in once-only" varlist)))
+  (let ((lose? (gensym))
+	(vars  (gensym)))
+    `(let (,@(mapcar #'list varlist varlist)
+	   (,lose? nil)
+	   (,vars  '()))
+       ,@(mapcar #'(lambda (x)
+		     `(cond ((and (symbolp ,x)
+				  (not (get ,x '+INTERNAL-STRING-MARKER)))
+			     (push (list ',x (gensym) ,x) ,vars))
+			    ((not (or (atom ,x)
+				      (memq (car ,x) '(function quote))))
+			     (setq ,lose? t)
+			     (push (list ',x (gensym) ,x) ,vars))))
+		 varlist)
+       (cond (,lose?
+	      ,@(mapcar #'(lambda (x)
+			    `(setq ,x (or (cadr (assq ',x ,vars)) ,x)))
+			varlist)))
+       (let ((result (progn ,@forms)))
+	 (if ,lose?
+	     `(let ,(mapcar #'cdr (nreverse ,vars)) ;get side-effects right!
+		,result)
+	   result)))))
+
+
+;;; (DOTIMES (index count) . body)	LispM Manual, 4th ed, p 42
+;;; 
+;;; DOTIMES is a convenient abbreviation for the most common integer 
+;;; iteration. DOTIMES performs BODY the number of times given by the value 
+;;; of COUNT, with INDEX bound to 0, 1, etc. on successive iterations...
+;;; You can use RETURN and GO and PROG-tags inside the body, as with DO.
+;;; DOTIMES forms return NIL unless returned from explicitly with RETURN....
+
+(defmacro dotimes (spec . body)
+  (cond ((or (atom spec)
+	     (atom (cdr spec))
+	     (cddr spec)
+	     (not (symbolp (car spec))))
+	 (error "Invalid binding spec for DOTIMES" spec)))
+  (let ((index (car spec))
+	(count (cadr spec)))
+    (once-only (count)
+      `(do ((,index 0 (1+ ,index)))
+	   ((not (< ,index ,count)))
+	 ,@body))))
+
+
+;;; (DEFSUBST name bvl . body)		LispM Manual, 4th ed, p 215
+;;;
+;;; A substitutable function is a function which is open coded by the 
+;;; compiler. It is like anyh other function when applied, but it can be 
+;;; expanded instead, and in that regard it resembles a macro....
+;;;
+;;; Note: Using #'name in code after a DEFSUBST of that name will result in
+;;;	  a proceedable compiler error currently. This is a bug in the 
+;;;	  compiler which will hopefully be fixed. Typing P to the compiler
+;;;	  will make the right thing happen.
+
+(defmacro defsubst (name bvl . body)
+  (cond ((atom bvl)
+	 (error "DEFSUBST can't hack atomic bvl." bvl)))
+  (dolist (var bvl)
+    (cond ((or (not (symbolp var))
+	       (= (getcharn var 1) #/&))
+	   (error "defsubst can't hack this variable spec." var))))
+  (let ((subst-name (symbolconc name " SUBST")))
+    `(progn 'compile
+	    (defmacro ,name ,bvl
+	      ,(cond ((cdr body)
+		      ``(progn
+			 ,@(sublis (list ,@(mapcar #'(lambda (x)
+						       `(cons ',x ,x))
+						   bvl))
+				   ',body)))
+		     (t
+		      `(sublis
+			(list ,@(mapcar #'(lambda (X) `(cons ',x ,x)) bvl))
+			',(car body)))))
+	    (eval-when (eval compile load)
+	      (cond ((status feature complr)
+		     (putprop ',name 't 'defcomplrmac))))
+	    (defun ,subst-name ,bvl ,@body)
+	    (let ((def (getl ',subst-name '(expr subr lsubr))))
+	      (putprop ',name (cadr def) (car def)))
+	    ',name)))
+
+
+;;;					LispM Manual, 4th ed, p 365
+;;;
+;;; (WITH-OPEN-FILE ((var filename . options) . body) ...)
+;;;
+;;; Evaluates the BODY forms with the variable VAR bound to a stream which
+;;; reads or writes the file named by the value of FILENAME. OPTIONS may be
+;;; any number of keywords to be passed open. These options control whether
+;;; a stream is for input from an existing file or output to a new file,
+;;; whether the file is text or binary, etc. The options are the same as 
+;;; those which may be given to the OPEN function.
+;;;
+;;; When control leaves the body, either normally or abnormally (eg, via 
+;;; *THROW), the file is closed.
+;;;
+;;; NOTE: The LispM feature wherein the file is deleted if a throw is done
+;;;       is not currently supported and is not likely to be in the near
+;;;	  future. In any case, code using this compatibility macro should
+;;;	  not make assumptions about its behavior one way or the other on
+;;;	  point. Please contact KMP if you have any troubles in this regard.
+;;;
+;;; Because it always closes the file even when an error exit is taken,
+;;; WITH-OPEN-FILE is preferred over OPEN. Opening a large number of files
+;;; and forgetting to close them is anti-social on some file systems (eg, ITS)
+;;; because there are only a finite number of disk channels available which
+;;; must be shared among the community of logged-in users.
+;;;
+;;; Because the filename will be passed to OPEN, either a namestring or a
+;;; namelist will work. However, code intended to run on the LispM should
+;;; use only namestring format for files since that's all the LispM will
+;;; accept.
+;;;
+;;; NOTE: If an error occurs during the OPEN, the friendly behavior of the 
+;;;	  LispM (wherein a new filename is prompted for) will not occur.
+;;;	  Instead, the IO-LOSSAGE handler will run as for any OPEN, probably
+;;;	  resulting in an error breakpoint. Users are encouraged to verify
+;;;	  the existence of a file before invoking WITH-OPEN-FILE on it.
+
+(defmacro with-open-file ((var filename . options) &body body)
+  (cond ((not (symbolp var))
+	 (error
+	  "bad var. Syntax is: (with-open-file (var file . modes) . body)"
+	  var)))
+  (let ((true-options (cond ((not (cdr options)) (car options))
+			    ((not (dolist (option options)
+				    (if (or (atom option)
+					    (not (eq (car option) 'quote)))
+					(return t))))
+			     `',(mapcar #'cadr options))
+			    (t
+			     `(list ,@options)))))
+    `(with-open-stream (,var (open ,filename ,true-options))
+		       ,@body)))
+
+
+;;;					Not documented in LispM Manual, 4th ed
+;;;
+;;; (WITH-OPEN-STREAM (var exp) . body)
+;;;
+;;; Like WITH-OPEN-FILE but exp may be an arbitrary form to accomplish the
+;;; OPEN. The result of evaluating EXP should be a file or sfa. BODY will be
+;;; evaluated in a context where VAR is bound to that file or sfa. 
+;;; Upon return, as with WITH-OPEN-FILE, the file or sfa will be closed.
+;;;
+;;; Note: This is a reasonably low-level primitive. If you don't know the
+;;;       which you want of WITH-OPEN-FILE or WITH-OPEN-STREAM, you almost
+;;;	  surely want WITH-OPEN-FILE.
+
+(defmacro with-open-stream (bindings &body body)
+  (cond ((or (atom bindings)
+	     (not (symbolp (car bindings))) ;var to bind
+	     (atom (cdr bindings))
+	     (not (null (cddr bindings))))
+	 (error "bad bindings. Syntax is: (WITH-OPEN-STREAM (var form) . body)"
+		bindings)))
+  (let (((var val) bindings)
+	(temp (gensym)))
+    `(let ((,temp nil))
+       (unwind-protect (progn (without-interrupts (setq ,temp ,val))
+			      (let ((,var ,temp))
+				,@body))
+		       (if (or (filep ,temp)
+			       (sfap  ,temp))
+			   (close ,temp))))))
+
+
+;;; (MEXP)				LispM Manual, 4th ed, p 226
+;;;
+;;; MEXP goes into a loop in which it reads forms and sequentially expands
+;;; them, printing out the result of each expansion (using the pretty printer
+;;; to improve readability). It terminates when it reads an atom. If you type 
+;;; in a form which is not a macro form, there will be no expansions. This
+;;; allows you to see what your macros are expanding into without actually 
+;;; evaluating the result of the expansion.
+
+(defun mexp ()
+  (do ((form)) (nil)
+    (errset
+     (progn
+      (format t "~&> ")
+      (setq form (read))
+      (cond ((atom form) (return nil)))
+      (cond ((symbolp (car form))
+	     (let ((fn (car form)))
+	       (cond ((and (not (get fn 'macro))
+			   (not (getl fn '(expr fexpr subr lsubr fsubr))))
+		      (let ((autoload-file (get fn 'autoload)))
+			(cond (autoload-file
+			       (format t "~&;Autoloading ~A looking for ~S..."
+				       (namestring autoload-file)
+				       fn)
+			       (load (get fn 'autoload))
+			       (format t "~%"))))))
+	       (cond ((get fn 'macro)
+		      (do ((form (macroexpand-1 form) (macroexpand-1 form)))
+			  (nil)
+			(format t "~& ==> ")
+			(sprin1 form)
+			(cond ((or (atom form)
+				   (not (symbolp (car form)))
+				   (not (get (car form) 'macro)))
+			       (return nil)))))
+		     (t
+		      (format t "~&;~S has no macro definition." fn)))))
+	    (t
+	     (format t
+		     "~&;CAR of that form is not a symbol, but I'll try it...~
+		      ~% ==> ")
+	     (sprin1 (macroexpand form)))))
+     t)))
+
+;;; (DO* bindings exitforms . body)	...undocumented...
+;;;
+;;; Like DO, but does sequential assignment rather than parallel assignment.
+
+(defmacro do* (bindings exitforms &body body)
+  (cond ((< (length bindings) 2)
+	 `(do ,bindings ,exitforms ,@body))
+	(t
+	 `(let* ,(mapcar #'(lambda (x)
+			     (if (atom x) x
+			       (cons (car x) (if (cdr x) (list (cadr x))))))
+			 bindings)
+	    (do () ,exitforms
+	      ,@body
+	      ,@(mapcan #'(lambda (x)
+			    (if (and (not (atom x)) (cddr x))
+			      (ncons `(setq ,(car x) ,(caddr x)))))
+			bindings))))))
+
+
+
+;;; Local Modes:;
+;;; Mode:LISP;
+;;; Lisp ONCE-ONLY Indent:1;
+;;; End:;