(FILECREATED " 9-Sep-86 13:44:42" {ERIS}<LISPCORE>NEWERR>BREAK.;5 114634
changes to: (VARS BREAKCOMS)
(FNS PROCEED-WITH-DEFAULTS PROCEED-FROM-BREAK CREATE-PROCEED-KEYLIST BREAK1
BREAK1A BREAKLOOP INTERLISP-BREAKLOOP BREAKCOM)
(STRUCTURES OLD-BREAK1)
previous date: " 8-Sep-86 14:12:09" {ERIS}<LISPCORE>NEWERR>BREAK.;4)
(* 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 BREAKCOMS)
(RPAQQ BREAKCOMS
((FNS BREAK1 BREAK1A BREAKLOOP INTERLISP-BREAKLOOP BRKLASTPOS BREAKCOM BREAKPRINTVALUES
BREAKCOM1 BREAKRESETFN \BREAKRESETRESTORE BREAKRETFROM BREAKRETEVAL BREAKEXIT \BREAKSTOP
BREAK2 BREAK?= BREAK?=1 BREAK= STKPOZ STKPOZ1 STKPOZ2 BREAKREAD BAKTRACE BAKTRACE1
BREAK3 BREAK BREAK0 BREAK0A UNBREAK UNBREAK0 REBREAK REBREAK0 TRACE BREAKIN
BREAKINCOMMENT UNBREAKIN SAVED BREAKREVERT SAVED1 SMARTARGLIST \SIMPLIFY.CL.ARGLIST
RESTORENAMES VIRGINFN RESTORE PACK-IN- BREAKNARGS)
(FNS PROCEED-FROM-BREAK PROCEED-WITH-DEFAULTS CREATE-PROCEED-KEYLIST)
(P (MOVD (QUOTE UNBREAK)
(QUOTE UNTRACE)))
(INITVARS (MSARGTABLE)
(MSHASHFILENAME)
(COMPILERMACROPROPS (QUOTE (DMACRO ALTOMACRO BYTEMACRO MACRO)))
(WBREAK))
(VARS BREAKAROUND BREAKBEFORE BREAKAFTER)
(VARS (BREAKFN (QUOTE BREAK1))
BREAKI
(NBREAKS 0)
NOBREAKIN
(BREAKDELIMITER (QUOTE "
"))
(BRKFILE T)
(BROKENFNS)
(BRKINFOLST)
BAKTRACELST
(\USEBREAKRESETFORMS T)
(BREAKHELPFLAG T))
(INITVARS (BREAKTTBL (GETTERMTABLE)))
(ADDVARS (LISPXFNS (RETFROM . BREAKRETFROM)
(RETEVAL . BREAKRETEVAL))
(BREAKMACROS (BT (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
0 T))
(BTV (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
1 T))
(BTVPP (PROG ((SYSPRETTYFLG T))
(BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
1 T)))
(BTV* (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
7 T))
(BTV+ (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
5 T))
(BTV! (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
39 T))
(PR (PROCEED-FROM-BREAK)))
(NOBREAKS GO QUOTE *)
(BREAKCOMSLST BT VALUE ?= @ EVAL OK GO RETURN BTV BTV* BTV! ARGS !EVAL !OK !GO EDIT UB
= -> IN? ↑ ~ %)
(BREAKRESETFORMS (INTERRUPTABLE T)
(SETTERMTABLE BREAKTTBL)))
(P (MOVD? (QUOTE EVAL)
(QUOTE \SAFEEVAL))
(MOVD? (QUOTE APPLY)
(QUOTE \SAFEAPPLY))
(MOVD? (QUOTE APPLY*)
(QUOTE \SAFEAPPLY*)))
(GLOBALVARS NOBREAKIN BAKTRACELST BREAKDELIMITER BRKFILE CLEARSTKLST BREAKCOMSLST BRKFILE
BREAKMACROS LISPXCOMS LISPXHISTORY BREAKRESETFORMS NOSPELLFLG BREAKI BREAKHELPFLAG
UPFINDFLG CLISPARRAY BRKINFOLST LASTWORD DWIMFLG USERWORDS GLOBALVARS BREAKFN
BROKENFNS BREAKAROUND BREAKBEFORE BREAKAFTER)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA TRACE REBREAK UNBREAK BREAK BREAK3)
(NLAML BREAKNARGS BREAKIN BREAK1)
(LAMA)))))
(DEFINEQ
(BREAK1
(NLAMBDA (BRKEXP BRKWHEN BRKFN BRKCOMS BRKTYPE CONDITION) (* amd " 4-Sep-86 17:48")
(* BRKTYPE is for use by DWIM and
HELPFIX. -
also is REVERT when called from REVERT
code)
(DECLARE (SPECVARS BRKEXP BRKWHEN BRKFN BRKCOMS BRKTYPE ERRORN NBREAKS \USEBREAKRESETFORMS))
(CL:UNLESS (OR (NULL CONDITION)
(CONDITION-TYPEP CONDITION (QUOTE CONDITION)))
(SETQ CONDITION (MAKE-CONDITION (QUOTE OLD-BREAK1)
:LIST CONDITION)))
(COND
((NULL (\SAFEEVAL BRKWHEN (QUOTE BREAK-EXP)))
(\SAFEEVAL BRKEXP (QUOTE BREAK-EXP)))
((MINUSP NBREAKS)
(SELECTQ BRKTYPE
(NIL (* for other break types, evaluating
the brkexp will just cause another
error. For this case, don't print a
msg; it may loop.)
(\SAFEEVAL BRKEXP (QUOTE BREAK-EXP)))
(INTERRUPT
(* this handles the case of ↑b while running in ttywait in a break.
Not very elegant but then the whole mechanism to prevent infinite breaks could
use redoing.)
(RESETLST (* RESETLST to catch exceptional stuff
like undoing BREAKRESETFORMS on ↑D)
(BREAK1A (ADD1 NBREAKS)
CONDITION)))
(PROG ((NBREAKS 0)
(\USEBREAKRESETFORMS NIL))
(UNBREAK0 BRKFN)
(PRIN1 "Break within a break on " T)
(PRINT BRKFN T)
(PRIN1 " unbroken." T)
(HELP))))
(T (VALUES-LIST (RESETLST (* RESETLST to catch exceptional stuff
like undoing BREAKRESETFORMS on ↑D)
(MULTIPLE-VALUE-LIST (BREAK1A (IMINUS (ADD1 NBREAKS))
CONDITION))))))))
(BREAK1A
(LAMBDA (NBREAKS CONDITION) (* amd " 4-Sep-86 15:44")
(* This was a separate function from BREAK1 so that BREAK1 doesnt have to both
an entry and a retfn. In latter case, there would be a frame for BREAK1, a
frame for BREAK1BLOCK, and then another from BREAK1, which would make the
STKNTH in BREAK1a work differently compiled than interpreted.
-
this reasoning is now bogus in Interlisp-D, but I am loath to change it)
(COND
(WBREAK (\WINDOWBREAKLOOP NBREAKS CONDITION))
(T (BREAKLOOP NBREAKS CONDITION)))))
(BREAKLOOP
(LAMBDA (NBREAKS CONDITION) (* amd " 4-Sep-86 15:45")
(* ;;
"starts a breakloop appropriate for the exec we're running under")
(* ;; "")
(DECLARE (SPECIAL *CURRENT-EXECUTIVE-TYPE*))
(if (AND (BOUNDP (QUOTE *CURRENT-EXECUTIVE-TYPE*))
(EQ *CURRENT-EXECUTIVE-TYPE* (QUOTE COMMON-LISP)))
then (COMMONLISP-BREAKLOOP NBREAKS CONDITION)
else (INTERLISP-BREAKLOOP NBREAKS CONDITION))))
(INTERLISP-BREAKLOOP
(LAMBDA (NBREAKS CONDITION) (* amd " 4-Sep-86 15:56")
(PROG ((TYPE-IN (NULL BRKCOMS))
(BRKFIL (OR (NULL BRKCOMS)
BRKFILE))
(HELPFLAG BREAKHELPFLAG)
BRKID BRKVALUES LASTPOS BRKRDBUF BRKBUFS BREAKRESETVALS \BREAKRESETEXPR BRKORIGFLG
BRKLISPXHIST BRKLINE !VALUES) (* HELPFLAG is bound so that calls to
ERROR with a NOBREAK of T will not
break because the user has set
HELPFLAG to BREAK!)
(* BRKFIL is used for output only when BRKCOMS are not NIL, e.g.
for tracing. In this case, by setting BRKFILE to the name of a file, the user
can redirect the output to a file.)
(COND
((AND (NULL BRKFN)
(NLISTP BRKTYPE))
(* The message (NIL broken) only makes sense for U.D.F.
NIL breaks, in which case BRKTYPE is a list.
For all others, the message is just (broken))
(SETQ BRKID (QUOTE (broken))))
((LISTP BRKFN)
(SETQ BRKID (APPEND BRKFN (QUOTE (broken)))))
(T (SETQ BRKID (LIST BRKFN (QUOTE broken)))))
(BREAKRESETFN (QUOTE ENTERING))
(SELECTQ BRKTYPE
(REVERT (AND (LISTP (STKNAME LASTPOS))
(LITATOM BRKFN)
(SETSTKNAME LASTPOS BRKFN)))
(NIL)
(PROGN (* Not a user BREAK.
the buffers will be restored when the
BREAK is left.)
(SETQ BRKRDBUF READBUF)
(SETQ BRKBUFS (CLBUFS (EQ BRKTYPE (QUOTE INTERRUPT))))
(SETQ READBUF NIL)
(AND (EQ BRKTYPE (QUOTE ERRORX))
(CONDITION-TYPECASE CONDITION (STACK-OVERFLOW T)
(OLD-INTERLISP-ERROR (EQ (OLD-INTERLISP-ERROR-NUMBER CONDITION)
2))
(T NIL))
(SETQ LASTPOS (STKNTH -1 LASTPOS)))(* This to avoid garbage backtraces.)
))
(COND
((AND LISPXHISTORY (NEQ CLEARSTKLST T)) (* moved to after LASTPOS is set up)
(SETQ CLEARSTKLST (CONS LASTPOS CLEARSTKLST)) (* In case user control-D's out of the
break, this will RELSTK LASPOS.)
(AND (STACKP BRKTYPE)
(SETQ CLEARSTKLST (CONS BRKTYPE CLEARSTKLST)))
(* occurs on ERRORX breaks. BRKTYPE will be used by the RETFROM that is waiting
to be called with the value returned by BREAK1 as its second argument.)
))
(* BREAKRESETFORMS are a list of forms suitable for use in a rsetform which are
to be executed, bt their execution made transparent to the evaluation of the
break expression. thus they are restored before doing an EVAL, OK, GO, RETURN,
or REVERT, aand then reexecuted when entering or returning into a break.
especially useful for debugging ppograms that fool around with i/o)
(COND
((EQ (CAR BRKCOMS)
(QUOTE TRACE)) (* handle TRACE specially.)
(COND
((NOT (OPENP BRKFIL (QUOTE OUTPUT)))
(OUTPUT (OUTFILE BRKFIL))))
(TERPRI BRKFIL)
(BREAK2) (* Indents appropriate number of
spaces.)
(PRIN2 BRKFN BRKFIL T)
(PRINT (QUOTE :)
BRKFIL T)
(SETQ BRKCOMS (CDR BRKCOMS)))
(T (COND
(CONDITION (* print error message)
(REPORT-CONDITION CONDITION T))
((EQ BRKTYPE (QUOTE INTERRUPT)) (* print the interrupted message)
(PRIN1 (SELECTQ (SYSTEMTYPE)
(D (QUOTE "interrupted below "))
(QUOTE "interrupted before "))
T)
(PRINT BRKFN T T)))
(TERPRI BRKFIL)
(BREAK2)
(PRINT BRKID BRKFIL T)))
LP (SETQ BRKLINE NIL)
(COND
(BRKCOMS (COND
((ERSETQ (BREAKCOM (CAR BRKCOMS)))
(SETQ BRKCOMS (CDR BRKCOMS))
(GO LP))))
(T (NLSETQ (PROMPTCHAR (QUOTE :)
T LISPXHISTORY))
(COND
((ERSETQ (PROG (BRKLISPXHIST (LISPXID (QUOTE :))
BRKCOM)
(SETQ BRKCOM (LISPXREAD T T))
(BREAKCOM BRKCOM T)))
(GO LP)))))
ERROR
(SETQ LISPXBUFS (OR (CLBUFS)
LISPXBUFS)) (* For a CONTINUE command WITHIN this
BREAK.)
(SETQ READBUF NIL) (* We don't worry about saving READBUF
on user induced interruptions, e.g.
control-d control-e since he can
always use REDO or RETRY.)
(SETQ BRKCOMS NIL)
(SETQ BRKFIL T)
(BREAKRESETFN (QUOTE REENTERING)) (* E.g. error occurred inside of an
EVAL or OK, like from a lower break
exited via ↑.)
(PRIN2 BRKID T T)
(TERPRI T)
(GO LP))))
(BRKLASTPOS
(LAMBDA (FLG) (* lmm "24-Aug-84 15:45")
(* returns initial value of LASTPOS, usually one before the call to break1,
except in the cseof an error break or call to interrupt when rguments ha to be
spread via evala. in this case, lastpos is the evala.
however, if FLG is T, value returned by BRKLASTPOS is always the first function
before the call to reak1. used by break package as well as by helpfix and
helpfix1)
(PROG ((POS (REALSTKNTH -1 (QUOTE BREAK1)
T)))
(SELECTQ (STKNAME POS)
((EVALA CLISPBREAK1)
(SETQ POS (REALSTKNTH -1 POS NIL POS)))
(if FLG
then (SELECTQ (STKNTHNAME -1 POS)
(EVALA (SETQ POS (REALSTKNTH -1 POS NIL POS)))
NIL)))
(RETURN POS))))
(BREAKCOM
(LAMBDA (BRKCOM TYPE-IN) (* amd " 4-Sep-86 16:01")
(PROG ((*LAST-CONDITION* *LAST-CONDITION*)
(BRKFIL (COND
(TYPE-IN T)
(T BRKFILE)))
BRKZ)
(DECLARE (SPECIAL *LAST-CONDITION*))
(COND
((AND TYPE-IN (NLISTP BRKCOM))
(SETQ BRKLINE (READLINE T (LIST BRKCOM)
T)) (* this gives the user a chance to
delete an atomic comand with a ↑W.)
(SETQ BRKCOM (CAR BRKLINE))
(SETQ BRKLINE (CDR BRKLINE))))
TOP (COND
((AND (NULL BRKORIGFLG)
(LITATOM BRKCOM)
(SETQ BRKZ (FASSOC BRKCOM BREAKMACROS)))
(BREAKCOM1 NIL NIL T NIL T) (* indicates to save the command,
without *PRINT* prints, and not to
evaluate it.)
(MAPC (CDR BRKZ)
(FUNCTION BREAKCOM)) (* each command will use the same
BRKLISPXHIST.)
)
(T (SELECTQ BRKCOM
(ORIGINAL (PROG ((BRKORIGFLG T))
(MAPC (BREAKREAD (QUOTE LINE))
(FUNCTION BREAKCOM))))
(RETURN (* User will type in expression to be
evaluated and returned as value of
BREAK. otherwise same as GO.)
(BREAKCOM1 (SETQ BRKZ (BREAKREAD (QUOTE LINE)))
NIL NIL (CONS (QUOTE RETURN)
BRKZ))
(BREAKEXIT))
(?= (BREAKCOM1 NIL NIL T (CONS BRKCOM (SETQ BRKZ (BREAKREAD (QUOTE LINE)))))
(BREAK?= BRKZ))
(@ (BREAKCOM1 NIL NIL T (CONS BRKCOM (SETQ BRKZ (BREAKREAD (QUOTE LINE)))))
(PRINT (STKNAME (SETQ BRKZ (STKPOZ BRKZ)))
T T))
(REVERT (SETQ BRKZ (BREAKREAD (QUOTE LINE)))
(BREAKCOM1 NIL NIL T (CONS BRKCOM BRKZ)
T)
(COND
(BRKZ (STKPOZ BRKZ)))
(RESETFORM (PRINTLEVEL (QUOTE (2 . 3)))
(PRINT (STKNAME LASTPOS)
T T))
(BREAKRESETFN (QUOTE REVERTING))
(BREAKREVERT LASTPOS))
(= (COND
((AND TYPE-IN BRKLINE (NLISTP BRKEXP)
(LISTP BRKTYPE))
(SETQ BRKZ (BREAKREAD))
(BREAKRETFROM (QUOTE BREAK1A)
(SHOWPRINT (BREAKCOM1 (LISPX/ (LIST (QUOTE SETQ)
BRKEXP BRKZ))
NIL NIL (LIST BRKCOM BRKZ))
T T)))
(T (PRINT (QUOTE ?)
T T))))
(-> (COND
(DWIMFLG (BREAKCOM1 (LIST (QUOTE HELPFIX1)
(LIST (QUOTE QUOTE)
BRKLINE)
(LIST (QUOTE QUOTE)
LISPXHIST))
NIL NIL (CONS BRKCOM BRKLINE)))
(T (PRINT (QUOTE ?)
T T))))
(COND
((AND TYPE-IN BRKLINE (FGETD BRKCOM))
(GO DEFAULT))
(T (SELECTQ BRKCOM
((↑ ~ STOP)
(\BREAKSTOP))
(GO (* always saves command, evaluates
brkexp unless already evaluated,
prints value, and exits)
(BREAKCOM1 BRKEXP NIL BRKVALUES)
(BREAKEXIT))
(OK (* if not already evaluated, saves
command and evaluates brkexp.
does not print value)
(BREAKCOM1 BRKEXP BRKVALUES BRKVALUES)
(BREAKEXIT T))
((EVAL EVALVALUE) (* Evaluate BRKEXP but do not exit
from BREAK.)
(BREAKCOM1 BRKEXP)
(BREAKRESETFN (QUOTE REENTERING))
(SETQ IT (CAR !VALUES))
(COND
((EQ TYPE-IN T)
(BREAK2)
(PRIN2 BRKFN T T)
(SELECTQ BRKCOM
(EVALVALUE (PRIN1 " = " T)
(BREAKPRINTVALUES !VALUES))
(PRIN1 (QUOTE " evaluated
")
T)))) (* For user's benefit.)
)
(VALUE (COND
((NULL BRKVALUES)
(ERROR (QUOTE "not evaluated yet.")
(QUOTE %)
T)))
(BREAKPRINTVALUES !VALUES)
(SETQ IT (CAR !VALUES)))
(ARGS (* The next 11 commands could be on
BREAKMACROS but are included here to
'PROTECT' the calls to PRINT, GETD,
READ, etc. contained in them.)
(PRINT (VARIABLES LASTPOS)
T T))
(!EVAL (* Evaluate as though unbroken and
then restore BREAK.)
(* the call to breakcom1 just saves
the command, but does not evaluate the
expression)
(BREAKCOM1 NIL NIL T)
(UNBREAK0 BRKFN)
(SETQ BRKZ (FASSOC BRKFN BRKINFOLST))
(BREAKCOM (QUOTE EVAL))
(AND BRKZ (REBREAK0 BRKZ))
(COND
((EQ TYPE-IN T)
(BREAK2)
(PRIN2 BRKFN T T)
(PRIN1 (QUOTE " evaluated
")
T))))
(!OK
(* only difference between this and defnit as a macro is that as a macro would
get PROPS on the event, so wouldnt say {FOO evaluated}} etc)
(BREAKCOM1 NIL NIL T)
(BREAKCOM (QUOTE !EVAL))
(BREAKCOM (QUOTE OK)))
(!GO (BREAKCOM1 NIL NIL T)
(BREAKCOM (QUOTE !EVAL))
(BREAKCOM (QUOTE GO)))
(EDIT (PROG (BRKVALUES)
(PRINT (BREAKCOM1 (QUOTE (HELPFIX)))
T T)))
(IN? (PRINT (HELPFIX T)
T T))
(UB (PROG (BRKVALUES)
(SETQ BRKZ (BREAKCOM1 (LIST (QUOTE UNBREAK0)
(LIST (QUOTE QUOTE)
(COND
((NLISTP BRKFN)
BRKFN)
(T (CAR BRKFN)))))))
(AND TYPE-IN (PRINT BRKZ T T))))
(COND
(TYPE-IN (GO DEFAULT))
(T (* Indicates BRKCOM is from coms, and
therefore value shouldn't be printed.)
(PROG ((NBREAKS (MINUS NBREAKS)))
(COND
(BRKLISPXHIST (PROG ((LISPXHIST BRKLISPXHIST))
(\SAFEEVAL BRKCOM (QUOTE BREAK))))
(T (\SAFEEVAL BRKCOM (QUOTE BREAK)))))))))))))
(RETURN)
DEFAULT
(COND
((AND DWIMFLG (LITATOM BRKCOM)
(NOT (FMEMB BRKCOM LISPXCOMS))
(COND
((OR (NULL TYPE-IN)
(NULL BRKLINE))
(NOT (BOUNDP BRKCOM)))
(T (AND (NULL (FGETD BRKCOM))
(NULL (GETLIS BRKCOM (QUOTE (EXPR FILEDEF)))))))
(SETQ BRKZ (FIXSPELL BRKCOM 70 BREAKCOMSLST (NULL TYPE-IN)
T))) (* Says command would generate an
unbound atom error so we first try to
correct spelling using BREAKCOMSLST in
addition to SPELLINGS3.)
(SETQ BRKCOM (COND
((NLISTP BRKZ)
BRKZ)
(T (SETQ BRKLINE (LIST (CDR BRKZ)))
(CAR BRKZ))))
(GO TOP))
(T (AND (NLISTP BRKCOM)
(LISPXUNREAD BRKLINE))
(PROG ((NBREAKS (MINUS NBREAKS)))
(LISPX BRKCOM (QUOTE :))))))))
(BREAKPRINTVALUES
(LAMBDA (VALS) (* lmm "19-May-86 13:33")
(bind (POS ← (DSPXPOSITION NIL T))
NOTFIRST for X in VALS do (if NOTFIRST
then (DSPXPOSITION POS T)
else (SETQ NOTFIRST T))
(SHOWPRINT X T T))))
(BREAKCOM1
(LAMBDA (BRKX NOSAVEFLG NOEVALFLG BRKZ NOPROPSFLG) (* lmm "24-May-86 18:09")
(DECLARE (SPECVARS TYPE-IN))
(COND
((AND (NULL NOSAVEFLG)
TYPE-IN LISPXHISTORY)
(SETQ BRKLISPXHIST (HISTORYSAVE LISPXHISTORY (QUOTE :)
NIL
(COND
((NULL BRKZ)
(COND
((EQ TYPE-IN T) (* enables breakcom1 to call itelf
recursively to interpret a command,
and still get it saved under original
name, e.g. !EVAL -
EVAL)
BRKCOM)
(TYPE-IN (* dont think i am using this anymore)
(SHOULDNT)))))
BRKZ
(AND (NULL NOPROPSFLG)
(LIST (QUOTE *PRINT*)
(LIST (QUOTE BREAK3)
(OR BRKFN (QUOTE 'BREAK'))
NBREAKS)))))
(* BRKLISPXHIST is bound in BREAK1A. Some break commands do not get LISPXHIST
rebound, e.g. ↑W commands, and for some situatons, several break commands use
the same lispxhist/brklispxhist, e.g. those arising from macros)
))
(COND
((NULL NOEVALFLG)
(PROG ((HELPCLOCK (CLOCK 2))
(NBREAKS (IMINUS NBREAKS)))
(* note thatHELPFLAG is not ebound here, as it is in LISPX, on the grounds
thatif you re doing a RETRY or for some other eason have set helpflg to BREAK!,
it applies while evaluating break expressions, since that is essentially a
continuation.)
(SETQ BRKVALUES (LIST (SETQ !VALUES
(COND
(BRKLISPXHIST (LET ((LISPXHIST BRKLISPXHIST))
(AND (EQ BRKX BRKEXP)
(BREAKRESETFN (QUOTE EVALUATING)))
(MULTIPLE-VALUE-LIST
(COND
((NULL BRKZ)
(\SAFEEVAL BRKX (QUOTE BREAK-EXP)))
((EQ (CAR BRKZ)
(QUOTE RETURN))
(COND
((CDR BRKX)
(\SAFEAPPLY (CAR BRKX)
(CADR BRKX)
(QUOTE :)))
(T (\SAFEEVAL (CAR BRKX)
(QUOTE :)))))
(T
(* Distinguishes between evaluation of
a typed-in expression and an
expression coming from a user
function. USED by DWIM.)
(\SAFEEVAL BRKX (QUOTE :)))))))
(T (AND (EQ BRKX BRKEXP)
(BREAKRESETFN (QUOTE EVALUATING)))
(MULTIPLE-VALUE-LIST (COND
((NULL BRKZ)
(\SAFEEVAL BRKX (QUOTE BREAK-EXP)
))
((EQ (CAR BRKZ)
(QUOTE RETURN))
(COND
((CDR BRKX)
(\SAFEAPPLY (CAR BRKX)
(CADR BRKX)
(QUOTE :)))
(T (\SAFEEVAL (CAR BRKX)
(QUOTE :)))))
(T
(* Distinguishes between evaluation of
a typed-in expression and an
expression coming from a user
function. USED by DWIM.)
(\SAFEEVAL BRKX (QUOTE :)))))))
))))
(AND BRKLISPXHIST (LISPXSTOREVALUE BRKLISPXHIST (CAR !VALUES)!VALUES))))
(CAAR BRKVALUES)))
(BREAKRESETFN
(LAMBDA (BREAKSTATE) (* rrb "29-Aug-84 19:40")
(SELECTQ BREAKSTATE
((ENTERING REENTERING) (* ENTERING is first time into break.
REENTERING is on rturn from EVAL, or
if an error happens following an OK
etc.)
(COND
((AND (NULL BREAKRESETVALS)
\USEBREAKRESETFORMS BREAKRESETFORMS)
(MAPC BREAKRESETFORMS (FUNCTION (LAMBDA (X)
(SETQ BREAKRESETVALS
(CONS (COND
((LITATOM X)
(LIST (QUOTE SET)
X
(EVALV X)))
((EQ (CAR X)
(QUOTE SETQ))
(PROG1 (LIST (QUOTE SET)
(CADR X)
(EVALV (CADR X)))
(EVAL X)))
(T (LIST (CAR X)
(EVAL X))))
BREAKRESETVALS)))))
(* Save as a RESETSAVE in case of ↑D.
RESETLST is in BREAK1)
(COND
(\BREAKRESETEXPR (RPLACA \BREAKRESETEXPR BREAKRESETVALS))
(T (RESETSAVE NIL (CONS (QUOTE \BREAKRESETRESTORE)
(SETQ \BREAKRESETEXPR (LIST BREAKRESETVALS))))))))
(COND
((OR (EQ BREAKSTATE (QUOTE ENTERING))
(RELSTKP LASTPOS))
(SETQ LASTPOS (BRKLASTPOS)))))
((NIL LEAVING EVALUATING RESTORE REVERTING)
(* LEAVE means leaving the break and going back up, either via an OK, RETURN,
or ↑ EVALUATING means going down, e.g. an EVAL or OK command.
in some situations, might want to do different things.)
(COND
(BREAKRESETVALS (MAPC BREAKRESETVALS (FUNCTION (LAMBDA (X)
(\SAFEAPPLY (CAR X)
(CDR X)))))
(RPLACA \BREAKRESETEXPR (SETQ BREAKRESETVALS NIL))))
(AND (NEQ BREAKSTATE (QUOTE REVERTING))
(BOUNDP (QUOTE LASTPOS))
(RELSTK LASTPOS)))
(SHOULDNT))))
(\BREAKRESETRESTORE
(LAMBDA (BREAKRESETVALS)
(DECLARE (SPECVARS BREAKSTATE)) (* rrb "29-Aug-84 19:40")
(AND BREAKRESETVALS (PROG ((BREAKSTATE (QUOTE LEAVING)))
(MAPC BREAKRESETVALS (FUNCTION (LAMBDA (X)
(\SAFEAPPLY (CAR X)
(CDR X)))))))))
(BREAKRETFROM
(LAMBDA (POS VAL FLG) (* wt: " 2-FEB-78 18:31")
(BREAKRESETFN (QUOTE LEAVING))
(RETFROM POS VAL FLG)))
(BREAKRETEVAL
(LAMBDA (POS FORM FLG) (* wt: " 2-FEB-78 18:31")
(BREAKRESETFN (QUOTE LEAVING))
(RETEVAL POS FORM FLG)))
(BREAKEXIT
(LAMBDA (NOPRINTFLG) (* lmm "19-May-86 13:35")
(RELSTK LASTPOS)
(BREAKRESETFN (QUOTE ENTERING))
(COND
(NOPRINTFLG (* Do not print value.)
(PRINT BRKFN BRKFIL T))
(T (* In the event that the exit command
came from BRKCOMS, e.g.
user is tracing, want to keep BREAK=
from calling BREAK2 a second time.)
(PROG NIL (* Prints name = value;
used by ?= commands and TRACE.)
(* NIL and NIL are for use in
connection with history.)
(PRIN2 (OR BRKFN (QUOTE 'BREAK'))
BRKFIL T)
(PRIN1 (QUOTE " = ")
BRKFIL)
(BREAKPRINTVALUES !VALUES)
(PRIN1 BREAKDELIMITER BRKFIL))))
(BREAKRESETFN (QUOTE LEAVING))
(BKBUFS BRKBUFS) (* BRKBUFS set at beginning of BREAK.)
(AND BRKRDBUF (SETQ READBUF (APPEND READBUF BRKRDBUF))) (* The AND is not just for efficiency.
without it, READBUF would be COPIED in
the case of tracing, which makes
debugging history stuff hard.)
(RETAPPLY (QUOTE BREAK1A)
(FUNCTION VALUES-LIST)
(LIST !VALUES))))
(\BREAKSTOP
(LAMBDA NIL (* rrb "12-JUL-83 18:38")
(* gets out of a break context with an
ERROR!)
(* this is a separate function so it
can be called by the break window
closefn.)
(RELSTK LASTPOS)
(AND (STACKP BRKTYPE)
(RELSTK BRKTYPE)) (* Occurs on ERRORX breaks.
See comment in BREAK1.)
(BREAKRESETFN (QUOTE LEAVING))
(RETEVAL (QUOTE BREAK1A)
(QUOTE (ERROR!)))))
(BREAK2
(LAMBDA (N) (* lmm " 3-JUL-83 23:04")
(SPACES (ITIMES BREAKI (IREMAINDER (SUB1 (OR N (if (MINUSP NBREAKS)
then (IMINUS NBREAKS)
else NBREAKS)))
5))
BRKFIL)))
(BREAK?=
(LAMBDA (LINE)
(DECLARE (LOCALVARS . T)) (* lmm "21-Jul-86 05:51")
(* Handles ?= commands.
-
crufty old code)
(LET ((*PRINT-LEVEL* 10)
(*PRINT-LENGTH* 10))
(PROG (BRK3TEM BRK3Y BRK3Z)
(SETQ BRK3Y (CDDR BRKLISPXHIST))
(SETQ BRK3Z (LISTGET1 BRKLISPXHIST (QUOTE *PRINT*)))
(COND
((NULL LINE) (* E.g. ?= typed, or ?= NIL in
BREAKCOMSLST => print all arguments.)
(LET ((ARGLIST (SMARTARGLIST (STKNAME LASTPOS)
T)))
(PRINT-ARGLIST ARGLIST (STKARGS LASTPOS)
T 0))
(GO OUT)))
LP (COND
((NUMBERP (CAR LINE))
(BREAK= (BREAK?=1 (CAR LINE)
LASTPOS)
(STKARG (CAR LINE)
LASTPOS)
BRK3Y BRK3Z))
((LISTP (CAR LINE))
(BREAK= (CAR LINE)
(STKEVAL LASTPOS (LIST (LIST (QUOTE LAMBDA)
(QUOTE (LISPXHIST))
(LISPX/ (CAR LINE)))
(KWOTE BRK3Y))
NIL
(QUOTE :))
BRK3Y BRK3Z)
(* Cannot simply bind LISPXHIST here in BREAK?= as the STKEVAL would cause
UNDOSAVE to pick up LISPXHIST as of a higher point on the stack.)
(* extra argument to STKEVAL is for
DWIM.)
)
((EQ (CAR LINE)
(QUOTE NIL))
(* This permits user to TRACE and just see the value and no argument printout
by performing (TRACE (FN)) which TRACE converts to
(TRACE (FN NIL)) note that (TRACE FN) would give all arguments.)
NIL)
(T (BREAK= (CAR LINE)
(EVALV (CAR LINE)
LASTPOS)
BRK3Y BRK3Z)))
(COND
((SETQ LINE (CDR LINE))
(GO LP)))
(GO OUT)
OUT (COND
((NEQ (POSITION BRKFIL)
0)
(TERPRI BRKFIL)))
(RETURN)))))
(BREAK?=1
(LAMBDA (N POS) (* lmm "18-Jul-86 15:39")
(PROG (ARGS TEM)
(RETURN (COND
((AND (SETQ TEM (STKARGNAME N POS))
(LITATOM TEM))
TEM)
(T (AND (FNTYP (SETQ TEM (STKNAME POS)))
(SETQ ARGS (SMARTARGLIST TEM))) (* e.g., dont want SMARTARGLIST to
print NIL not a function, or *PROG*LAM
not a function.)
(COND
((AND ARGS (NLISTP ARGS)) (* for lambda nospreads, the argument
name is bound to the number of
arguments passed,)
(SETQ ARGS (AND (NEQ (ARGTYPE (STKNAME POS))
2)
(LIST ARGS)))))
(COND
((SETQ TEM (CAR (NTH ARGS N)))
(CONCAT (QUOTE *)
TEM
(QUOTE *)))
(T (CONCAT (QUOTE *ARG)
N
(QUOTE *))))))))))
(BREAK=
(LAMBDA (X Y BRK3Y BRK3Z) (* lmm "18-Jul-86 15:40")
(PROG NIL (* Prints name = value;
used by ?= commands and TRACE.)
(* BRK3Y and BRK3Z are for use in
connection with history.)
(COND
((NULL TYPE-IN)
(BREAK2)))
(if (STRINGP X)
then (PRIN1 X BRKFIL)
else (PRIN2 X BRKFIL T))
(COND
(BRK3Z (* Saves expression to left of '='
sign)
(NCONC1 BRK3Z X)))
(PRIN1 (QUOTE " = ")
BRKFIL)
(COND
(BRK3Y (* Saves value to right of '=' sign)
(COND
((NLISTP (CAR BRK3Y)) (* First time through, still has
initial value of %.)
(FRPLACA BRK3Y (LIST Y)))
(T (NCONC1 (CAR BRK3Y)
Y)))))
(SHOWPRIN2 Y BRKFIL)
(PRIN1 BREAKDELIMITER BRKFIL))))
(STKPOZ
(LAMBDA (X) (* lmm "10-Sep-84 18:34")
(PROG (FN (LSTPOS (BRKLASTPOS T))
SAWNAME) (* Called from BREAK?= and by @ macro)
(if (AND X (NLISTP X))
then (STKPOZ1 X)
(GO EXIT))
LP (COND
((NULL X)
(GO EXIT)))
(SELECTQ (CAR X)
(@ (SETQ LSTPOS LASTPOS)
(SETQ X (CDR X)))
(= (SETQ LSTPOS (STKNTH 0 (EVAL (CADR X))))
(SETQ X (CDDR X)))
(COND
((NUMBERP (CAR X))
(SETQ LSTPOS (COND
((MINUSP (CAR X))
(STKNTH (CAR X)
LSTPOS LSTPOS))
(T (STKPOZ2 (CAR X)
LSTPOS))))
(SETQ X (CDR X)))
((EQ (CADR X)
(QUOTE /)) (* E.g. FOO / 2 means second
occurrence of FOO)
(STKPOZ1 (CAR X)
(IMINUS (CADDR X)))
(SETQ X (CDDDR X)))
(T (if SAWNAME
then (SETQ LSTPOS (STKNTH -1 LSTPOS LSTPOS))
(* So FOO FOO will be equivalent to
FOO / 2)
else (SETQ SAWNAME T))
(STKPOZ1 (CAR X))
(SETQ X (CDR X)))))
(GO LP)
EXIT
(COND
((NEQ LASTPOS LSTPOS)
(STKNTH 0 LSTPOS LASTPOS) (* smashes lstpos into the LASTPOS
stack pointer, if we just reset
lastpos to lstpos would also have
toaadd new lastpos onto clearstklst.)
(RELSTK LSTPOS)))
(RETURN LASTPOS))))
(STKPOZ1
(LAMBDA (FN N) (* lmm " 3-JUL-83 23:04")
(PROG (TEM)
(if (SETQ TEM (STKPOS FN N LSTPOS))
then (RELSTK LSTPOS)
(RETURN (SETQ LSTPOS TEM))
elseif (AND DWIMFLG (NEQ NOSPELLFLG T)
(PROG (BRKPAT)
(SETQ BRKPAT (EDITFPAT (CONCAT FN "")))
(RETURN (SETQ TEM (SEARCHPDL (FUNCTION (LAMBDA (FN)
(SKOR0 FN (CADR BRKPAT)
(CADDR BRKPAT)
(CDDDR BRKPAT))))
LSTPOS)))))
then (PRIN1 (QUOTE =)
T)
(PRINT (CAR TEM)
T)
(RELSTK LSTPOS)
(RETURN (SETQ LSTPOS (CDR TEM)))
else (RELSTK LSTPOS)
(ERROR FN (QUOTE "not found")
T)))))
(STKPOZ2
(LAMBDA (N POS) (* lmm " 3-JUL-83 23:04")
(* Returns the stack position N below POS by starting at current position and
backing up the control links until it reaches a point N frames before POS.)
(PROG (POS1 POS2)
(SETQ POS1 (STKNTH -1))
LP (if (EQP POS1 POS)
then (RELSTK POS1)
(RETURN NIL)
elseif (NOT (ZEROP N))
then (SETQ N (SUB1 N))
(SETQ POS1 (STKNTH -1 POS1 POS1))
(GO LP))
(SETQ POS2 (STKNTH -1))
LP1 (* POS1 stays N ahead of POS2.
When POS1 reaches END, POS2 is the
desired position.)
(COND
((NULL POS1)
(RELSTK POS2)
(RETURN NIL))
((EQP POS1 POS)
(RELSTK POS1)
(RETURN POS2)))
(SETQ POS1 (STKNTH -1 POS1 POS1))
(SETQ POS2 (STKNTH -1 POS2 POS2))
(GO LP1))))
(BREAKREAD
(LAMBDA (TYPE) (* lmm " 3-JUL-83 23:05")
(* Gets input for next BREAK command -
used by BREAKMACROS.)
(COND
(BRKCOMS (PROG1 (CADR BRKCOMS)
(SETQ BRKCOMS (CDR BRKCOMS))))
((EQ TYPE (QUOTE LINE)) (* Macro wants a line for input, e.g.
?=)
BRKLINE)
(T (* Macro wants a single item, this is
different than calling read since
READLINE will return NIL if nothing is
there WHILE read will wait.)
(PROG1 (CAR BRKLINE)
(SETQ BRKLINE (CDR BRKLINE)))))))
(BAKTRACE
(LAMBDA (IPOS EPOS SKIPFNS FLAGS FILE) (* rrb "29-Aug-84 19:38")
(* FLAGS is a bit mask telling BACKTRACE what is to be printed.
1 is variables, 2 is eval blips, 4 is everything, 8 suppresses function name
and "UNTRACE:" , and 16 uses access links.)
(RESETFORM (PRINTLEVEL 2 10)
(PROG ((POS (STKNTH 0 IPOS))
(N 0)
FN X Y Z (PLVLFILEFLG T))
(OR FILE (SETQ FILE T))
(AND (NEQ CLEARSTKLST T)
(SETQ CLEARSTKLST (CONS POS CLEARSTKLST)))
(* POS is used as a scratch-position. N is an offset from FROM.
whenever baktrace needs to look at a stkname or stack position, it
(re) uses POS and computes (STKNTH N IPOS POS)%.)
LP (SETQ FN (STKNAME POS))
LP1 (COND
((AND (SETQ X (FASSOC FN BAKTRACELST))
(COND
((NLISTP (SETQ Z (CADR X)))
(SETQ Y (BAKTRACE1 (CDDR X)
N IPOS POS)))
(T (SOME (CDR X)
(FUNCTION (LAMBDA (X)
(SETQ Z (CAR X))
(SETQ Y (BAKTRACE1 (CDR X)
N IPOS POS))))))))
(SETQ N Y)
(COND
(Z (PRIN2 Z FILE T)
(PRIN1 BREAKDELIMITER FILE))))
((AND SKIPFNS (SOME SKIPFNS (FUNCTION (LAMBDA (SKIPFN)
(\SAFEAPPLY* SKIPFN FN))))))
(T (COND
((NEQ FLAGS 0)
(BACKTRACE (SETQ POS (STKNTH N IPOS POS))
POS
(LOGOR FLAGS 8)
FILE
(FUNCTION SHOWPRINT)) (* Tells BACKTRACE not to print
"UNTRACE:" or the function name.)
(* The SETQ would be unnecessary in
spaghetti)
))
(PRIN2 FN FILE T) (* Prints function name.)
(PRIN1 BREAKDELIMITER FILE)))
(COND
((AND (SETQ POS (STKNTH (SETQ N (SUB1 N))
IPOS POS))
(NOT (EQP POS EPOS)))
(GO LP)))
(RELSTK POS)
(TERPRI FILE)
(RETURN)))))
(BAKTRACE1
(LAMBDA (LST N IPOS POS) (* lmm " 3-JUL-83 23:05")
(* 'MATCHES' LST against stack
starting at POS. Returns NIL or offset
corresponding to last functionthat
matches)
(PROG (TEM)
LP (COND
((NULL LST)
(RETURN N))
((NULL (SETQ POS (STKNTH (SUB1 N)
IPOS POS)))
(GO OUT))
((EQ (SETQ TEM (CAR LST))
(STKNAME POS))
(* make this check first if user WANTS to put the name of a dummy frame in
baktracelst, he can. e.g. this is necessary in order to have the sequence
*PROG*LAM EVALA *ENV* disappear)
(SETQ N (SUB1 N)))
((DUMMYFRAMEP POS)
(SETQ N (SUB1 N))
(GO LP))
((EQ TEM (QUOTE &))
(SETQ N (SUB1 N)))
((NLISTP TEM)
(GO OUT))
((NULL (SOME TEM (FUNCTION (LAMBDA (X)
(COND
((EQ X (QUOTE -))
(* Optional match)
T)
((SETQ X (BAKTRACE1 X N IPOS POS))
(SETQ N X)))))))
(GO OUT)))
(SETQ LST (CDR LST))
(GO LP)
OUT (RETURN NIL))))
(BREAK3
(NLAMBDA Y (* lmm " 3-JUL-83 23:05")
(RESETFORM (PRINTLEVEL 10 10)
(RESETVARS ((BREAKI (COND
((EQ (CAR Y)
T)
BREAKI)
(T 1))))
(RETURN (PROG (BRKCOMS (BRKFIL (CAR Y))
(VAL (CADDR (EVQ EVENT)))
(X (CAR (EVQ EVENT)))
(TYPE-IN T)
(BRKFN (CADR Y))
(N (CADDR Y))
(PLVLFILEFLG T))
(SETQ Y (CDDDR Y)) (* Prints various BREAK commands for
history list.)
(COND
((EQ VAL (QUOTE %)) (* VAL and X are bound in
PRINTHISTORY1)
(BREAK2 N)
(PRIN1 (QUOTE {)
BRKFIL)
(PRIN2 BRKFN BRKFIL T)
(PRIN1 (QUOTE " not finished}
")
BRKFIL))
(T (SELECTQ (CAR X)
((OK !OK)
(BREAK2 N)
(PRINT BRKFN BRKFIL T))
((GO !GO RETURN)
(BREAK2 N)
(BREAK= BRKFN VAL))
((EVAL !EVAL)
(BREAK2 N)
(PRIN2 BRKFN BRKFIL T)
(PRIN1 (QUOTE " evaluated
")
BRKFIL))
(?= (PROG NIL
LP (BREAK2 N)
(BREAK= (CAR Y)
(CAR VAL))
(SETQ Y (CDR Y))
(COND
((SETQ VAL (CDR VAL))
(TAB 5 NIL BRKFIL)
(GO LP)))))
(PRINT VAL BRKFIL T))))))))))
(BREAK
(NLAMBDA X (* lmm "14-Aug-84 18:54")
(for L on (NLAMBDA.ARGS X)
join (PROG (TEM)
(RETURN (if (OR (NLISTP (SETQ TEM (CAR L)))
(EQ (CADR TEM)
(QUOTE IN)))
then (BREAK0 TEM T NIL NIL L)
else (BREAK0 (CAR TEM)
(CADR TEM)
(CADDR TEM)
(CADDDR TEM)
L)))))))
(BREAK0
(LAMBDA (FN WHEN COMS BRKFN TAIL) (* lmm "31-Jul-85 02:00")
(PROG (X Y VAL)
(AND (NULL BRKFN)
(SETQ BRKFN BREAKFN))
TOP (SETQ VAL FN)
(if (LISTP FN)
then (RETURN (if (NEQ (CADR FN)
(QUOTE IN))
then (* Used to BREAK on several functions
using same breaking condition
(WHEN) and/or same COMS.)
(MAPCONC FN (FUNCTION (LAMBDA (X)
(BREAK0 X WHEN COMS BRKFN))))
elseif (NLISTP (SETQ X (CAR FN)))
then (if (NLISTP (SETQ Y (CADDR FN)))
then (BREAK0A X Y)
else (* Used to BREAK on one function where
it appears in several others, e.g.
(PRINT IN (FOO FIE FUM)))
(MAPCONC Y (FUNCTION (LAMBDA (Y)
(BREAK0A X Y)))))
elseif (NLISTP (SETQ Y (CADDR FN)))
then (* Used to BREAK on several functions
in one, e.g. ((PRIN1 PRIN2 PRINT) IN
FOO))
(MAPCONC X (FUNCTION (LAMBDA (X)
(BREAK0A X Y))))
else (* Combination of above two cases.)
(MAPCONC X (FUNCTION (LAMBDA (X)
(MAPCONC Y (FUNCTION (LAMBDA (Y)
(BREAK0A X Y)))))))))
)
(COND
((NULL (SETQ X (GETD FN)))
(if (GETPROP FN (QUOTE EXPR))
then (PRIN2 FN T T)
(PRIN1 (QUOTE " unsaved.
")
T)
(UNSAVEDEF FN (QUOTE EXPR))
(GO TOP)
elseif (SETQ X (FNCHECK FN T NIL NIL TAIL))
then (SETQ FN X)
(GO TOP))
(SETQ VAL (CONS FN (QUOTE (not a function))))
(GO OUT1))
((AND (EXPRP X)
(AND (EQ (CAADDR X)
BREAKFN)
(NULL (CDDDR X))))
(* the or is for caaling breakdown on a broken function, or vice versa, i.e.
where brkfn does not eq (CAADDR X) but function is nevertheless borken.)
(/RPLACA (SETQ Y (CADDR X))
BRKFN)
(/RPLACA (SETQ Y (CDDR Y))
WHEN)
(/RPLACD (CDR Y)
(LIST COMS))
(if (SETQ Y (FASSOC (QUOTE BREAK0)
(GETPROP FN (QUOTE BRKINFO))))
then
(* This detects the BREAK (FOO) MOVD (FOO FIE) BREAK
(FIE) situation, also BREAK (FOO) BREAK (
(FOO IN FIE)) in these cases, FIE and FOO-IN-FIE would appear to be broken even
WHEN they were not.)
(/RPLACD Y (LIST WHEN COMS))
(/SETATOMVAL (QUOTE BROKENFNS)
(CONS FN (/DREMOVE FN BROKENFNS)))
(* Moves FN to front of BROKENFNS so
that UNBREAK of T will UNBREAK it.)
(RETURN (LIST FN))
else (SETQ X (CONS (CAR X)
(CONS (CADR X)
(CDADR (CADDR X)))))))
((UNSAFE.TO.MODIFY FN "break")
(SETQ VAL (LIST FN (QUOTE not)
(QUOTE broken)))
(GO OUT1)))
(SETQ X (SAVED FN (QUOTE BROKEN)
X)) (* Computes appropriate s-expression
definition for this function.)
PUTD
(/PUTD FN (LIST (CAR X)
(CADR X)
(LIST BRKFN (CONS (QUOTE PROGN)
(CDDR X))
WHEN FN COMS)))
OUT (if (NULL (FMEMB FN BROKENFNS))
then (/SETATOMVAL (QUOTE BROKENFNS)
(CONS FN BROKENFNS)))
(/ADDPROP FN (QUOTE BRKINFO)
(LIST (QUOTE BREAK0)
WHEN COMS))
(* Used for rebreaking. Information saved at time of BREAK instead of retrieved
when unbroken because for BREAKIN, information is not available in a convenient
form at time of UNBREAK. i.e. program would have to search through entire
definition looking for calls to BREAK1.)
OUT1
(RETURN (LIST VAL)))))
(BREAK0A
(LAMBDA (X Y) (* lmm " 3-JUL-83 23:05")
(PROG (Z)
(* Note that while information about -IN-
breaks is stored on the property list of the atom, e.g.
FOO-IN-FIE, and it is the atom which is added to BROKENFNS, the user should be
able to refer to the function using either the atom form or the list form,
whether he is talking to BREAK, UNBREAK, or REBREAK.
(Of course, the very first time he breaks the function, he must refer to in
list form, e.g. (FOO IN FIE) or else the alias will not be created.))
(RETURN (if (NLISTP (SETQ Z (CHNGNM Y X)))
then (* X was found in Y)
(BREAK0 Z WHEN COMS BRKFN)
else (LIST Z))))))
(UNBREAK
(NLAMBDA X (* lmm "14-Aug-84 19:14")
(if (AND (NULL (SETQ X (NLAMBDA.ARGS X)))
(OR BROKENFNS BRKINFOLST))
then (SETQ X (REVERSE BROKENFNS)) (* So that most recently broken
function will be unbroken last.)
(/SETATOMVAL (QUOTE BROKENFNS)
NIL)
(/SETATOMVAL (QUOTE BRKINFOLST)
NIL))
(MAPCON X (FUNCTION (LAMBDA (L)
(UNBREAK0 (CAR L)
L))))))
(UNBREAK0
(LAMBDA (FN TAIL) (* LMM "26-Jul-86 21:06")
(MAPCAR (PACK-IN- FN)
(FUNCTION (LAMBDA (FN)
(PROG (VAL (ALIAS (GETPROP FN (QUOTE ALIAS)))
(BRKINFO (GETPROP FN (QUOTE BRKINFO))))
(if (EQ FN T)
then (SETQ FN (CAR BROKENFNS))
elseif (AND DWIMFLG (NULL (FMEMB FN BROKENFNS))
(NULL (OR (GETD FN)
(GETPROP FN (QUOTE EXPR)))))
then
(* Only spelling correct if FN is not a function.
This is because certain functions such as UNSAVEDEF call UNBREAK0 just to make
sure function is not broken. Also, user may perform
(UNBREAK FOO) just to be sure. In these cases, don't want to correct spelling.)
(SETQ FN (OR (FIXSPELL FN 70 BROKENFNS NIL TAIL)
(FIXSPELL FN 70 USERWORDS NIL TAIL
(FUNCTION GETD))
FN)))
(COND
((AND TAIL (BOUNDP (QUOTE EDITFX))
(EQ (CAR EDITFX)
FN))
(* The TAIL check is becauseUNBREAK0 gets called virginfn from inside of editf
when it IS ok to unbreak. only time it isnt is when user calls unbreak himself.)
(PRIN1 FN T)
(PRIN1 (QUOTE " is currently being edited.
")
T)
(/SETATOMVAL (QUOTE BROKENFNS)
(UNION (LIST FN)
BROKENFNS))
(RETURN (CONS FN (QUOTE (not unbroken))))))
(AND DWIMFLG (SETQ LASTWORD FN))
(/SETATOMVAL (QUOTE BROKENFNS)
(/DREMOVE FN BROKENFNS))
(SETQ VAL (RESTORE FN (QUOTE BROKEN)))
(COND
((GETPROP FN (QUOTE BROKEN-IN))
(UNBREAKIN FN)
(/REMPROP FN (QUOTE BROKEN-IN))
(SETQ VAL FN)))
(COND
(BRKINFO (/SETATOMVAL (QUOTE BRKINFOLST)
(CONS (CONS FN (CONS ALIAS BRKINFO))
BRKINFOLST))
(/REMPROP FN (QUOTE BRKINFO))))
(COND
((AND (LISTP ALIAS)
(NULL (GETPROP FN (QUOTE ADVISED))))
(CHNGNM (CAR ALIAS)
(CDR ALIAS)
T)))
(RETURN VAL)))))))
(REBREAK
(NLAMBDA X (* lmm "14-Aug-84 19:14")
(PROG (SPLST)
(RETURN
(if (NULL X)
then (* Reverse so that most recently
unbroken function will be rebroken
last.)
(MAPCONC (REVERSE BRKINFOLST)
(FUNCTION REBREAK0))
elseif (EQ (CAR (SETQ X (NLAMBDA.ARGS X)))
T)
then (REBREAK0 (CAR BRKINFOLST))
else (SETQ SPLST (MAPCAR BRKINFOLST (FUNCTION CAR)))
(* For spellings correction.)
(MAPCONC X
(FUNCTION (LAMBDA (FN)
(MAPCONC
(PACK-IN- FN)
(FUNCTION (LAMBDA (FN)
(PROG (Y)
(COND
((AND DWIMFLG (NULL (SETQ Y
(FASSOC FN BRKINFOLST
)))
(NULL (GETD FN)))
(SETQ FN
(OR (FIXSPELL FN 75 SPLST)
(FIXSPELL FN 75 USERWORDS NIL NIL
(FUNCTION GETD))
FN))))
(RETURN
(COND
((OR Y (SETQ Y (FASSOC FN BRKINFOLST)))
(* Information is stored on BRKINFOLST by function name.
If user is performing A REBREAK on (FOO IN FIE) the information will not be
found unless it is looked for under FOO-IN-FIE, hence the call to PACK-IN-
which converts list forms of aliases to their atomic form.)
(REBREAK0 Y))
(T (LIST (CONS FN
(QUOTE (- NO BREAK
INFORMATION
SAVED)))))))))))
))))))))
(REBREAK0
(LAMBDA (INFO) (* lmm " 3-JUL-83 23:05")
(PROG ((FN (CAR INFO))
(ALIAS (CADR INFO)))
(RETURN (MAPCONC (CDDR INFO)
(FUNCTION (LAMBDA (X)
(AND DWIMFLG (SETQ LASTWORD FN))
(if (NEQ (CAR X)
(QUOTE BREAK0))
then (LIST (APPLY (QUOTE BREAKIN)
(CONS FN X)))
else (APPLY (QUOTE BREAK0)
(CONS (COND
(ALIAS
(* Only want to do the CHANGENAME once. Therefore set ALIAS to NIL in case
there are other breaks as well, e.g. user does BREAK
((FOO IN FIE)) and then BREAK (((FOO IN FIE)
(NULL Z))))
(PROG1 (LIST (CDR ALIAS)
(QUOTE IN)
(CAR ALIAS))
(SETQ ALIAS NIL)))
(T FN))
(CDR X)))))))))))
(TRACE
(NLAMBDA X (* lmm "27-Aug-84 18:43")
(MAPCONC (NLAMBDA.ARGS (OR X (AND DWIMFLG LASTWORD)))
(FUNCTION (LAMBDA (Z)
(PROG (Y)
(COND
((OR (NLISTP Z)
(EQ (CADR Z)
(QUOTE IN)))
(SETQ Y (QUOTE (TRACE ?= NIL GO))))
(T (SETQ Y (LIST (QUOTE TRACE)
(QUOTE ?=)
(OR (CDR Z)
(QUOTE (NIL)))
(QUOTE GO)))
(SETQ Z (CAR Z))))
(RETURN (BREAK0 Z T Y))))))))
(BREAKIN
(NLAMBDA (FN WHERE WHEN BRKCOMS) (* lmm " 1-JUL-84 23:25")
(RESETVARS ((UPFINDFLG T))
(RETURN (PROG (W BRK X TEM)
(SETQ FN (FNCHECK FN))
(if (NULL (EXPRP (SETQ X (GETD (OR (GETPROP FN (QUOTE BROKEN))
FN)))))
then (ERROR FN (QUOTE "not an expr.")
T))
(COND
((NULL (FMEMB FN BROKENFNS))
(/SETATOMVAL (QUOTE BROKENFNS)
(CONS FN BROKENFNS))))
(COND
((NULL WHERE) (* Convenient default case, especially
for BREAKIN for NIL, meaning
(BREAKIN LASTWORD))
(PRIN1 (QUOTE (BEFORE))
T)
(SETQ WHERE (LIST (QUOTE BEFORE)
(QUOTE TTY:))))
((LISTP (CAR WHERE))
(SETQ W (CDR WHERE))
(SETQ WHERE (CAR WHERE))))
LOOP
(COND
((FMEMB (CAR WHERE)
(QUOTE (AFTER AROUND BEFORE))))
(T (RETURN (LIST (CAR WHERE)
(QUOTE ?)))))
(SETQ BRK (LIST (OR WHEN T)
(BREAKINCOMMENT FN WHERE)
BRKCOMS))
(SETQ BRK (COND
((EQ (CAR WHERE)
(QUOTE AROUND))
(LIST (QUOTE MBD)
(CONS BREAKFN (CONS EDITEMBEDTOKEN BRK))))
(T (LIST (CAR WHERE)
(CONS BREAKFN (CONS NIL BRK))))))
(COND
((NEQ (CADR WHERE)
(QUOTE TTY:)) (* Don't print 'SEARCHING...' for
(before/after/around tty))
(PRIN1 (QUOTE searching...)
T)))
(OR (NLSETQ (EDITE X
(LIST (CONS (QUOTE LC)
(APPEND (CDR WHERE)
NOBREAKIN))
BRK
(QUOTE (E (PROGN (/PUT FN (QUOTE BROKEN-IN)
T)
(/ADDPROP FN (QUOTE BRKINFO)
(LIST WHERE WHEN
BRKCOMS)))
T)))))
(PRINT (QUOTE (not found))
T T))
(AND (NEQ (POSITION T)
0)
(TERPRI T))
(COND
(W (SETQ WHERE (CAR W))
(SETQ W (CDR W))
(GO LOOP)))
(RETURN FN))))))
(BREAKINCOMMENT
(LAMBDA (FN WHERE) (* lmm "11-Jul-84 18:16")
(CONS (if (LISTP FN)
then (CAR FN)
else FN)
(CONS (SELECTQ (CAR WHERE)
(AROUND BREAKAROUND)
(BEFORE BREAKBEFORE)
(AFTER BREAKAFTER)
(SHOULDNT))
(CDR WHERE)))))
(UNBREAKIN
(LAMBDA (FN) (* lmm " 1-JUL-84 22:07")
(* Just does the editing.
Property values not affected.)
(RESETVARS ((UPFINDFLG T))
(RETURN
(PROG ((DEF (CGETD FN)))
(if (EXPRP DEF)
then
(EDITE
DEF
(QUOTE
((BIND (LPQ (I F BREAKFN T)
(COMS (COND ((EQ (SETQ #1 (CAR (NLSETQ (## 4 2))))
BREAKAROUND)
(QUOTE (XTR 2)))
((OR (EQ #1 BREAKBEFORE)
(EQ #1 BREAKAFTER))
(QUOTE (ORR (BK UP (2))
DELETE)))
(T (QUOTE ((ORR (NX)
(!NX))))))))))))
(* The first clause is so that whenever possible, breaks are removed by
patching around. If just a delete were done, the interpreter would skip the
next form since cdr of the current list of forms would be patched.
The only time this fails is when a breakis inserted as the first elemen of a
list, e.g. as a cond prediate.)
)
(RETURN FN))))))
(SAVED
(LAMBDA (FN WHERE DF GS) (* lmm " 1-Jun-86 16:59")
(PROG (ARGS TYP TEM)
(COND
((NULL GS) (* We are going to clobber FN, so save
its definition.)
(/PUTD (SETQ GS (PACK* FN (GENSYM (QUOTE B))))
DF)))
(COND
((FMEMB (CAR (LISTP DF))
(QUOTE (LAMBDA NLAMBDA))) (* DF is already an EXPR, so no more
need be done.)
(COND
(WHERE (/PUT FN WHERE GS)))
(RETURN DF))
(DF (SETQ TYP (FNTYP DF))
(SETQ ARGS (SMARTARGLIST FN))
(SETQ DF (SAVED1 TYP GS ARGS))))
(COND
(WHERE (/PUT FN WHERE GS)))
(RETURN (AND DF (LIST (SELECTQ TYP
((CEXPR CEXPR* EXPR EXPR*)
(QUOTE LAMBDA))
((FEXPR FEXPR* CFEXPR CFEXPR*)
(QUOTE NLAMBDA))
(SHOULDNT))
ARGS DF))))))
(BREAKREVERT
(LAMBDA (POS) (* lmm " 5-SEP-84 12:59")
(PROG (ARGNAMES (FN (STKNAME POS))
DEF)
LP (SELECTQ (STKNAME POS)
((EVAL \EVAL \EVALFORM \SAFEEVAL) (* these can just be redone)
(RETURN (ENVEVAL (BQUOTE (BREAK1 , (STKARG 1 POS)
T , FN))
POS POS T T)))
(PROG (* PROG is special in Interlisp-D)
(SELECTQ (SYSTEMTYPE)
(D (SETQ POS (STKNTH -1 POS POS))
(GO LP))
NIL))
NIL)
(COND
((AND (SETQ DEF (COND
((LITATOM FN)
(GETD FN))
(T (* POS could be a lambda expression
call)
FN)))
(SELECTQ (ARGTYPE FN)
((0 1)
(SETQ ARGNAMES (SMARTARGLIST FN))
(AND (EQLENGTH ARGNAMES (STKNARGS POS))
(for I from 1 as X in ARGNAMES always (EQ X (STKARGNAME I POS)))))
(3 (EQ (SETQ ARGNAMES (SMARTARGLIST FN))
(STKARGNAME 1 POS)))
NIL)) (* can evaluate in place, since all
SMARTARGLIST is bound at POS)
(RETURN (ENVEVAL (COND
((FMEMB (CAR (LISTP DEF))
(QUOTE (LAMBDA NLAMBDA)))
(* FN is either a lambda expression or
has a lambda definition)
(BQUOTE (BREAK1 (PROGN ., (CDDR DEF))
T , FN)))
(T (BQUOTE (BREAK1 , (SELECTQ (ARGTYPE FN)
((0 NIL)
(CONS FN ARGNAMES))
(1 (BQUOTE (\SAFEAPPLY (QUOTE , FN)
(LIST ., ARGNAMES)
(QUOTE INTERNAL))))
(2 (BQUOTE (\SAFEAPPLY (QUOTE , FN)
(BREAKNARGS , ARGNAMES)
(QUOTE INTERNAL))))
(3 (BQUOTE (\SAFEAPPLY (QUOTE , FN)
, ARGNAMES (QUOTE
INTERNAL
))))
(SHOULDNT))
T , FN))))
POS POS T T)))) (* either SMARTARGLIST doesn't match
what is bound, or fn is not defined,
etc.)
(SETQ ARGNAMES (SMARTARGLIST FN)) (* cons together what BREAK would put
on the function if you did a BREAK of
it)
(RETURN
(ENVAPPLY (LIST (SELECTQ (ARGTYPE FN)
((1 3)
(QUOTE NLAMBDA))
(QUOTE LAMBDA))
ARGNAMES
(BQUOTE (BREAK1 , (SELECTQ (ARGTYPE FN)
(0 (CONS FN ARGNAMES))
(1 (BQUOTE (\SAFEAPPLY (QUOTE , FN)
(LIST ., ARGNAMES)
(QUOTE INTERNAL))))
(2 (BQUOTE (\SAFEAPPLY (QUOTE , FN)
(BREAKNARGS , ARGNAMES)
(QUOTE INTERNAL))))
(3 (BQUOTE (\SAFEAPPLY (QUOTE , FN)
,
(COND
((NLISTP ARGNAMES)
ARGNAMES)
(T
(* e.g. SETQ is an FSUBR* but
smartarglist treatts it as though it
were a spread.)
(CONS (QUOTE LIST)
ARGNAMES)))
(QUOTE INTERNAL))))
(SHOULDNT))
T , FN NIL REVERT)))
(STKARGS POS)
(SETQ POS (STKNTH -1 POS POS))
POS T T)))))
(SAVED1
(LAMBDA (TYP FN ARGS) (* rrb "29-Aug-84 19:41")
(* Constructs body of definition.)
(SELECTQ TYP
((EXPR CEXPR SUBR SEXPR)
(CONS FN ARGS))
((FEXPR CFEXPR FSUBR SFEXPR)
(* \SAFEAPPLY is same as APPLY but user might have a BREAK on APPLY, i.e.
this is in lieu of a BRKAPPLY The internal is for DWIM, i.e.
so FINDFN will look through this functon.)
(LIST (QUOTE \SAFEAPPLY)
(LIST (QUOTE QUOTE)
FN)
(CONS (QUOTE LIST)
ARGS)
(QUOTE (QUOTE INTERNAL))))
((EXPR* CEXPR* SUBR* SEXPR*)
(LIST (QUOTE \SAFEAPPLY)
(LIST (QUOTE QUOTE)
FN)
(LIST (QUOTE BREAKNARGS)
ARGS)
(QUOTE (QUOTE INTERNAL))))
((FEXPR* CFEXPR* FSUBR* SFEXPR*)
(LIST (QUOTE \SAFEAPPLY)
(LIST (QUOTE QUOTE)
FN)
(if (NLISTP ARGS)
then ARGS
else (* e.g. SETQ is an FSUBR* but
smartarglist treatts it as though it
were a spread.)
(CONS (QUOTE LIST)
ARGS))
(QUOTE (QUOTE INTERNAL))))
(HELP))))
(SMARTARGLIST
(LAMBDA (FN EXPLAINFLG TAIL) (* lmm " 1-Aug-86 01:24")
(PROG (TEM DEF)
(COND
((NOT (LITATOM FN))
(if (AND EXPLAINFLG (LISTP FN)
(EQ (CAR FN)
(QUOTE CL:LAMBDA)))
then (RETURN (\SIMPLIFY.CL.ARGLIST (CADR FN))))
(RETURN (ARGLIST FN))))
RETRY
(COND
((SETQ TEM (GETLIS FN (QUOTE (ARGNAMES))))
(* gives user an override. also provides a way of ensuring that argument names
stay around even if helpsys data base goes away.
for example, if user wanted to advise a system subr and was worried.)
(RETURN (COND
((OR (NLISTP (SETQ TEM (CADR TEM)))
(CAR TEM)) (* "ARGNAMES is used for two purposes, one to provide an override, the other to have a lookup. therefore for nospread functions, we must store both the arglist to be used for explaining, and the one to be used for breaking and advising. this situation is indicated by having the value of ARGNAMES be a dotted pair of the two arglists. (note thatthe first one will always be a list, hence this nlistp check to distinguish the two cases.)")
TEM)
(EXPLAINFLG (CADR TEM))
(T (CDDR TEM))))))
(COND
(EXPLAINFLG (COND
((SETQ DEF (GET FN (QUOTE ARGUMENT-LIST)))
(RETURN DEF))
((AND (if (EXPRP FN)
then (SETQ DEF (GETD FN))
else (SETQ DEF (GET FN (QUOTE EXPR))))
(FMEMB (CAR (LISTP DEF))
(QUOTE (CL:LAMBDA LAMBDA NLAMBDA))))
(RETURN (\SIMPLIFY.CL.ARGLIST (CADR DEF))))
((AND (SETQ DEF (GET FN (QUOTE FUNCTIONS)))
(SELECTQ (CAR DEF)
((DEFMACRO DEFUN )
T)
((DEFDEFINER DEFCOMMAND )
(pop DEF))
NIL))
(RETURN (\SIMPLIFY.CL.ARGLIST (THIRD DEF)))))))
(COND
((SETQ DEF (OR (GETD FN)
(CADR (GETLIS FN (QUOTE (EXPR CODE))))))
(COND
((AND (OR (EXPRP DEF)
(CCODEP DEF))
(OR (NOT EXPLAINFLG)
(NOT (FMEMB (ARGTYPE DEF)
(QUOTE (2 3))))))
(* Can use ARGLIST if function is defined.
Want to try harder for subrs in interlisp-10, maybe.
Want to try harder if "EXPLAINING" rather than advising)
(RETURN (ARGLIST DEF))))
(COND
((AND (GETD (QUOTE HELPSYS))
(NLSETQ (SETQ TEM (HELPSYS FN (QUOTE ARGS))))
TEM)
(COND
((NULL (CAR TEM)) (* helpsys stores arglists of NIL as
(NIL))
(SETQ TEM NIL)))
(COND
((NEQ (NARGS DEF)
(LENGTH TEM)) (* DIFERENT NUMBER THAN IN MANUAL)
(SETQ TEM (ARGLIST DEF))))
(/PUT FN (QUOTE ARGNAMES)
(COND
((SUBRP DEF) (* vanilla subr)
TEM)
(T (CONS NIL (CONS TEM (ARGLIST DEF))))))
(RETURN TEM)))))
(RETURN (COND
((AND EXPLAINFLG (SETQ TEM (GETMACROPROP FN COMPILERMACROPROPS)))
(SELECTQ (CAR TEM)
((LAMBDA NLAMBDA OPENLAMBDA)
(CADR TEM))
(= (SMARTARGLIST (CDR TEM)
EXPLAINFLG))
(NIL NIL)
(COND
((LISTP (CAR TEM))
(RETURN (COND
((CDR (LAST (CAR TEM)))
(APPEND (CAR TEM)
(LIST (QUOTE ...)
(CDR (LAST (CAR TEM))))))
(T (CAR TEM))))))))
((AND MSHASHFILENAME (SETQ TEM (GETTABLE FN (CADR MSARGTABLE))))
(AND (NEQ TEM T)
TEM))
((AND (SETQ TEM (FNCHECK FN T NIL T TAIL))
(NEQ TEM FN))
(SETQ FN TEM)
(GO RETRY))
(T (ARGLIST FN)))))))
(\SIMPLIFY.CL.ARGLIST
(LAMBDA (LST) (* lmm " 1-Aug-86 01:25")
(for X in LST collect (CL:IF (LISTP X)
(COND
((LISTP (CAR X))
(CAAR X))
(T (CAR X)))
(CL:IF (EQ X (QUOTE &AUX))
(GO $$OUT)
X)))))
(RESTORENAMES
(LAMBDA (FN) (* lmm " 3-JUL-83 23:06")
(PROG1 (MAPCAR (GETPROP FN (QUOTE NAMESCHANGED))
(FUNCTION (LAMBDA (XXX MACROX MACROY FN)
(PROG (Z (DEF (GETD (OR (GETP FN (QUOTE ADVISED))
(GETP FN (QUOTE BROKEN))
FN)))
(NEW (PACK* XXX (QUOTE -IN-)
FN)))
(/PUTD NEW)
(if (FMEMB NEW BROKENFNS)
then (/SETATOMVAL (QUOTE BROKENFNS)
(REMOVE NEW BROKENFNS)))
(COND
((SETQ Z (REMOVE XXX (GETPROP FN (QUOTE NAMESCHANGED))))
(/PUTPROP FN (QUOTE NAMESCHANGED)
Z))
(T (/REMPROP FN (QUOTE NAMESCHANGED))))
(/REMPROP NEW (QUOTE ALIAS))
(COND
((NULL DEF)
(RETURN (CONS DEF (QUOTE (not defined)))))
((NULL (RESETVARS ((NOLINKMESS T))
(RETURN (CHANGENAME1 DEF NEW XXX FN))))
(RETURN (CONS NEW (APPEND (QUOTE (not found in))
(LIST FN))))))
(RETURN XXX)))))
(/REMPROP FN (QUOTE NAMESCHANGED)))))
(VIRGINFN
(LAMBDA (FN FLG) (* lmm " 1-JUL-84 22:42")
(PROG (D (X1 (GETPROP FN (QUOTE BROKEN)))
(X2 (GETPROP FN (QUOTE ADVISED)))
(X3 (GETPROP FN (QUOTE NAMESCHANGED)))
(X4 (GETPROP FN (QUOTE BROKEN-IN)))
(X5 (GETPROP FN (QUOTE EXPR))))
(if FLG
then (COND
((OR X1 X4)
(PRIN2 FN T T)
(PRIN1 (QUOTE " unbroken.
")
T)
(UNBREAK0 FN)))
(COND
(X2 (PRIN2 FN T T)
(PRIN1 (QUOTE " unadvised.
")
T)
(APPLY (QUOTE UNADVISE)
(LIST FN))))
(COND
(X3 (PRIN2 FN T T)
(PRIN1 (QUOTE " names restored.
")
T)
(RESTORENAMES FN)))
(COND
((AND (NULL (EXPRP (SETQ D (GETD FN))))
X5)
(SETQ D X5)))
(RETURN D))
(SETQ D (GETD (OR (AND X2 (GETPROP FN (QUOTE ADVISED)))
X1 FN)))
(COND
((OR (NLISTP D)
(NLISTP (CDR D)))
(RETURN (OR X5 D))))
(COND
(X4 (SETQ D (UNBREAKIN (COPY D)))
(SETQ FLG T)))
(COND
(X3 (COND
((NULL FLG)
(SETQ D (COPY D))))
(MAPC X3 (FUNCTION (LAMBDA (X)
(SETQ D (/DSUBST X (PACK* X (QUOTE -IN-)
FN)
D)))))))
(RETURN D))))
(RESTORE
(LAMBDA (FN X) (* lmm " 3-JUL-83 23:06")
(PROG (Y)
(RETURN (if (SETQ Y (GETPROP FN X))
then (/PUTD FN (GETD Y))
(AND (NULL (RELSTK (STKPOS FN)))
(/PUTD Y))
(/REMPROP FN X)
FN
else (LIST FN (QUOTE NOT)
X))))))
(PACK-IN-
(LAMBDA (X) (* lmm " 1-JUL-84 22:42")
(* Allows user to refer to alias-functions using either atomic or list form by
always converting to atomic form. called by REBREAK, UNBREAK0, READVISE0,
UNADVISE, and ADVISEDUMP. returns a list of functions.)
(COND
((NLISTP X)
(LIST X))
(T (PROG ((TEM1 (CAR X))
(TEM2 (CADDR X)))
(RETURN (COND
((NEQ (CADR X)
(QUOTE IN))
(ERROR (QUOTE "not of form (fn1 IN fn2)")
X T))
((LISTP TEM1)
(MAPCONC TEM1 (FUNCTION (LAMBDA (Y)
(PACK-IN- (LIST Y (QUOTE IN)
TEM2))))))
((LISTP TEM2)
(MAPCONC TEM2 (FUNCTION (LAMBDA (Y)
(PACK-IN- (LIST TEM1 (QUOTE IN)
Y))))))
(T (LIST (PACK* TEM1 (QUOTE -IN-)
TEM2))))))))))
(BREAKNARGS
(NLAMBDA (BRKX) (* rrb "29-Aug-84 19:42")
(* Makes a list of the arguments to a
nospread EVAL type function.)
(PROG (BRKY (BRKN (EVAL BRKX)))
LP (COND
((NOT (IGREATERP BRKN 0))
(RETURN BRKY)))
(SETQ BRKY (CONS (\SAFEAPPLY (QUOTE ARG)
(LIST BRKX BRKN))
BRKY))
(SETQ BRKN (SUB1 BRKN))
(GO LP))))
)
(DEFINEQ
(PROCEED-FROM-BREAK
(LAMBDA NIL (* amd " 8-Sep-86 12:19")
(LET* ((KEYS (CREATE-PROCEED-KEYLIST *LAST-CONDITION*)))
(CL:IF KEYS (LET ((CASE (PROGN (ASKUSEREXPLAIN KEYS NIL NIL "
")
(ASKUSER NIL NIL "Proceed how? " KEYS T))))
(CL:WHEN CASE (PROCEED-WITH-DEFAULTS CASE *LAST-CONDITION*)))
(FORMAT *DEBUG-IO* "~&No proceed cases enabled.~%%")))))
(PROCEED-WITH-DEFAULTS
(LAMBDA (CASE CONDITION) (* amd " 8-Sep-86 14:11")
(LET* ((NAME (PROCEED-CASE-NAME CASE))
(ARGS (AND NAME (FBOUNDP NAME)
(EVAL (BQUOTE (PROCEED-CASE ((\, NAME)
(QUOTE (\, CONDITION)))
((\, NAME)
(IGNORE &REST ARGS)
:TEST TRUE ARGS)))))))
(CL:APPLY (FUNCTION INVOKE-PROCEED-CASE)
CASE CONDITION ARGS))))
(CREATE-PROCEED-KEYLIST
(LAMBDA (CONDITION) (* amd " 8-Sep-86 12:21")
(LET ((CASES (COMPUTE-PROCEED-CASES CONDITION)))
(CL:WHEN CASES (LET ((KEYLIST (for CASE in CASES as I from 1 bind MESSAGE
eachtime (SETQ MESSAGE (FORMAT NIL "~A " CASE))
collect (BQUOTE ((\, I)
(\, MESSAGE)
NOECHOFLG T EXPLAINSTRING
(\, (CONCAT I " - " MESSAGE))
CONFIRMFLG T RETURN
(PROGN (TERPRI T)
(QUOTE (\, CASE))))))))
(SETF (CDR (LAST KEYLIST))
(QUOTE (("N" "No - don't proceed " NOECHOFLG T CONFIRMFLG T
AUTOCONFIRMFLG T RETURN (TERPRI T)))))
KEYLIST)))))
)
(MOVD (QUOTE UNBREAK)
(QUOTE UNTRACE))
(RPAQ? MSARGTABLE )
(RPAQ? MSHASHFILENAME )
(RPAQ? COMPILERMACROPROPS (QUOTE (DMACRO ALTOMACRO BYTEMACRO MACRO)))
(RPAQ? WBREAK )
(RPAQQ BREAKAROUND broken-around)
(RPAQQ BREAKBEFORE broken-before)
(RPAQQ BREAKAFTER broken-after)
(RPAQQ BREAKFN BREAK1)
(RPAQQ BREAKI 3)
(RPAQQ NBREAKS 0)
(RPAQQ NOBREAKIN ((COMS (COND ((SOME (CDR L)
(FUNCTION (LAMBDA (X)
(MEMB (CAR X)
NOBREAKS))))
(ERROR!))
((CAR (NLSETQ (SELECTQ (## 1 !0 BK)
((LAMBDA NLAMBDA)
T)
NIL)))
(ERROR!))
(T (SELECTQ (## !0 1)
(COND 1)
(SELECTQ (AND (NEQ (##)
(## !0 2))
(NEQ (##)
(## !0 -1))
1))
NIL))))
(IF (NEQ (CAR WHERE)
(QUOTE AROUND))
(MARK (>*)
(IF (AND (NEQ (##)
(## ←))
(LISTP (##)))
((E (PROGN (PRIN1 (QUOTE "break inserted ")
T)
(PRIN1 (CAR WHERE)
T)
(SPACES 1 T)
(## P))
T))
NIL))
NIL)))
(RPAQQ BREAKDELIMITER "
")
(RPAQQ BRKFILE T)
(RPAQQ BROKENFNS NIL)
(RPAQQ BRKINFOLST NIL)
(RPAQQ BAKTRACELST ((APPLY (**BREAK** LISPX ERRORSET BREAK1A ERRORSET BREAK1)
(**TOP** LISPX ERRORSET EVALQT T)
(**EDITOR** LISPX ERRORSET ERRORSET ERRORSET EDITL1 EDITL0 ERRORSET
((ERRORSET ERRORSET ERRORSET EDITL1 EDITL0 ERRORSET)
-)
EDITL ERRORSET ERRORSET EDITE ((EDITF)
(EDITV)
(EDITP)
-))
(**USEREXEC** LISPX ERRORSET ERRORSET USEREXEC))
(EVAL (**BREAK** LISPX ERRORSET BREAK1A ERRORSET BREAK1)
(**TOP** LISPX ERRORSET EVALQT T)
(**EDITOR** ((MAPCAR APPLY)
(ERRORSET LISPX))
ERRORSET ERRORSET ERRORSET EDITL1 EDITL0 ERRORSET
((ERRORSET ERRORSET ERRORSET EDITL1 EDITL0 ERRORSET)
-)
EDITL ERRORSET ERRORSET EDITE ((EDITF)
(EDITV)
(EDITP)
-))
(**USEREXEC** ERRORSET LISPX ERRORSET ERRORSET USEREXEC))
(PROGN **BREAK** EVAL ((ERRORSET BREAK1A ERRORSET BREAK1)
(BREAK1)))
(BLKAPPLY **BREAK** PROGN EVAL ERRORSET BREAK1A ERRORSET BREAK1)
(*PROG*LAM (NIL EVALA *ENV*)
(NIL CLISPBREAK1))))
(RPAQQ \USEBREAKRESETFORMS T)
(RPAQQ BREAKHELPFLAG T)
(RPAQ? BREAKTTBL (GETTERMTABLE))
(ADDTOVAR LISPXFNS (RETFROM . BREAKRETFROM)
(RETEVAL . BREAKRETEVAL))
(ADDTOVAR BREAKMACROS (BT (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
0 T))
(BTV (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
1 T))
(BTVPP (PROG ((SYSPRETTYFLG T))
(BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
1 T)))
(BTV* (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
7 T))
(BTV+ (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
5 T))
(BTV! (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
39 T))
(PR (PROCEED-FROM-BREAK)))
(ADDTOVAR NOBREAKS GO QUOTE *)
(ADDTOVAR BREAKCOMSLST
BT VALUE ?= @ EVAL OK GO RETURN BTV BTV* BTV! ARGS !EVAL !OK !GO EDIT UB = -> IN? ↑ ~ %)
(ADDTOVAR BREAKRESETFORMS (INTERRUPTABLE T)
(SETTERMTABLE BREAKTTBL))
(MOVD? (QUOTE EVAL)
(QUOTE \SAFEEVAL))
(MOVD? (QUOTE APPLY)
(QUOTE \SAFEAPPLY))
(MOVD? (QUOTE APPLY*)
(QUOTE \SAFEAPPLY*))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS NOBREAKIN BAKTRACELST BREAKDELIMITER BRKFILE CLEARSTKLST BREAKCOMSLST BRKFILE BREAKMACROS
LISPXCOMS LISPXHISTORY BREAKRESETFORMS NOSPELLFLG BREAKI BREAKHELPFLAG UPFINDFLG CLISPARRAY
BRKINFOLST LASTWORD DWIMFLG USERWORDS GLOBALVARS BREAKFN BROKENFNS BREAKAROUND BREAKBEFORE
BREAKAFTER)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA TRACE REBREAK UNBREAK BREAK BREAK3)
(ADDTOVAR NLAML BREAKNARGS BREAKIN BREAK1)
(ADDTOVAR LAMA )
)
(PUTPROPS BREAK COPYRIGHT ("Xerox Corporation" T 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4063 106072 (BREAK1 4073 . 6651) (BREAK1A 6653 . 7335) (BREAKLOOP 7337 . 7993) (
INTERLISP-BREAKLOOP 7995 . 14562) (BRKLASTPOS 14564 . 15565) (BREAKCOM 15567 . 27576) (
BREAKPRINTVALUES 27578 . 27995) (BREAKCOM1 27997 . 34195) (BREAKRESETFN 34197 . 37492) (
\BREAKRESETRESTORE 37494 . 37946) (BREAKRETFROM 37948 . 38127) (BREAKRETEVAL 38129 . 38309) (BREAKEXIT
38311 . 40275) (\BREAKSTOP 40277 . 41171) (BREAK2 41173 . 41568) (BREAK?= 41570 . 44557) (BREAK?=1
44559 . 46070) (BREAK= 46072 . 47563) (STKPOZ 47565 . 49879) (STKPOZ1 49881 . 51074) (STKPOZ2 51076 .
52307) (BREAKREAD 52309 . 53385) (BAKTRACE 53387 . 56379) (BAKTRACE1 56381 . 58160) (BREAK3 58162 .
61232) (BREAK 61234 . 61904) (BREAK0 61906 . 67631) (BREAK0A 67633 . 68566) (UNBREAK 68568 . 69230) (
UNBREAK0 69232 . 72609) (REBREAK 72611 . 75669) (REBREAK0 75671 . 77233) (TRACE 77235 . 78151) (
BREAKIN 78153 . 82331) (BREAKINCOMMENT 82333 . 82755) (UNBREAKIN 82757 . 84524) (SAVED 84526 . 85871)
(BREAKREVERT 85873 . 92204) (SAVED1 92206 . 93906) (SMARTARGLIST 93908 . 99221) (\SIMPLIFY.CL.ARGLIST
99223 . 99744) (RESTORENAMES 99746 . 101610) (VIRGINFN 101612 . 103575) (RESTORE 103577 . 104064) (
PACK-IN- 104066 . 105446) (BREAKNARGS 105448 . 106070)) (106073 108433 (PROCEED-FROM-BREAK 106083 .
106593) (PROCEED-WITH-DEFAULTS 106595 . 107214) (CREATE-PROCEED-KEYLIST 107216 . 108431)))))
STOP