(FILECREATED " 5-Jun-86 05:08:41" {ERIS}<LISPCORE>SOURCES>HELPDL.;21 30898
changes to: (FNS FAULTEVAL)
previous date: "28-May-86 16:03:29" {ERIS}<LISPCORE>SOURCES>HELPDL.;20)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 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)
(INITVARS (HELPDEPTH 7)
(HELPTIME 1000)
(HELPCLOCK)
(NLSETQGAG T)
(STORAGERRORS (QUOTE (2 12 21 31 34)))
(ERRORTYPELST)
(USERINTERRUPTS))
(P (OR (AND (BOUNDP (QUOTE CLISPARRAY))
CLISPARRAY)
(SETQ CLISPARRAY (HASHARRAY 1000)))
(OR (NEQ (QUOTE NOBIND)
(GETTOPVAL (QUOTE HELPFLAG)))
(SETTOPVAL (QUOTE HELPFLAG)
T)))
(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 (HELPDLBLOCK ERRORX ERRORX2 ERRORX3 ERRORX4 INTERRUPT MAKEAPPLY FAULT1
(ENTRIES ERRORX INTERRUPT FAULT1 MAKEAPPLY)
(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)))
(GLOBALVARS LISPXPRINTFLG LISPXHISTORY DWIMFLG STORAGERRORS LAMBDATRANFNS LAMBDASPLST)
(DECLARE: EVAL@COMPILE (ADDVARS (SYSSPECVARS HELPFLAG)))
(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) (* lmm " 1-Apr-85 00:02")
(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 " 5-Jun-86 05:07")
(PROG (TEM TEM2)
[COND
((LISTP FAULTX)
[COND
((LITATOM (SETQ TEM (CAR FAULTX)))
(COND
([AND (SETQ TEM2 (GETMACROPROP TEM COMPILERMACROPROPS))
(NOT (EQUAL FAULTX (SETQ TEM2 (MACROEXPANSION FAULTX TEM2]
(COND
(CLISPARRAY (PUTHASH FAULTX (OR (LISTP TEM2)
(LIST (QUOTE PROGN)
TEM2))
CLISPARRAY)))
(RETURN (EVAL TEM2)))
[(SETQ TEM2 (GET TEM (QUOTE MACRO-FN)))
(RETURN (\EVAL (FUNCALL TEM2 FAULTX NIL]
(T (SETQ TEM (GETD (CAR FAULTX]
(COND
((AND (LISTP TEM)
(FMEMB (CAR TEM)
LAMBDASPLST))
(RETURN (\EVALFORMASLAMBDA FAULTX]
(RETURN (COND
((AND DWIMFLG (GETD (QUOTE NEWFAULT1)))
(NEWFAULT1 FAULTX))
(T (FAULT1 FAULTX])
(FAULTAPPLY
[LAMBDA (FAULTFN FAULTARGS) (* lmm "27-May-86 15:38")
(COND
((CCODEP FAULTFN)
(SPREADAPPLY (QUOTE \INTERPRETER-DUMMY)
(UNINTERRUPTABLY
(PUTD (QUOTE \INTERPRETER-DUMMY)
FAULTFN T)
FAULTARGS)))
(T (PROG ((DEF (COND
((SYMBOLP FAULTFN)
(GETD FAULTFN))
(T FAULTFN)))
%%LEXICAL-ENVIRONMENT%%)
RETRY
(COND
((TYPEP DEF (QUOTE CLOSURE))
(SETQ %%LEXICAL-ENVIRONMENT%% (CLOSURE-ENVIRONMENT DEF))
(SETQ DEF (CLOSURE-FUNCTION DEF))
(GO RETRY)))
(RETURN (PROG (TRAN TRANFN)
(OR (AND (LISTP DEF)
(FMEMB (CAR DEF)
LAMBDASPLST))
(GO OUT))
(COND
((OR (SETQ TRAN (GETHASH DEF CLISPARRAY))
(AND [SETQ TRANFN (CAR (CDR (ASSOC (CAR DEF)
LAMBDATRANFNS]
(LISTP (SETQ TRAN (FUNCALL TRANFN DEF)))
(PROGN (AND CLISPARRAY (PUTHASH DEF TRAN CLISPARRAY))
T)))
(SETQ DEF TRAN))
(%%LEXICAL-ENVIRONMENT%%)
(T (GO OUT)))
(RETURN (APPLY DEF FAULTARGS))
OUT (RETURN (COND
((AND DWIMFLG (GETD (QUOTE NEWFAULT1)))
(NEWFAULT1 FAULTFN FAULTARGS T))
(T (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])
)
(RPAQ? HELPDEPTH 7)
(RPAQ? HELPTIME 1000)
(RPAQ? HELPCLOCK )
(RPAQ? NLSETQGAG T)
(RPAQ? STORAGERRORS (QUOTE (2 12 21 31 34)))
(RPAQ? ERRORTYPELST )
(RPAQ? USERINTERRUPTS )
(OR (AND (BOUNDP (QUOTE CLISPARRAY))
CLISPARRAY)
(SETQ CLISPARRAY (HASHARRAY 1000)))
(OR (NEQ (QUOTE NOBIND)
(GETTOPVAL (QUOTE HELPFLAG)))
(SETTOPVAL (QUOTE HELPFLAG)
T))
(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))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: HELPDLBLOCK ERRORX ERRORX2 ERRORX3 ERRORX4 INTERRUPT MAKEAPPLY FAULT1
(ENTRIES ERRORX INTERRUPT FAULT1 MAKEAPPLY)
(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))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS LISPXPRINTFLG LISPXHISTORY DWIMFLG STORAGERRORS LAMBDATRANFNS LAMBDASPLST)
)
(DECLARE: EVAL@COMPILE
(ADDTOVAR SYSSPECVARS HELPFLAG)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS HELPDL COPYRIGHT ("Xerox Corporation" T 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3556 28561 (HELP 3566 . 3921) (SHOULDNT 3923 . 4266) (ERROR 4268 . 4797) (ERRORMESS
4799 . 6170) (ERRORMESS1 6172 . 7112) (ERRORX 7114 . 7484) (ERRORX2 7486 . 11718) (ERRORX3 11720 .
13067) (ERRORX4 13069 . 16370) (BREAKCHECK 16372 . 17475) (FINDERSET 17477 . 19497) (STKARGS 19499 .
20117) (VARIABLES 20119 . 20348) (INTERRUPT 20350 . 21688) (MAKEAPPLY 21690 . 22259) (FAULTEVAL 22261
. 23583) (FAULTAPPLY 23585 . 25646) (FAULT1 25648 . 27624) (SEARCHPDL 27626 . 28122) (MAPDL 28124 .
28559)))))
STOP