(FILECREATED "11-Sep-84 16:51:16" {ERIS}<LISPCORE>SOURCES>HELPDL.;6 35021
changes to: (VARS HELPDLCOMS)
(FNS INTCHAR)
previous date: "11-Sep-84 15:04:48" {ERIS}<LISPCORE>SOURCES>HELPDL.;5)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation. All rights reserved. The following program was
created in 1982 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 HELPDLCOMS)
(RPAQQ HELPDLCOMS [(FNS HELP SHOULDNT ERROR ERRORMESS ERRORMESS1 ERRORX ERRORX2 ERRORX3 ERRORX4
BREAKCHECK FINDERSET STKARGS VARIABLES INTERRUPT MAKEAPPLY FAULTEVAL
FAULTAPPLY FAULT1 SEARCHPDL MAPDL INTCHAR INTERRUPTCHAR LISPINTERRUPTS
RESETTERMCHARS RESETINT)
(INITVARS (HELPFLAG T)
(HELPDEPTH 7)
(HELPTIME 1000)
(HELPCLOCK)
(NLSETQGAG T)
(STORAGERRORS (QUOTE (2 12 21 31 34)))
(ERRORTYPELST)
(USERINTERRUPTS))
(P (MOVD? (QUOTE FAULT1)
(QUOTE OLDFAULT1))
(MOVD? (QUOTE CLOSEF)
(QUOTE EOFCLOSEF))
[PUTDQ? BREAK1 (NLAMBDA (BRKEXP BRKWHEN BRKFN)
(PROG (BRKTEM)
(PRINT (LIST BRKFN (QUOTE BROKEN))
T T)
LP
(PRIN1 ":" T T)
(SELECTQ (SETQ BRKTEM (READ T T))
(OK (RETEVAL (QUOTE BREAK1)
BRKEXP))
(BT (BACKTRACE (QUOTE BREAK1)
T 0))
(BTV (BACKTRACE (QUOTE BREAK1)
T 7))
NIL)
(PRINT (EVAL BRKTEM (QUOTE :))
T T)
(GO LP]
(AND (CCODEP (QUOTE GETINTERRUPT))
(INTCHAR T)))
(BLOCKS * HELPDLBLOCKS)
(DECLARE: EVAL@COMPILE (ADDVARS (SYSSPECVARS HELPFLAG))
DONTCOPY
(MACROS CFOBF))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(DEFINEQ
(HELP
[LAMBDA (MESS1 MESS2 BRKTYPE) (* rrb "11-AUG-83 11:07")
(* Help always breaks.)
(APPLY* (FUNCTION BREAK1)
(QUOTE (ERROR (QUOTE "??")
(QUOTE "")
T))
T
(QUOTE HELP)
NIL BRKTYPE (LIST MESS1 MESS2 (QUOTE help!])
(SHOULDNT
[LAMBDA (MESS) (* rrb "11-AUG-83 11:05")
(* changed to pass (QUOTE ERRORX) through to HELP so
that BREAK1 will clear type ahead.)
(HELP "
Shouldn't happen!" (OR MESS "")
(QUOTE ERRORX])
(ERROR
[LAMBDA (MESS1 MESS2 NOBREAK) (* rmk: "18-NOV-81 17:34")
(DECLARE (GLOBALVARS NLSETQGAG))
(COND
((AND NOBREAK (NEQ HELPFLAG (QUOTE BREAK!))) (* An ERROR! cum message.)
[PROG (POS)
(COND
((OR (NULL NLSETQGAG)
(NULL (SETQ POS (STKPOS (QUOTE ERRORSET)
-1)))
(PROG1 (STKARG 2 POS)
(RELSTK POS)))
(SETERRORN 17 (CONS MESS1 MESS2))
(ERRORMESS]
(ERROR!))
(T (ERRORX (LIST 17 (CONS MESS1 MESS2])
(ERRORMESS
[LAMBDA (U) (* rrb " 9-SEP-83 12:22")
(* Replaces ERRORM.)
(* merged FAULT2 printing in, driven off of extra
information on ERRORN -
rrb 7/83)
[COND
((NULL U)
(SETQ U (ERRORN]
(COND
((EQ (CAR U)
17)
(ERRORMESS1 (CAR (SETQ U (CADR U)))
(CDR U)
(QUOTE ERROR)))
(T [COND
((AND LISPXHISTORY (NEQ (CAR U)
18)
(NOT (MEMB (CAR U)
STORAGERRORS)))
(LISPXPUT (QUOTE *ERROR*)
(CADR U]
(COND
(LISPXPRINTFLG (PROG ((EXTRAMES (CADDR U)))
(LISPXTERPRI T)
(LISPXPRIN1 (ERRORSTRING (CAR U))
T)
(LISPXTERPRI T)
(LISPXPRIN2 (CADR U)
T)
[COND
((LISTP EXTRAMES) (* in top level unbound atoms this is the litatom NORMAL
for which nothing should print.)
(LISPXPRIN1 (QUOTE " {in ")
T)
(LISPXPRIN2 (CAR EXTRAMES)
T T)
(LISPXPRIN1 (QUOTE "}")
T)
(COND
((CDR EXTRAMES)
(LISPXPRIN1 (QUOTE " in ")
T)
(LISPXPRIN2 (CDR EXTRAMES)
T T]
(LISPXTERPRI T)))
(T (ERRORM U])
(ERRORMESS1
[LAMBDA (MESS1 MESS2 MESS3) (* lmm " 1-APR-82 23:02")
(* Prints messages for help and error)
(PROG (BADGUY MESSAGE)
(COND
((AND (NULL MESS1)
(NULL MESS2))
(LISPXPRINT MESS3 T T)
(RETURN)))
(LISPXPRIN1 MESS1 T)
(COND
((OR (ATOM MESS1)
(STRINGP MESS2))
(LISPXSPACES 1 T))
(T (LISPXTERPRI T)))
(SETQ BADGUY MESS1)
(SETQ MESSAGE MESS2)
(COND
((STRINGP MESS2)
(LISPXPRIN1 MESS2 T)
(LISPXTERPRI T))
(T (LISPXPRINT (SETQ BADGUY MESS2)
T T)
(SETQ MESSAGE MESS1))) (* The offender is MESS2 if it is not a string,
otherwise MESS1.)
(COND
((AND LISPXHISTORY (NEQ MESS3 (QUOTE help!)))
(LISPXPUT (QUOTE *ERROR*)
BADGUY])
(ERRORX
[LAMBDA (ERXM) (* wt: 15-NOV-76 23 38)
(* ERXM is an optional error number and message.)
(ERRORX2 (COND
(ERXM (SETERRORN (CAR ERXM)
(CADR ERXM))
ERXM)
(T (ERRORN)))
(REALSTKNTH -1 (QUOTE ERRORX)
T])
(ERRORX2
[LAMBDA (ERRORMESS ERRORPOS) (* JonL " 9-Mar-84 00:42")
(* ERRORMESS is the error message, ERRORPOS is the stack
position of the last function before any error function)
(SELECTQ (SYSTEMTYPE)
((TENEX TOPS20)
(* It is hard for the 10 SKIPSEPRS subr to return NIL on EOF, so we handle it here prior to any other processing,
since this is technically not an error.)
(AND (EQ 16 (CAR ERRORMESS))
(EQ (STKNAME ERRORPOS)
(QUOTE SKIPSEPRS))
(RETFROM ERRORPOS NIL T)))
NIL)
(PROG (EX2X EX2FN (PRINTMSG T)
BREAKCHK)
(* PRINTMSG is initially T because if no errorset is found, i.e. error occurs in typein a top level, the message
is to be printed)
(SETQ BREAKCHK (BREAKCHECK ERRORPOS (CAR ERRORMESS)))
(COND
([AND (SETQ EX2X (FASSOC (CAR ERRORMESS)
ERRORTYPELST))
(SETQ EX2X (EVAL (CADR EX2X]
(* This is an attempt at providing the user with a way of specifying treatment of certain error conditions.
The error number is looked up on ERRORTYPELST and if found, CADR is evaluated. If this produces a non-nil value,
the function causing the error is reevaluated with the result of the evaluation substituted for the offender, a la
the alt-mode command. (If Alice fixes the call to ERRORX2 so that they all continue, e.g. INFILE, RPLACA, etc.
then we can take out the RETEVAL.) Note of course that the user can always 'take over' by simply having the form
on ERRORMESS, ERRORPOS, to a RETEVAL. In order to make this feature more convenient to user, ERRORMESS and
BREAKCHK are SPECVARS)
(RETAPPLY ERRORPOS (STKNAME ERRORPOS)
(SUBST EX2X (CADR ERRORMESS)
(STKARGS ERRORPOS))
T)))
(SELECTQ (CAR ERRORMESS)
[16 (* END OF FILE)
(AND (OPENP (CADR ERRORMESS))
(EOFCLOSEF (CADR ERRORMESS]
[26 (* Hash array full. When PUTHASH is fixed in all
implementations so that it calls HASHOVERFLOW directly,
then special treatment here can be removed.)
(COND
((LISTP (CADR ERRORMESS))
(RETURN (PROG1 (HASHOVERFLOW (CADR ERRORMESS))
(RELSTK ERRORPOS]
[43 (* User break)
(COND
((SETQ EX2X (FASSOC (CADR ERRORMESS)
USERINTERRUPTS))
[RETEVAL (QUOTE ERRORX)
(SUBPAIR (QUOTE (ERRORPOS EXP))
(LIST ERRORPOS (CADR EX2X))
(QUOTE (OR (ERSETQ (RETFROM ERRORPOS EXP T))
(PROGN (RELSTK ERRORPOS)
(ERROR!]
(* causes a return to the functi at errorpos, with
(CADR EX2X) evaluated as of ERRORX)
)
(T (ERROR (QUOTE "undefined user interrupt")
(CADR ERRORMESS]
NIL)
[COND
((NULL BREAKCHK) (* Causes error to occur just after actual positio)
(COND
(PRINTMSG (* print message if no break is to occur.)
(ERRORMESS ERRORMESS)))
(RELSTK ERRORPOS)
(RETEVAL (QUOTE ERRORX)
(QUOTE (ERROR!]
(SETQ EX2FN (STKNAME ERRORPOS))
(COND
((SETQ EX2X (FNTYP EX2FN))
(SETQ EX2X (ERRORX3 EX2FN EX2X ERRORPOS ERRORMESS)))
(T (* the realstknth in errorx should take care of skipping
over *PROG*LAM and BLOCK frames)
(SHOULDNT)))
(RETEVAL (QUOTE ERRORX)
(LIST (QUOTE RETFROM)
ERRORPOS EX2X T))
(* the reson for calling reteval to do the retfrom, rather than doing it in one operaton is that we want the
evaluation of the break expression to take place just below where the error occurs, so thatthe arguments are on
the stack, but we want the value returned to be returned as the value of the function causing the error.)
])
(ERRORX3
[LAMBDA (FN TYPE POS ERRMESS) (* lmm "13-AUG-83 23:34")
(PROG (NARGS N TEM)
(SETQ NARGS (STKNARGS POS))
[COND
((EQ (ARGTYPE FN)
2) (* EXPR* or CEXPR*)
(COND
((AND (SETQ TEM (STKARGNAME NARGS POS))
(LITATOM TEM))
(GO OUT))
(T (GO MKEVALA]
(SETQ N 0)
LP (* check to see if all argument names are on the stack)
(COND
((EQ N NARGS)
(GO OUT) (* all argument names are on the stack, so can proceed
by simply constructing the appropriate expression and
returning)
)
((AND (SETQ TEM (STKARGNAME (SETQ N (ADD1 N))
POS))
(LITATOM TEM))
(GO LP)))
MKEVALA
(RETURN (ERRORX4 FN TYPE POS NARGS NIL ERRMESS))
OUT (RETURN (LIST (QUOTE BREAK1)
[SAVED1 TYPE FN (COND
((FMEMB (CAR ERRMESS)
STORAGERRORS)
(* these errors are out of storage errors: STACK OVERFLOW, ATOM ARRAYS FULL, HASH TABLE FULL, STORAGE FULL, and
DATATYPE FULL dangerous to call smartarglist in this siutation)
(ARGLIST FN))
(T (SMARTARGLIST FN]
T FN NIL POS ERRMESS])
(ERRORX4
[LAMBDA (FN TYPE POS NARGS ARGVALS ERRMESS) (* lmm "13-AUG-83 23:38")
(* wt: 22-MAR-77 0 10)
(* constructs an appropriate expression to reteval when
all of the argument names are NOT on the stack.)
(PROG (ALST (N 0)
TEM BRKEXP ARGNAMES)
(SELECTQ TYPE
[(EXPR* CEXPR*)
(* this doesnt lend itself to the evala method, since the only bound variable is the one holding the number of
arguments passed. the others have to be spread just before the function call, and then the function called with
the number as its argument. hairy, not sure f it can be done.)
(COND
((STACKP POS)
(SETQ ARGVALS (STKARGS POS (SUB1 NARGS)))
(* the SUB1 is because dont want to include the number
of arguments in the list of arguments.)
]
[(SUBR* FSUBR*)
(COND
((STACKP POS)
(SETQ ARGVALS (STKARGS POS NARGS)))
((EQ TYPE (QUOTE FSUBR*)) (* because interrupt is given a LIST of the argument
values, but this is a nospead function.)
(SETQ ARGVALS (CAR ARGVALS]
(GO LP))
(RETURN (LIST (QUOTE BREAK1)
(LIST (QUOTE BLKAPPLY)
(LIST (QUOTE QUOTE)
FN)
(LIST (QUOTE QUOTE)
ARGVALS)
(QUOTE (QUOTE INTERNAL)))
T FN NIL POS ERRMESS))
LP [SETQ BRKEXP (SAVED1 TYPE FN (SETQ ARGNAMES (COND
((FMEMB (CAR ERRMESS)
STORAGERRORS)
(* these errors are out of storage errors: STACK OVERFLOW, ATOM ARRAYS FULL, HASH TABLE FULL, STORAGE FULL, and
DATATYPE FULL dangerous to call smartarglist in this siutation)
(ARGLIST FN))
(T (SMARTARGLIST FN]
[COND
((AND ARGNAMES (ATOM ARGNAMES))
(* this makes it easier for the loop below. note that in the cse of a call from interrupt, argvals lists the
single argument value. this corresponds to the CAR in MAKEAPPLY, and is why we have to take car in the case of an
FSUBR* above.)
(SETQ ARGNAMES (LIST ARGNAMES]
[COND
((NULL NARGS) (* called from interrupt.)
(SETQ NARGS (LENGTH ARGNAMES]
LP1 [COND
[(EQ N NARGS)
(RETURN (LIST (QUOTE EVALA)
(LIST (QUOTE QUOTE)
(LIST (QUOTE BREAK1)
BRKEXP T FN NIL POS ERRMESS))
(LIST (QUOTE QUOTE)
ALST]
(T (SETQ N (ADD1 N))
(SETQ ALST (NCONC1 ALST (CONS (COND
[ARGNAMES (COND
((ATOM ARGNAMES)
(PROG1 ARGNAMES (SETQ ARGNAMES NIL)))
(T (PROG1 (CAR ARGNAMES)
(SETQ ARGNAMES (CDR ARGNAMES]
(T (* extra arguments supplied.)
[SETQ TEM (PACK (LIST FN (GENSYM]
(NCONC1 BRKEXP TEM)
TEM))
(COND
((STACKP POS)
(STKARG N POS))
(T (* INTERRUPT calls ERRORX4 with POS=INTERRUPT AND
ARGVALS SUPPLIED)
(PROG1 (CAR ARGVALS)
(SETQ ARGVALS (CDR ARGVALS]
(GO LP1])
(BREAKCHECK
[LAMBDA (ERRORPOS ERXN) (* rmk: "18-NOV-81 18:19")
(* Used by ERRORX2, and FAULT1.)
(PROG (TEM)
(COND
((EQ ERXN 18)
(* Error number for control-b BREAK So no need to search for errorset position. always break, even if helpflag is
NIL. if user typed control-b, thats what he wants to have happen, evenif system rebound helpflag.)
(GO BREAK))
((NULL HELPFLAG)
(FINDERSET ERRORPOS) (* Called to decide on printing)
(RETURN NIL))
((EQ (SETQ TEM (FINDERSET ERRORPOS HELPDEPTH))
(QUOTE NOBREAK))
(RETURN NIL))
((OR TEM (EQ HELPFLAG (QUOTE BREAK!))
(AND (FIXP HELPCLOCK)
(FIXP HELPTIME)
(IGREATERP (IDIFFERENCE (CLOCK 2)
HELPCLOCK)
HELPTIME)))
(GO BREAK))
(T (RETURN NIL)))
BREAK
(SETQ PRINTMSG T) (* Always print message if going into a BREAK.)
(RETURN T])
(FINDERSET
[LAMBDA (ERRORPOS N) (* jds " 6-Sep-84 13:33")
(* Scans control stack looking for ERRORSET with second arg T, NIL, or NOBREAK. If the arg is T, then break will
occur if the ERRORSET is more than N real frames back. Otherwise (NLSETQ), normally there will be no break and no
printing. ERRORSET's whose second argument is INTERNAL are ignored. Note hoever that they will affect the return
of control in the case that no break occurs.)
(PROG NIL
(SETQ ERRORPOS (STKNTH 0 ERRORPOS)) (* Copies POS.)
LP [COND
((AND N (REALFRAMEP ERRORPOS))
(* Only keep track of real frames, so that the heuristics are machine independent. The BLIPVAL counts the number
of EVALBLIPS in this frame, the -1 counts the frame. The AND N is for when HELPDEPTH is NIL.)
(SETQ N (SUB1 (IDIFFERENCE N (BLIPVAL (QUOTE *FORM*)
ERRORPOS T]
[COND
((EQ (STKNAME ERRORPOS)
(QUOTE ERRORSET))
(RETURN (PROG1 (SELECTQ (AND (IGEQ (STKNARGS ERRORPOS)
2)
(STKARG 2 ERRORPOS))
(T (SETQ PRINTMSG T) (* Print error messages.)
(AND N (ILESSP N 0)))
(NIL (* NLSETQ case. Normally, NLSETQGAG is T, and don't
print or break. NLSETQGAG is NIL for debugging, which
means do print and break.)
(OR (SETQ PRINTMSG (NULL NLSETQGAG))
(QUOTE NOBREAK)))
(NOBREAK (SETQ PRINTMSG NIL)
(QUOTE NOBREAK))
(GO NEXT))
(RELSTK ERRORPOS]
NEXT(COND
((SETQ ERRORPOS (STKNTH -1 ERRORPOS ERRORPOS))
(* ERRORSET'S with second argument INTERNAL or FAILSET are ignored for the purposes of deciding whether or not to
break, and whether or not to print a message. The STKNTH is NIL when we hit the top of the stack.)
(GO LP)))
(RELSTK ERRORPOS)
(RETURN NIL])
(STKARGS
[LAMBDA (POS NARGS) (* wt: 2-FEB-76 0 59)
(PROG (L)
(OR NARGS (SETQ NARGS (STKNARGS POS)))
(* NARGS is upplied on calls from ERRORX2 to handle lambda spreads. in this case, errorx2 gives stkargs one less
than the number of arguments so that the last argument, which is how many there were actually supplied, is left
off of the list of argument values.)
LP (COND
((ZEROP NARGS)
(RETURN L)))
(SETQ L (CONS (STKARG NARGS POS)
L))
(SETQ NARGS (SUB1 NARGS))
(GO LP])
(VARIABLES
[LAMBDA (POS)
(PROG (N L)
(SETQ N (STKNARGS POS))
LP (COND
((ZEROP N)
(RETURN L)))
(SETQ L (CONS (STKARGNAME N POS)
L))
(SETQ N (SUB1 N))
(GO LP])
(INTERRUPT
[LAMBDA (INTFN INTARGS INTYPE) (* lmm "13-AUG-83 23:59")
(PROG (INTX (ERRORPOS (QUOTE INTERRUPT)))
[SELECTQ INTYPE
(1)
[2 (RETEVAL (QUOTE INTERRUPT)
(LIST (QUOTE BREAK1)
NIL T [COND
((NLISTP INTFN)
INTFN)
(T (LIST (CAR INTFN)
(QUOTE --]
NIL
(QUOTE INTERRUPT]
(3 (PRIN1 (QUOTE gctrp)
T))
((0 -1)
(* For use in conjunction with GCTRP. After doing the reclaim, the user can conveniently cause the form that was
intrrupted to bbe evaluated by simply setting INTYPE to NIL. dont know what the 0 means but it happens.)
(RETEVAL (QUOTE INTERRUPT)
(MAKEAPPLY INTFN INTARGS)))
(COND
[(IGREATERP INTYPE 64) (* User interrupt)
(COND
((SETQ INTX (FASSOC (SETQ INTYPE (IDIFFERENCE INTYPE 64))
USERINTERRUPTS))
(EVAL (CADR INTX))
(BKBUFS (CLBUFS T))
(RETEVAL (QUOTE INTERRUPT)
(MAKEAPPLY INTFN INTARGS)))
(T (ERROR (QUOTE "undefined user interrupt")
INTYPE]
(T (HELP (QUOTE "bad interrupt type")
INTYPE]
(RETEVAL (QUOTE INTERRUPT)
(ERRORX4 INTFN (FNTYP INTFN)
(QUOTE INTERRUPT)
NIL INTARGS])
(MAKEAPPLY
[LAMBDA (INTFN INTARGS)
(* Constructs appropriate expression for BREAK1 when function has not yet been entered but its arguments have been
evaluated. the 'internal is for DWIM's benefit. If the usr defines the function in the BREAK or otherwise fixes
the error and then continues the computation, want DWIM to ignore this APPLY.)
(LIST (QUOTE APPLY)
(LIST (QUOTE QUOTE)
INTFN)
(LIST (QUOTE QUOTE)
(COND
((EQ (ARGTYPE INTFN)
3)
(CAR INTARGS))
(T INTARGS)))
(QUOTE (QUOTE INTERNAL])
(FAULTEVAL
[LAMBDA (FAULTX) (* lmm "14-Aug-84 18:52")
(FAULT1 FAULTX])
(FAULTAPPLY
[LAMBDA (FAULTFN FAULTARGS)
(FAULT1 FAULTFN FAULTARGS T])
(FAULT1
[LAMBDA (FAULTX FAULTARGS FAULTAPPLYFLG FAULTZ) (* rrb " 6-SEP-83 14:10")
(* When DWIM is enabled, and an error is to occur, DWIM calls FAULT1 specifying FAULTZ as the superexpression and
function name in which the error occurred. This information is passed to BREAK1 to be printed.)
(PROG ([FAULTPOS (STKNTH -1 (COND
(FAULTAPPLYFLG (QUOTE FAULTAPPLY))
(T (QUOTE FAULTEVAL]
(FAULTFN FAULTX)
ERRORMESS
(PRINTMSG T)) (* PRINTMSG is set freely under BREAKCHECK.)
(AND DWIMFLG (ATOM FAULTX)
(NULL FAULTAPPLYFLG)
(SETQ LASTWORD FAULTX))
(* So user can simply set it by typing $← form. Not much use to reset lastword for functions, and user might want
to type editf "()" using his earlier context.)
(SETERRORN (COND
(FAULTAPPLYFLG 46)
((ATOM FAULTX)
44)
(T (SETQ FAULTFN (CAR FAULTX))
45))
FAULTFN)
[SETQ ERRORMESS (COND
((AND FAULTZ (NOT FAULTAPPLYFLG)) (* FAULTZ is being passed down as extra arg tacked onto
ERRORN until the spec for ERRORN can be changed to allow
for it.)
(APPEND (ERRORN)
(CONS FAULTZ)))
(T (ERRORN]
(COND
((NULL (BREAKCHECK FAULTPOS))
(RELSTK FAULTPOS)
(COND
(PRINTMSG (ERRORMESS ERRORMESS)))
(ERROR!))) (* printing on this branch is done by break1.)
(AND LISPXHISTORY (LISPXPUT (QUOTE *ERROR*)
FAULTFN))
[COND
(FAULTAPPLYFLG (SETQ FAULTX (MAKEAPPLY FAULTFN FAULTARGS]
(RETEVAL (COND
(FAULTAPPLYFLG (QUOTE FAULTAPPLY))
(T (QUOTE FAULTEVAL)))
(LIST (QUOTE BREAK1)
FAULTX T FAULTFN NIL (LIST (PROG1 (BLIPVAL (QUOTE *FORM*)
FAULTPOS)
(RELSTK FAULTPOS)))
ERRORMESS])
(SEARCHPDL
[LAMBDA (SRCHFN SRCHPOS) (* Does not release or reuse SRCHPOS)
(PROG (SRCHX)
(SETQ SRCHPOS (COND
((NULL SRCHPOS)
(STKPOS (QUOTE SEARCHPDL)))
(SPAGHETTIFLG (STKNTH 0 SRCHPOS))
(T SRCHPOS)))
LP [COND
((NULL (SETQ SRCHPOS (STKNTH -1 SRCHPOS SRCHPOS)))
(RETURN NIL))
((APPLY* SRCHFN (SETQ SRCHX (STKNAME SRCHPOS))
SRCHPOS)
(RETURN (CONS SRCHX SRCHPOS]
(GO LP])
(MAPDL
[LAMBDA (MAPDLFN MAPDLPOS) (* wt: " 9-SEP-78 20:55")
(PROG NIL
(SETQ MAPDLPOS (COND
((NULL MAPDLPOS)
(STKPOS (QUOTE MAPDL)))
(SPAGHETTIFLG (STKNTH 0 MAPDLPOS))
(T MAPDLPOS)))
LP (COND
((NULL (SETQ MAPDLPOS (STKNTH -1 MAPDLPOS MAPDLPOS)))
(RETURN NIL)))
(APPLY* MAPDLFN (STKNAME MAPDLPOS)
MAPDLPOS)
(GO LP])
(INTCHAR
[LAMBDA (CHAR TYP/FORM HARDFLG) (* lmm "11-Sep-84 14:54")
(* this function is the non-undoable version of
INTERRUPTCHAR; INTERRUPTCHAR calls it)
(PROG (VAL ENTRY OLDINT)
(SELECTQ CHAR
(NIL (* this is illegal, so don't do anything about it)
(RETURN))
(T (* (INTCHAR T) means restore interrupts to the
"standard" setting)
[MAPC (GETINTERRUPT)
(FUNCTION (LAMBDA (CHAR)
(SETQ VAL (NCONC (INTCHAR CHAR)
VAL] (* turn off all user interrupts -
(GETINTERRUPT) returns list of user interrupts)
[MAPC (LISPINTERRUPTS)
(FUNCTION (LAMBDA (LST)
(SETQ VAL (NCONC (APPLY (QUOTE INTCHAR)
LST)
VAL] (* and reset all SYSTEM interrupts to default -
(LISPINTERRUPTS) returns a list of argument lists for
INTCHAR)
(* and VAL has been set to a valid arg list for INTCHAR)
(RETURN VAL))
NIL)
(COND
((LISTP CHAR)
(* Call from undoing or resetform. CHAR is a list of characters followed by typ/form arguments.
When typ/form is a list, the following element is hardflg, so thatchar is a linear list where each individual call
to interruptchar corresonds to either 2 or 3 elements of the list.)
(while CHAR do (SETQ VAL (NCONC (INTCHAR (CAR CHAR)
(CADR CHAR)
(COND
[(LISTP (CADR CHAR))
(* If a list, then it is a user interrupt and the next
thing is the HARDFLG)
(PROG1 (CADDR CHAR)
(SETQ CHAR (CDDDR CHAR]
(T (SETQ CHAR (CDDR CHAR))
NIL)))
VAL)))
(RETURN VAL)))
[COND
((FIXP CHAR) (* character code given)
)
((AND (LITATOM CHAR)
(EQ (NCHARS CHAR)
1)) (* turn single character into character code)
(SETQ CHAR (CHCON1 CHAR)))
(T
(* CHAR can be an interrupt character class, meaning the character which is currently assigned to that interrupt -
this is most useful in, say, (INTCHAR (QUOTE HELP)) which says turn off the character whose class is HELP)
(SETQ CHAR (OR (GETINTERRUPT CHAR)
(ERRORX (LIST 27 CHAR]
(SETQ ENTRY (FASSOC CHAR USERINTERRUPTS)) (* always check for an entry, just in case)
(SETQ VAL (SELECTQ (SETQ OLDINT (GETINTERRUPT CHAR))
(NIL (* this character was disabled)
NIL)
[(ERRORX INTERRUPT) (* it was a user interrupt)
(AND (LISTP (CADR ENTRY))
(LIST CHAR (LISTP (CADR ENTRY))
(EQ OLDINT (QUOTE ERRORX]
(LIST CHAR OLDINT)))
(COND
((EQ TYP/FORM T) (* just return value indicating what it was.)
(RETURN VAL)))
(AND ENTRY (SETQ USERINTERRUPTS (DREMOVE ENTRY USERINTERRUPTS)))
(COND
((EQ OLDINT TYP/FORM) (* if the character is already set up, just return)
(RETURN)))
(COND
(OLDINT (SETINTERRUPT CHAR)))
[COND
((NULL TYP/FORM) (* just leave character disabled)
)
[(LISTP TYP/FORM) (* make a user interrupt)
[SETINTERRUPT CHAR (COND
((AND HARDFLG (NEQ (SYSTEMTYPE)
(QUOTE D)))
(QUOTE ERRORX))
(T (QUOTE INTERRUPT]
(SETQ USERINTERRUPTS (CONS (LIST CHAR TYP/FORM HARDFLG)
USERINTERRUPTS))
(SETQ VAL (CONS CHAR (CONS NIL VAL]
(T (* either a variable or a system interrupt)
[COND
((AND (LITATOM TYP/FORM)
(SETQ OLDINT (GETINTERRUPT TYP/FORM)))
(* if a system interrupt and there is another character
assigned to that channel, turn that character off)
(SETINTERRUPT OLDINT)
(SETQ VAL (CONS OLDINT (CONS TYP/FORM VAL]
(SETINTERRUPT CHAR TYP/FORM)
(SETQ VAL (CONS CHAR (CONS NIL VAL]
(RETURN VAL])
(INTERRUPTCHAR
[LAMBDA (CHAR TYP/FORM HARDFLG) (* lmm: "16-MAR-77 03:12:09")
(PROG ((VAL (INTCHAR CHAR TYP/FORM HARDFLG)))
(AND LISPXHIST (UNDOSAVE (LIST (QUOTE INTERRUPTCHAR)
VAL)))
(RETURN VAL])
(LISPINTERRUPTS
[LAMBDA (SYSTYPE) (* lmm " 7-AUG-84 17:43")
(SELECTQ (OR SYSTYPE (SYSTEMTYPE))
[(TOPS20 JERICHO)
(QUOTE ((8 HELP)
(16 PRINTLEVEL)
(24 STORAGE)
(26 RUBOUT)
(5 ERROR)
(4 RESET)
(15 OUTPUTBUFFER)
(2 BREAK)
(14 CTRLUFLG)
(NIL CONTROL-T]
[TENEX (QUOTE ((8 HELP)
(16 PRINTLEVEL)
(19 STORAGE)
(28 RUBOUT)
(5 ERROR)
(4 RESET)
(15 OUTPUTBUFFER)
(2 BREAK)
(21 CTRLUFLG)
(20 CONTROL-T]
[VAX (QUOTE ((0 RUBOUT)
(2 BREAK)
(3 \QUIT)
(4 RESET)
(5 ERROR)
(8 HELP)
(15 OUTPUTBUFFER)
(16 PRINTLEVEL)
(37 \QUOTE)
(19 \STOPOUTPUT)
(20 CONTROL-T)
(14 CTRLUFLG)
(26 \PAUSE]
[D (QUOTE ((2 BREAK)
(4 RESET)
(5 ERROR)
(8 HELP)
(16 PRINTLEVEL)
(20 CONTROL-T)
(21 CTRLUFLG)
(127 RUBOUT]
(SHOULDNT])
(RESETTERMCHARS
[LAMBDA (TERMTABLE SYSTEMTYPE) (* rmk: "24-JUN-82 22:50")
(SELECTQ (OR SYSTEMTYPE (SYSTEMTYPE))
((TOPS20 JERICHO)
(RESETINT (CHARCODE ↑U)
(CHARCODE ↑N))
(COND
((NOT (GETINTERRUPT (CHARCODE ↑U))) (* make ↑U the line-delete)
(ECHOCONTROL (CHARCODE ↑U)
(QUOTE IGNORE)
TERMTABLE)
(SETSYNTAX (CHARCODE ↑U)
(QUOTE LINEDELETE)
TERMTABLE)))
(RESETINT (CHARCODE DEL)
(CHARCODE ↑Z))
(COND
((NOT (GETINTERRUPT (CHARCODE DEL))) (* make rubout the character delete)
(SETSYNTAX (CHARCODE DEL)
(QUOTE CHARDELETE)
TERMTABLE)))
(RESETINT (CHARCODE ↑S)
(CHARCODE ↑X)))
[VAX (RESETINT (CHARCODE ↑U)
(CHARCODE ↑N))
(COND
((NOT (GETINTERRUPT (CHARCODE ↑U))) (* make ↑U the line-delete)
(ECHOCONTROL (CHARCODE ↑U)
(QUOTE IGNORE)
TERMTABLE)
(SETSYNTAX (CHARCODE ↑U)
(QUOTE LINEDELETE)
TERMTABLE)))
(RESETINT (CHARCODE DEL))
(COND
((NOT (GETINTERRUPT (CHARCODE DEL))) (* make rubout the character delete)
(SETSYNTAX (CHARCODE DEL)
(QUOTE CHARDELETE)
TERMTABLE]
((TENEX D)
(RESETINT (CHARCODE ↑N)
(CHARCODE ↑U))
(RESETINT (CHARCODE ↑Z)
(CHARCODE DEL))
(RESETINT (CHARCODE ↑S)
(CHARCODE ↑X))
(COND
((NOT (GETINTERRUPT (CHARCODE ↑Q))) (* ↑Q becomes line delete)
(ECHOCONTROL (CHARCODE ↑Q)
(QUOTE IGNORE)
TERMTABLE)
(SETSYNTAX (CHARCODE ↑Q)
(QUOTE LINEDELETE)
TERMTABLE)))
(COND
((NOT (GETINTERRUPT (CHARCODE ↑A))) (* ↑A becomes char delete)
(SETSYNTAX (CHARCODE ↑A)
(QUOTE CHARDELETE)
TERMTABLE)))
(RESETINT (CHARCODE ↑X)
(CHARCODE ↑S)))
(SHOULDNT))
NIL])
(RESETINT
[LAMBDA (FROM TO) (* lmm: "16-MAR-77 13:45:18")
(PROG (FI TI)
(SELECTQ (SETQ FI (GETINTERRUPT FROM))
((NIL ERRORX INTERRUPT))
(COND
((OR (NOT (SETQ TI (GETINTERRUPT TO)))
(EQ TI FI))
(SETINTERRUPT FROM)
(SETINTERRUPT TO FI])
)
(RPAQ? HELPFLAG T)
(RPAQ? HELPDEPTH 7)
(RPAQ? HELPTIME 1000)
(RPAQ? HELPCLOCK )
(RPAQ? NLSETQGAG T)
(RPAQ? STORAGERRORS (QUOTE (2 12 21 31 34)))
(RPAQ? ERRORTYPELST )
(RPAQ? USERINTERRUPTS )
(MOVD? (QUOTE FAULT1)
(QUOTE OLDFAULT1))
(MOVD? (QUOTE CLOSEF)
(QUOTE EOFCLOSEF))
[PUTDQ? BREAK1 (NLAMBDA (BRKEXP BRKWHEN BRKFN)
(PROG (BRKTEM)
(PRINT (LIST BRKFN (QUOTE BROKEN))
T T)
LP
(PRIN1 ":" T T)
(SELECTQ (SETQ BRKTEM (READ T T))
(OK (RETEVAL (QUOTE BREAK1)
BRKEXP))
(BT (BACKTRACE (QUOTE BREAK1)
T 0))
(BTV (BACKTRACE (QUOTE BREAK1)
T 7))
NIL)
(PRINT (EVAL BRKTEM (QUOTE :))
T T)
(GO LP]
(AND (CCODEP (QUOTE GETINTERRUPT))
(INTCHAR T))
(RPAQQ HELPDLBLOCKS ((HELPDLBLOCK ERRORX (NOLINKFNS BREAKCHECK)
ERRORX2 ERRORX3 ERRORX4 INTERRUPT MAKEAPPLY FAULT1
(ENTRIES ERRORX INTERRUPT FAULT1 MAKEAPPLY)
(LINKFNS . T)
(SPECVARS ERRORMESS ERRORPOS BREAKCHK INTFN INTARGS PRINTMSG)
(LOCALFREEVARS PRINTMSG)
(GLOBALVARS STORAGERRORS LASTWORD DWIMFLG LISPXHISTORY
USERINTERRUPTS))
(BREAKCHECKBLOCK BREAKCHECK FINDERSET (ENTRIES BREAKCHECK)
(GLOBALVARS HELPTIME HELPDEPTH NLSETQGAG)
(SPECVARS PRINTMSG))
(NIL HELP SHOULDNT ERROR (LINKFNS . T))
(NIL SEARCHPDL MAPDL (GLOBALVARS SPAGHETTIFLG)
(LINKFNS . T))
(NIL FAULTAPPLY (LINKFNS . T)
(NOLINKFNS FAULT1))
(NIL ERRORMESS ERRORMESS1 (GLOBALVARS LISPXPRINTFLG LISPXHISTORY DWIMFLG
STORAGERRORS)
(LINKFNS . T))
(NIL INTCHAR INTERRUPTCHAR (LOCALVARS . T)
(GLOBALVARS USERINTERRUPTS))
(RESETTERMCHARS RESETTERMCHARS RESETINT)))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: HELPDLBLOCK ERRORX (NOLINKFNS BREAKCHECK)
ERRORX2 ERRORX3 ERRORX4 INTERRUPT MAKEAPPLY FAULT1 (ENTRIES ERRORX INTERRUPT FAULT1 MAKEAPPLY)
(LINKFNS . T)
(SPECVARS ERRORMESS ERRORPOS BREAKCHK INTFN INTARGS PRINTMSG)
(LOCALFREEVARS PRINTMSG)
(GLOBALVARS STORAGERRORS LASTWORD DWIMFLG LISPXHISTORY USERINTERRUPTS))
(BLOCK: BREAKCHECKBLOCK BREAKCHECK FINDERSET (ENTRIES BREAKCHECK)
(GLOBALVARS HELPTIME HELPDEPTH NLSETQGAG)
(SPECVARS PRINTMSG))
(BLOCK: NIL HELP SHOULDNT ERROR (LINKFNS . T))
(BLOCK: NIL SEARCHPDL MAPDL (GLOBALVARS SPAGHETTIFLG)
(LINKFNS . T))
(BLOCK: NIL FAULTAPPLY (LINKFNS . T)
(NOLINKFNS FAULT1))
(BLOCK: NIL ERRORMESS ERRORMESS1 (GLOBALVARS LISPXPRINTFLG LISPXHISTORY DWIMFLG STORAGERRORS)
(LINKFNS . T))
(BLOCK: NIL INTCHAR INTERRUPTCHAR (LOCALVARS . T)
(GLOBALVARS USERINTERRUPTS))
(BLOCK: RESETTERMCHARS RESETTERMCHARS RESETINT)
]
(DECLARE: EVAL@COMPILE
(ADDTOVAR SYSSPECVARS HELPFLAG)
DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS CFOBF MACRO (NIL (ASSEMBLE NIL
(MOVEI 1 , 101Q)
(JSYS 101Q))))
(PUTPROPS CFOBF DMACRO (NIL NIL))
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS HELPDL COPYRIGHT ("Xerox Corporation" T 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1855 31825 (HELP 1865 . 2220) (SHOULDNT 2222 . 2565) (ERROR 2567 . 3096) (ERRORMESS
3098 . 4469) (ERRORMESS1 4471 . 5411) (ERRORX 5413 . 5783) (ERRORX2 5785 . 10017) (ERRORX3 10019 .
11366) (ERRORX4 11368 . 14669) (BREAKCHECK 14671 . 15781) (FINDERSET 15783 . 17803) (STKARGS 17805 .
18423) (VARIABLES 18425 . 18654) (INTERRUPT 18656 . 19994) (MAKEAPPLY 19996 . 20565) (FAULTEVAL 20567
. 20697) (FAULTAPPLY 20699 . 20782) (FAULT1 20784 . 22760) (SEARCHPDL 22762 . 23258) (MAPDL 23260 .
23695) (INTCHAR 23697 . 28265) (INTERRUPTCHAR 28267 . 28534) (LISPINTERRUPTS 28536 . 29519) (
RESETTERMCHARS 29521 . 31474) (RESETINT 31476 . 31823)))))
STOP