(FILECREATED "31-Dec-85 14:18:56" {IVY}<HTHOMPSON>LISP>SIGNALS>SIGNAL.;28 16427
changes to: (FNS Signal)
previous date: " 1-Aug-85 22:17:59" {IVY}<HTHOMPSON>LISP>SIGNALS>SIGNAL.;27)
(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT SIGNALCOMS)
(RPAQQ SIGNALCOMS ((FNS \EnableTran \EnableQuitTran Signal \EnablePPMacro)
(PROP CLISPWORD ENABLE EXIT GOTO REJECT SRESUME enable exit goto reject sresume)
(FNS ST TestSignals)
(FNS \NewErrorx2 \NewOldFault1 MakeErrorsSignals MakeErrorsErrorsAgain)
(P (MOVD? '\HELPDLBLOCK/ERRORX2
'\OldErrorx2)
(MOVD? 'OLDFAULT1
'\OldOldFault1))
(RECORDS LispError)
(E (SETQ $PF PRETTYFLG)
(SETQ PRETTYFLG NIL))
(ALISTS (PRETTYPRINTMACROS ENABLE enable))
(E (SETQ PRETTYFLG $PF))))
(DEFINEQ
(\EnableTran
[LAMBDA (form) (* ht: "25-Sep-84 23:10")
(PROG (catches finals (p (form::1))
sig tran it unwind any)
(catches←(while p::1 until p:3= '->
collect (if p:2~= '=>
then (HELP "Missing 'sig =>" form))
(if (U-CASE p:1)= 'ANY
then (pop p)
(pop p)
(any←(while p::1 until (OR p:2= '=>
p:3=
'->)
collect (pop p)))
(GO $$LP))
(<sig←(if (LITATOM p:1)
then (pop p)
else (HELP "Expected atom before =>"))
!(first (pop p) while p::1 until (OR p:2= '=>
p:3=
'->)
collect (pop p))
>)))
(it←(pop p))
(finals←(while p::2
collect (if p:2~= '->
then (HELP "Missing 'label ->'" form))
(if (U-CASE p:1)= 'UNWIND
then (pop p)
(pop p)
(unwind←(while p until p:2= '-> collect (pop p)))
(GO $$LP))
(<(if (LITATOM p:1)
then (pop p)
else (HELP "Expected atom before ->"))
!(first (pop p) while p until p:2= '-> collect (pop p))
>)))
(CLISPTRAN
form tran←(DWIMIFY
[BQUOTE (PROG ($SignalType$ $SignalArg$ result
[$SignalCatcher$
(FUNCTION (LAMBDA (type arg)
(PROG NIL
(SELECTQ type ,. catches ,
(if any
then (if (CDR any)
then (CONS 'PROGN
any)
else (CAR any]
$Exit$)
(DECLARE (SPECVARS $SignalType$ $SignalArg$ $SignalCatcher$ $Exit$))
(RETURN (COND
((SETQ result (NLSETQ , it))
(CAR result))
(T (SELECTQ $Exit$ ,. finals (NIL ,. unwind (ERROR!))
(T)
(SHOULDNT]
T))
(RETURN tran])
(\EnableQuitTran
[LAMBDA (form) (* ht: "22-JAN-83 11:11")
(PROG (tran)
(CLISPTRAN form tran←(DWIMIFY
(SELECTQ (U-CASE form:1)
(GOTO (if ~(AND form:2 (LITATOM form:2))
then (HELP "Must have non-NIL atomic exit label" form:2)
else <(QUOTE RETURN)
(KWOTE form:2)
>))
(EXIT (if form::1
then (printout T "exit should not have args - args ignored"
T))
(QUOTE (RETURN T)))
[SRESUME (if ~(form::1)
then (HELP "sresume must have a value"))
(BQUOTE (RETURN (LIST , (IF (CDDR form)
THEN (CONS (QUOTE PROGN)
(CDR form))
ELSE (CADR form]
(REJECT (if form::1
then (printout T
"reject should not have args - args ignored"
T))
(QUOTE (RETURN)))
(SHOULDNT))
T))
(RETURN tran])
(Signal
[LAMBDA (type arg) (* ht: "31-Dec-85 14:18")
(PROG (frame val)
LP (if frame←(STKSCAN '$SignalCatcher$
(STKNTH 1 frame frame)
frame)
then (SELECTQ (val←(APPLY* (STKARG '$SignalCatcher$
frame)
type arg))
(NIL (* reject or uncaught at that frame, try higher)
(GO LP))
(if (LISTP val)
then (* resume up above)
(RELSTK frame)
(RETURN val:1)
else (* exit up top)
(SETSTKARG '$SignalType$
frame type)
(SETSTKARG '$SignalArg$
frame arg)
(SETSTKARG '$Exit$
frame val)
(RELSTK frame)
(ERROR!)))
else (RELSTK frame)
(if type= 'LispError
then (if arg:ePntMsg
then (ERRORMESS arg:eMess))
(if arg:eBkChk
then (RETEVAL 'Signal
(LIST 'RETFROM
arg:ePos
(if arg:eType
then
(* from an ordinary error)
(\HELPDLBLOCK/ERRORX3
arg:eFn arg:eType arg:ePos)
else
(* from FAULTEVAL/APPLY)
(CONS 'BREAK1
arg:eFn))
T))
else (RELSTK arg:ePos)
(ERROR!))
else (RETURN (HELP "Uncaught signal" (CONS type arg])
(\EnablePPMacro
[LAMBDA (form) (* ht: "18-JAN-83 15:28")
(PROG ((pos (POSITION))
npos)
(printout NIL "(" .FONT CLISPFONT (pop form)
.FONT DEFAULTFONT)
[while (AND form::1 form:2=(QUOTE =>)) do (printout NIL .TAB (pos+5)
.FONT FONT5 (pop form)
.FONT CLISPFONT " => " #
(npos←(POSITION))
.FONT DEFAULTFONT .PPFTL
(first (pop form) while form::1
until (OR form:2=(QUOTE =>)
form:3=(QUOTE ->))
collect (pop form]
(printout NIL .TAB (pos+3)
.PPF
(pop form))
[while form do (printout NIL .TAB (pos+5)
.FONT FONT5 (pop form)
.FONT CLISPFONT " -> " # (npos←(POSITION))
.FONT DEFAULTFONT .PPFTL (first (pop form) while form
until form:2=(QUOTE ->)
collect (pop form]
(printout NIL ")"])
)
(PUTPROPS ENABLE CLISPWORD (\EnableTran . enable))
(PUTPROPS EXIT CLISPWORD (\EnableQuitTran . exit))
(PUTPROPS GOTO CLISPWORD (\EnableQuitTran . goto))
(PUTPROPS REJECT CLISPWORD (\EnableQuitTran . reject))
(PUTPROPS SRESUME CLISPWORD (\EnableQuitTran . sresume))
(PUTPROPS enable CLISPWORD (\EnableTran . enable))
(PUTPROPS exit CLISPWORD (\EnableQuitTran . exit))
(PUTPROPS goto CLISPWORD (\EnableQuitTran . goto))
(PUTPROPS reject CLISPWORD (\EnableQuitTran . reject))
(PUTPROPS sresume CLISPWORD (\EnableQuitTran . sresume))
(DEFINEQ
(ST
[LAMBDA NIL (* ht: " 8-JUN-83 14:15")
(enable
s1 => (PRINT "s1 caught" T)
(goto s1)
s2 => (PRINT "s2 caught")
(sresume 37)
s3 => (PRINT "s3 caught")
(reject)
s4 => (PRINT "s4 caught")
(exit)
LispError => (printout T "lisp error " # (ERRORMESS arg:eMess)
T)
(exit)
any => (printout T type " caught by any" T)
(exit)
(TestSignals)
s1 -> (PRINT "s1 unwound")
unwind -> (PRINT "unwinding"))])
(TestSignals
[LAMBDA NIL (* ht: " 1-Aug-85 22:17")
(printout T T (SELECTQ (PROGN (printout T T ">")
(READ))
(1 (Signal 's1
1))
(2 (Signal 's2
2))
(3 (Signal 's3
3))
(4 (Signal 's4))
(5 (Signal 'foo
5))
(6 (LET ((A))
X←1+A)
6)
(7 X← (CONS 'A
BBAABB)
7)
(8 (UNDEFINEDITRUST)
8)
(9 (APPLY* 'AlsoUndefined
3 2)
9)
(10 (NLSETQ (UNDEFINEDITRUST))
8)
(11 (NLSETQ (APPLY* 'AlsoUndefined
3 2))
9)
12)
'←])
)
(DEFINEQ
(\NewErrorx2
[LAMBDA (ERRORMESS ERRORPOS) (* ht: " 1-Aug-85 21:37")
(* ERRORMESS is the error message, ERRORPOS is the
stack position of the last function before any error
function)
(* Henry%'s kludged up version for Signal world correct
as of Intermezzo release)
(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 16=ERRORMESS:1 (STKNAME ERRORPOS)= 'SKIPSEPRS
(RETFROM ERRORPOS NIL T)))
NIL)
(PROG (EX2X EX2Y 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)
(BREAKCHK←(BREAKCHECK ERRORPOS ERRORMESS:1))
(if (AND EX2X←(FASSOC ERRORMESS:1 ERRORTYPELST)
EX2X←(EVAL EX2X:2))
then
(* 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 (QUOTE 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 ERRORMESS:2 (STKARGS ERRORPOS))
T))
(SELECTQ ERRORMESS:1
(16 (* END OF FILE)
(if (OPENP ERRORMESS:2)
then (EOFCLOSEF ERRORMESS:2)))
[26 (* Hash array full. When PUTHASH is fixed in all
implementations so that it calls HASHOVERFLOW directly,
then special treatment here can be removed.)
(if (LISTP ERRORMESS:2)
then (RETURN (PROG1 (HASHOVERFLOW ERRORMESS:2)
(RELSTK ERRORPOS]
(43 (* User break)
(if EX2X←(FASSOC ERRORMESS:2 USERINTERRUPTS)
then [RETEVAL 'ERRORX
(SUBPAIR '(ERRORPOS EXP)
<ERRORPOS EX2X:2>
'(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)
else (ERROR '"undefined user interrupt"
ERRORMESS:2)))
NIL)
(EX2FN←(STKNAME ERRORPOS))
(if EX2X←(FNTYP EX2FN)
then EX2X←[BQUOTE (Signal 'LispError
,
(KWOTE (create LispError
eMess ← ERRORMESS
eFn ← EX2FN
eType ← EX2X
ePos ← ERRORPOS
eBkChk ← BREAKCHK
ePntMsg ← PRINTMSG]
else (* the realstknth in errorx should take care of
skipping over *PROG*LAM and BLOCK frames)
(SHOULDNT))
(RETEVAL 'ERRORX
< '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.)
])
(\NewOldFault1
[LAMBDA (FAULTX FAULTARGS FAULTAPPLYFLG FAULTZ) (* ht: " 1-Aug-85 21:37")
(* Henry%'s buggered version for SIGNAL -
(correct as of Intermezzo release))
(* When DWIM is enabled, and an eror is to occur, DWIM calls FAULT1 speicyfing FAULTZ so that FAULT1 can print out
the superexpression and function name.)
(PROG ([FAULTPOS (STKNTH -1 (if FAULTAPPLYFLG
then 'FAULTAPPLY
else 'FAULTEVAL]
(FAULTFN FAULTX)
ERRORMESS FXF BREAKCHK (PRINTMSG T))
(AND DWIMFLG (ATOM FAULTX)
FAULTAPPLYFLG=NIL 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 (if FAULTAPPLYFLG
then 46
elseif (ATOM FAULTX)
then 44
else 45)
FAULTFN)
(ERRORMESS←(if (AND (FAULTZ (NOT FAULTAPPLYFLG)))
then (* 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))
else (ERRORN)))
(if FAULTAPPLYFLG
then FAULTX←(MAKEAPPLY FAULTFN FAULTARGS))
(AND LISPXHISTORY (LISPXPUT '*ERROR*
FAULTFN))
(BREAKCHK←(BREAKCHECK FAULTPOS))
[FXF←(BQUOTE (Signal 'LispError
,
(KWOTE (create LispError
eMess ← ERRORMESS
eFn ←(LIST FAULTX T FAULTFN NIL
(LIST (BLIPVAL '*FORM*
FAULTPOS)))
ePos ← FAULTPOS
eBkChk ← BREAKCHK
ePntMsg ← PRINTMSG]
(RETEVAL (if FAULTAPPLYFLG
then 'FAULTAPPLY
else 'FAULTEVAL)
< 'RETFROM
FAULTPOS FXF T>])
(MakeErrorsSignals
[LAMBDA NIL (* ht: " 8-JUN-83 14:46")
(MOVD? (QUOTE \HELPDLBLOCK/ERRORX2)
(QUOTE \OldErrorx2))
(MOVD (QUOTE \NewErrorx2)
(QUOTE \HELPDLBLOCK/ERRORX2))
(if (GETD (QUOTE OLDFAULT1))
then (MOVD? (QUOTE OLDFAULT1)
(QUOTE \OldOldFault1))
(MOVD (QUOTE \NewOldFault1)
(QUOTE OLDFAULT1))
else (PROMPTPRINT "WARNING -
FAULT1 no longer lives as OLDFAULT1,
can't fix u.b.a and u.d.f."))
"Errors are now signals"])
(MakeErrorsErrorsAgain
[LAMBDA NIL (* ht: " 8-JUN-83 14:48")
(if (GETD (QUOTE \OldErrorx2))
then (MOVD (QUOTE \OldErrorx2)
(QUOTE \HELPDLBLOCK/ERRORX2))
(if (GETD (QUOTE \OldOldFault1))
then (MOVD (QUOTE \OldOldFault1)
(QUOTE OLDFAULT1)))
else (PROMPTPRINT "Errors were still errors anyway"))
"Errors are now errors"])
)
(MOVD? '\HELPDLBLOCK/ERRORX2
'\OldErrorx2)
(MOVD? 'OLDFAULT1
'\OldOldFault1)
[DECLARE: EVAL@COMPILE
(RECORD LispError ((eMess eFn . eType)
ePos eBkChk . ePntMsg))
]
(ADDTOVAR PRETTYPRINTMACROS (ENABLE . \EnablePPMacro) (enable . \EnablePPMacro))
(PUTPROPS SIGNAL COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (861 6722 (\EnableTran 871 . 3020) (\EnableQuitTran 3022 . 4001) (Signal 4003 . 5651) (
\EnablePPMacro 5653 . 6720)) (7303 8714 (ST 7313 . 7975) (TestSignals 7977 . 8712)) (8715 16067 (
\NewErrorx2 8725 . 12981) (\NewOldFault1 12983 . 15093) (MakeErrorsSignals 15095 . 15632) (
MakeErrorsErrorsAgain 15634 . 16065)))))
STOP