(FILECREATED "27-Aug-86 23:18:21" {ERIS}<LISPCORE>SOURCES>ASSIST.;34 38575
changes to: (VARS ASSISTCOMS)
previous date: "21-Jul-86 06:09:07" {ERIS}<LISPCORE>SOURCES>ASSIST.;33)
(* Copyright (c) 1978, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved. The
following program was created in 1978 but has not been published within the meaning of the copyright
law, is furnished under license, and may not be used, copied and/or disclosed except in accordance
with the terms of said license.)
(PRETTYCOMPRINT ASSISTCOMS)
(RPAQQ ASSISTCOMS [(COMS (FILEPKGCOMS CONSTANTS))
(COMS (GLOBALVARS SPELLINGS1 SPELLINGS2 USERWORDS)
(FNS PRINTPROPS PRINTBINDINGS)
(LISPXMACROS PL PB ;))
(COMS (GLOBALVARS SYSPRETTYFLG)
(FNS SHOWPRINT SHOWPRIN2)
(INITVARS (SYSPRETTYFLG)))
(COMS (GLOBALVARS LAST? LISPXREADFN)
(FNS DO? DO?= READLINEP PRINT-ARGLIST)
(VARS (LAST?))
[DECLARE: DONTEVAL@LOAD DOCOPY
(P (LET ((RDTBL (FIND-READTABLE "OLD-INTERLISP-T")))
(COND (RDTBL (SETSYNTAX (QUOTE ?)
(QUOTE (INFIX FIRST NOESC DO?))
RDTBL)
(AND (READTABLEP (EVALV (QUOTE EDITRDTBL)))
(SETSYNTAX (QUOTE ?)
RDTBL EDITRDTBL]
(PROP ARGNAMES DEFINEQ)
(USERMACROS ?=))
(COMS (* Coroutine package.)
(I.S.OPRS OUTOF)
(PROP (MACRO INFO)
COROUTINE GENERATOR TRYNEXT POSSIBILITIES)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML TRYNEXT POSSIBILITIES GENERATOR COROUTINE BQUOTE
ASKUSERLOOKUP)
(LAMA AU-REVOIR ADIEU)))
(FNS COROUTINE GENERATOR GENERATE PRODUCE GENERATEFN)
(FNS ADIEU AU-REVOIR CLEANPOSLST NOTE POSSIBILITIES TRYNEXT TRYNEXT1
POSSIBILITYFN)
(ADDVARS (SYSSPECVARS COMVAR## POSSLIST##)))
[COMS (* gainspace package)
(DECLARE: DOEVAL@COMPILE DONTCOPY (RECORDS GAINSPACE)
(GLOBALVARS GAINSPACEFORMS SMASHPROPSMENU SMASHPROPSLST
SMASHPROPSLST1 DWIMWAIT ARCHIVELST LASTHISTORY ARCHIVEFLG
LISPXCOMS LISPXHISTORY EDITHISTORY))
(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]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML TRYNEXT POSSIBILITIES GENERATOR COROUTINE)
(LAMA AU-REVOIR ADIEU])
(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) [QUOTE ((COM MACRO
(X (DECLARE: EVAL@COMPILE (VARS . X)
(P (CONSTANTS . X])
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SPELLINGS1 SPELLINGS2 USERWORDS)
)
(DEFINEQ
(PRINTPROPS
[LAMBDA (AT) (* lmm " 7-May-84 15:35")
(RESETFORM (PRINTLEVEL (QUOTE (2 . 3)))
(MAP (OR (GETPROPLIST AT)
(GETPROPLIST (OR (MISSPELLED? AT NIL USERWORDS)
AT)))
[FUNCTION (LAMBDA (TL)
(PRIN2 (CAR TL)
T T)
(PRIN1 " : " T)
(SHOWPRINT (CADR TL)
T T]
(FUNCTION CDDR])
(PRINTBINDINGS
[LAMBDA (AT POS FL) (* lmm "14-Aug-84 20:33")
(* Print out the bindings of an atom)
(RESETFORM (PRINTLEVEL 2 3)
(PROG (NAME VAL EPOS)
(OR FL (SETQ FL T))
(printout FL "bindings for " AT ": " 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 (MAPC (NLAMBDA.ARGS LISPXLINE)
(FUNCTION PRINTPROPS)))
(T (QUOTE (E PL]
[PB (COND [LISPXLINE (MAPC (NLAMBDA.ARGS LISPXLINE)
(FUNCTION (LAMBDA
(X)
(PRINTBINDINGS
X
(AND (EQ LISPXID (QUOTE :))
LASTPOS]
(T (QUOTE (E PB]
(; NIL NIL))
(ADDTOVAR HISTORYCOMS ;)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SYSPRETTYFLG)
)
(DEFINEQ
(SHOWPRINT
[LAMBDA (X FILE RDTBL) (* lmm "14-Aug-84 20:40")
(COND
(SYSPRETTYFLG (PRINTDEF X T NIL NIL NIL FILE)
(TERPRI FILE))
(T (PRINT X FILE RDTBL)))
X])
(SHOWPRIN2
[LAMBDA (X FILE RDTBL) (* lmm "14-Aug-84 20:40")
(COND
(SYSPRETTYFLG (PRINTDEF X T NIL NIL NIL FILE))
(T (PRIN2 X FILE RDTBL)))
X])
)
(RPAQ? SYSPRETTYFLG )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS LAST? LISPXREADFN)
)
(DEFINEQ
(DO?
[LAMBDA (FILE RDTBL LST) (* AJB "16-Jan-86 17:41")
(PROG (C TAIL FORM FN TEM LN)
(SETQ C (PEEKC FILE))
[COND
[(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 "21-Jul-86 05:47")
(ERSETQ (PROG (ARGNAMES TEM (*PRINT-LEVEL* 3))
(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)) (* tail provided for spelling
correction purposes.)
(PRINT-ARGLIST ARGNAMES (CDR FORM)
FILE LEFT])
(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])
(PRINT-ARGLIST
[LAMBDA (ARGS ACTUALS FILE LEFT) (* lmm "21-Jul-86 06:01")
(PROG (TYPE REMARGS)
(OR LEFT (SETQ LEFT 0)) (* Prints args to fn, mastching up
with ACTUALS, if supplied.
Do this in a way that lets us keep
track of where we are)
(if (AND ARGS (NLISTP ARGS))
then (SETQ ARGS (LIST (QUOTE &NREST)
ARGS)))
[COND
(ACTUALS (COND
((CDR ACTUALS)
(TAB 0 0 FILE))
(T (PRIN1 " " FILE)))
(bind MODE while ACTUALS
do [COND
((NULL ARGS)
(TAB 0 0 FILE)
(PRIN1 "...+" FILE))
((NLISTP ARGS)
(TAB 0 0 FILE)
(PRIN1 " . " FILE)
(PRIN2 ARGS FILE)
(SETQ ARGS))
(T (SELECTQ (CAR ARGS)
((&REST &BODY)
(TAB 0 0 FILE)
(PRIN2 (pop ARGS)
FILE)
(PRIN1 " " FILE)
(PRIN2 (pop ARGS)
FILE)
(PROGN (TAB 15 1 FILE)
(PRIN1 "= " FILE))
(PRIN2 ACTUALS FILE)
(SETQ ACTUALS)
(TERPRI FILE)
(RETURN))
(&ALLOW-OTHER-KEYS
(SPACES 1 FILE)
(PRIN2 (pop ARGS)
FILE)
(TERPRI FILE)
(GO $$ITERATE))
(&OPTIONAL (PRIN2 (SETQ MODE (pop ARGS))
FILE)
(PRIN1 " " FILE)
(PRIN2 (pop ARGS)
FILE))
(&KEY (while ARGS do (PRIN1 " " FILE)
(PRIN2 (pop ARGS)
FILE))
(while ACTUALS do (PROGN (TAB 15 1 FILE)
(PRIN1 "= " FILE))
(PRIN2 (pop ACTUALS)
FILE)
(PRIN1 " " FILE)
(PRIN2 (pop ACTUALS)
FILE)
(TERPRI FILE))
(RETURN))
(PRIN2 (pop ARGS)
FILE]
(PROGN (TAB 15 1 FILE)
(PRIN1 "= " FILE))
(PRIN2 (CAR ACTUALS)
FILE)
(SETQ ACTUALS (CDR ACTUALS))
(TERPRI FILE]
(while ARGS do (PRIN2 (pop ARGS)
FILE)
(AND ARGS (PRIN1 " " FILE])
)
(RPAQQ LAST? NIL)
(DECLARE: DONTEVAL@LOAD DOCOPY
[LET ((RDTBL (FIND-READTABLE "OLD-INTERLISP-T")))
(COND (RDTBL (SETSYNTAX (QUOTE ?)
(QUOTE (INFIX FIRST NOESC DO?))
RDTBL)
(AND (READTABLEP (EVALV (QUOTE EDITRDTBL)))
(SETSYNTAX (QUOTE ?)
RDTBL EDITRDTBL]
)
(PUTPROPS DEFINEQ ARGNAMES (NIL (X1 XI ... XN) . X))
(ADDTOVAR EDITMACROS (?= NIL (E (PROGN (DO?= (##))
(TERPRI T))
T)))
(ADDTOVAR EDITCOMSA ?=)
(* Coroutine package.)
(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 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 ((FORM COMVAR)
(GENERATEFN [FUNCTION (LAMBDA NIL FORM]
COMVAR)))
(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)
(POSSIBILITYFN (FUNCTION (LAMBDA NIL FORM])
(PUTPROPS COROUTINE INFO EVAL)
(PUTPROPS GENERATOR INFO EVAL)
(PUTPROPS TRYNEXT INFO EVAL)
(PUTPROPS POSSIBILITIES INFO EVAL)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML TRYNEXT POSSIBILITIES GENERATOR COROUTINE BQUOTE ASKUSERLOOKUP)
(ADDTOVAR LAMA AU-REVOIR ADIEU)
)
(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])
(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])
)
(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##)
(* gainspace package)
(DECLARE: DOEVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD GAINSPACE (PRECHECK MESSAGE FORM KEYLST)
(SYSTEM))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS GAINSPACEFORMS SMASHPROPSMENU SMASHPROPSLST SMASHPROPSLST1 DWIMWAIT ARCHIVELST
LASTHISTORY ARCHIVEFLG LISPXCOMS LISPXHISTORY EDITHISTORY)
)
)
(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 COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML TRYNEXT POSSIBILITIES GENERATOR COROUTINE)
(ADDTOVAR LAMA AU-REVOIR ADIEU)
)
(PUTPROPS ASSIST COPYRIGHT ("Xerox Corporation" T 1978 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (6693 8979 (PRINTPROPS 6703 . 7298) (PRINTBINDINGS 7300 . 8977)) (9949 10419 (SHOWPRINT
9959 . 10201) (SHOWPRIN2 10203 . 10417)) (10515 20675 (DO? 10525 . 15107) (DO?= 15109 . 15941) (
READLINEP 15943 . 16432) (PRINT-ARGLIST 16434 . 20673)) (23508 25947 (COROUTINE 23518 . 24455) (
GENERATOR 24457 . 25078) (GENERATE 25080 . 25182) (PRODUCE 25184 . 25282) (GENERATEFN 25284 . 25945))
(25948 28353 (ADIEU 25958 . 26147) (AU-REVOIR 26149 . 26378) (CLEANPOSLST 26380 . 26629) (NOTE 26631
. 26820) (POSSIBILITIES 26822 . 27157) (TRYNEXT 27159 . 27503) (TRYNEXT1 27505 . 28001) (
POSSIBILITYFN 28003 . 28351)) (28773 35299 (GAINSPACE 28783 . 30610) (ERASEPROPS 30612 . 32221) (
PURGEHISTORY 32223 . 34094) (PURGEHISTORY1 34096 . 34767) (PURGEHISTORY2 34769 . 35297)))))
STOP