(FILECREATED "22-JUL-83 01:21:25" <NEWLISP>ASSIST.;2 81660
changes to: (FNS DO?= READVBAR)
previous date: " 9-MAR-83 22:25:40" <LISP>ASSIST.;157)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT ASSISTCOMS)
(RPAQQ ASSISTCOMS [[COMS (FILEPKGCOMS CONSTANTS)
(P (MOVD? (QUOTE *)
(QUOTE CONSTANTS]
(COMS * BQUOTECOMS)
(COMS (* Read macros for ' * and ↑W)
(FNS CONTROLW READLINEP READ' READCOMMENT GETCOMMENT PRINTCOMMENT)
[VARS (NORMALCOMMENTSFLG (COND ((NOT (BOUNDP (QUOTE NORMALCOMMENTSFLG)))
T)
(T NORMALCOMMENTSFLG]
[P (PROGN (SETSYNTAX (QUOTE ')
(QUOTE (MACRO FIRST NOESC READ'))
EDITRDTBL)
(SETSYNTAX (QUOTE ')
EDITRDTBL T))
(PROGN (SETSYNTAX (CHARCODE ↑W)
(QUOTE (INFIX IMMEDIATE CONTROLW))
T)
(SETSYNTAX (CHARCODE ↑W)
T EDITRDTBL)
(ECHOCONTROL (CHARCODE ↑W)
(QUOTE IGNORE)))
(SETSYNTAX (QUOTE *)
(QUOTE (INFIX ALONE NOESC READCOMMENT))
FILERDTBL)
(MAPC (CHARCODE (↑A ↑B ↑C ↑D ↑E ↑F))
(FUNCTION (LAMBDA (X)
(ECHOCONTROL X (QUOTE IGNORE]
(ADDVARS (PRETTYPRINTMACROS (* . PRINTCOMMENT)))
(USERMACROS GET*)
(DECLARE: DOEVAL@COMPILE DONTCOPY (RECORDS COMMENTBOX)))
[COMS (FNS PRINTPROPS PRINTBINDINGS)
(LISPXMACROS PL PB ;)
(BLOCKS (PRINTPROPS PRINTPROPS (NOLINKFNS . T)
(GLOBALVARS SPELLINGS1 SPELLINGS2 USERWORDS))
(PRINTBINDINGS PRINTBINDINGS (NOLINKFNS . T]
[COMS (FNS SHOWPRINT SHOWPRIN2)
(VARS (SYSPRETTYFLG))
(BLOCKS (NIL SHOWPRINT SHOWPRIN2 (GLOBALVARS SYSPRETTYFLG]
(COMS (FNS DO? DO?=)
(VARS (LAST?))
(P (SETSYNTAX (QUOTE ?)
(QUOTE (INFIX FIRST NOESC DO?))
T)
(SETSYNTAX (QUOTE ?)
T EDITRDTBL))
(PROP ARGNAMES DEFINEQ)
(USERMACROS ?=))
(COMS * ASKUSERCOMS)
(COMS (* Coroutine package.)
(FNS * COFNS)
(FNS * GENERFNS)
(ADDVARS (SYSSPECVARS COMVAR## POSSLIST##))
(P (MOVD? (QUOTE OLDRESUME)
(QUOTE RESUME)))
(PROP (MACRO INFO)
* COMACROS)
(I.S.OPRS OUTOF)
(PROP BYTEMACRO GENERATOR POSSIBILITIES))
(COMS * GAINSPACECOMS)
(BLOCKS (NIL READ' CONTROLW (LINKFNS . T))
(NIL READLINEP (GLOBALVARS LISPXREADFN))
(NIL READCOMMENT PRINTCOMMENT GETCOMMENT
(GLOBALVARS **COMMENT**FLG CHANGEFLG0 CLISPCHARRAY CLISPFLG COMMENTFLG
COMMENTFONT DEFAULTFONT FILERDTBL FIRSTCOL FONTCHANGEFLG
NORMALCOMMENTSFLG TTYFONTCHANGEFLG)
(LINKFNS . T))
(NIL DO?= DO? (GLOBALVARS LAST?)
(NOLINKFNS HELPSYS)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML TRYNEXT POSSIBILITIES GENERATOR COROUTINE BQUOTE ASKUSERLOOKUP)
(LAMA AU-REVOIR ADIEU])
(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) [QUOTE ((COM MACRO (X (DECLARE: EVAL@COMPILE
(VARS . X)
(P (CONSTANTS . X])
(MOVD? (QUOTE *)
(QUOTE CONSTANTS))
(RPAQQ BQUOTECOMS ((* BQUOTE AND FRIENDS)
(FNS READVBAR READBQUOTE)
(FNS EXPANDBQUOTE BQUOTE DOBQUOTE)
(MACROS BQUOTE)
(P (SETSYNTAX (QUOTE %|)
(QUOTE (INFIX READVBAR))
FILERDTBL)
(SETSYNTAX (QUOTE %|)
(QUOTE (INFIX READVBAR))
T)
(SETSYNTAX (QUOTE %|)
(QUOTE (INFIX READVBAR))
EDITRDTBL))))
(* BQUOTE AND FRIENDS)
(DEFINEQ
(READVBAR
[LAMBDA (FILE RDTBL TC) (* lmm "22-JUL-83 01:01")
(PROG NIL
LP (RETURN (SELECTQ (PEEKC FILE)
(' (READC FILE)
(TCONC TC (READBQUOTE FILE RDTBL)))
(% (READC FILE)
(GO LP))
((%( { ↑)
(TCONC TC (HREAD FILE)))
TC])
(READBQUOTE
[LAMBDA (FILE RDTBL) (* lmm " 7-APR-82 23:11")
(RESETLST (RESETSAVE NIL (LIST (QUOTE SETSYNTAX)
(QUOTE ,)
(SETSYNTAX (QUOTE ,)
[QUOTE (MACRO FIRST (LAMBDA (FILE RDTBL)
(SELECTQ (PEEKC FILE)
(%. (READC FILE)
(QUOTE ,.))
(, (READC FILE)
(QUOTE ,,))
(! (READC FILE)
(QUOTE ,!))
(@ (READC FILE)
(QUOTE ,@))
(QUOTE ,]
RDTBL)
RDTBL))
(LIST (QUOTE BQUOTE)
(READ FILE RDTBL])
)
(DEFINEQ
(EXPANDBQUOTE
[LAMBDA (X) (* lmm "14-MAY-82 22:55")
(* This function does the expansion of a BQUOTEd form.)
(COND
((NLISTP X)
(LIST (QUOTE QUOTE)
X))
(T (SELECTQ (CAR X)
[, (LIST (QUOTE CONS)
(CADR X)
(EXPANDBQUOTE (CDDR X]
[(,. ., ,, ,@ ,!)
(COND
[(CDDR X)
(LIST (SELECTQ (CAR X)
((., ,.)
(QUOTE NCONC))
(QUOTE APPEND))
(CADR X)
(EXPANDBQUOTE (CDDR X]
(T (CADR X]
(PROG [(BCAR (EXPANDBQUOTE (CAR X)))
(BCDR (EXPANDBQUOTE (CDR X]
(RETURN (COND
[(AND (EQ (CAR BCAR)
(QUOTE QUOTE))
(EQ (CAR BCDR)
(QUOTE QUOTE)))
(LIST (QUOTE QUOTE)
(CONS (CADR BCAR)
(CADR BCDR]
(T (LIST (QUOTE CONS)
BCAR BCDR])
(BQUOTE
[NLAMBDA (BQUOTEX) (* lmm "31-MAR-82 23:34")
(DECLARE (LOCALVARS . T))
(DOBQUOTE BQUOTEX])
(DOBQUOTE
[LAMBDA (BQUOTEX) (* lmm "14-MAY-82 22:58")
(DECLARE (LOCALVARS . T)) (* This function does the expansion of a BQUOTEd form.)
(COND
((NLISTP BQUOTEX)
BQUOTEX)
(T (SELECTQ (CAR BQUOTEX)
[, (CONS (EVAL (CADR BQUOTEX)
(QUOTE INTERNAL))
(DOBQUOTE (CDDR BQUOTEX]
[(., ,.)
(COND
[(CDDR BQUOTEX)
(NCONC (EVAL (CADR BQUOTEX)
(QUOTE INTERNAL))
(DOBQUOTE (CDDR BQUOTEX]
(T (EVAL (CADR BQUOTEX)
(QUOTE INTERNAL]
[(,, ,@ ,!)
(COND
[(CDDR BQUOTEX)
(APPEND (EVAL (CADR BQUOTEX)
(QUOTE INTERNAL))
(DOBQUOTE (CDDR BQUOTEX]
(T (EVAL (CADR BQUOTEX)
(QUOTE INTERNAL]
(PROG [(BCAR (DOBQUOTE (CAR BQUOTEX)))
(BCDR (DOBQUOTE (CDR BQUOTEX]
(RETURN (COND
((AND (EQ BCAR (CAR BQUOTEX))
(EQ BCDR (CDR BQUOTEX)))
BQUOTEX)
(T (CONS BCAR BCDR])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS BQUOTE MACRO (FORM (EXPANDBQUOTE (CAR FORM))))
)
(SETSYNTAX (QUOTE %|)
(QUOTE (INFIX READVBAR))
FILERDTBL)
(SETSYNTAX (QUOTE %|)
(QUOTE (INFIX READVBAR))
T)
(SETSYNTAX (QUOTE %|)
(QUOTE (INFIX READVBAR))
EDITRDTBL)
(* Read macros for ' * and ↑W)
(DEFINEQ
(CONTROLW
[LAMBDA (X Y Z) (* lmm "17-JUN-82 19:36")
(PROG (TEM)
[RETURN (COND
[(NEQ X T)
(TCONC Z (CONSTANT (CHARACTER (CHARCODE ↑W]
[(NULL Z) (* Control-w not inside of a list)
(COND
[(NULL (READLINEP))
(* and not inside of a readline. read it.)
(PRIN1 (QUOTE "↑W")
T)
(TCONC Z (CONSTANT (CHARACTER (CHARCODE ↑W]
((NULL LINE)
(* trying to delete in empty line.)
(PRIN1 (CONSTANT (CHARACTER (CHARCODE BELL)))
T)
NIL)
((NULL (CDR LINE))
(SETQ TEM (CAR LINE))
(SETQ LINE NIL)
(GO ECHO))
((NULL (CDDR LINE))
(* reason we erase the last two things from LINE and return the first back is so thatif user then types a c.r.
the readline will terminate. remember the control-w was typed while in a call to read. Note that if there was just
one thing on the line and the user typed a control-w, a c.r. will not suffice to terminate.)
(SETQ TEM (CADR LINE))
(SETQ Z (TCONC NIL (CAR LINE)))
(SETQ LINE NIL)
(GO ECHO))
(T (SETQ TEM (NLEFT LINE 3))
(SETQ TEM (PROG1 (CADDR TEM)
(SETQ Z (TCONC NIL (CADR TEM)))
(RPLACD TEM)))
(GO ECHO]
((NULL (CAR Z))
(PRIN1 (CONSTANT (CHARACTER (CHARCODE BELL)))
T)
Z)
(T (SETQ TEM (CADR Z))
[COND
((NULL (CDAR Z))
(RPLACD Z NIL)
(RPLACA Z NIL))
((RPLACD Z (NLEFT (CAR Z)
2))
(RPLACD (CDR Z]
(GO ECHO]
ECHO(PRIN1 (QUOTE \\)
T)
(PRIN2 [COND
([OR (NLISTP TEM)
(NULL (CDR TEM))
(AND (NULL (CDDR TEM))
(ATOM (CADR TEM]
TEM)
(T (CONS (CAR TEM)
(QUOTE (--]
T)
(SPACES 1 T)
(RETURN Z])
(READLINEP
[LAMBDA (POS) (* wt: "13-JUN-79 15:08")
(* returns T if under a readline)
(PROG (SCRATCHPOS)
(RETURN (AND (SETQ SCRATCHPOS (STKPOS LISPXREADFN -1 POS))
(PROG1 (EQ (STKNAME (REALSTKNTH -1 SCRATCHPOS NIL SCRATCHPOS))
(QUOTE READLINE))
(RELSTK SCRATCHPOS])
(READ'
[LAMBDA (FILE RDTBL) (* lmm "31-MAR-82 23:29")
(PROG [(CH (CHCON1 (PEEKC FILE]
(RETURN (COND
((OR (SYNTAXP CH (QUOTE SEPR)
RDTBL)
(SYNTAXP CH (QUOTE RIGHTPAREN)
RDTBL)
(SYNTAXP CH (QUOTE RIGHTBRACKET)
RDTBL))
(QUOTE '))
(T (KWOTE (READ FILE RDTBL])
(READCOMMENT
[LAMBDA (FL RDTBL LST) (* lmm " 5-NOV-82 00:36")
(PROG (X START END NCHARS POS TEM FLG FL1 N)
[COND
((OR (NULL LST)
(CAR LST)
(EQ FL T)
(EQ NORMALCOMMENTSFLG T)
(NOT (RANDACCESSP FL)))
(* the * appears interior to a lit.)
(RETURN (TCONC LST COMMENTFLG]
(SETQ FLG (ILESSP (SETQ N (POSITION FL))
26))
(* comment starts at left margin. use 26 to take into account font info. (there can be up to three ↑F sequences,
which accounts for an extra 12 throwing position off by 12.0 position should be 10 + 1 for left paren + 1 for * + 1
for space.))
(SETQ POS (GETFILEPTR FL))
(COND
([SELECTQ (SETQ TEM (RATOM FL RDTBL))
((%( %) %[ %] %" ' %. DECLARATIONS: E)
T)
(COND
((NUMBERP TEM)
T)
((EQ TEM COMMENTFLG)
NIL)
((AND CLISPFLG CLISPCHARRAY (STRPOSL CLISPCHARRAY TEM))
T)
(T (SELECTQ (PEEKC FL)
((%) %] ←)
T)
NIL]
(* an attempt to distinguish comments from non comments. if * is followed by list, or only one thing, then assume
not a comment. The numberp check is in case user has done a makefile fast and actually written out a comment in
abbreviated form.)
(GO NO)))
(SETFILEPTR FL (SETQ START (IPLUS POS -2)))
[COND
((EQ N 2)
(* problem is that a terpri preceded the *. this can happen for comments that werent prettyprinted, e.g. were part
of data structures. in this case, to get back to the %(, must back up another two characters,
(one for the *, two for c.r./l.f., and one for paren))
(SETFILEPTR FL (SETQ START (IPLUS START -2]
(* BACKUP TWO , SKIPPING OVER THE * AND THE "(")
[COND
((EQ (SKREAD FL)
(QUOTE %]))
(* comment ends in %] means that it is not in a function, and better not use abbreviated form because when recopied
the %] would be recopied, but prettyprint wouldnt know about it and print anther.)
(SETFILEPTR FL POS)
(RETURN (TCONC LST COMMENTFLG]
(SETQ NCHARS (IDIFFERENCE (SETQ END (GETFILEPTR FL))
START))
(SETFILEPTR FL (SUB1 END))
(* READ had previously seen a left-paren before the * read macro was invoked. This backs up over the closing RIGHT
paren so that the read will terminate this list.)
(COND
([AND NORMALCOMMENTSFLG (OR (AND (BOUNDP NORMALCOMMENTSFLG)
(OPENP (SETQ FL1 (EVALV NORMALCOMMENTSFLG))
(QUOTE OUTPUT)))
(OPENP (SETQ FL1 NORMALCOMMENTSFLG)
(QUOTE OUTPUT]
(* if the value of the value of NORMALCOMMENTSFLG, or the value of NORMALCOMMENTSFLG is the name of an open file,
the comment is coied to the file. this provides a mechanism for storing all comments in one file to be associated
with the sysout or makesys. this feature is useful when one is using commentboxes to store text for messages, where
one does not want to have the material in core, and does not want it scattered over many files.
the extra levelof indirection is so that the source file can be renamed to a different directory and the variable
simply reset)
(SETQ TEM (GETFILEPTR FL1))
(COPYBYTES FL FL1 START END)
(* the copybyes changes the file pointer)
(SETFILEPTR FL (SUB1 END))
(SETQ START TEM)
(SETQ FL NORMALCOMMENTSFLG)))
[RETURN (LCONC LST (create COMMENTBOX
START ← START
NCHARS ← NCHARS
FLG ← FLG
FILE ←(OR FL (INPUT]
NO (SETFILEPTR FL POS)
(RETURN (TCONC LST COMMENTFLG])
(GETCOMMENT
[LAMBDA (X DESTFL DEF) (* DECLARATIONS: UNDOABLE)
(* lmm " 5-NOV-82 00:32")
(PROG (ST NC FL FLG STR TEM)
(RETURN (COND
((AND [OR (NUMBERP (SETQ ST (fetch (COMMENTBOX START) of X)))
(AND (LISTP ST)
(NUMBERP (CAR ST))
(NUMBERP (CDR ST))
(SETQ ST (IPLUS (ITIMES (CAR ST)
1000)
(CDR ST]
(NUMBERP (SETQ NC (fetch (COMMENTBOX NCHARS) of X)))
(SETQ FL (fetch (COMMENTBOX FILE) of X))
(OR (NULL (SETQ FLG (fetch (COMMENTBOX FLG) of X)))
(EQ FLG T))
(NULL (fetch (COMMENTBOX REST) of X))
(NEQ FL DESTFL)
(NOT (ILESSP ST 0)))
(* The NEQ is because if the exact same comment is printed twice, e.g. once in COMS once when printed, then it would
already have been updated in this case, we will have to print the actual comment with numbers in it, but when the
file is loaded, the effect will be the same as though we had printed the comment, except that there will be two
comments pointing to the same locations. which is perfectly ok.)
[COND
((BOUNDP FL)
(* see comment in readcomment)
(SETQ FL (EVALV FL]
[COND
((NOT (OPENP FL (QUOTE INPUT)))
(COND
([NULL (NLSETQ (SETQ FL (OPENFILE FL (QUOTE INPUT]
(COND
([NOT (MEMB (SETQQ TEM "can't find file ")
(LISTGET1 LISPXHIST (QUOTE *LISPXPRINT*]
(LISPXPRIN1 TEM T)
(LISPXPRIN2 (fetch (COMMENTBOX FILE) of X)
T)
(LISPXPRIN1 " - comments lost
" T)))
(RETURN X)))
(RESETSAVE NIL (LIST (QUOTE CLOSEF?)
FL]
(SETFILEPTR FL ST)
(COND
[(NULL DESTFL)
(* means read it in. called from GET* edit macro)
(RESETVARS ((NORMALCOMMENTSFLG T))
(RETURN (/RPLNODE2 X (READ FL FILERDTBL]
(T [COND
(DEF (SETQ STR (CHANGEFONT DEFAULTFONT))
(* Want to be in defaultfont before we space over.)
[COND
(FLG (ENDLINE1)
(ENDLINE1 10 NIL T))
((IGREATERP (IPLUS (SETQ TEM (POSITION))
3)
FIRSTCOL)
(* This is essentially a TAB, except will cause changechar to get printed.)
(ENDLINE1 FIRSTCOL NIL T))
(T (SPACES (IDIFFERENCE FIRSTCOL TEM]
(COND
(COMMENTFONT (CHANGEFONT COMMENTFONT]
(COND
((AND (NEQ NORMALCOMMENTSFLG (QUOTE DONTUPDATE))
(NOT (DISPLAYP DESTFL)))
(* i have several times gotten scrwed by being in a sysout in whcih i had dumped multiple versions of a file and
accidentally deleted the original parent so that the comments were lost and had to be recovered.
this updates the comments to point to the newest file. note you can still lose out if you do not edit a particular
function (so that it is simply copied in toto) until after you delete the original parent. of course, you can
recover by doing a loadfns and reediting.)
(* the NORMALCOMMENTSFLG check is so that prettyprint can disable this when necessary, e.g. when printing COMS.
otherwise when it goes to print a coment in a coms, it has already been updated and all that gets put out is the
comment box.)
(replace (COMMENTBOX START) of X with (GETFILEPTR DESTFL))
(replace (COMMENTBOX FILE) of X with DESTFL)))
(COPYBYTES FL DESTFL ST (IPLUS ST NC))
(* notice we cant do anything bout the presence or absence of changechar in the
magin during the text of the comment.)
(COND
(STR (CHANGEFONT STR)))
(COND
((AND DEF FLG)
(ENDLINE1)
(ENDLINE1)))
NIL)))
(T X])
(PRINTCOMMENT
[LAMBDA (X) (* lmm " 5-NOV-82 00:34")
(PROG (FL)
(RETURN (COND
((OR (NULL DEF)
(NULL FORMFLG))
(* this is not eally a comment and so shouldnt be prttyprinted as such)
(GETCOMMENT X))
((AND (DISPLAYP (SETQ FL (OUTPUT)))
**COMMENT**FLG)
(PRIN1 **COMMENT**FLG)
NIL)
((OR CHANGEFLG0 (DISPLAYP FL))
(* want the comment to actually be prettyprinted in the case that changeflg0 is
on)
(GETCOMMENT X))
(T (* DEF is bound in prettyprint block)
(GETCOMMENT X FL DEF])
)
(RPAQ NORMALCOMMENTSFLG (COND ((NOT (BOUNDP (QUOTE NORMALCOMMENTSFLG)))
T)
(T NORMALCOMMENTSFLG)))
(PROGN (SETSYNTAX (QUOTE ')
(QUOTE (MACRO FIRST NOESC READ'))
EDITRDTBL)
(SETSYNTAX (QUOTE ')
EDITRDTBL T))
(PROGN (SETSYNTAX (CHARCODE ↑W)
(QUOTE (INFIX IMMEDIATE CONTROLW))
T)
(SETSYNTAX (CHARCODE ↑W)
T EDITRDTBL)
(ECHOCONTROL (CHARCODE ↑W)
(QUOTE IGNORE)))
(SETSYNTAX (QUOTE *)
(QUOTE (INFIX ALONE NOESC READCOMMENT))
FILERDTBL)
[MAPC (CHARCODE (↑A ↑B ↑C ↑D ↑E ↑F))
(FUNCTION (LAMBDA (X)
(ECHOCONTROL X (QUOTE IGNORE]
(ADDTOVAR PRETTYPRINTMACROS (* . PRINTCOMMENT))
(ADDTOVAR EDITMACROS (GET* NIL (BIND (IF (NEQ (SETQ #1 (GETCOMMENT (##)))
(##))
((I : #1)
1)
NIL))))
(ADDTOVAR EDITCOMSA GET*)
(DECLARE: DOEVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD COMMENTBOX (HEAD START NCHARS FILE FLG . REST)
HEAD ← COMMENTFLG)
]
)
(DEFINEQ
(PRINTPROPS
[LAMBDA (AT) (* wt: "23-JUL-78 21:46")
(RESETFORM (PRINTLEVEL (QUOTE (2 . 3)))
(MAP (OR (LISTP (GETPROPLIST AT))
[LISTP (GETPROPLIST (OR (FIXSPELL AT NIL USERWORDS T)
(FIXSPELL AT NIL SPELLINGS2 T)
(FIXSPELL AT NIL SPELLINGS1 T]
(PROGN (PRINT AT T)
NIL))
(FUNCTION [LAMBDA (TL)
(PRIN2 (CAR TL)
T T)
(PRIN1 " : " T)
(SHOWPRINT (CADR TL)
T T])
(FUNCTION CDDR])
(PRINTBINDINGS
[LAMBDA (AT POS FL) (* wt: "24-JAN-79 11:07")
(* Print out the bindings of an atom)
(RESETFORM (PRINTLEVEL 2 3)
(PROG (NAME VAL EPOS)
(OR FL (SETQ FL T))
[SETQ POS (STKNTH 0 (OR POS (QUOTE PRINTBINDINGS]
LP (OR (SETQ POS (STKSCAN AT POS POS))
(GO OUT))
(SETQ VAL (STKARG AT POS))
(PRIN1 (QUOTE "@ ")
FL)
(PRIN2 (STKNAME POS)
FL T)
[COND
((NOT (REALFRAMEP POS))
(PRIN1 "/" FL)
(PROG NIL
(SETQ EPOS (STKNTH 1 POS EPOS))
LP (COND
((REALFRAMEP EPOS)
(PRIN2 (STKNAME EPOS)
FL T))
((SETQ EPOS (STKNTH 1 EPOS EPOS))
(GO LP))
(T (PRIN1 "? " FL]
(PRIN1 (QUOTE " : ")
FL)
(SHOWPRINT VAL FL T)
(AND (SETQ POS (STKNTH 1 POS POS))
(GO LP))
OUT (RELSTK EPOS)
(PRIN1 "@ " FL)
LAST(PRIN1 (QUOTE "TOP : ")
FL)
(SHOWPRINT (GETTOPVAL AT)
FL T)
(RETURN])
)
(ADDTOVAR LISPXHISTORYMACROS [PL (COND (LISPXLINE (PRINTPROPS (CAR LISPXLINE)))
(T (QUOTE (E PL]
[PB (MAPC LISPXLINE (FUNCTION (LAMBDA (X)
(PRINTBINDINGS
X
(AND (EQ LISPXID (QUOTE :))
LASTPOS]
(; NIL NIL))
(ADDTOVAR HISTORYCOMS ;)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: PRINTPROPS PRINTPROPS (NOLINKFNS . T)
(GLOBALVARS SPELLINGS1 SPELLINGS2 USERWORDS))
(BLOCK: PRINTBINDINGS PRINTBINDINGS (NOLINKFNS . T))
]
(DEFINEQ
(SHOWPRINT
[LAMBDA (X FILE RDTBL) (* wt: " 1-JAN-79 23:23")
(COND
[SYSPRETTYFLG (RESETFORM (OUTPUT FILE)
(PROGN (PRINTDEF X T)
(TERPRI FILE]
(T (PRINT X FILE RDTBL)))
X])
(SHOWPRIN2
[LAMBDA (X FILE RDTBL) (* wt: " 1-JAN-79 23:23")
(COND
(SYSPRETTYFLG (RESETFORM (OUTPUT FILE)
(PRINTDEF X T)))
(T (PRIN2 X FILE RDTBL)))
X])
)
(RPAQQ SYSPRETTYFLG NIL)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL SHOWPRINT SHOWPRIN2 (GLOBALVARS SYSPRETTYFLG))
]
(DEFINEQ
(DO?
[LAMBDA (FILE RDTBL LST) (* rmk: " 6-JUN-82 16:19"
)
(PROG (C TAIL FORM FN TEM LN)
(SETQ C (PEEKC FILE))
[COND
[(OR
(NEQ FILE T)
(SELECTQ
C
[(%
= ↑)
(NOT (SETQ TAIL
(COND
([AND (READLINEP)
(SETQ LN LINE)
LISPXFLG
(OR (EQ (INREADMACROP)
1)
(NOT (CAR LST]
(* Says you are arguments to a functio in apply
format, and either at top level
(the inreadmacrop) or one level down but havent
typed a functionname, e.g. typing FOO
(A B (? -
would tell you about FOO)))
(SETQ FORM (CONS (SETQ FN (CAR LINE))
(CAR LST)))
(* For ?= purposes.)
LINE)
(T (SETQ FORM (CAR LST]
T)) (* False alarm.)
(RETURN (TCONC LST (COND
((OR (SYNTAXP (SETQ C (CHCON1 C))
(QUOTE SEPR)
RDTBL)
(SYNTAXP C (QUOTE BREAK)
RDTBL))
(* would have been
separated anyway.)
(QUOTE ?))
(T (PACK* (QUOTE ?)
(READ FILE RDTBL]
((EQ C (QUOTE %
))
(AND (XNLSETQ
[SETQ TEM
(COND
((AND (NEQ LAST? (SETQ LAST? (CAR TAIL)))
LST
(CDR FORM)
(FNCHECK (CAR FORM)
T NIL T TAIL))
(* User typed ? after supplying some arguments, so
only give him info about that argument.)
(HELPSYS (LENGTH FORM)
(QUOTE ARGS)
(CAR FORM)
(QUOTE FD)))
(T (HELPSYS (CAR TAIL)
(AND (FNTYP (CAR TAIL))
(QUOTE FD]
NOBREAK)
(NULL TEM)
(PRIN1 (QUOTE "unavailable subject.
")
T)))
[(AND (EQ (SETQ TEM (READ FILE RDTBL))
(QUOTE =))
(EQ (PEEKC FILE)
(QUOTE %
)))
(ERSETQ (PROGN (DO?= TAIL FORM)
(TERPRI FILE]
[(AND (EQ (CHCON1 TEM)
(CHARCODE ↑))
(EQ (PEEKC FILE)
(QUOTE %
)))
(ERSETQ (APPLY* (FUNCTION PF)
(CAR FORM)
(AND (IGREATERP (NCHARS TEM)
1)
(SUBATOM TEM 2 -1]
(T (RETURN (TCONC LST (PACK* (QUOTE ?)
TEM]
(AND (CDDR LST)
(FRPLACD LST (FLAST LST))) (* remove the ?)
(TERPRI T)
(AND FN (PRIN2 FN T T))
[AND LN (MAPRINT (CDR LN)
T " " " " NIL (FUNCTION (LAMBDA (X)
(PRIN2 X T T]
[AND LST (MAPRINT (CAR LST)
T "(" " " NIL (FUNCTION (LAMBDA (X)
(PRIN2 X T T] (* tell the user where
he is)
(RETURN LST])
(DO?=
[LAMBDA (TAIL FORM FILE LEFT) (* lmm "22-JUL-83 01:20")
(ERSETQ (RESETFORM (PRINTLEVEL 3)
(PROG (ARGNAMES TEM)
(OR FILE (SETQ FILE T))
(OR LEFT (SETQ LEFT 0))
(COND
((NULL FORM)
(* from editor)
(SETQQ COM ?=)
(OR (LISTP TAIL)
(ERROR!))
(SETQ FORM TAIL)))
(SETQ ARGNAMES (SMARTARGLIST (CAR TAIL)
T TAIL))
[COND
((AND (LISTP ARGNAMES)
(NULL (CDR ARGNAMES))
(OR (EQ (SETQ TEM (ARGTYPE (CAR TAIL)))
2)
(EQ TEM 3)))
(SETQ ARGNAMES (CAR ARGNAMES]
(* tail provided for spelling correction purposes.)
(COND
[(OR (NULL ARGNAMES)
(LISTP ARGNAMES))
(COND
((NULL (CDR FORM))
(PRIN2 (CONS (CAR FORM)
ARGNAMES)
FILE T))
(T [eachtime (SETQ FORM (CDR FORM)) while (AND FORM ARGNAMES)
do (AND (NEQ LEFT 0)
(SPACES LEFT FILE))
(COND
((NEQ (CAR ARGNAMES)
(QUOTE ...))
(PRIN2 (CAR ARGNAMES)
FILE T)
(SETQ ARGNAMES (CDR ARGNAMES)))
(T (SPACES 2 FILE)))
(PRIN1 " = " FILE)
(PRIN2 (COND
((NEQ FILE T)
(RETDWIM3 (CAR FORM)
NIL 10 3))
(T (CAR FORM)))
FILE T)
(COND
((OR (CDR FORM)
ARGNAMES)
(* i have an application where i do not want that last terpri printed, which is
why i go to this trouble.)
(TERPRI FILE]
(COND
((AND (EQ FILE T)
(EQ (CAR ARGNAMES)
(QUOTE ...)))
(PRIN1 (QUOTE ".
.
")
FILE)
(PRIN2 (CADR ARGNAMES)
FILE T)
(PRIN1 " = " FILE))
[FORM (MAPRINT FORM FILE "plus ... " (QUOTE %))
NIL
(COND
[(NEQ FILE T)
(FUNCTION (LAMBDA (X)
(PRIN2 (RETDWIM3 X NIL 10 3)
FILE T]
(T (QUOTE PRIN2]
(ARGNAMES (MAPRINT ARGNAMES FILE NIL " = " (QUOTE ,]
(T (PRIN1 ARGNAMES FILE)
(MAPRINT (CDR FORM)
FILE " = ... " (QUOTE %))
NIL
(COND
[(NEQ FILE T)
(FUNCTION (LAMBDA (X)
(PRIN2 (RETDWIM3 X NIL 10 3)
FILE T]
(T (QUOTE PRIN2])
)
(RPAQQ LAST? NIL)
(SETSYNTAX (QUOTE ?)
(QUOTE (INFIX FIRST NOESC DO?))
T)
(SETSYNTAX (QUOTE ?)
T EDITRDTBL)
(PUTPROPS DEFINEQ ARGNAMES (NIL (X1 XI ... XN) . X))
(ADDTOVAR EDITMACROS (?= NIL (E (PROGN (DO?= (##))
(TERPRI T))
T)))
(ADDTOVAR EDITCOMSA ?=)
(RPAQQ ASKUSERCOMS ((* Askuser package.)
(FNS ASKUSER ASKUSERLOOKUP ASKUSERCHAR ASKUSER$ ASKUSER1 ASKUSERSETUP
ASKUSEREXPLAIN ASKUSERPRIN1 MAKEKEYLST)
(INITVARS [DEFAULTKEYLST (QUOTE ((Y "es
")
(N "o
"]
(ASKUSERTTBL (COPYTERMTABLE)))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (CONTROL T ASKUSERTTBL)
(ECHOMODE NIL ASKUSERTTBL)))
(BLOCKS (ASKUSERBLOCK ASKUSER ASKUSERLOOKUP ASKUSERCHAR ASKUSER1 ASKUSER$
ASKUSERSETUP ASKUSEREXPLAIN ASKUSERPRIN1 (GLOBALVARS
DEFAULTKEYLST
ASKUSERTTBL)
(LOCALFREEVARS KEY CONFIRMFLG NOECHOFLG PROMPTSTRING
OPTIONS OPTIONSLST FILE NOCASEFLG ECHOEDFLG
LISPXPRNTFLG)
(SPECVARS PRINTLST KEYLST ORIGMESS)
(SPECVARS ANSWER OLDTTBL)
(BLKLIBRARY LISTGET MEMB)
(ENTRIES ASKUSER ASKUSEREXPLAIN)
(NOLINKFNS PRINTBELLS)))
(DECLARE: DOEVAL@COMPILE DONTCOPY (PROP BLKLIBRARYDEF LISTGET)
(RECORDS ASKUSER OPTIONS))))
(* Askuser package.)
(DEFINEQ
(ASKUSER
[LAMBDA (WAIT DEFAULT MESS KEYLST TYPEAHEAD LISPXPRNTFLG OPTIONSLST FILE)
(* DD: "27-Oct-81 12:17")
(* reads characters one at a time echoing and/or
prompting as indicated by KEYLST)
(RESETLST (COND
((NULL KEYLST) (* Yes, no recognized without conforimation)
(SETQ KEYLST DEFAULTKEYLST)))
(PROG (OLDTTBL CHAR TEM KEYLST1 ANSWER BUFS (ORIGKEYLST KEYLST)
(ORIGMESS MESS)
(ORIGDEFAULT DEFAULT)
(NC 1)
KEY PROMPTSTRING OPTIONS NOECHOFLG CONFIRMFLG NOCASEFLG PRINTLST
ECHOEDFLG)
(COND
((NULL FILE)
(SETQ FILE T))
((NEQ FILE T)
(GO MESS)))
(SETQ OLDTTBL (GETTERMTABLE))
(RESETSAVE (SETTERMTABLE ASKUSERTTBL))
(* ASKUSERTTBL has (CONTROL T) and (RAISE T) performed. The latter means that if the user types lower case
characters, they are converted to uppercase. Note however that this will recognize lower case y and n.
This is so the caller can provide y or n as a default, and distinguish the default cse from the case where the
user types lowercase y or n (which will be converted to uppercase automatically by the terminal table) ASKUSERTTBL
also has (ECHOMODE NIL) performed so can handle mistypings and confirations properly.)
(* File can be a file name or a string)
(COND
(TYPEAHEAD (* TYPEAHEAD permitted)
(SETQ TYPEAHEAD (READP T))
(* used in case there is a mistake.
in this case all typeahead is restored.)
(GO MESS)))
(LINBUF)
(SYSBUF)
(SETQ BUFS (CLBUFS NIL T READBUF))
(* Clear and save typeahead. This call to CLBUFS will ring the bells if there is any typeahead to warn the user to
stop typing.)
(COND
[(LISTP MESS)
(ASKUSERPRIN1 (CAR MESS))
(COND
((SETQ MESS (CDR MESS))
(ASKUSERPRIN1 " "))
(T (ASKUSERPRIN1 " ? "]
(MESS (ASKUSERPRIN1 MESS)
(SETQ MESS NIL)))
(* The problem with user interactions such as this where typeahead is not allowed is that we have no way of
knowing WHEN the user types something, i.e. if he typed it after seeing part of the message or no, without doing a
DOBE before doing any printing, and this is not desirable as it produces a noticeable snag in teletype output.
-
Therefore what we do is the following: all typeahead before the call to ASKUSER is cleared and saved for later
restoration, and n the event ther is any typeahead, bells are rung to warn the user to stop typing.
(this is done by the call to CLBUFS above.) -
After that we print something, either the first part of the message or the message itself, to give the user time
to respond to the warning to stop typing. IN this interval, anything that is typed is thrown away.
After printing the message, we do a DOBE, and then check to see if user has typed anything.
If he has, this material is discarded, and bells printed again to warn him.)
(DOBE)
(COND
((READP T)
(PRINTBELLS)
(DOBE)
(CLEARBUF T)))
MESS (* MESS is either an atom or string or a list, in which
case it is MAPRINTed)
(COND
((NULL MESS) (* Either user didnt supply a message or else was
printed above.)
)
((NLISTP MESS)
(ASKUSERPRIN1 MESS))
(T (MAPRINT MESS T NIL " ? " NIL NIL LISPXPRNTFLG)))
(COND
((OR (NOT (NUMBERP WAIT))
(NULL DEFAULT)) (* is : either a number, meaning wait that many seconds
or NIL, meaning wait forever)
(GO READLP)))
(SETQ WAIT (ITIMES 4 WAIT)) (* WAIT is in seconds. but we are going to dismiss for
quarter second intervals.)
[COND
((AND DEFAULT (NLISTP DEFAULT))
(SETQ DEFAULT (LIST DEFAULT]
WAITLP
(COND
((READP T))
([NOT (MINUSP (SETQ WAIT (SUB1 WAIT]
(DISMISS 250)
(GO WAITLP))
(T (* Assume DEFAULT if nothing typed in WAIT/4 seconds.)
(PRIN1 "..." T)
(SETQ CHAR (CAR DEFAULT))
(GO INTERP)))
READLP
[COND
((AND (STRINGP FILE)
(NOT (READP FILE T)))
(SETQ FILE T)
(SETQ OLDTTBL (GETTERMTABLE))
(RESETSAVE (SETTERMTABLE ASKUSERTTBL]
(* the string ran out)
(SETQ CHAR (PEEKC FILE)) (* PEEKC used so that in case of $ as a key, askuser can
do a READ.)
(SETQ ECHOEDFLG NIL) (* this character has not yet been echoed.
or read)
(SETQ DEFAULT NIL)
INTERP
(* KEYLST is a list of elements of the form (KEY PROMPTSTRING . OPTIONS), where KEY is an atom or string
(including the empty string) that characters are to be matched against, PROMPTSTRING a string or atom
(NIL is equivalent to ""), and OPTIONS a list in property list format which can contain the properties
(KEYLST CONFIRMFLG RETURN EXPLAINSTRING NOECHOFLG KEYSTRING PROMPTON COMPLETEON AUTOCOMPLETEFLG) Default options
for the entire keylst can be supplied as an argument to ASKUSER -
-
A key is considered to be complete when (1) all of its characters have been matched and it is the only key left,
i.e. there are no other keys for which this key is a substring, (2) all of its characters have been matched, and
CONFIRMFLG is NIL, and the next character matches one of the keys on its KEYLST, (3) all of its characters have
been matched, and a confirming character is typed, i.e. a c.r., space, or member of CONFIRMFLG
(This option is used for implementing TENEX protocosl, where CONFIRMFLG is ($)) or (4) there is only one key left
and a confirming character is typed. -
-
When a key is complete, PROMPTSTRING is printed. Then if CONFIRMFLG is non-NIL and the key was not completed via a
confirming character (case 3 and 4 above) askuser waits for a confirming character. -
-
After confirmation, if KEYLST is non NIL, askuser descends into KEYLST. Otherwise askuser returns a value which is
the value of (eval of) the RETURN field, if non-NIL, otherwise the result of packing all the keys or keystrings,
if present -
see below on the path. -
At any point, the user can type an alt-mode which is equivalent to typing the next n shared characters.
(if there are none, a bell is rung.) Typing a confirming character has the same effect as typing an alt-mode, i.e.
the next n shared characters will be supplied. If the key is the only key left, confirmation is not required.
(this is case 4 above). If the key is not the only key left, a bell is rung. -
-
special options: -
EXPLAINSTRING if non-nil, used in place of key/keystring + promptstring when user types a ? -
NOECHOFLG if non-nil, characters that are matched are not echoed -
KEYSTRING if non-nil, characters that are matched are echoed from keystring. The main reason for this feature
echoing, since ASKUSER converts everything to a canonical upper case form, keys will always be represented in
uppercase. KEYSTRING can be used to provide for lower case echoing, and for returning a lower case value.
i.e. if the RETURN option is not specified, and KEYSTRING is specified, then KEYSTRING will be used in
constructing the value to be returned, rather than KEY. -
PROMPTON if non-NIL, PROMPTSTRING is printed only when the key is confirmed with a member of PROMPTON.
This feature is used for implementing TENEX protocols, in which case PROMPTON would be ($) Note that this doesnt
make much sense unless CONFIRMFLG is also non-NIL and includes the elements on PROMPTON -
-
COMPLETEON when a confirming character is typed, the n characters that are supplied are not echoed unless the
confirming charactter is a member of COMPLETEON. This is used for implementing tenex protocols in which case
COMPLETEON is ($), i.e. user could complete a command with space or c.r. but completion and prompting would take
place only for $ -
-
AUTOCOMPLETEFLG if T, says supply characters as soon as they are unambiguous, i.e. act as though alt-mode were
typed after each character (but dont ring a bell) -
MACROCHARS, a list of characters and forms. if one of the characters is typed, and doesnt match as a key, then the
form is evaluated for effect and everything else stays the same, e.g. ? could have been implemented this way.
this feature is probably most useful when MACROCHARS is supplied on OPTIONSLST since one probably wants a global
set of MACROCHARS for a call single call to askuser. -
-
& as a key matches any character. -
-
"" can be used as a key It starts out with all of its characters matched, so that it is complete if it is the only
key left, (1) above, or the next character mtches one of the keys on its KEYLST, etc. -
-
$ can be used as a key to match the result of doing a READ. For example, the filepkg has as one of its entries on
its keylst ("" "file/list: " KEYLST ($)) which means that if a character is typpd that does not match any of the
other charactters on its keylst, the prompt message file/list: is printed, and a read is then performed and
eturned as the value of the call to askuser. -
-
-
For the more common useage, KEY is the same as (KEY NIL CONFIRMFLG T), and (KEY . PROMPT) the same as
(KEY PROMPT))
[SETQ KEYLST1 (for ENTRY in KEYLST eachtime (ASKUSERSETUP ENTRY) collect ENTRY
when (COND
((ASKUSERCHAR CHAR (SETQ TEM (NTHCHAR KEY NC)))
(* char matches the corresponding character in key.)
T)
((OR TEM $$VAL (EQ CHAR (QUOTE ?)))
(* There was another character in the key, and char didnt match it. The $$VAL check is to insure that once there
has been a match with a character in a key atthis level, we do not treat space or c.r. as terminators, so that
space and c.r. can be used as keys themselves, nor do we descend into subkeylists, and so thatthe user can specify
a default match via "" as a place marker, and have it operate ONLY when other elements are not matched by placing
it last on the keylst. e.g. if keylst is of the form ((c.r. --) -- ("" -- subkeylst)) and a c.r.
is typed, matching wont go into subkeylst ADDTOFILES uses this feature)
NIL)
((AND (NULL (ASKUSERLOOKUP CONFIRMFLG))
(ASKUSERLOOKUP KEYLST)
(ASKUSER1 ENTRY CHAR))
(* We have already matched all the characters in key, and entry contains a lower keylst. and char matches one of
its elements, therefore do any prompting necessary for this key, and descend)
(SETQ ANSWER (NCONC1 ANSWER (OR (ASKUSERLOOKUP
KEYSTRING)
KEY)))
[AND (NULL NOECHOFLG)
(SETQ PRINTLST (NCONC1 PRINTLST
(OR (ASKUSERLOOKUP
KEYSTRING)
KEY]
[AND PROMPTSTRING (SETQ PRINTLST
(NCONC1 PRINTLST (PRIN1 PROMPTSTRING T]
(* PRINTLST is maintained to implement the ? feature and
to be able to replay the output to put on the history.)
(SETQ KEYLST (ASKUSERLOOKUP KEYLST))
(SETQ NC 1) (* CHAR will then be matched aainst the lower keylst.)
(GO INTERP))
([COND
((LISTP CONFIRMFLG)
(MEMB CHAR CONFIRMFLG))
(T (OR (EQ CHAR (QUOTE %
))
(EQ CHAR (QUOTE % ]
(* all of its characters were matched, and this character was a c.r. or space. e.g. CHARLST=
(CLISP CLISPFLG CLISPTRANFLG) and CLISP c.r. has been typed The check is made after the other checks so that space
and carriage return themselves can be used in keys. Note that it doesnt matter whether confirmflg is T or not, the
user can still use c.r. or space to terminate a key.)
(AND (NULL NOECHOFLG)
(SETQ PRINTLST (NCONC1 PRINTLST CHAR)))
T]
[COND
(KEYLST1 (SETQ KEYLST KEYLST1)
(GO RIGHT))
([AND (NULL ANSWER)
(EQ NC 1)
(NULL DEFAULT)
(OR (EQ CHAR (QUOTE % ))
(EQ CHAR (QUOTE %
] (* user typed c.r. or space simply to keep dwim from
defaulting on him.)
(AND (NULL NOECHOFLG)
(PRIN1 CHAR T))
(AND (READC FILE))
(GO READLP))
([OR [EQ CHAR (CONSTANT (CHARACTER (CHARCODE ESCAPE]
(COND
((LISTP CONFIRMFLG)
(MEMB CHAR CONFIRMFLG))
(T (OR (EQ CHAR (QUOTE %
))
(EQ CHAR (QUOTE % ]
(* altmode c.r. or space says supply characters from atoms in this level of keylst until there are two or more
atms with different characters at thatposition. C.R. and space is same as alt mode except if there is only one
atom, then return without confirmation after supplying the characters. If thee are not atms with common characters
beyond this point, then ring a bell and take no action.)
[COND
((NULL (SETQ TEM (ASKUSER$ KEYLST CHAR NC)))
(GO WRONG))
(T (SETQ NC (ADD1 TEM]
(AND (NULL DEFAULT)
(READC FILE))
(COND
((NULL (CDR KEYLST)) (* only one. Therefore this character completes the
key,)
(GO COMPLETED))
((OR (EQ CHAR (QUOTE %
))
(EQ CHAR (QUOTE % )))
(PRIN1 (CONSTANT (CHARACTER (CHARCODE BELL)))
T) (* print a bell.)
))
(GO NEXT))
((OR (SYNTAXP (SETQ TEM (CHCON1 CHAR))
(QUOTE CHARDELETE))
(SYNTAXP TEM (QUOTE LINEDELETE)))
(* control-a, q,)
(GO RETRY))
([AND (NULL DEFAULT)
(EQ FILE T)
(SETQ TEM (FASSOC CHAR (ASKUSERLOOKUP MACROCHARS]
(READC T)
(SETTERMTABLE OLDTTBL)
(EVAL (CDR TEM))
(SETTERMTABLE ASKUSERTTBL)
(GO READLP))
((AND (NULL DEFAULT)
(EQ CHAR (QUOTE ?))
(EQ FILE T))
(TERPRI T)
(READC T)
[NLSETQ (PROGN (PRIN1 (OR (fetch (OPTIONS EXPLAINSTRING) of OPTIONSLST)
(QUOTE "one of:
"))
T)
(ASKUSEREXPLAIN KEYLST PRINTLST OPTIONSLST
(OR (ASKUSERLOOKUP EXPLAINDELIMITER)
"
"]
(TERPRI T)
[AND ORIGMESS (COND
((NLISTP ORIGMESS)
(ASKUSERPRIN1 ORIGMESS))
(T (MAPRINT ORIGMESS T NIL " ? " NIL NIL LISPXPRNTFLG]
[MAPC PRINTLST (FUNCTION (LAMBDA (X)
(PRIN1 X T]
(AND (NEQ NC 1)
(PRIN1 (SUBSTRING [COND
((NLISTP (CAR KEYLST))
(CAR KEYLST))
(T (OR (fetch (ASKUSER KEYSTRING)
of (CAR KEYLST))
(fetch (ASKUSER KEY) of (CAR KEYLST]
1
(SUB1 NC))
T)) (* These are the characters that have been matched on
this level key, bt not yet added to answer or printlst.)
(GO READLP))
([SETQ KEYLST1
(find X in KEYLST
suchthat (SELECTC
X
([LIST (QUOTE &)
(CHARACTER (CHARCODE ESCAPE))
(PACKC (CHARCODE (ESCAPE ESCAPE]
(SETQ KEY X)
T)
(AND (LISTP X)
(SELECTC (CAR X)
((QUOTE &)
(COND
((OR [NULL (SETQ TEM (LISTGET1
X
(QUOTE CLASS]
(APPLY* TEM CHAR))
(SETQ KEY (CAR X))
T)))
([LIST (CHARACTER (CHARCODE ESCAPE))
(PACKC (CHARCODE (ESCAPE ESCAPE]
(SETQ KEY (CAR X))
T)
(AND (LISTP (CAR X))
(SETQ KEY (CAR X]
(COND
((EQ KEY (QUOTE &))
[SETQ KEYLST (LIST (CONS CHAR (AND (LISTP KEYLST1)
(CDR KEYLST1]
(GO RIGHT))
(T (* altmode. or double-altmode)
(AND (EQ FILE T)
(PRIN1 CHAR T))
(* The character would not have been echoed since the PEEKC was done with echomode off. Since it has already been
seen by LISP, it wold not be echoed by the READ below, even though ECHOMODE would then be turned on.
Therefore must print it.)
(SETTERMTABLE OLDTTBL)
(OR (PROG1 [NLSETQ (COND
([EQ KEY (CONSTANT (CHARACTER (CHARCODE ESCAPE]
(SETQ TEM (READ FILE T)))
[[EQ KEY (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE]
(RESETVARS (READBUF)
(* since READ is used, rather than lispxread for $ key, we should not have readline be affected by readbuf, e.g.
if user is redoing an event contaig an askuser, he wants to type in tuff again.)
(SETQ TEM (READLINE T]
(T (SETQ TEM (EVAL KEY]
(SETTERMTABLE ASKUSERTTBL))
(GO RETRY))
(SETQ KEYLST (LIST (create ASKUSER using (LISTP KEYLST1)
KEY ← TEM)))
(SETQ NC (ADD1 (NCHARS TEM)))
(SETQ ECHOEDFLG T) (* so that the character terminatng the read wont be
echoed twice)
[COND
[(SYNTAXP [SETQ TEM (CHCON1 (SETQ CHAR (LASTC FILE]
(QUOTE SEPR)
T) (* character was included as part of the read)
(replace OPTIONS of (CAR KEYLST)
with (CONS (QUOTE CONFIRMFLG)
(CONS (LIST CHAR)
(fetch OPTIONS of (CAR KEYLST]
((SYNTAXP TEM (QUOTE BREAK)
T) (* e.g. read of a lit)
(GO READLP))
(T (SETQ CHAR (READC FILE]
(* (COND ((EQ KEY (CONSTANT (CHARACTER (CHARCODE ESCAPE)))) (* (61 . 965) 130 <NEWLISP>ASSIST.;8 NIL)
(SETQ CHAR (READC FILE))) ((EQ KEY (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE))))) (SETQ CHAR
(LASTC FILE)) (replace OPTIONS of (CAR KEYLST) with (CONS (QUOTE CONFIRMFLG) (CONS (QUOTE
(%] %
)) (fetch (ASKUSER OPTIONS) of (CAR KEYLST)))))) ((LISTP KEY) (* (73 . 955) 107 <NEWLISP>ASSIST.;30 NIL))
(T (SHOULDNT))))
(SETQ DEFAULT (QUOTE (T)))
(* so wont attempt to read the character again. reason we have to read it here, in the case of read, is that it
has already been echoed, and in the case of a lower keylst, there would be no way to psass on the information
about it having been echoed without setting echoedflg to T. thus we cant go back to READLP, sice that wold set
echoflg to NIL.)
(GO INTERP]
WRONG (* user typed invalid answer)
(AND (NEQ FILE T)
(ERROR!))
(AND (NULL DEFAULT)
(READC FILE))
(COND
(TYPEAHEAD (GO RETRY1)))
(PRINTBELLS)
(DOBE)
(CLEARBUF T)
(GO READLP)
RIGHT (* character matched.)
(AND (NULL DEFAULT)
(READC FILE))
RIGHT1
(ASKUSERSETUP (CAR KEYLST))
(COND
((OR (CDR KEYLST)
(ILESSP NC (NCHARS KEY))) (* More than one candidate. or this candidate not
finished yet.)
(AND (NULL NOECHOFLG)
(EQ FILE T)
(SETQ TEM (COND
((SETQ TEM (ASKUSERLOOKUP KEYSTRING))
(* primarily to allow specifying of echoing in lower
case, even though askuser always converts to uppercase
when it reads.)
(NTHCHAR TEM NC))
(T CHAR)))
(PRIN1 TEM T))
(SETQ NC (ADD1 NC))
[COND
((AND (ASKUSERLOOKUP AUTOCOMPLETEFLG)
(SETQ TEM (ASKUSER$ KEYLST CHAR NC)))
(COND
((AND (NULL (CDR KEYLST))
(EQ (SETQ NC TEM)
(NCHARS KEY)))
(GO COMPLETED))
(T (SETQ NC (ADD1 TEM]
(GO NEXT))) (* There is only one entry left, and all of its
characters are matched.)
(AND (NULL NOECHOFLG)
(EQ FILE T)
(EQ NC (NCHARS KEY))
(SETQ TEM (COND
((SETQ TEM (ASKUSERLOOKUP KEYSTRING))
(NTHCHAR TEM NC))
(T CHAR)))
(PRIN1 TEM T)) (* the character is the last one in the key.
the case where a c.r. was typed to terminate a key is
handled below.)
COMPLETED
(SETQ ANSWER (NCONC1 ANSWER (OR (ASKUSERLOOKUP KEYSTRING)
KEY)))
[AND (NULL NOECHOFLG)
(SETQ PRINTLST (NCONC1 PRINTLST (OR (ASKUSERLOOKUP KEYSTRING)
KEY]
[AND PROMPTSTRING (OR (NULL (SETQ TEM (ASKUSERLOOKUP PROMPTON)))
(MEMB CHAR TEM))
(SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 PROMPTSTRING T]
(* If PROMPTON is present, must wait till after confirmation to see if confirming charactter is PROMPTON
(usually $). this enables tenex like protocols.)
(AND (NULL NOECHOFLG)
(EQ FILE T)
(IGREATERP NC (NCHARS KEY))
(PRIN1 (COND
((AND (EQ CHAR (QUOTE %
))
(NULL (ASKUSERLOOKUP KEYLST)))
(* space is echoed for all confirming characters except
on a terminal leaf,in which char isused itself.)
CHAR)
(T (QUOTE % )))
T))
(COND
([OR (NULL CONFIRMFLG)
(COND
((LISTP CONFIRMFLG)
(MEMB CHAR CONFIRMFLG))
(T (OR (EQ CHAR (QUOTE %
))
(EQ CHAR (QUOTE % ] (* CONFIRMFLG can be a list of characters that are
acceptable for confirming. e.g.
($) can be used to implemente tenex like protocols.)
(GO CONFIRMED))
(T (GO CONFIRM)))
NEXT(SETQ DEFAULT (CDR DEFAULT)) (* DEFAULT stays one behind the current character so
that we can tell if the character came from a default
list.)
(COND
((NULL DEFAULT)
(GO READLP))
(T (SETQ CHAR (CAR DEFAULT))
(GO INTERP)))
(GO INTERP)
CONFIRM
(COND
((ASKUSERLOOKUP PROMPTCONFIRMFLG)
(PRIN1 " [confirm] " T)))
[COND
((AND (STRINGP FILE)
(NOT (READP FILE T)))
(SETQ FILE T)
(SETQ OLDTTBL (GETTERMTABLE))
(RESETSAVE (SETTERMTABLE ASKUSERTTBL]
[SETQ CHAR (COND
((SETQ DEFAULT (CDR DEFAULT))
(CAR DEFAULT))
(T (READC FILE]
(COND
((OR (SYNTAXP (SETQ TEM (CHCON1 CHAR))
(QUOTE CHARDELETE))
(SYNTAXP TEM (QUOTE LINEDELETE)))
(* control-a or q)
(GO RETRY))
[(LISTP CONFIRMFLG)
(COND
((MEMB CHAR CONFIRMFLG) (* used for TENEX mode.)
[AND PROMPTSTRING (SETQ TEM (ASKUSERLOOKUP PROMPTON))
(MEMB CHAR TEM)
(SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 PROMPTSTRING T]
(AND (NULL NOECHOFLG)
(PRIN1 (QUOTE % )
T))
(GO CONFIRMED]
((OR (EQ CHAR (QUOTE % ))
(EQ CHAR (QUOTE %
))) (* C.R. or space)
[COND
((NULL NOECHOFLG)
(SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 (COND
((NULL (ASKUSERLOOKUP KEYLST))
CHAR)
(T (QUOTE % )))
T]
(GO CONFIRMED))
((SETQ TEM (FASSOC CHAR (ASKUSERLOOKUP MACROCHARS)))
(SETTERMTABLE OLDTTBL)
(EVAL (CDR TEM))
(SETTERMTABLE ASKUSERTTBL)
(GO CONFIRM)))
(COND
((NEQ CHAR (QUOTE ?))
(PRIN1 [CONSTANT (PACKC (CHARCODE (BELL ?]
T)
(DOBE)
(CLEARBUF T)))
(PRIN1 " [confirm] " T)
(GO CONFIRM)
CONFIRMED
(COND
((SETQ TEM (ASKUSERLOOKUP KEYLST))
(SETQ KEYLST TEM)
(SETQ NC 1)
(GO NEXT)))
(COND
(LISPXPRNTFLG [MAPC PRINTLST (FUNCTION (LAMBDA (X)
(ASKUSERPRIN1 X T]
(* fakes the printing for the history list.)
))
(COND
(BUFS (BKBUFS BUFS)))
(RETURN (COND
[(SETQ TEM (OR (FMEMB (QUOTE RETURN)
OPTIONS)
(FMEMB (QUOTE RETURN)
OPTIONSLST)))
(SETTERMTABLE OLDTTBL)
(COND
([SETQ TEM (NLSETQ (EVAL (CADR TEM]
(* ASKUSERLOOKUP not used since then couldnt distinguish
case where RETURN NIL was specified from case where
RETURN was not specified at all.)
(* This permits user to return ANSWER as a list itself, or to take some other action, and then restart by simply
generateing an error.)
(CAR TEM))
(T (SETTERMTABLE ASKUSERTTBL)
(GO RETRY]
(ANSWER (PACK ANSWER))
(T (NOTCHECKED)
KEY)))
RETRY
(COND
(TYPEAHEAD (GO RETRY1)))
(PRIN1 "←←←
" T)
(DOBE)
(CLEARBUF T)
(SETQ KEYLST ORIGKEYLST)
(SETQ PRINTLST NIL)
(SETQ NC 1)
(SETQ ANSWER NIL)
(GO READLP)
RETRY1
(* User has typed ahead before the call to askuser1 and his resonse is invalid. therefore assume he didnt know
that askuser would be called and his typeahead was intended for what follows. clear and ave the typeahead and
continue with interaction.)
(LINBUF)
(SYSBUF)
(SETQ BUFS (CLBUFS NIL T READBUF))
[SETQ TEM (APPLY (QUOTE CONCAT)
(NCONC ANSWER [AND (NEQ NC 1)
(LIST (SUBSTRING (COND
((LISTP (CAR KEYLST))
(CAAR KEYLST))
(T (CAR KEYLST)))
1
(SUB1 NC]
(LIST CHAR]
[COND
((NULL BUFS)
(SETQ BUFS (CONS NIL TEM)))
(T (RPLACD BUFS (COND
((CDR BUFS)
(CONCAT TEM (CDR BUFS)))
(T TEM]
(SETQ TYPEAHEAD NIL) (* so this is only done once)
(SETQ ANSWER NIL)
(SETQ KEYLST ORIGKEYLST)
(SETQ MESS ORIGMESS)
(SETQ DEFAULT ORIGDEFAULT)
(SETQ PRINTLST NIL)
(TERPRI T)
(GO MESS])
(ASKUSERLOOKUP
[NLAMBDA (FIELD) (* wt: % 4-DEC-75 00:27)
(* this wuld be just a fetch, xcept want to lok it up on
optionslst if not found on options.)
(PROG (TEM)
(RETURN (COND
((SETQ TEM (FMEMB FIELD OPTIONS))
(CADR TEM))
((SETQ TEM (FMEMB FIELD OPTIONSLST))
(CADR TEM])
(ASKUSERCHAR
[LAMBDA (C1 C2) (* wt: " 4-OCT-78 14:48")
(OR (EQ C1 C2)
(AND (NULL NOCASEFLG)
C2
(PROGN (SETQ C1 (CHCON1 C1))
(SETQ C2 (CHCON1 C2))
(COND
((AND (IGREATERP C1 96)
(ILESSP C1 123))
(EQ (IDIFFERENCE C1 32)
C2))
((AND (IGREATERP C2 96)
(ILESSP C2 123))
(EQ C1 (IDIFFERENCE C2 32])
(ASKUSER$
[LAMBDA (KEYLST CHAR NC) (* rmk: " 6-JUN-82 16:17"
)
(for ENTRY bind NC0 KEY0 TEM in KEYLST
eachtime [SETQ KEY (COND
((NLISTP ENTRY)
ENTRY)
(T (fetch (ASKUSER KEY) of ENTRY]
when [AND [NEQ KEY (CONSTANT (CHARACTER (CHARCODE ESCAPE]
(NEQ KEY (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE]
do [COND
((NULL KEY0) (* first time through)
[SETQ KEY0 (COND
((NLISTP (CAR KEYLST))
(CAR KEYLST))
(T (fetch (ASKUSER KEY) of (CAR KEYLST]
(SETQ NC0 (NCHARS KEY0)))
(T
(* Goes through keylst and looks at each key and
determines the largest N for which NTHCHAR of
thatcharacter is equal for every atom.)
(SETQ NC0 (for I from 1 to NC0
while (EQ (NTHCHARCODE KEY I)
(NTHCHARCODE KEY0 I))
finally (RETURN (SUB1 I]
finally (COND
((OR (NULL NC0)
(ILESSP NC0 NC)) (* all atoms have
different characters at
this position.)
(RETURN NIL)))
(ASKUSERSETUP (CAR KEYLST))
[SETQ TEM (AND (OR (NULL (SETQ TEM (ASKUSERLOOKUP
COMPLETEON)))
(MEMB CHAR TEM))
(SUBSTRING (OR (ASKUSERLOOKUP KEYSTRING)
KEY)
NC
(COND
((EQ (NCHARS KEY0)
NC0)
(* reason for this is in case KEYSTRING is longer,
will get all of it.)
-1)
(T NC0]
(* if COMPLETEON is $ means only complete on
alt-mode. this is used for tenex type protocol)
(AND (NULL NOECHOFLG)
TEM
(PRIN1 TEM T))
(* Reason for not just using value of noechoflg is
that askusersetup oul have set noechoflg to T when
reading from a string in order to suppress echoing
of the character, but this does not mean that we do
not echo the characters that are supplied for
copleting.)
(RETURN NC0])
(ASKUSER1
[LAMBDA (ENTRY CHAR) (* DD: "26-Oct-81 12:34")
(* We know that ENTRY contains a subkeylst.
This function sees if char could conceivably match one
of the entries on keylst.)
(thereis ENTRY bind TEM in (fetch (ASKUSER KEYLST) of ENTRY)
eachtime [SETQ TEM (COND
((NLISTP ENTRY)
ENTRY)
(T (fetch (ASKUSER KEY) of ENTRY]
suchthat (OR (EQ TEM (QUOTE &))
[EQ TEM (CONSTANT (CHARACTER (CHARCODE ESCAPE]
[EQ TEM (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE]
(LISTP TEM)
(EQ (SETQ TEM (NTHCHAR TEM 1))
CHAR)
(AND (NULL TEM)
(LISTP ENTRY)
(LISTP (CDR ENTRY))
(ASKUSER1 ENTRY CHAR])
(ASKUSERSETUP
[LAMBDA (ENTRY) (* wt: " 4-OCT-78 14:48")
(* Sets free variables KEY, CONFIRMFLG, QUIETFLG, and
PROMPTSTRING)
(PROG (TEM)
[COND
[(NLISTP ENTRY)
(SETQ KEY ENTRY)
(SETQ PROMPTSTRING NIL)
(SETQ OPTIONS NIL) (* The default is for NOECHOFLG to be NIL and CONFIRMFLG
to be T.)
(SETQ CONFIRMFLG (COND
((SETQ TEM (MEMB (QUOTE CONFIRMFLG)
OPTIONSLST))
(CADR TEM))
(T T]
[(NLISTP (CDR ENTRY))
(SETQ KEY (CAR ENTRY))
(SETQ PROMPTSTRING (CDR ENTRY))
(SETQ OPTIONS NIL)
(SETQ CONFIRMFLG (COND
((SETQ TEM (MEMB (QUOTE CONFIRMFLG)
OPTIONSLST))
(CADR TEM))
(T T]
(T (SETQ KEY (fetch (ASKUSER KEY) of ENTRY))
(SETQ PROMPTSTRING (fetch (ASKUSER PROMPTSTRING) of ENTRY))
(SETQ OPTIONS (fetch (ASKUSER OPTIONS) of ENTRY))
(SETQ CONFIRMFLG (ASKUSERLOOKUP CONFIRMFLG]
(SETQ NOECHOFLG (ASKUSERLOOKUP NOECHOFLG))
(SETQ NOCASEFLG (ASKUSERLOOKUP NOCASEFLG))
(AND ECHOEDFLG (SETQ NOECHOFLG T))
(COND
((AND (NEQ FILE T)
(STRINGP FILE)
(READP FILE T))
(SETQ NOECHOFLG T)
(SETQ PROMPTSTRING NIL)
(* askusersetup is called after the character has been read. Thus, this sets noechoflg to T and promptstring to
NIL only if there are more characters to be read. However, the check on whether or not the character JUST read is
to bechoed alsoincludes an (EQ FILE T) check)
])
(ASKUSEREXPLAIN
[LAMBDA (KEYLST PREV OPTIONSLST DELIMITER) (* DD: "26-Oct-81 12:47")
(MAPC KEYLST (FUNCTION (LAMBDA (ENTRY)
(PROG (KEY CONFIRMFLG NOECHOFLG PROMPTSTRING TEM OPTIONS (FILE T))
(ASKUSERSETUP ENTRY)
(COND
((SETQ TEM (ASKUSERLOOKUP KEYLST)) (* entry is of the form (key prompt charlst))
(ASKUSEREXPLAIN TEM [COND
((SETQ TEM (fetch (OPTIONS EXPLAINSTRING) of OPTIONS))
(* reason for not using askuserlookup is that don't want top level explainstring on ptionslst, if any.
doesnt make sense to print it each time. it is printed only once.)
(APPEND PREV (LIST TEM)))
(T (APPEND PREV (AND (NULL NOECHOFLG)
(LIST (OR (ASKUSERLOOKUP KEYSTRING)
KEY)))
(AND PROMPTSTRING (LIST PROMPTSTRING]
OPTIONSLST DELIMITER)
(RETURN)))
[MAPC PREV (FUNCTION (LAMBDA (X)
(COND
((LISTP X)
(MAPRINT X T))
(T (PRIN1 X T]
[COND
[(SETQ TEM (fetch (OPTIONS EXPLAINSTRING) of OPTIONS))
(COND
((LISTP TEM)
(MAPRINT TEM T))
(T (PRIN1 TEM T]
((SETQ TEM (OR (ASKUSERLOOKUP KEYSTRING)
KEY))
(AND (NULL NOECHOFLG)
[NEQ TEM (CONSTANT (CHARACTER (CHARCODE ESCAPE]
(NEQ TEM (QUOTE &))
(PRIN1 TEM T)) (* If the user wants to explain the & or $, he can
include the appropriate text in the prompt field.)
(AND PROMPTSTRING (PRIN1 PROMPTSTRING T]
(AND (NEQ (POSITION T)
0)
(PRIN1 DELIMITER T))
(RETURN])
(ASKUSERPRIN1
[LAMBDA (X NODOFLG) (* wt: % 4-DEC-75 00:39)
(* does a lispxprin1 if lispxprntflg is non-NIL. used to be done by having everythin printed with lispxprin1 and
doing a resetsave on lisxpprintflg, but this costs several conses each call.)
(COND
((NULL LISPXPRNTFLG)
(OR NODOFLG (PRIN1 X T)))
(T (LISPXPRIN1 X T NIL NODOFLG)))
X])
(MAKEKEYLST
[LAMBDA (LST DEFAULTKEY LCASFLG AUTOCOMPLETEFLG) (* wt: "14-NOV-78 02:03")
(PROG (TEM)
(RETURN (NCONC [SETQ TEM (MAPCAR LST (FUNCTION (LAMBDA (KEY)
(LIST KEY NIL (QUOTE KEYSTRING)
(CONCAT (COND
((AND LCASFLG (EQUAL KEY (U-CASE
KEY)))
(* when ucasep gets in system, use it instead)
(L-CASE KEY))
(T KEY))
" ")
(QUOTE CONFIRMFLG)
T
(QUOTE AUTOCOMPLETEFLG)
AUTOCOMPLETEFLG
(QUOTE RETURN)
(KWOTE KEY]
[for X in TEM bind KEYSTRING as I from 1
collect (SETQ KEYSTRING (LISTGET X (QUOTE KEYSTRING)))
(LIST I KEYSTRING (QUOTE NOECHOFLG)
T
(QUOTE EXPLAINSTRING)
(CONCAT I " - " KEYSTRING)
(QUOTE CONFIRMFLG)
T
(QUOTE RETURN)
(LIST (QUOTE PROGN)
(QUOTE (TERPRI T))
(KWOTE (CAR X]
(COND
[(NULL DEFAULTKEY)
(LIST (QUOTE ("No - none of the above " "" CONFIRMFLG T AUTOCOMPLETEFLG
T RETURN NIL]
((LISTP DEFAULTKEY) (* so user can specify no default key by simply calling
with defaultkey=T)
(LIST DEFAULTKEY])
)
(RPAQ? DEFAULTKEYLST (QUOTE ((Y "es
")
(N "o
"))))
(RPAQ? ASKUSERTTBL (COPYTERMTABLE))
(DECLARE: DONTEVAL@LOAD DOCOPY
(CONTROL T ASKUSERTTBL)
(ECHOMODE NIL ASKUSERTTBL)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: ASKUSERBLOCK ASKUSER ASKUSERLOOKUP ASKUSERCHAR ASKUSER1 ASKUSER$ ASKUSERSETUP ASKUSEREXPLAIN
ASKUSERPRIN1 (GLOBALVARS DEFAULTKEYLST ASKUSERTTBL)
(LOCALFREEVARS KEY CONFIRMFLG NOECHOFLG PROMPTSTRING OPTIONS OPTIONSLST FILE NOCASEFLG
ECHOEDFLG LISPXPRNTFLG)
(SPECVARS PRINTLST KEYLST ORIGMESS)
(SPECVARS ANSWER OLDTTBL)
(BLKLIBRARY LISTGET MEMB)
(ENTRIES ASKUSER ASKUSEREXPLAIN)
(NOLINKFNS PRINTBELLS))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTPROPS LISTGET BLKLIBRARYDEF [LAMBDA (LST PROP)
(PROG NIL LP [COND ((NLISTP LST)
(RETURN))
((EQ (CAR LST)
PROP)
(RETURN (CADR LST]
[SETQ LST (CDR (LISTP (CDR LST]
(GO LP])
[DECLARE: EVAL@COMPILE
(RECORD ASKUSER (KEY PROMPTSTRING . OPTIONS))
(PROPRECORD OPTIONS (KEYLST CONFIRMFLG RETURN EXPLAINSTRING NOECHOFLG KEYSTRING PROMPTON COMPLETEON
AUTOCOMPLETEFLG MACROCHARS NOCASEFLG PROMPTCONFIRMFLG CLASS))
]
)
(* Coroutine package.)
(RPAQQ COFNS (COROUTINE OLDRESUME GENERATOR GENERATE PRODUCE GENERATEFN))
(DEFINEQ
(COROUTINE
[NLAMBDA (CALLPTR## COROUTPTR## COROUTFORM## ENDFORM##) (* wt: 17-APR-76 19 48)
(* CALLPTR## and COROUTPTR## ARE the names of communication variables in the function calling COROUTINE.
They will be set to stkptrs if they ARE not already ones. COROUTFORM## is the form which starts the COROUTINE.
ENDFORM## is evaluated in the context of the caller when COROUTFORM## returns.)
[SETQ CALLPTR## (SET CALLPTR## (OR (STACKP (EVALV CALLPTR##))
(STKNTH 0 T]
[SETQ COROUTPTR## (SET COROUTPTR## (OR (STACKP (EVALV COROUTPTR##))
(STKNTH 0 T]
(RESUME COROUTPTR## (STKNTH -1 (QUOTE COROUTINE))
COROUTPTR##)
(EVAL COROUTFORM##)
(RETTO CALLPTR## (ENVEVAL ENDFORM## (STKNTH -1 (QUOTE COROUTINE))
NIL T)
T])
(OLDRESUME
[LAMBDA (FROMPTR TOPTR VAL) (* wt: 12-JUL-76 11 57)
(* FROMPTR is A stkptr wich is SMASHED by the STKNTH to contain A pointer to this RESUME frame.
Control is transfered to the RESUME frame specified by TOPTR, releasing the STORAGE held by that stack pointer.
A RETFROM back to this frame returns as the value of this call to RESUME. Thus A call to this RESUME returns VAL
as the value of the RESUME specified by TOPTR.)
(* this function is called oldresume, rather than resume, because in some systems it might be written as a SUBR.
RESUME is defined via a MOVD? so that if it already has a definition, that one will remain in efect.)
(STKNTH -1 (QUOTE RESUME)
FROMPTR)
(RETTO TOPTR VAL T])
(GENERATOR
[NLAMBDA (FORM## COMVAR##)
[COND
(COMVAR## (SETQ COMVAR## (EVAL COMVAR##]
[COND
[(NLISTP COMVAR##)
(SETQ COMVAR## (CONS (STKNTH 0 T)
(STKNTH 0 T]
(T [COND
((NOT (STACKP (CAR COMVAR##)))
(FRPLACA COMVAR## (STKNTH 0 T]
(COND
((NOT (STACKP (CDR COMVAR##)))
(FRPLACD COMVAR## (STKNTH 0 T]
(RESUME (CDR COMVAR##)
(STKNTH -1 (QUOTE GENERATOR)
(CAR COMVAR##))
COMVAR##)
(EVAL FORM##)
(RETTO (CAR COMVAR##)
COMVAR## T])
(GENERATE
[LAMBDA (HANDLE VAL)
(RESUME (CAR HANDLE)
(CDR HANDLE)
VAL])
(PRODUCE
[LAMBDA (VAL)
(RESUME (CDR COMVAR##)
(CAR COMVAR##)
VAL])
(GENERATEFN
[LAMBDA (FN COMVAR##)
(DECLARE (SPECVARS COMVAR##)) (* lmm: "11-FEB-77 15:51:34")
[COND
[(NLISTP COMVAR##)
(SETQ COMVAR## (CONS (STKNTH 0 T)
(STKNTH 0 T]
(T [COND
((NOT (STACKP (CAR COMVAR##)))
(FRPLACA COMVAR## (STKNTH 0 T]
(COND
((NOT (STACKP (CDR COMVAR##)))
(FRPLACD COMVAR## (STKNTH 0 T]
(RESUME (CDR COMVAR##)
(STKNTH -1 (QUOTE GENERATEFN)
(CAR COMVAR##))
COMVAR##)
(APPLY* FN)
(RETTO (CAR COMVAR##)
COMVAR## T])
)
(RPAQQ GENERFNS (ADIEU AU-REVOIR CLEANPOSLST NOTE POSSIBILITIES TRYNEXT TRYNEXT1 POSSIBILITYFN))
(DEFINEQ
(ADIEU
[LAMBDA VAL##
[COND
((NOT (ZEROP VAL##))
(NOTE (ARG VAL## 1]
(RETTO (CAR COMVAR##)
(PROG1 POSSLIST## (SETQ POSSLIST## NIL))
T])
(AU-REVOIR
[LAMBDA VAL##
[COND
((NOT (ZEROP VAL##))
(NOTE (ARG VAL## 1]
(NOTE COMVAR##)
(RESUME (CDR COMVAR##)
(CAR COMVAR##)
(PROG1 POSSLIST## (SETQ POSSLIST## NIL])
(CLEANPOSLST
[LAMBDA (PLST)
(for X in PLST do (COND
((AND (LISTP X)
(STACKP (CAR X)))
(RELSTK (CAR X))
(RELSTK (CDR X])
(NOTE
[LAMBDA (VAL LSTFLG)
(SETQ POSSLIST## (NCONC POSSLIST## (COND
(LSTFLG VAL)
(T (LIST VAL])
(POSSIBILITIES
[NLAMBDA (FORM##) (* DD: " 5-Oct-81 17:08")
(PROG (COMVAR## POSSLIST##)
[PRODUCE (LIST (SETQ COMVAR## (CONS (STKNTH -1 (QUOTE POSSIBILITIES))
(STKNTH 0 T]
(EVAL FORM##)
(ADIEU])
(TRYNEXT
[NLAMBDA (PLST## ENDFORM## VAL##)
(PROG (PL1##)
[SET PLST## (CDR (SETQ PL1## (TRYNEXT1 (EVAL PLST##)
(EVAL VAL##]
(COND
((NULL PL1##)
(RETEVAL (QUOTE TRYNEXT)
ENDFORM##))
(T (RETURN (CAR PL1##])
(TRYNEXT1
[LAMBDA (PLST## MSG##)
(PROG (PL1##)
LP (COND
((NULL PLST##)
(RETURN NIL)))
(SETQ PL1## (CAR PLST##))
(COND
([OR (NLISTP PL1##)
(NOT (STACKP (CAR PL1##]
(RETURN PLST##)))
(SETQ PLST## (NCONC (RESUME (CAR PL1##)
(CDR PL1##)
MSG##)
(CDR PLST##)))
(GO LP])
(POSSIBILITYFN
[LAMBDA (FN COMVAR## POSSLIST##)
(DECLARE (LOCALVARS FN)
(SPECVARS COMVAR## POSSLIST##)) (* lmm: "11-FEB-77 15:58:48")
[PRODUCE (LIST (SETQ COMVAR## (CONS (STKNTH -1 (QUOTE POSSIBILITYFN))
(STKNTH 0 T]
(APPLY* FN)
(ADIEU])
)
(ADDTOVAR SYSSPECVARS COMVAR## POSSLIST##)
(MOVD? (QUOTE OLDRESUME)
(QUOTE RESUME))
(RPAQQ COMACROS (COROUTINE GENERATOR TRYNEXT POSSIBILITIES))
(PUTPROPS COROUTINE MACRO [(P1 P2 F1 F2)
(PROGN (OR (STACKP P1)
(SETQ P1 (STKNTH 0 T)))
(OR (STACKP P2)
(SETQ P2 (STKNTH 0 T)))
([LAMBDA (..MACROX.)
(COND
((EQ ..MACROX. P2)
P2)
(T (RESUME P2 ..MACROX. P2)
F1
(RETTO P1 F2 T]
(STKNTH -1])
(PUTPROPS GENERATOR MACRO [X
(PROG [(Y (SUBST (CAR X)
(QUOTE FORM##)
(QUOTE (LAMBDA (COMVAR## ..MACROX.)
(COND
((EQ (SETQ ..MACROX. (STKNTH -1 (QUOTE *PROG*LAM)
(CAR COMVAR##)))
COMVAR##)
COMVAR##)
(T (RESUME (CDR COMVAR##)
..MACROX. COMVAR##)
FORM##
(RETTO (CAR COMVAR##)
COMVAR## T]
(RETURN (COND
[(CADR X)
[FRPLACD (CDR Y)
(CONS [QUOTE (OR (STACKP (CAR COMVAR##))
(FRPLACA COMVAR## (STKNTH 0 T]
(CONS [QUOTE (OR (STACKP (CDR COMVAR##))
(FRPLACD COMVAR## (STKNTH 0 T]
(CDDR Y]
(LIST Y (LIST (QUOTE OR)
(LIST (QUOTE LISTP)
(CADR X))
(QUOTE (CONS (STKNTH 0 T)
(STKNTH 0 T]
(T (LIST Y (QUOTE (CONS (STKNTH 0 T)
(STKNTH 0 T])
(PUTPROPS TRYNEXT MACRO ((PLST NOMORE MSG)
(COND
[(SETQ PLST (TRYNEXT1 PLST MSG))
(PROG1 (CAR PLST)
(SETQ PLST (CDR PLST]
(T (SETQ PLST (CDR PLST))
NOMORE))))
(PUTPROPS POSSIBILITIES MACRO ((FORM)
(PROG (COMVAR## POSSLIST##)
[PRODUCE (LIST (SETQ COMVAR## (CONS (STKNTH -1 (QUOTE *PROG*LAM))
(STKNTH 0 T]
FORM(ADIEU))))
(PUTPROPS COROUTINE INFO EVAL)
(PUTPROPS GENERATOR INFO EVAL)
(PUTPROPS TRYNEXT INFO EVAL)
(PUTPROPS POSSIBILITIES INFO EVAL)
(DECLARE: EVAL@COMPILE
(I.S.OPR (QUOTE OUTOF)
NIL
[QUOTE (SUBST (GENSYM)
(QUOTE GENVAR)
(QUOTE (BIND GENVAR ← (GENERATOR BODY)
EACHTIME
(COND ((EQ (SETQ I.V. (GENERATE GENVAR))
GENVAR)
(GO $$OUT)))
FINALLY
(RELSTK (CDR GENVAR]
T)
)
(PUTPROPS GENERATOR BYTEMACRO ((FORM COMVAR)
(GENERATEFN (FUNCTION [LAMBDA NIL FORM])
COMVAR)))
(PUTPROPS POSSIBILITIES BYTEMACRO [(FORM)
(POSSIBILITYFN (FUNCTION (LAMBDA NIL FORM])
(RPAQQ GAINSPACECOMS ((* gainspace package)
(FNS GAINSPACE ERASEPROPS PURGEHISTORY PURGEHISTORY1 PURGEHISTORY2)
(VARS SMASHPROPSMENU (SMASHPROPSLST))
[ADDVARS (GAINSPACEFORMS ((CAR LISPXHISTORY)
"purge history lists"
(PURGEHISTORY RESPONSE)
((Y "es")
(N "o")
(E . "verything")))
[T "discard definitions on property lists"
(SETQ SMASHPROPSLST1
(CONS (QUOTE EXPR)
(CONS (QUOTE CODE)
(CONS (QUOTE SUBR)
SMASHPROPSLST1]
(T "discard old values of variables"
(SETQ SMASHPROPSLST1 (CONS (QUOTE VALUE)
SMASHPROPSLST1)))
(T "erase properties" (ERASEPROPS RESPONSE)
((Y "es" EXPLAINSTRING
"Yes - you will be asked which properties are to be erased")
(N "o")
(A "ll" CONFIRMFLG T EXPLAINSTRING
"All - all properties on mentioned on SMASHPROPSMENU")
(E "dit
" EXPLAINSTRING "Edit - you will be allowed to edit a list of property names")))
(CLISPARRAY "erase CLISP translations" (CLRHASH
CLISPARRAY))
(CHANGESARRAY "erase changes array" (CLRHASH
CHANGESARRAY))
(SYSHASHARRAY "erase system hash array" (CLRHASH))
((GETPROP (QUOTE EDIT)
(QUOTE LASTVALUE))
"discard context of last edit"
(REMPROP (QUOTE EDIT)
(QUOTE LASTVALUE)))
(GREETHIST
"discard information saved for undoing your greeting"
(SETQ GREETHIST]
(BLOCKS (GAINSPACEBLOCK GAINSPACE ERASEPROPS PURGEHISTORY PURGEHISTORY1
PURGEHISTORY2 (ENTRIES GAINSPACE ERASEPROPS
PURGEHISTORY)
(GLOBALVARS GAINSPACEFORMS SMASHPROPSMENU SMASHPROPSLST
SMASHPROPSLST1 DWIMWAIT ARCHIVELST
LASTHISTORY ARCHIVEFLG LISPXCOMS
LISPXHISTORY EDITHISTORY)
(SPECVARS RESPONSE)))
(DECLARE: DOEVAL@COMPILE DONTCOPY (RECORDS GAINSPACE))))
(* gainspace package)
(DEFINEQ
(GAINSPACE
[LAMBDA NIL (* wt: 30-JUL-77 13 35)
(SETQ SMASHPROPSLST1 NIL)
[MAPC GAINSPACEFORMS (FUNCTION (LAMBDA (X)
(PROG (RESPONSE)
(AND (NEQ (POSITION T)
0)
(TERPRI T))
(ERSETQ (AND (EVAL (fetch (GAINSPACE PRECHECK) of X))
(NEQ (SETQ RESPONSE (ASKUSER DWIMWAIT (QUOTE N)
(LIST (fetch (GAINSPACE MESSAGE)
of X))
(fetch (GAINSPACE KEYLST) of X)
T))
(QUOTE N))
(EVAL (fetch (GAINSPACE FORM) of X]
[COND
(SMASHPROPSLST1 (TERPRI T)
(PRIN1 "mapatoms called to erase the indicated properties..." T)
[MAPATOMS (FUNCTION (LAMBDA (ATM)
(REMPROPLIST ATM SMASHPROPSLST1]
(MAPC SMASHPROPSLST1 (FUNCTION (LAMBDA (X)
(AND (LISTP X)
(EVAL X]
(QUOTE done])
(ERASEPROPS
[LAMBDA (RESPONSE) (* wt: 30-JUL-77 12 43)
(SETQ SMASHPROPSLST1 (UNION SMASHPROPSLST1 SMASHPROPSLST))
(* smashpropslst lets user prespecify properties to
always be smashed, and not to ask him.)
(SELECTQ RESPONSE
[Y (TERPRI T)
(PRIN1 "indicate which ones:
" T)
(MAPC SMASHPROPSMENU (FUNCTION (LAMBDA (X)
(AND [SOME (CDR X)
(FUNCTION (LAMBDA (X)
(AND (LITATOM X)
(NOT (MEMB X SMASHPROPSLST1]
(EQ (ASKUSER NIL NIL (LIST (CAR X))
NIL T)
(QUOTE Y))
(SETQ SMASHPROPSLST1 (UNION (CDR X)
SMASHPROPSLST1]
[(A E)
[SETQ SMASHPROPSLST1 (MAPCONC SMASHPROPSMENU (FUNCTION (LAMBDA (X)
(APPEND (CDR X]
(AND (EQ RESPONSE (QUOTE E))
(EDITE (SORT SMASHPROPSLST1]
(HELP])
(PURGEHISTORY
[LAMBDA (TYPE) (* wt: "14-NOV-78 02:03")
(RESETVARS (ARCHIVEFLG)
(SELECTQ TYPE
(E (SETQ ARCHIVEFLG T))
[Y (SETQ TYPE (ASKUSER NIL NIL
"purge everything, or just the properties, e.g. SIDE, LISPXPRINT, etc. ? "
[QUOTE ((Y "es - everything" RETURN T)
(N "o - just the properties" RETURN
(QUOTE NIL))
(E "verything" RETURN T)
(J "ust the properties" RETURN (QUOTE NIL]
T))
(TERPRI T)
(SETQ ARCHIVEFLG (EQ (ASKUSER NIL NIL
"ARCHIVELST and named commands too ? "
NIL T)
(QUOTE Y]
(HELP))
(PURGEHISTORY1 LISPXHISTORY TYPE)
(PURGEHISTORY1 EDITHISTORY TYPE)
(PURGEHISTORY1 LASTHISTORY TYPE)
[COND
(ARCHIVEFLG (PURGEHISTORY1 ARCHIVELST TYPE)
(MAPC LISPXCOMS (FUNCTION (LAMBDA (COM)
(AND (LITATOM COM)
(COND
(TYPE (REMPROP COM (QUOTE *HISTORY*)))
(T (PURGEHISTORY2 (CADDR (GETPROP COM (QUOTE *HISTORY*]
(RETURN])
(PURGEHISTORY1
[LAMBDA (LST FLG) (* DD: "26-Oct-81 12:48")
(COND
((NLISTP LST))
(FLG (RPLACA LST NIL))
[(EQ LST EDITHISTORY)
(MAPC (CAR LST)
(FUNCTION (LAMBDA (ENTRY)
(* CADDR of the entry is used for saving side information on the edito history list. however, can't just rplacd
CDR because that node is reused by historysave.)
(RPLNODE (CDDR ENTRY)
(CONSTANT (CHARACTER (CHARCODE BELL]
(T (MAPC (CAR LST)
(FUNCTION PURGEHISTORY2])
(PURGEHISTORY2
[LAMBDA (ENTRY) (* wt: 2-DEC-75 15 46)
(PROG (TEM)
(COND
((SETQ TEM (LISTGET1 ENTRY (QUOTE *GROUP*)))
[RPLACD (CDDR ENTRY)
(LIST (QUOTE *GROUP*)
TEM
(QUOTE *HISTORY*)
(LISTGET1 ENTRY (QUOTE *HISTORY*]
(MAPC TEM (FUNCTION PURGEHISTORY2)))
(T (RPLACD (CDDR ENTRY)
NIL])
)
(RPAQQ SMASHPROPSMENU (("old values of variables" VALUE)
("function definitions on property lists" EXPR CODE)
("advice information" ADVISED ADVICE READVICE (SETQ ADVISEDFNS NIL))
("filemaps" FILEMAP)
("clisp information (warning: this will disable clisp!)" ACCESSFN BROADSCOPE CLISPCLASS
CLISPCLASSDEF CLISPFORM
CLISPIFYISPROP CLISPINFIX
CLISPISFORM CLISPISPROP CLISPNEG
CLISPTYPE CLISPWORD CLMAPS I.S.OPR
I.S.TYPE LISPFN SETFN UNARYOP)
("compiler information (warning: this will disable the compiler!)" AMAC BLKLIBRARYDEF CROPS
CTYPE GLOBALVAR MACRO MAKE
OPD UBOX)
("definitions of named history commands" *HISTORY*)
("context of edits exited via save command" EDIT-SAVE)))
(RPAQQ SMASHPROPSLST NIL)
(ADDTOVAR GAINSPACEFORMS ((CAR LISPXHISTORY)
"purge history lists"
(PURGEHISTORY RESPONSE)
((Y "es")
(N "o")
(E . "verything")))
[T "discard definitions on property lists"
(SETQ SMASHPROPSLST1 (CONS (QUOTE EXPR)
(CONS (QUOTE CODE)
(CONS (QUOTE SUBR)
SMASHPROPSLST1]
(T "discard old values of variables" (SETQ SMASHPROPSLST1
(CONS (QUOTE VALUE)
SMASHPROPSLST1)))
(T "erase properties" (ERASEPROPS RESPONSE)
((Y "es" EXPLAINSTRING
"Yes - you will be asked which properties are to be erased")
(N "o")
(A "ll" CONFIRMFLG T EXPLAINSTRING
"All - all properties on mentioned on SMASHPROPSMENU")
(E "dit
" EXPLAINSTRING "Edit - you will be allowed to edit a list of property names")))
(CLISPARRAY "erase CLISP translations" (CLRHASH CLISPARRAY))
(CHANGESARRAY "erase changes array" (CLRHASH CHANGESARRAY))
(SYSHASHARRAY "erase system hash array" (CLRHASH))
((GETPROP (QUOTE EDIT)
(QUOTE LASTVALUE))
"discard context of last edit"
(REMPROP (QUOTE EDIT)
(QUOTE LASTVALUE)))
(GREETHIST "discard information saved for undoing your greeting"
(SETQ GREETHIST)))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: GAINSPACEBLOCK GAINSPACE ERASEPROPS PURGEHISTORY PURGEHISTORY1 PURGEHISTORY2
(ENTRIES GAINSPACE ERASEPROPS PURGEHISTORY)
(GLOBALVARS GAINSPACEFORMS SMASHPROPSMENU SMASHPROPSLST SMASHPROPSLST1 DWIMWAIT ARCHIVELST
LASTHISTORY ARCHIVEFLG LISPXCOMS LISPXHISTORY EDITHISTORY)
(SPECVARS RESPONSE))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD GAINSPACE (PRECHECK MESSAGE FORM KEYLST))
]
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL READ' CONTROLW (LINKFNS . T))
(BLOCK: NIL READLINEP (GLOBALVARS LISPXREADFN))
(BLOCK: NIL READCOMMENT PRINTCOMMENT GETCOMMENT
(GLOBALVARS **COMMENT**FLG CHANGEFLG0 CLISPCHARRAY CLISPFLG COMMENTFLG COMMENTFONT
DEFAULTFONT FILERDTBL FIRSTCOL FONTCHANGEFLG NORMALCOMMENTSFLG TTYFONTCHANGEFLG)
(LINKFNS . T))
(BLOCK: NIL DO?= DO? (GLOBALVARS LAST?)
(NOLINKFNS HELPSYS))
]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML TRYNEXT POSSIBILITIES GENERATOR COROUTINE BQUOTE ASKUSERLOOKUP)
(ADDTOVAR LAMA AU-REVOIR ADIEU)
)
(PUTPROPS ASSIST COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3383 4296 (READVBAR 3393 . 3698) (READBQUOTE 3700 . 4294)) (4297 6335 (EXPANDBQUOTE
4307 . 5192) (BQUOTE 5194 . 5358) (DOBQUOTE 5360 . 6333)) (6653 17841 (CONTROLW 6663 . 8531) (
READLINEP 8533 . 8955) (READ' 8957 . 9320) (READCOMMENT 9322 . 13169) (GETCOMMENT 13171 . 17129) (
PRINTCOMMENT 17131 . 17839)) (18821 20431 (PRINTPROPS 18831 . 19339) (PRINTBINDINGS 19341 . 20429)) (
20944 21441 (SHOWPRINT 20954 . 21210) (SHOWPRIN2 21212 . 21439)) (21581 26606 (DO? 21591 . 24196) (
DO?= 24198 . 26604)) (27941 63715 (ASKUSER 27951 . 54892) (ASKUSERLOOKUP 54894 . 55340) (ASKUSERCHAR
55342 . 55757) (ASKUSER$ 55759 . 57687) (ASKUSER1 57689 . 58543) (ASKUSERSETUP 58545 . 60288) (
ASKUSEREXPLAIN 60290 . 61930) (ASKUSERPRIN1 61932 . 62367) (MAKEKEYLST 62369 . 63713)) (65030 67921 (
COROUTINE 65040 . 65843) (OLDRESUME 65845 . 66664) (GENERATOR 66666 . 67183) (GENERATE 67185 . 67275)
(PRODUCE 67277 . 67363) (GENERATEFN 67365 . 67919)) (68024 69956 (ADIEU 68034 . 68201) (AU-REVOIR
68203 . 68412) (CLEANPOSLST 68414 . 68577) (NOTE 68579 . 68702) (POSSIBILITIES 68704 . 69000) (TRYNEXT
69002 . 69272) (TRYNEXT1 69274 . 69650) (POSSIBILITYFN 69652 . 69954)) (74447 78408 (GAINSPACE 74457
. 75380) (ERASEPROPS 75382 . 76317) (PURGEHISTORY 76319 . 77430) (PURGEHISTORY1 77432 . 77993) (
PURGEHISTORY2 77995 . 78406)))))
STOP