(FILECREATED "14-AUG-83 00:13:48" <NEWLISP>HELPDL.;3 34666
changes to: (FNS ERRORX ERRORX3 ERRORX4 INTERRUPT MAKEAPPLY FAULT1)
previous date: "11-AUG-83 11:10:48" <NEWLISP>HELPDL.;2)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(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 FAULTEVAL)
(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 "17-JUL-83 18:06")
(* 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)
(LISPXPRIN1 (CADR U)
T)
[COND
(EXTRAMES (LISPXPRIN1 (QUOTE " {in ")
T)
(COND
((NLISTP EXTRAMES)
(LISPXPRIN2 (CAR EXTRAMES)
T T)
(LISPXPRIN1 (QUOTE "}")
T))
(T (LISPXPRIN2 (CAR EXTRAMES)
T T)
(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) (* rrb "15-JUL-83 17: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) (* rmk: "18-NOV-81 18:58"
)
(* 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 (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
[NLAMBDA FAULTX
(FAULT1 FAULTX])
(FAULTAPPLY
[LAMBDA (FAULTFN FAULTARGS)
(FAULT1 FAULTFN FAULTARGS T])
(FAULT1
[LAMBDA (FAULTX FAULTARGS FAULTAPPLYFLG FAULTZ)
(* rrb "17-JUL-83 18:32")
(* 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
(PRINTMSG T))
(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.)
[COND
(FAULTAPPLYFLG (SETERRORN 46 FAULTX))
((ATOM FAULTX)
(SETERRORN 44 FAULTX))
(T (SETERRORN 45 (CAR FAULTX]
(COND
((NULL (BREAKCHECK FAULTPOS))
(RELSTK FAULTPOS)
[COND
(PRINTMSG [SETQ FAULTX (COND
(FAULTAPPLYFLG (LISPXPRINT (QUOTE u.d.f.)
T T)
(LISPXPRINT FAULTX T T))
((ATOM FAULTX)
(LISPXPRINT (QUOTE u.b.a.)
T T)
(LISPXPRINT FAULTX T T))
(T (LISPXPRINT (QUOTE u.d.f.)
T T)
(LISPXPRINT (CAR FAULTX)
T T]
(AND LISPXHISTORY (LISPXPUT (QUOTE *ERROR*)
FAULTX]
(ERROR!))) (* printing on this branch is done by break1.)
[COND
(FAULTAPPLYFLG (SETQ FAULTX (MAKEAPPLY (SETQ FAULTFN FAULTX)
FAULTARGS))
(SETQ FAULTZ NIL))
((ATOM FAULTX)
(SETQ FAULTFN FAULTX))
(T (SETQ FAULTFN (CAR FAULTX]
(AND LISPXHISTORY (LISPXPUT (QUOTE *ERROR*)
FAULTFN))
(RETEVAL (COND
(FAULTAPPLYFLG (QUOTE FAULTAPPLY))
(T (QUOTE FAULTEVAL)))
(LIST (QUOTE BREAK1)
FAULTX T FAULTFN NIL (LIST (PROG1 (BLIPVAL (QUOTE *FORM*)
FAULTPOS)
(RELSTK FAULTPOS)))
(COND
(FAULTZ
(* FAULTZ is being passed down as extra arg tacked onto ERRORN until the spec for ERRORN can be changed to allow for
it. BREAK1 needs it to print the message in the break window after it is open.)
(APPEND (ERRORN)
(CONS FAULTZ)))
(T (ERRORN])
(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: "18-MAR-77 07:13:05")
(* 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 33Q 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
(HARDFLG (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)
(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)
(3 RAID)
(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 ERRORTYPELST))
(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 ERRORTYPELST))
(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 FAULTEVAL)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS HELPDL COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1586 31438 (HELP 1596 . 1951) (SHOULDNT 1953 . 2296) (ERROR 2298 . 2825) (ERRORMESS
2827 . 4143) (ERRORMESS1 4145 . 5028) (ERRORX 5030 . 5348) (ERRORX2 5350 . 9581) (ERRORX3 9583 . 10803
) (ERRORX4 10805 . 14062) (BREAKCHECK 14064 . 15115) (FINDERSET 15117 . 17079) (STKARGS 17081 . 17696)
(VARIABLES 17698 . 17925) (INTERRUPT 17927 . 19257) (MAKEAPPLY 19259 . 19829) (FAULTEVAL 19831 .
19886) (FAULTAPPLY 19888 . 19969) (FAULT1 19971 . 22312) (SEARCHPDL 22314 . 22807) (MAPDL 22809 .
23450) (INTCHAR 23452 . 27997) (INTERRUPTCHAR 27999 . 28243) (LISPINTERRUPTS 28245 . 29170) (
RESETTERMCHARS 29172 . 31118) (RESETINT 31120 . 31436)))))
STOP