(FILECREATED "17-Jan-86 22:48:48" {ERIS}<LISPCORE>SOURCES>ASSIST.;31 70164  

      changes to:  (VARS ASSISTCOMS)

      previous date: "16-Jan-86 17:46:56" {ERIS}<LISPCORE>SOURCES>ASSIST.;30)


(* 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 (* Read macro for ')
                         (FNS READ')
                         (P (AND (BOUNDP (QUOTE EDITRDTBL))
                                 (READTABLEP EDITRDTBL)
                                 (PROGN (SETSYNTAX (QUOTE ')
                                               (QUOTE (MACRO FIRST ESCQUOTE READ'))
                                               EDITRDTBL)
                                        (SETSYNTAX (QUOTE ')
                                               EDITRDTBL T]
                   (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)
                         (VARS (LAST?))
                         (P (SETSYNTAX (QUOTE ?)
                                   (QUOTE (INFIX FIRST NOESC DO?))
                                   T)
                            (AND (BOUNDP (QUOTE EDITRDTBL))
                                 (READTABLEP EDITRDTBL)
                                 (SETSYNTAX (QUOTE ?)
                                        T EDITRDTBL)))
                         (PROP ARGNAMES DEFINEQ)
                         (USERMACROS ?=))
                   (COMS * ASKUSERCOMS)
                   (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 ASKUSERLOOKUP)
                                 (LAMA AU-REVOIR ADIEU])
(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) [QUOTE ((COM MACRO
                                                           (X (DECLARE: EVAL@COMPILE (VARS . X)
                                                                     (P (CONSTANTS . X])



(* Read macro for ')

(DEFINEQ

(READ'

  [LAMBDA (FILE RDTBL)                                       (* bvm: " 6-Jul-85 22:44")

    (
SELECTQ
 (
GETSYNTAX
 (
PEEKCCODE
 FILE)
			RDTBL)
	     ((RIGHTPAREN RIGHTBRACKET)                      (* Shouldn't have to test this, since such a quote is 

							     required to be escaped. This test is merely a nicety 

							     for type-in)

	       (
QUOTE
 '))
	     (
LIST
 (
QUOTE
 QUOTE)
		   (
READ
 FILE RDTBL])
)
(AND (BOUNDP (QUOTE EDITRDTBL))
     (READTABLEP EDITRDTBL)
     (PROGN (SETSYNTAX (QUOTE ')
                   (QUOTE (MACRO FIRST ESCQUOTE READ'))
                   EDITRDTBL)
            (SETSYNTAX (QUOTE ')
                   EDITRDTBL T)))
(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 "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])

(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])
)

(RPAQQ LAST? NIL)
(SETSYNTAX (QUOTE ?)
       (QUOTE (INFIX FIRST NOESC DO?))
       T)
(AND (BOUNDP (QUOTE EDITRDTBL))
     (READTABLEP EDITRDTBL)
     (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.)
                    (GLOBALVARS DEFAULTKEYLST ASKUSERTTBL)
                    (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)))
                    (DECLARE: DOEVAL@COMPILE DONTCOPY (RECORDS ASKUSER OPTIONS))))



(* Askuser package.)

(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DEFAULTKEYLST ASKUSERTTBL)
)
(DEFINEQ

(ASKUSER

  [LAMBDA (WAIT DEFAULT MESS KEYLST TYPEAHEAD LISPXPRNTFLG OPTIONSLST FILE)
    (DECLARE
 (
SPECVARS
 LISPXPRNTFLG OPTIONSLST FILE))        (* lmm "15-Jun-85 17:40")

                                                             (* 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)))
		    [
COND

		      ((
AND
 DEFAULT (
NLISTP
 DEFAULT))
			(
SETQ
 DEFAULT (
LIST
 DEFAULT]
		    (
COND

		      ((
NULL
 (
WAITFORINPUT
 (
ITIMES
 WAIT 1000)))
                                                             (* 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: DOEVAL@COMPILE DONTCOPY 
[DECLARE: EVAL@COMPILE 

(RECORD ASKUSER (KEY PROMPTSTRING . OPTIONS)
                (SYSTEM))

(PROPRECORD OPTIONS (KEYLST CONFIRMFLG RETURN EXPLAINSTRING NOECHOFLG KEYSTRING PROMPTON COMPLETEON 
                           AUTOCOMPLETEFLG MACROCHARS NOCASEFLG PROMPTCONFIRMFLG CLASS)
                    (SYSTEM))
]
)



(* 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 ASKUSERLOOKUP)

(ADDTOVAR LAMA AU-REVOIR ADIEU)
)
(PUTPROPS ASSIST COPYRIGHT ("Xerox Corporation" T 1978 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (6764 7238 (READ' 6774 . 7236)) (7567 9115 (PRINTPROPS 7577 . 7970) (PRINTBINDINGS 7972
 . 9113)) (10077 10527 (SHOWPRINT 10087 . 10315) (SHOWPRIN2 10317 . 10525)) (10619 16634 (DO? 10629 . 
13756) (DO?= 13758 . 16164) (READLINEP 16166 . 16632)) (17840 55729 (ASKUSER 17850 . 46906) (
ASKUSERLOOKUP 46908 . 47354) (ASKUSERCHAR 47356 . 47771) (ASKUSER$ 47773 . 49701) (ASKUSER1 49703 . 
50557) (ASKUSERSETUP 50559 . 52302) (ASKUSEREXPLAIN 52304 . 53944) (ASKUSERPRIN1 53946 . 54381) (
MAKEKEYLST 54383 . 55727)) (58453 60523 (COROUTINE 58463 . 59266) (GENERATOR 59268 . 59785) (GENERATE 
59787 . 59877) (PRODUCE 59879 . 59965) (GENERATEFN 59967 . 60521)) (60524 62456 (ADIEU 60534 . 60701) 
(AU-REVOIR 60703 . 60912) (CLEANPOSLST 60914 . 61077) (NOTE 61079 . 61202) (POSSIBILITIES 61204 . 
61500) (TRYNEXT 61502 . 61772) (TRYNEXT1 61774 . 62150) (POSSIBILITYFN 62152 . 62454)) (62857 66818 (
GAINSPACE 62867 . 63790) (ERASEPROPS 63792 . 64727) (PURGEHISTORY 64729 . 65840) (PURGEHISTORY1 65842
 . 66403) (PURGEHISTORY2 66405 . 66816)))))
STOP