(FILECREATED "20-SEP-83 23:51:26" <NEWLISP>WTFIX.;1 16466
changes to: (FNS FINDATOM)
previous date: "22-MAY-83 23:09:40" <LISP>WTFIX.;158)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT WTFIXCOMS)
(RPAQQ WTFIXCOMS ((FNS HELPFIX HELPFIX1 HELPFIX2 FINDATOM FIXAPPLY1 FIXLISPX/)
(SPECVARS TYPE-IN? VARS EXPR PARENT BREAKFLG SUBPARENT FORMSFLG TAIL HELPFIXTAIL
HELPFIXFLG TYPE-IN? VARS EXPR PARENT)
(GLOBALVARS CLEARSTKLST SPELLINGS2 FILEPKGFLG USERWORDS SPELLINGS3 ADDSPELLFLG
LISPXHISTORY)))
(DEFINEQ
(HELPFIX
[LAMBDA (NOEDITFLG) (* lmm "22-MAY-83 23:09")
(* Calls editor on last interpreted function or argument to EVAL, and searches for the last interpreted form, i.e.
the one currently being interpreted. If user exits from editor via OK, and if this eval-blip was responsible for the
BREAK, also resets BRKEXP so user can continue computation via OK.)
(PROG (POS POS1 RESETFLG TEM)
(SETQ POS (BRKLASTPOS T))
(* first functon before the call to break1.)
[SETQ POS1 (FSTKNTH -1 (COND
([SETQ RESETFLG (NOT (EQP LASTPOS (SETQ TEM (BRKLASTPOS]
(* user has reset lastpos via @ command)
LASTPOS)
(T POS]
(RELSTK TEM) (* true if the user reset LASTPOS via an @ command)
(RETURN
(PROG1
(PROG (FORM FN EXPR TYPE-IN? HELPFIXTAIL PARENT HELPFIXFLG NOCHANGEFLG TEM FORMSFLG
SUBPARENT)
LP (COND
((OR (NLISTP BRKTYPE)
RESETFLG)
(* All types of breaks except u.b.a. or u.d.f. Breaks, or else user has reset LASTPOS. Procedure is to search for
*FORM* and then find super expression containing it.)
(SETQ FORM (BLIPVAL (QUOTE *FORM*)
POS1))
(COND
((AND FORM (NULL (CDR FORM))
(GENSYM? (CAR FORM))
(SETQ TEM (STKPOS (CAR FORM)
-1 POS1)))
(* this "form" comes from a compiled errorset)
(RELSTK POS1)
(SETQ POS1 (STKNTH -2 TEM TEM))
(GO LP)))
[SETQ NOCHANGEFLG (NEQ (CAR FORM)
(EVALV (QUOTE BRKFN]
(* Indicates whether to reset BRKEXP, i.e. did the scan find the FORM causing the BREAK. For example, if performed
(ADD1 T) BRKEXP would be (ADD1 X), so after editing, it should be reset to whatever (ADD1 T) now is.
The situation where the FORM found does not correspond occurs for example if an APPLY caused the error, or if the
error occurs out of a compiled function -
In this case the FORM obtained by edit is the last interpreted one. note that for U.B.A. Or U.D.F.
Breaks, FORM is given to BREAK1.)
)
[(LISTP BRKEXP)
(* U.D.F. BREAK)
(COND
[(EQ (CAR BRKEXP)
(QUOTE APPLY))
(SETQ FORM (CADADR BRKEXP))
(OR (SETQ HELPFIXTAIL (FIXAPPLY1 (FSTKNTH 0 POS)
FORM FORM (CAR BRKTYPE)))
(RETURN (QUOTE can't]
(T (SETQ FORM BRKEXP]
((SETQ HELPFIXTAIL (FINDATOM BRKEXP POS (CAR BRKTYPE)))
(* U.B.A. BREAK. The value of BRKTYPE is a BLIPEVAL for eval-blip performed in
FAULT1 before the BREAK was induced by a RETEVAL.)
(SETQ FORM BRKEXP)))
[COND
([OR (NULL FORM)
(NULL (SETQ FN (FINDFN (COND
((AND (LISTP BRKTYPE)
(NULL RESETFLG))
(* The only time to consider the function at LASTPOS as a possible candidate is
on error breaks when LASTPOS has not been reset.)
POS)
(T POS1]
(RETURN (QUOTE can't)))
((NLISTP EXPR)
(* Set in FINDFN.)
(RETURN (QUOTE can't]
[COND
(NOEDITFLG
(* For use with IN? command: find and print parent form but do not call editor.)
(PRIN2 FN T T)
(PRIN1 (QUOTE ": ")
T)
(RETURN (COND
((NLISTP FORM)
PARENT)
(T FORM]
(PRIN1 (QUOTE "in ")
T)
(PRIN2 FN T T)
(PRINT (QUOTE ...)
T)
(COND
([NULL (NLSETQ (EDITE EXPR
(NCONC [COND
((EQ EXPR FORM)
(SETQ HELPFIXTAIL (LIST FORM))
NIL)
((NLISTP FORM)
(* The IF makes sure you find the right atom.)
(LIST [LIST (QUOTE LC)
(QUOTE F)
FORM
(QUOTE (IF (EQ (##)
HELPFIXTAIL]
0))
(T
(* Set HELPFIXTAIL so that if the user replaces the entire offending expression, e.g. via MBD or XTR,
(instead of just changing portions of it), can pick up the corresponding expression to for resetting BRKEXP.)
(LIST (LIST (QUOTE F=)
FORM T)
(QUOTE (E (SETQ HELPFIXTAIL
(## UP))
T]
(QUOTE ((ORR (P)
NIL)
(E (SETQ HELPFIXFLG L)
T)
TTY:)))
(AND (EXPRP FN)
(LITATOM FN)
FN)
(QUOTE FNS]
(* Explanation of EDIT commands: NEQ is because EXPR may in fact be the offending FORM, e.g. do EVAL of an
expression whose CAR is undefined. The F= is to make sure you find the FORM that is EQ to FORM.
The lc and if is necessary because if FORM is an atom, HELPFIXTAIL will be non-nil, and must check to make sure have
found that u.b.a. If HELPFIXTAIL is non-nil,)
(AND (NULL HELPFIXFLG)
(PRINT (QUOTE (not found))
T))
(RETURN)))
(* Reset BRKEXP.)
(COND
(NOCHANGEFLG (GO NOCHANGE)))
(SETQ TEM (CAR HELPFIXTAIL))
[COND
(TYPE-IN? (SETQ TEM (LISPX/ TEM NIL (VARSBOUNDINEDITCHAIN HELPFIXFLG]
(* HELPFIXFLG is L, the edit push-down list, leding up to BRKEXP.
VARSBOUNDINEDITCHAIN climbs it and returns list of bound variables.)
(COND
((LISTP BRKTYPE)
(* U.B.A. or U.D.F. break.)
(* Note that the / substitution will not affect any editing changes made beyond the scope of BRKEXP.
The only way to catch these would be to destructively substitute throughout EXPR.)
(COND
((EQ (CAR BRKEXP)
(QUOTE APPLY))
(* Fixes stack so if in mapping function won't get another u.d.f.
Error)
(/RPLNODE (CDADR BRKEXP)
TEM NIL)
(FIXAPPLY1 (FSTKNTH 0 POS)
FORM TEM (CAR BRKTYPE)))
(T (SETQ BRKEXP TEM)))
(RETURN FN))
(T
(* STKEVAL is used in the new BRKEXP because the lambda variables of the function broken may clash with variables in
FORM. E.g. User gets a BREAK on FOO, looks at its arguments, finds a bug. So he does an EDIT to get to the place
where FOO was called, say it is (FOO (CAR X)), and changes CAR to CADR to correct it. Now even if FOO has an
argument named X, he can continue in the FOO BREAK because the new BRKEXP is (STKEVAL (FSTKNTH -1 POS)
(QUOTE (FOO (CADR X)))))
(SETQ BRKEXP (FSTKNTH -1 POS))
(AND (NEQ CLEARSTKLST T)
(SETQ CLEARSTKLST (CONS BRKEXP CLEARSTKLST)))
(SETQ BRKEXP (LIST (QUOTE STKEVAL)
BRKEXP
(LIST (QUOTE QUOTE)
TEM)
T))
(RETURN FN)))
NOCHANGE
(PRIN1 (QUOTE "Note: BRKEXP not changed.
")
T)
(RETURN FN))
(RELSTK POS)
(RELSTK POS1])
(HELPFIX1
[LAMBDA (X HIST) (* rrb "25-NOV-81 09:39")
(* Designed for use with UBA and UDF breaks.
Performs the changes that would have been done in
spelling corrector.)
(COND
((OR (NLISTP BRKTYPE)
(NULL X)) (* Not a u.b.a. Or u.d.f. BREAK, or else nothing typed
on line following ->)
(PRINT (QUOTE ?)
T)
NIL)
(T (PROG (FAULTFN TAIL PARENT VARS EXPR TYPE-IN? (POS (BRKLASTPOS T))
TEM FORMSFLG SUBPARENT)
(SETQ FAULTFN (FINDFN (FSTKNTH 0 POS)))
(COND
((ATOM BRKEXP)
(COND
((AND [NULL (SETQ TAIL (FINDATOM BRKEXP POS (CAR BRKTYPE]
(CDR X))
(GO CAN'T)))
(SETQ BRKEXP (CAR X))
(AND ADDSPELLFLG (NEQ (EVALV (CAR X)
POS)
(QUOTE NOBIND))
(ADDSPELL (CAR X)
T)
(MOVETOP (CAR X)
SPELLINGS3)
(MOVETOP (CAR X)
USERWORDS))
(COND
(TAIL (HELPFIX2 TAIL (CAR X)
(NCONC (CDR X)
(CDR TAIL))
HIST)))
(GO OUT)))
(COND
((EQ (CAR BRKEXP)
(QUOTE APPLY))
(COND
((CDR X) (* Since this is an APPLY error, it doesn't make sense
to replace the function name by a function and an
argument.)
(GO CAN'T)))
(AND ADDSPELLFLG (GETD (CAR X))
(ADDSPELL (CAR X)
2)
(MOVETOP (CAR X)
SPELLINGS2))
(* SPELLINGS2 are used because the APPLY error comes from within a function and is more likely to be a function like
CONS, or ADD1, or print, than MAKEFILE, or LOAD.)
(FIXAPPLY1 POS (CAR (SETQ TEM (CDADR BRKEXP)))
(FIXLISPX/ (CAR X))
(CAR BRKTYPE))
(HELPFIX2 TEM (FIXLISPX/ (CAR X))
NIL HIST)
(HELPFIX2 (SETQ TEM (CDADDR BRKEXP))
(FIXLISPX/ (CAR TEM)
(CAR X))
(CDR TEM)
HIST))
(T (AND ADDSPELLFLG (GETD (CAR X))
(ADDSPELL (CAR X)
2)
(MOVETOP (CAR X)
SPELLINGS2)) (* Adds to SPELLINGS2, list used to correct misspellings
of functions inside of other forms.)
(HELPFIX2 BRKEXP (FIXLISPX/ (CAR X))
(NCONC (CDR X)
(CDR BRKEXP))
HIST) (* E.g. User can say MEMBX -> MEMB X)
))
OUT (AND FILEPKGFLG (LITATOM FAULTFN)
(EXPRP FAULTFN)
(MARKASCHANGED FAULTFN (QUOTE FNS)))
(RELSTK POS)
(RELSTK LASTPOS)
(BREAKRETEVAL (QUOTE BREAK1)
BRKEXP)
CAN'T
(PRINT (QUOTE can't)
T)
(RELSTK POS)
(RETURN])
(HELPFIX2
[LAMBDA (X A D LISPXHIST0)
(AND (LISTP X)
LISPXHIST0
(UNDOSAVE (CONS X (CONS (CAR X)
(CDR X)))
LISPXHIST0))
(* So that the undoinformation will be saved on the parent event as well as
on the -> event.)
(/RPLNODE X A D])
(FINDATOM
[LAMBDA (ATOM POS BLIP) (* J.Gibbons " 9-Jun-83 23:27")
(* Returns TAIL for which atom is CAR. If found on *form* BLIP, also sets free
variable PARENT to this form.)
(PROG (XTAIL TEM NAME REALPOS)
(COND
((NULL BLIP))
((SETQ XTAIL (FMEMB ATOM (LISTP BLIP)))
(SETQ PARENT BLIP)
(SETQ SUBPARENT (AND (OR (EQ (CAR PARENT)
(QUOTE SETQ))
(EQ (CAR PARENT)
(QUOTE SAVESETQ)))
(CDDR PARENT)))
(RETURN XTAIL)))
(* The EQ checks for no eval-blip on the stack, the NULL check checks for whether ATM is in that binding.
In either case, must try something else.)
[COND
((EQ [SETQ NAME (STKNAME (SETQ REALPOS (SELECTQ (SYSTEMTYPE)
((D JERICHO)
(* Skip over internal interpreter frames)
(REALSTKNTH -1 POS T))
POS]
(QUOTE PROG)) (* Error of form (PROG (.. (VAR U.B.A.) ..) ..))
[SOME (CADR (LISTP BLIP))
(FUNCTION (LAMBDA (X)
(AND (LISTP X)
(SETQ XTAIL (FMEMB ATOM (SETQ PARENT X]
(SETQ SUBPARENT XTAIL))
[[EQ ATOM (CAR (SETQ TEM (BLIPVAL (QUOTE *TAIL*)
POS]
(* U.B.A. occurs at top level of COND clause but in consequent, e.g. (COND (& .. U.B.A. ..)), or at top level of
SELECTQ clause, e.g. (SELECTQ & .. (& .. U.B.A.) ..), or at top level of lambda expression.)
(SETQ XTAIL TEM)
(COND
((EXPRP NAME)
[SETQ PARENT (COND
((LISTP NAME)
(* open lambda expression, e.g. error occurred at top level of lambda expression
which was passed as functonal argument and then apply'ed.)
NAME)
((LITATOM NAME)
(FGETD NAME))
(T (HELP (QUOTE FINDATOM]
(SETQ SUBPARENT (AND (EQ XTAIL (CDDR PARENT))
XTAIL)))
[(SETQ FORMSFLG (EQ NAME (QUOTE COND)))
(SETQ PARENT (CAR (SOME (STKARG 1 REALPOS)
(FUNCTION (LAMBDA (X)
(TAILP XTAIL X]
([AND (EQ NAME (QUOTE PROGN))
(EQ (STKNAME (SETQ REALPOS (FSTKNTH -2 REALPOS REALPOS)))
(QUOTE SELECTQ))
(SETQ PARENT (CAR (SOME (STKARG 1 REALPOS)
(FUNCTION (LAMBDA (X)
(TAILP XTAIL X]
(* SELECTQs are a mess: e.g. (SELECTQ X (key ... atom← (expr) ...)) in this case, need to find the tail of the
SELECTQ and it is not bound anywhere easily accessible on the stack. SELECTQs are implemented via a call to PROGN
from APPLY)
(SETQ SUBPARENT (AND (EQ XTAIL (CDR PARENT))
XTAIL]
((AND (LISTP TEM)
(EQ ATOM (CAAR TEM)))
(* This is necessary for u.b.a.'s as predicate in COND clause, e.g.
(COND .. (U.B.A. ..)))
(SETQ PARENT (SETQ XTAIL (CAR TEM)))
(SETQ FORMSFLG T))
([AND (LISTP EXPR)
(SETQ XTAIL (FMEMB ATOM (SETQ PARENT EXPR]
(* Desperation. Will work for case like SETQ (FOO 8CONS A B) where there is no higher PARENT containing ATM, but it
is contained in EXPR.)
(SETQ SUBPARENT (AND (EQ XTAIL (CDR PARENT))
XTAIL))
(SETQ FORMSFLG T) (* e.g. EDITFNS (' (FOO FIE) --) should go to
((QUOTE --)) not (QUOTE -))
]
(SELECTQ (SYSTEMTYPE)
((D JERICHO)
(RELSTK REALPOS))
NIL)
(RETURN (AND PARENT XTAIL])
(FIXAPPLY1
[LAMBDA (POS OLD NEW *FORM*BLIP)
(* lmm "11-JUN-81 11:32")
(* Analagous to FINDATOM. Finds the XTAIL for which the u.d.f. OLD is CAR, and replaces it with NEW.
Also changes places where OLD appears on the stack to NEW. Sets PARENT to be the element containing OLD, and returns
with the TAIL. Releases POS in all cases.)
(PROG (XTAIL LST)
(PROG ((N (STKNARGS POS)))
LP (COND
((ZEROP N)
(RETURN))
((EQ (FSTKARG N POS)
OLD)
(SETSTKARG N POS NEW)))
(SETQ N (SUB1 N))
(GO LP))
NX
(* Attempts to find the occurrence of the u.d.f. in the user's program, e.g. if (MAPC X (FUNCTION PRINNT)) caused
the error, this will change (FUNCTION PRINNT) to (FUNCTION PRINT))
(COND
((EQ (CAAAAR LISPXHISTORY)
OLD)
(GO OUT)))
[SETQ LST (COND
(TYPE-IN? EXPR)
(T (OR *FORM*BLIP (BLIPVAL (QUOTE *FORM*)
POS]
(* POS0 is used because want to find the form from which the function before
FAULTAPPLY, e.g. MAPC, was called.)
(COND
([SOME (CDR LST)
(FUNCTION (LAMBDA (X)
(AND (EQ (CAR X)
(QUOTE FUNCTION))
(EQ (CADR X)
OLD)
(SETQ XTAIL (CDR X]
(SETQ PARENT LST))
((AND (LISTP EXPR)
(SETQ XTAIL (FMEMB OLD EXPR)))
(* Second case corresponds to where MAPC
((A B C) PRINNT) is typed in.)
)
(T (GO OUT)))
(/RPLNODE XTAIL NEW (CDR XTAIL))
OUT (RELSTK POS)
(RETURN XTAIL])
(FIXLISPX/
[LAMBDA (X FN) (* wt: 25-FEB-76 2 2)
(COND
((NULL TYPE-IN?)
X)
(T (LISPX/ X FN VARS])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS TYPE-IN? VARS EXPR PARENT BREAKFLG SUBPARENT FORMSFLG TAIL HELPFIXTAIL HELPFIXFLG TYPE-IN?
VARS EXPR PARENT)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS CLEARSTKLST SPELLINGS2 FILEPKGFLG USERWORDS SPELLINGS3 ADDSPELLFLG LISPXHISTORY)
)
(PUTPROPS WTFIX COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (564 16086 (HELPFIX 574 . 7695) (HELPFIX1 7697 . 10477) (HELPFIX2 10479 . 10759) (
FINDATOM 10761 . 14230) (FIXAPPLY1 14232 . 15918) (FIXLISPX/ 15920 . 16084)))))
STOP