[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Axiom-developer] 20090307.01.tpd.patch (bookvol5 add trace root)
|
From: |
daly |
|
Subject: |
[Axiom-developer] 20090307.01.tpd.patch (bookvol5 add trace root) |
|
Date: |
Sat, 7 Mar 2009 20:27:14 -0600 |
The )trace function was contained in a single file, trace.boot.
This file was removed and all of the code merged into bookvol5
A first patch cleanup of the lisp code was done.
Tim
=======================================================================
diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet
index 2b28252..8b2dfe0 100644
--- a/books/bookvol5.pamphlet
+++ b/books/bookvol5.pamphlet
@@ -384,7 +384,7 @@ Starts the interpreter but does not read in profiles, etc.
(progn
(spadlet mode '|restart|)
(do ()
- ((null (boot-equal mode '|restart|)) NIL)
+ ((null (boot-equal mode '|restart|)) nil)
(seq
(exit
(progn
@@ -639,7 +639,7 @@ minus any leading spaces.
@
-\subsection{make-absolute-filename}
+\subsection{defun make-absolute-filename}
Prefix a filename with the {\bf AXIOM} shell variable.
<<defun make-absolute-filename>>=
(defun make-absolute-filename (name)
@@ -2973,7 +2973,7 @@ displayFrameNames() ==
(progn
(spadlet fs
(prog (tmp0)
- (spadlet tmp0 NIL)
+ (spadlet tmp0 nil)
(return
(do ((tmp1 |$interpreterFrameRing| (cdr tmp1)) (f nil))
((or (atom tmp1)
@@ -2983,7 +2983,7 @@ displayFrameNames() ==
(exit
(setq tmp0
(append tmp0 (cons '|%l|
- (cons (makestring " ") (|bright| (frameName f))))))))))))
+ (cons " " (|bright| (frameName f))))))))))))
(|sayKeyedMsg| 'S2IZ0024 (cons fs nil))))))) ; frame names are ...
@
@@ -3154,7 +3154,7 @@ frameSpad2Cmd args ==
(cond
(|$options|
(|throwKeyedMsg| 'S2IZ0016 ; frame command does not take options
- (cons (makestring ")frame") nil)))
+ (cons ")frame" nil)))
((null args)
(|helpSpad2Cmd| (cons '|frame| nil)))
(t
@@ -3603,7 +3603,7 @@ initHistList() ==
(spadlet li (cons nil li)))))
(rplacd |$HistList| li)
(spadlet |$HistListAct| 0)
- (spadlet |$HistRecord| NIL))))))
+ (spadlet |$HistRecord| nil))))))
@
\subsection{defun history}
@@ -3674,7 +3674,7 @@ historySpad2Cmd() ==
(prog (tmp1)
(spadlet tmp1 nil)
(return
- (do ((tmp2 |$options| (cdr tmp2)) (tmp3 NIL))
+ (do ((tmp2 |$options| (cdr tmp2)) (tmp3 nil))
((or (atom tmp2)
(progn
(setq tmp3 (car tmp2))
@@ -3810,20 +3810,20 @@ setHistoryCore inCore ==
(cond
((boot-equal inCore |$useInternalHistoryTable|)
(if inCore
- (|sayKeyedMsg| 'S2IH0030 NIL) ; memory history already in use
- (|sayKeyedMsg| 'S2IH0029 NIL))) ; file history already in use
+ (|sayKeyedMsg| 'S2IH0030 nil) ; memory history already in use
+ (|sayKeyedMsg| 'S2IH0029 nil))) ; file history already in use
((null |$HiFiAccess|)
(spadlet |$useInternalHistoryTable| inCore)
(if inCore
- (|sayKeyedMsg| 'S2IH0032 NIL) ; use memory history
- (|sayKeyedMsg| 'S2IH0031 NIL))) ; use file history
+ (|sayKeyedMsg| 'S2IH0032 nil) ; use memory history
+ (|sayKeyedMsg| 'S2IH0031 nil))) ; use file history
(inCore
(spadlet |$internalHistoryTable| nil)
(cond
((nequal |$IOindex| 0)
(spadlet l (length (rkeyids (|histFileName|))))
(do ((|i| 1 (qsadd1 |i|)))
- ((qsgreaterp |i| l) NIL)
+ ((qsgreaterp |i| l) nil)
(seq
(exit
(progn
@@ -3844,7 +3844,7 @@ setHistoryCore inCore ==
(cons 'file (|histFileName|))
nil))))
(do ((tmp0 (reverse |$internalHistoryTable|) (cdr tmp0))
- (tmp1 NIL))
+ (tmp1 nil))
((or (atom tmp0)
(progn
(setq tmp1 (car tmp0))
@@ -3863,7 +3863,7 @@ setHistoryCore inCore ==
(spadlet |$HiFiAccess| t)
(spadlet |$internalHistoryTable| nil)
(spadlet |$useInternalHistoryTable| nil)
- (|sayKeyedMsg| 'S2IH0031 NIL))))) ; use file history
+ (|sayKeyedMsg| 'S2IH0031 nil))))) ; use file history
@
\subsection{defun writeInputLines}
@@ -4273,7 +4273,7 @@ undoChanges(li) ==
(progn
(when (null (boot-equal (cdr li) |$HistList|))
(|undoChanges| (cdr li)))
- (do ((tmp0 (car li) (cdr tmp0)) (p1 NIL))
+ (do ((tmp0 (car li) (cdr tmp0)) (p1 nil))
((or (atom tmp0) (progn (setq p1 (car tmp0)) nil)) nil)
(seq
(exit
@@ -4517,7 +4517,7 @@ restoreHistory(fn) ==
(|sayKeyedMsg| 'S2IH0024 ; file does not exist
(cons (|namestring| restfile) nil)))
(t
- (spadlet |$options| NIL)
+ (spadlet |$options| nil)
(|clearSpad2Cmd| '(|all|))
(spadlet curfile (|histFileName|))
(|histFileErase| curfile)
@@ -4660,9 +4660,9 @@ showHistory(arg) ==
(t
(|sayMSG|
(|concat|
- (makestring " ")
+ " "
(|bright| arg1)
- (makestring "is an invalid argument.")))))))))
+ "is an invalid argument."))))))))
(when (>= n |$IOindex|)
(spadlet n (spaddifference |$IOindex| 1)))
(spadlet mini (spaddifference |$IOindex| n))
@@ -4706,7 +4706,7 @@ showInput(mini,maxi) ==
(return
(seq
(do ((|ind| mini (+ |ind| 1)))
- ((> |ind| maxi) NIL)
+ ((> |ind| maxi) nil)
(seq
(exit
(progn
@@ -4720,21 +4720,21 @@ showInput(mini,maxi) ==
((stringp l)
(|sayMSG|
(cons
- (makestring " [")
+ " ["
(cons |ind|
- (cons (makestring "] ")
+ (cons "] "
(cons (car vec) nil))))))
(t
(|sayMSG|
- (cons (makestring " [")
+ (cons " ["
(cons |ind|
- (cons (makestring "] ") nil))))
+ (cons "] " nil))))
(do ((tmp0 l (cdr tmp0)) (|ln| nil))
((or (atom tmp0) (progn (setq |ln| (car tmp0)) nil)) nil)
(seq
(exit
(|sayMSG|
- (cons (makestring " ") (cons |ln| nil))))))))))))))))
+ (cons " " (cons |ln| nil))))))))))))))))
@
\subsection{defun showInOut}
@@ -5035,7 +5035,7 @@ writifyComplain s ==
<<defun writifyComplain>>=
(defun |writifyComplain| (s)
(cond
- ((boot-equal |$writifyComplained| t) NIL)
+ ((boot-equal |$writifyComplained| t) nil)
(t
(spadlet |$writifyComplained| t)
(|sayKeyedMsg| 'S2IH0027 (cons s nil))))) ; cannot save value
@@ -5205,7 +5205,7 @@ writify ob ==
(hput |$seen| ob nob)
(hput |$seen| nob nob)
(do ((|i| 0 (qsadd1 |i|)))
- ((qsgreaterp |i| n) NIL)
+ ((qsgreaterp |i| n) nil)
(seq
(exit
(qsetvelt nob |i| (|writify,writifyInner| (QVELT ob |i|))))))
@@ -5435,9 +5435,9 @@ dewritify ob ==
(when (intp oname) (exit (eval (gensymmer oname))))
(exit (symbol-function oname))))
(when (null (compiled-function-p f))
- (exit (|error| (makestring "A required BPI does not exist."))))
+ (exit (|error| "A required BPI does not exist.")))
(when (and (> (|#| ob) 3) (nequal (hasheq f) (elt ob 3)))
- (exit (|error| (makestring "A required BPI has been redefined."))))
+ (exit (|error| "A required BPI has been redefined.")))
(hput |$seen| ob f)
(exit f))))
(when (boot-equal type 'hashtable)
@@ -5479,8 +5479,7 @@ dewritify ob ==
(when (null (fboundp name))
(exit
(|error|
- (strconc (makestring "undefined function: ")
- (symbol-name name)))))
+ (strconc "undefined function: " (symbol-name name)))))
(spadlet nob (cons (symbol-function name) vec))
(hput |$seen| ob nob)
(hput |$seen| nob nob)
@@ -5493,7 +5492,7 @@ dewritify ob ==
(hput |$seen| nob nob)
(exit nob))))
(when (boot-equal type 'readtable)
- (exit (|error| (makestring "Cannot de-writify a read table."))))
+ (exit (|error| "Cannot de-writify a read table.")))
(when (boot-equal type 'nullstream)
(exit |$NullStream|))
(when (boot-equal type 'nonnullstream)
@@ -5512,7 +5511,7 @@ dewritify ob ==
(when (minusp sign)
(exit (spaddifference fval)))
(exit fval))))
- (exit (|error| (makestring "Unknown type to de-writify."))))))
+ (exit (|error| "Unknown type to de-writify.")))))
(when (pairp ob)
(exit
(seq
@@ -5626,7 +5625,7 @@ gensymInt g ==
(seq
(cond
((null (gensymp g))
- (|error| (makestring "Need a GENSYM")))
+ (|error| "Need a GENSYM"))
(t
(spadlet p (pname g))
(spadlet n 0)
@@ -5654,7 +5653,7 @@ charDigitVal c ==
(return
(seq
(progn
- (spadlet digits (makestring "0123456789"))
+ (spadlet digits "0123456789")
(spadlet n (spaddifference 1))
(do ((tmp0 (spaddifference (|#| digits) 1)) (|i| 0 (qsadd1 |i|)))
((or (qsgreaterp |i| tmp0) (null (minusp n))) nil)
@@ -5664,7 +5663,7 @@ charDigitVal c ==
((boot-equal c (elt digits |i|)) (spadlet n |i|))
(t nil)))))
(cond
- ((minusp n) (|error| (makestring "Character is not a digit")))
+ ((minusp n) (|error| "Character is not a digit"))
(t n)))))))
@
@@ -6621,6 +6620,3081 @@ to escape them with an underscore.
\fnref{lisp}, and
\fnref{ltrace}
+\subsection{The trace global variables}
+This decides when to give trace and untrace messages.
+<<initvars>>=
+(defvar |$traceNoisely| nil)
+
+@
+
+This reports the traced functions
+<<initvars>>=
+(defvar |$reportSpadTrace| nil)
+
+@
+
+<<initvars>>=
+(defvar |$optionAlist| nil)
+
+@
+
+<<initvars>>=
+(defvar |$tracedMapSignatures| nil)
+
+@
+
+<<initvars>>=
+(defvar |$traceOptionList|
+ '(|after| |before| |break| |cond| |count| |depth| |local| |mathprint|
+ |nonquietly| |nt| |of| |only| |ops| |restore| |timer| |varbreak|
+ |vars| |within|))
+
+@
+
+\subsection{defun trace}
+<<defun trace>>=
+(defun |trace| (l)
+ (|traceSpad2Cmd| l))
+
+@
+
+\subsection{defun traceSpad2Cmd}
+\begin{verbatim}
+;traceSpad2Cmd l ==
+; if l is ['Tuple, l1] then l := l1
+; $mapSubNameAlist:= getMapSubNames(l)
+; trace1 augmentTraceNames(l,$mapSubNameAlist)
+; traceReply()
+\end{verbatim}
+
+<<defun traceSpad2Cmd>>=
+(defun |traceSpad2Cmd| (l)
+ (let (tmp1 l1)
+ (cond
+ ((and (pairp l)
+ (eq (qcar l) '|Tuple|)
+ (progn
+ (setq tmp1 (qcdr l))
+ (and (pairp tmp1)
+ (eq (qcdr tmp1) nil)
+ (progn
+ (setq l1 (qcar tmp1))
+ t))))
+ (setq l l1)))
+ (setq |$mapSubNameAlist| (|getMapSubNames| l))
+ (|trace1| (|augmentTraceNames| l |$mapSubNameAlist|))
+ (|traceReply|)))
+
+@
+
+\subsection{defun trace1}
+\begin{verbatim}
+;trace1 l ==
+; $traceNoisely: local := NIL
+; if hasOption($options,'nonquietly) then $traceNoisely := true
+; hasOption($options,'off) =>
+; (ops := hasOption($options,'ops)) or
+; (lops := hasOption($options,'local)) =>
+; null l => throwKeyedMsg("S2IT0019",NIL)
+; constructor := unabbrev
+; atom l => l
+; null rest l =>
+; atom first l => first l
+; first first l
+; NIL
+; not(isFunctor constructor) => throwKeyedMsg("S2IT0020",NIL)
+; if ops then
+; ops := getTraceOption ops
+; NIL
+; if lops then
+; lops := rest getTraceOption lops
+; untraceDomainLocalOps(constructor,lops)
+; (1 < # $options) and not hasOption($options,'nonquietly) =>
+; throwKeyedMsg("S2IT0021",NIL)
+; untrace l
+; hasOption($options,'stats) =>
+; (1 < # $options) =>
+; throwKeyedMsg("S2IT0001",['")trace ... )stats"])
+; [.,:opt] := CAR $options
+; -- look for )trace )stats to list the statistics
+; -- )trace )stats reset to reset them
+; null opt => -- list the statistics
+; centerAndHighlight('"Traced function execution times",78,"-")
+; ptimers ()
+; SAY '" "
+; centerAndHighlight('"Traced function execution counts",78,"-")
+; pcounters ()
+; selectOptionLC(first opt,'(reset),'optionError)
+; resetSpacers()
+; resetTimers()
+; resetCounters()
+; throwKeyedMsg("S2IT0002",NIL)
+; a:= hasOption($options,'restore) =>
+; null(oldL:= $lastUntraced) => nil
+; newOptions:= DELETE(a,$options)
+; null l => trace1 oldL
+; for x in l repeat
+; x is [domain,:opList] and VECP domain =>
+; sayKeyedMsg("S2IT0003",[devaluate domain])
+; $options:= [:newOptions,:LASSOC(x,$optionAlist)]
+; trace1 LIST x
+; null l => nil
+; l is ["?"] => _?t()
+; traceList:= [transTraceItem x for x in l] or return nil
+; for x in traceList repeat $optionAlist:=
+; ADDASSOC(x,$options,$optionAlist)
+; optionList:= getTraceOptions $options
+; argument:=
+; domainList:= LASSOC("of",optionList) =>
+; LASSOC("ops",optionList) =>
+; throwKeyedMsg("S2IT0004",NIL)
+; opList:=
+; traceList => LIST ["ops",:traceList]
+; nil
+; varList:=
+; y:= LASSOC("vars",optionList) => LIST ["vars",:y]
+; nil
+; [:domainList,:opList,:varList]
+; optionList => [:traceList,:optionList]
+; traceList
+; _/TRACE_,0 [funName for funName in argument]
+; saveMapSig [funName for funName in argument]
+\end{verbatim}
+
+<<defun trace1>>=
+(defun |trace1| (|l|)
+ (prog (|$traceNoisely| |constructor| |ops| |lops| temp1 |opt| |a|
+ |oldL| |newOptions| |domain| |traceList| |optionList| |domainList|
+ |opList| |y| |varList| |argument|)
+ (declare (special |$traceNoisely|))
+ (return
+ (seq
+ (progn
+ (spadlet |$traceNoisely| nil)
+ (cond
+ ((|hasOption| |$options| '|nonquietly|)
+ (spadlet |$traceNoisely| t)))
+ (cond
+ ((|hasOption| |$options| '|off|)
+ (cond
+ ((or (spadlet |ops| (|hasOption| |$options| '|ops|))
+ (spadlet |lops| (|hasOption| |$options| '|local|)))
+ (cond
+ ((null |l|) (|throwKeyedMsg| 's2it0019 nil))
+ (t
+ (spadlet |constructor|
+ (|unabbrev|
+ (cond
+ ((atom |l|) |l|)
+ ((null (cdr |l|))
+ (cond
+ ((atom (car |l|)) (car |l|))
+ (t (car (car |l|)))))
+ (t nil))))
+ (cond
+ ((null (|isFunctor| |constructor|))
+ (|throwKeyedMsg| 's2it0020 nil))
+ (t
+ (cond (|ops| (spadlet |ops| (|getTraceOption| |ops|)) nil))
+ (cond
+ (|lops|
+ (spadlet |lops| (cdr (|getTraceOption| |lops|)))
+ (|untraceDomainLocalOps| |constructor| |lops|))
+ (t nil)))))))
+ ((and (qslessp 1 (|#| |$options|))
+ (null (|hasOption| |$options| '|nonquietly|)))
+ (|throwKeyedMsg| 's2it0021 nil))
+ (t (|untrace| |l|))))
+ ((|hasOption| |$options| '|stats|)
+ (cond
+ ((qslessp 1 (|#| |$options|))
+ (|throwKeyedMsg| 's2it0001 (cons ")trace ... )stats" nil)))
+ (t
+ (spadlet temp1 (car |$options|))
+ (spadlet |opt| (cdr temp1))
+ (cond
+ ((null |opt|)
+ (|centerAndHighlight| "Traced function execution times" 78 '-)
+ (|ptimers|)
+ (say " ")
+ (|centerAndHighlight| "Traced function execution counts" 78 '-)
+ (|pcounters|))
+ (t
+ (|selectOptionLC| (car |opt|) '(|reset|) '|optionError|)
+ (|resetSpacers|)
+ (|resetTimers|)
+ (|resetCounters|)
+ (|throwKeyedMsg| 's2it0002 nil))))))
+ ((spadlet |a| (|hasOption| |$options| '|restore|))
+ (cond
+ ((null (spadlet |oldL| |$lastUntraced|)) nil)
+ (t
+ (spadlet |newOptions| (|delete| |a| |$options|))
+ (cond
+ ((null |l|) (|trace1| |oldL|))
+ (t
+ (do ((t0 |l| (cdr t0)) (|x|l nil))
+ ((or (atom t0) (progn (setq |x| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (cond
+ ((and (pairp |x|)
+ (progn
+ (spadlet |domain| (qcar |x|))
+ (spadlet |opList| (qcdr |x|))
+ t)
+ (vecp |domain|))
+ (|sayKeyedMsg| 's2it0003 (cons (|devaluate| |domain|) nil)))
+ (t
+ (spadlet |$options|
+ (append |newOptions| (lassoc |x| |$optionAlist|)))
+ (|trace1| (list |x|))))))))))))
+ ((null |l|) nil)
+ ((and (pairp |l|) (eq (qcdr |l|) nil) (eq (qcar |l|) '?)) (|?t|))
+ (t
+ (spadlet |traceList|
+ (or
+ (prog (t1)
+ (spadlet t1 nil)
+ (return
+ (do ((t2 |l| (cdr t2)) (|x| nil))
+ ((or (atom t2)
+ (progn (setq |x| (car t2)) nil))
+ (nreverse0 t1))
+ (seq
+ (exit
+ (setq t1 (cons (|transTraceItem| |x|) t1)))))))
+ (return nil)))
+ (do ((t3 |traceList| (cdr t3)) (|x| nil))
+ ((or (atom t3) (progn (setq |x| (car t3)) nil)) nil)
+ (seq
+ (exit
+ (spadlet |$optionAlist| (addassoc |x| |$options| |$optionAlist|)))))
+ (spadlet |optionList| (|getTraceOptions| |$options|))
+ (spadlet |argument|
+ (cond
+ ((spadlet |domainList| (lassoc '|of| |optionList|))
+ (cond
+ ((lassoc '|ops| |optionList|)
+ (|throwKeyedMsg| 's2it0004 nil))
+ (t
+ (spadlet |opList|
+ (cond
+ (|traceList| (list (cons '|ops| |traceList|)))
+ (t nil)))
+ (spadlet |varList|
+ (cond
+ ((spadlet |y| (lassoc '|vars| |optionList|))
+ (list (cons '|vars| |y|)))
+ (t nil)))
+ (append |domainList| (append |opList| |varList|)))))
+ (|optionList| (append |traceList| |optionList|))
+ (t |traceList|)))
+ (|/TRACE,0|
+ (prog (t4)
+ (spadlet t4 nil)
+ (return
+ (do ((t5 |argument| (cdr t5)) (|funName| nil))
+ ((or (atom t5)
+ (progn (setq |funName| (car t5)) nil))
+ (nreverse0 t4))
+ (seq
+ (exit
+ (setq t4 (cons |funName| t4))))))))
+ (|saveMapSig|
+ (prog (t6)
+ (spadlet t6 nil)
+ (return
+ (do ((t7 |argument| (cdr t7)) (|funName| nil))
+ ((or (atom t7)
+ (progn (setq |funName| (car t7)) nil))
+ (nreverse0 t6))
+ (seq
+ (exit
+ (setq t6 (cons |funName| t6)))))))))))))))
+
+@
+
+\subsection{defun getTraceOptions}
+\begin{verbatim}
+;getTraceOptions options ==
+; $traceErrorStack: local := nil
+; optionList:= [getTraceOption x for x in options]
+; $traceErrorStack =>
+; null rest $traceErrorStack =>
+; [key,parms] := first $traceErrorStack
+; throwKeyedMsg(key,['"",:parms])
+; throwListOfKeyedMsgs("S2IT0017",[# $traceErrorStack],
+; NREVERSE $traceErrorStack)
+; optionList
+\end{verbatim}
+
+<<defun getTraceOptions>>=
+(defun |getTraceOptions| (|options|)
+ (prog (|$traceErrorStack| |optionList| temp1 |key| |parms|)
+ (declare (special |$traceErrorStack|))
+ (return
+ (seq
+ (progn
+ (spadlet |$traceErrorStack| nil)
+ (spadlet |optionList|
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 |options| (cdr t1)) (|x| nil))
+ ((or (atom t1) (progn (setq |x| (car t1)) nil)) (nreverse0 t0))
+ (seq
+ (exit
+ (setq t0 (cons (|getTraceOption| |x|) t0))))))))
+ (cond
+ (|$traceErrorStack|
+ (cond
+ ((null (cdr |$traceErrorStack|))
+ (spadlet temp1 (car |$traceErrorStack|))
+ (spadlet |key| (car temp1))
+ (spadlet |parms| (cadr temp1))
+ (|throwKeyedMsg| |key| (cons "" |parms|)))
+ (t
+ (|throwListOfKeyedMsgs| 's2it0017
+ (cons (|#| |$traceErrorStack|) nil)
+ (nreverse |$traceErrorStack|)))))
+ (t |optionList|)))))))
+
+@
+
+\subsection{defun saveMapSig}
+\begin{verbatim}
+;saveMapSig(funNames) ==
+; for name in funNames repeat
+; map:= RASSOC(name,$mapSubNameAlist) =>
+; $tracedMapSignatures:= ADDASSOC(name,getMapSig(map,name),
+; $tracedMapSignatures)
+\end{verbatim}
+
+<<defun saveMapSig>>=
+(defun |saveMapSig| (|funNames|)
+ (prog (|map|)
+ (return
+ (seq
+ (do ((t0 |funNames| (cdr t0)) (|name| nil))
+ ((or (atom t0) (progn (setq |name| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (cond
+ ((spadlet |map| (|rassoc| |name| |$mapSubNameAlist|))
+ (exit
+ (spadlet |$tracedMapSignatures|
+ (addassoc |name| (|getMapSig| |map| |name|)
+ |$tracedMapSignatures|))))))))))))
+
+@
+
+\subsection{defun getMapSig}
+\begin{verbatim}
+;getMapSig(mapName,subName) ==
+; lmms:= get(mapName,'localModemap,$InteractiveFrame) =>
+; for mm in lmms until sig repeat
+; CADR mm = subName => sig:= CDAR mm
+; sig
+\end{verbatim}
+
+<<defun getMapSig>>=
+(defun |getMapSig| (|mapName| |subName|)
+ (PROG (|lmms| |sig|)
+ (RETURN
+ (SEQ
+ (COND
+ ((SPADLET |lmms| (|get| |mapName| '|localModemap| |$InteractiveFrame|))
+ (EXIT
+ (SEQ
+ (DO ((t0 |lmms| (CDR t0)) (|mm| nil) (t1 nil |sig|))
+ ((OR (ATOM t0) (PROGN (SETQ |mm| (CAR t0)) nil) t1) nil)
+ (SEQ
+ (EXIT
+ (COND
+ ((BOOT-EQUAL (CADR |mm|) |subName|)
+ (EXIT
+ (SPADLET |sig| (CDAR |mm|))))))))
+ (EXIT |sig|)))))))))
+
+@
+
+\subsection{defun getTraceOption}
+\begin{verbatim}
+;getTraceOption (x is [key,:l]) ==
+; key:= selectOptionLC(key,$traceOptionList,'traceOptionError)
+; x := [key,:l]
+; MEMQ(key,'(nonquietly timer nt)) => x
+; key='break =>
+; null l => ['break,'before]
+; opts := [selectOptionLC(y,'(before after),NIL) for y in l]
+; and/[IDENTP y for y in opts] => ['break,:opts]
+; stackTraceOptionError ["S2IT0008",NIL]
+; key='restore =>
+; null l => x
+; stackTraceOptionError ["S2IT0009",[STRCONC('")",object2String key)]]
+; key='only => ['only,:transOnlyOption l]
+; key='within =>
+; l is [a] and IDENTP a => x
+; stackTraceOptionError ["S2IT0010",['")within"]]
+; MEMQ(key,'(cond before after)) =>
+; key:=
+; key="cond" => "when"
+; key
+; l is [a] => [key,:l]
+; stackTraceOptionError ["S2IT0011",[STRCONC('")",object2String key)]]
+; key='depth =>
+; l is [n] and FIXP n => x
+; stackTraceOptionError ["S2IT0012",['")depth"]]
+; key='count =>
+; (null l) or (l is [n] and FIXP n) => x
+; stackTraceOptionError ["S2IT0012",['")count"]]
+; key="of" =>
+; ["of",:[hn y for y in l]] where
+; hn x ==
+; atom x and not UPPER_-CASE_-P (STRINGIMAGE x).(0) =>
+; isDomainOrPackage EVAL x => x
+; stackTraceOptionError ["S2IT0013",[x]]
+; g:= domainToGenvar x => g
+; stackTraceOptionError ["S2IT0013",[x]]
+; MEMQ(key,'(local ops vars)) =>
+; null l or l is ["all"] => [key,:"all"]
+; isListOfIdentifiersOrStrings l => x
+; stackTraceOptionError ["S2IT0015",[STRCONC('")",object2String key)]]
+; key='varbreak =>
+; null l or l is ["all"] => ["varbreak",:"all"]
+; isListOfIdentifiers l => x
+; stackTraceOptionError ["S2IT0016",[STRCONC('")",object2String key)]]
+; key='mathprint =>
+; null l => x
+; stackTraceOptionError ["S2IT0009",[STRCONC('")",object2String key)]]
+; key => throwKeyedMsg("S2IT0005",[key])
+\end{verbatim}
+
+<<defun getTraceOption,hn>>=
+(defun |getTraceOption,hn| (|x|)
+ (prog (|g|)
+ (return
+ (seq
+ (if (and (atom |x|) (null (upper-case-p (elt (stringimage |x|) 0))))
+ (exit
+ (seq
+ (if (|isDomainOrPackage| (eval |x|)) (exit |x|))
+ (exit
+ (|stackTraceOptionError|
+ (cons 's2it0013 (cons (cons |x| nil) nil)))))))
+ (if (spadlet |g| (|domainToGenvar| |x|)) (exit |g|))
+ (exit
+ (|stackTraceOptionError| (cons 's2it0013 (cons (cons |x| nil) nil))))))))
+
+@
+
+<<defun getTraceOption>>=
+(defun |getTraceOption| (|x|)
+ (prog (|l| |opts| |key| |a| |n|)
+ (return
+ (seq
+ (progn
+ (spadlet |key| (car |x|))
+ (spadlet |l| (cdr |x|))
+ (spadlet |key|
+ (|selectOptionLC| |key| |$traceOptionList| '|traceOptionError|))
+ (spadlet |x| (cons |key| |l|))
+ (cond
+ ((memq |key| '(|nonquietly| |timer| |nt|)) |x|)
+ ((boot-equal |key| '|break|)
+ (cond
+ ((null |l|) (cons '|break| (cons '|before| nil)))
+ (t
+ (spadlet |opts|
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 |l| (cdr t1)) (|y| nil))
+ ((or (atom t1)
+ (progn (setq |y| (car t1)) nil))
+ (nreverse0 t0))
+ (seq
+ (exit
+ (setq t0
+ (cons
+ (|selectOptionLC| |y| '(|before| |after|) nil) t0))))))))
+ (cond
+ ((prog (t2)
+ (spadlet t2 t)
+ (return
+ (do ((t3 nil (null t2)) (t4 |opts| (cdr t4)) (|y| nil))
+ ((or t3 (atom t4) (progn (setq |y| (car t4)) nil)) t2)
+ (seq
+ (exit
+ (setq t2 (and t2 (identp |y|))))))))
+ (cons '|break| |opts|))
+ (t
+ (|stackTraceOptionError| (cons 's2it0008 (cons nil nil))))))))
+ ((boot-equal |key| '|restore|)
+ (cond
+ ((null |l|) |x|)
+ (t
+ (|stackTraceOptionError|
+ (cons 's2it0009
+ (cons (cons (strconc ")" (|object2String| |key|)) nil) nil))))))
+ ((boot-equal |key| '|only|) (cons '|only| (|transOnlyOption| |l|)))
+ ((boot-equal |key| '|within|)
+ (cond
+ ((and (pairp |l|)
+ (eq (qcdr |l|) nil)
+ (progn (spadlet |a| (qcar |l|)) t)
+ (identp |a|))
+ |x|)
+ (t
+ (|stackTraceOptionError|
+ (cons 's2it0010 (cons (cons ")within" nil) nil))))))
+ ((memq |key| '(|cond| |before| |after|))
+ (spadlet |key|
+ (cond
+ ((boot-equal |key| '|cond|) '|when|)
+ (t |key|)))
+ (cond
+ ((and (pairp |l|)
+ (eq (qcdr |l|) nil)
+ (progn (spadlet |a| (qcar |l|)) t))
+ (cons |key| |l|))
+ (t
+ (|stackTraceOptionError|
+ (cons 's2it0011
+ (cons
+ (cons (strconc ")"
+ (|object2String| |key|)) nil) nil))))))
+ ((boot-equal |key| '|depth|)
+ (cond
+ ((and (pairp |l|)
+ (eq (qcdr |l|) nil)
+ (progn (spadlet |n| (qcar |l|)) t)
+ (fixp |n|))
+ |x|)
+ (t
+ (|stackTraceOptionError|
+ (cons 's2it0012 (cons (cons ")depth" nil) nil))))))
+ ((boot-equal |key| '|count|)
+ (cond
+ ((or (null |l|)
+ (and (pairp |l|)
+ (eq (qcdr |l|) nil)
+ (progn (spadlet |n| (qcar |l|)) t)
+ (fixp |n|)))
+ |x|)
+ (t
+ (|stackTraceOptionError|
+ (cons 's2it0012 (cons (cons ")count" nil) nil))))))
+ ((boot-equal |key| '|of|)
+ (cons '|of|
+ (prog (t5)
+ (spadlet t5 nil)
+ (return
+ (do ((t6 |l| (cdr t6)) (|y| nil))
+ ((or (atom t6) (progn (setq |y| (car t6)) nil)) (nreverse0 t5))
+ (seq
+ (exit
+ (setq t5 (cons (|getTraceOption,hn| |y|) t5)))))))))
+ ((memq |key| '(|local| |ops| |vars|))
+ (cond
+ ((or (null |l|)
+ (and (pairp |l|) (eq (qcdr |l|) nil) (eq (qcar |l|) '|all|)))
+ (cons |key| '|all|))
+ ((|isListOfIdentifiersOrStrings| |l|) |x|)
+ (t
+ (|stackTraceOptionError|
+ (cons 's2it0015
+ (cons
+ (cons (strconc ")" (|object2String| |key|)) nil) nil))))))
+ ((boot-equal |key| '|varbreak|)
+ (cond
+ ((or (null |l|)
+ (and (pairp |l|) (eq (qcdr |l|) nil) (eq (qcar |l|) '|all|)))
+ (cons '|varbreak| '|all|))
+ ((|isListOfIdentifiers| |l|) |x|)
+ (t
+ (|stackTraceOptionError|
+ (cons 's2it0016
+ (cons
+ (cons (strconc ")" (|object2String| |key|)) nil) nil))))))
+ ((boot-equal |key| '|mathprint|)
+ (cond
+ ((null |l|) |x|)
+ (t
+ (|stackTraceOptionError|
+ (cons 's2it0009
+ (cons
+ (cons (strconc ")" (|object2String| |key|)) nil) nil))))))
+ (|key| (|throwKeyedMsg| 's2it0005 (CONS |key| nil)))))))))
+
+@
+
+\subsection{defun traceOptionError}
+\begin{verbatim}
+;traceOptionError(opt,keys) ==
+; null keys => stackTraceOptionError ["S2IT0007",[opt]]
+; commandAmbiguityError("trace option",opt,keys)
+\end{verbatim}
+
+<<defun traceOptionError>>=
+(defun |traceOptionError| (|opt| |keys|)
+ (cond
+ ((null |keys|)
+ (|stackTraceOptionError| (cons 's2it0007 (cons (cons |opt| nil) nil))))
+ (t
+ (|commandAmbiguityError| '|trace option| |opt| |keys|))))
+
+@
+
+\subsection{defun resetTimers}
+\begin{verbatim}
+;resetTimers () ==
+; for timer in _/TIMERLIST repeat
+; SET(INTERN STRCONC(timer,'"_,TIMER"),0)
+\end{verbatim}
+
+<<defun resetTimers>>=
+(defun |resetTimers| ()
+ (seq
+ (do ((t0 /timerlist (cdr t0)) (|timer| nil))
+ ((or (atom t0) (progn (setq |timer| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (set (intern (strconc |timer| ",TIMER")) 0))))))
+
+@
+
+\subsection{defun resetSpacers}
+\begin{verbatim}
+;resetSpacers () ==
+; for spacer in _/SPACELIST repeat
+; SET(INTERN STRCONC(spacer,'"_,SPACE"),0)
+\end{verbatim}
+
+<<defun resetSpacers>>=
+(defun |resetSpacers| ()
+ (seq
+ (do ((t0 /spacelist (cdr t0)) (|spacer| nil))
+ ((or (atom t0) (progn (setq |spacer| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (set (intern (strconc |spacer| ",SPACE")) 0))))))
+
+@
+\subsection{defun resetCounters}
+\begin{verbatim}
+;resetCounters () ==
+; for k in _/COUNTLIST repeat
+; SET(INTERN STRCONC(k,'"_,COUNT"),0)
+\end{verbatim}
+
+<<defun resetCounters>>=
+(defun |resetCounters| ()
+ (seq
+ (do ((t0 /countlist (cdr t0)) (|k| nil))
+ ((or (atom t0) (progn (setq |k| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (set (intern (strconc |k| ",COUNT")) 0))))))
+
+@
+
+\subsection{defun ptimers}
+\begin{verbatim}
+;ptimers() ==
+; null _/TIMERLIST => sayBrightly '" no functions are timed"
+; for timer in _/TIMERLIST repeat
+; sayBrightly [" ",:bright timer,'_:,'" ",
+; EVAL(INTERN STRCONC(timer,'"_,TIMER")) / float $timerTicksPerSecond,'"
sec."]
+\end{verbatim}
+
+<<defun ptimers>>=
+(defun |ptimers| ()
+ (seq
+ (cond
+ ((null /timerlist) (|sayBrightly| " no functions are timed"))
+ (t
+ (do ((t0 /timerlist (cdr t0)) (|timer| nil))
+ ((or (atom t0) (progn (setq |timer| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (|sayBrightly|
+ (cons " "
+ (append
+ (|bright| |timer|)
+ (cons '|:|
+ (cons " "
+ (cons
+ (quotient
+ (eval (intern (strconc |timer| ",TIMER")))
+ (|float| |$timerTicksPerSecond|))
+ (cons " sec." nil))))))))))))))
+
+@
+
+\subsection{defun pspacers}
+\begin{verbatim}
+;pspacers() ==
+; null _/SPACELIST => sayBrightly '" no functions have space monitored"
+; for spacer in _/SPACELIST repeat
+; sayBrightly [" ",:bright spacer,'_:,'" ",
+; EVAL INTERN STRCONC(spacer,'"_,SPACE"),'" bytes"]
+\end{verbatim}
+
+<<defun pspacers>>=
+(defun |pspacers| ()
+ (seq
+ (cond
+ ((null /spacelist) (|sayBrightly| " no functions have space monitored"))
+ (t
+ (do ((t0 /spacelist (cdr t0)) (|spacer| nil))
+ ((or (atom t0) (progn (setq |spacer| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (|sayBrightly|
+ (cons " "
+ (append
+ (|bright| |spacer|)
+ (cons '|:|
+ (cons " "
+ (cons
+ (eval (intern (strconc |spacer| ",SPACE")))
+ (cons " bytes" nil))))))))))))))
+
+@
+
+\subsection{defun pcounters}
+\begin{verbatim}
+;pcounters() ==
+; null _/COUNTLIST => sayBrightly '" no functions are being counted"
+; for k in _/COUNTLIST repeat
+; sayBrightly [" ",:bright k,'_:,'" ",
+; EVAL INTERN STRCONC(k,'"_,COUNT"),'" times"]
+\end{verbatim}
+
+<<defun pcounters>>=
+(defun |pcounters| ()
+ (seq
+ (cond
+ ((null /countlist) (|sayBrightly| " no functions are being counted"))
+ (t
+ (do ((t0 /countlist (cdr t0)) (|k| nil))
+ ((or (atom t0) (progn (setq |k| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (|sayBrightly|
+ (cons " "
+ (append
+ (|bright| |k|)
+ (cons '|:|
+ (cons " "
+ (cons
+ (eval (intern (strconc |k| ",COUNT")))
+ (cons " times" nil))))))))))))))
+
+@
+
+\subsection{defun transOnlyOption}
+\begin{verbatim}
+;transOnlyOption l ==
+; l is [n,:y] =>
+; FIXP n => [n,:transOnlyOption y]
+; MEMQ(n:= UPCASE n,'(V A C)) => [n,:transOnlyOption y]
+; stackTraceOptionError ["S2IT0006",[n]]
+; transOnlyOption y
+; nil
+\end{verbatim}
+
+<<defun transOnlyOption>>=
+(defun |transOnlyOption| (|l|)
+ (prog (|y| |n|)
+ (return
+ (cond
+ ((and (pairp |l|)
+ (progn (spadlet |n| (qcar |l|)) (spadlet |y| (qcdr |l|)) t))
+ (cond
+ ((fixp |n|)
+ (cons |n| (|transOnlyOption| |y|)))
+ ((memq (spadlet |n| (upcase |n|)) '(V A C))
+ (cons |n| (|transOnlyOption| |y|)))
+ (t
+ (|stackTraceOptionError|
+ (cons 's2it0006 (cons (cons |n| nil) nil)))
+ (|transOnlyOption| |y|))))
+ (t nil)))))
+
+@
+
+\subsection{defun stackTraceOptionError}
+<<defun stackTraceOptionError>>=
+(defun |stackTraceOptionError| (x)
+ (push x |$traceErrorStack|)
+ nil)
+
+@
+
+\subsection{defun removeOption}
+\begin{verbatim}
+;removeOption(op,options) ==
+; [optEntry for (optEntry:=[opt,:.]) in options | opt ^= op]
+\end{verbatim}
+
+<<defun removeOption>>=
+(defun |removeOption| (|op| |options|)
+ (prog (|opt|)
+ (return
+ (seq
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 |options| (cdr t1)) (|optEntry| nil))
+ ((or (atom t1)
+ (progn (setq |optEntry| (car t1)) nil)
+ (progn (progn (spadlet |opt| (CAR |optEntry|)) |optEntry|) nil))
+ (nreverse0 t0))
+ (seq
+ (exit
+ (cond
+ ((nequal |opt| |op|) (setq t0 (cons |optEntry| t0)))))))))))))
+
+@
+
+\subsection{defun domainToGenvar}
+\begin{verbatim}
+;domainToGenvar x ==
+; $doNotAddEmptyModeIfTrue: local:= true
+; (y:= unabbrevAndLoad x) and GETDATABASE(opOf y,'CONSTRUCTORKIND) = 'domain
=>
+; g:= genDomainTraceName y
+; SET(g,evalDomain y)
+; g
+\end{verbatim}
+
+<<defun domainToGenvar>>=
+(defun |domainToGenvar| (|x|)
+ (prog (|$doNotAddEmptyModeIfTrue| |y| |g|)
+ (declare (special |$doNotAddEmptyModeIfTrue|))
+ (return
+ (progn
+ (spadlet |$doNotAddEmptyModeIfTrue| t)
+ (cond
+ ((and (spadlet |y| (|unabbrevAndLoad| |x|))
+ (boot-equal (getdatabase (|opOf| |y|) 'constructorkind) '|domain|))
+ (progn
+ (spadlet |g| (|genDomainTraceName| |y|))
+ (set |g| (|evalDomain| |y|)) |g|)))))))
+
+@
+
+\subsection{defun genDomainTraceName}
+\begin{verbatim}
+;genDomainTraceName y ==
+; u:= LASSOC(y,$domainTraceNameAssoc) => u
+; g:= GENVAR()
+; $domainTraceNameAssoc:= [ [y,:g],:$domainTraceNameAssoc]
+; g
+\end{verbatim}
+
+<<defun genDomainTraceName>>=
+(defun |genDomainTraceName| (y)
+ (prog (u g)
+ (return
+ (cond
+ ((spadlet u (lassoc y |$domainTraceNameAssoc|)) u)
+ (t
+ (spadlet g (genvar))
+ (spadlet |$domainTraceNameAssoc|
+ (cons (cons y g) |$domainTraceNameAssoc|))
+ g)))))
+
+@
+
+\subsection{defun untrace}
+\begin{verbatim}
+;--this is now called from trace with the )off option
+;untrace l ==
+; $lastUntraced:=
+; null l => COPY _/TRACENAMES
+; l
+; untraceList:= [transTraceItem x for x in l]
+; _/UNTRACE_,0 [lassocSub(funName,$mapSubNameAlist) for
+; funName in untraceList]
+; removeTracedMapSigs untraceList
+\end{verbatim}
+
+<<defun untrace>>=
+(defun |untrace| (|l|)
+ (prog (|untraceList|)
+ (return
+ (seq
+ (progn
+ (spadlet |$lastUntraced| (cond ((null |l|) (copy /tracenames)) (t |l|)))
+ (spadlet |untraceList|
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 |l| (cdr t1)) (|x| nil))
+ ((or (atom t1) (progn (setq |x| (car t1)) nil)) (nreverse0 t0))
+ (seq
+ (exit
+ (setq t0 (cons (|transTraceItem| |x|) t0))))))))
+ (|/UNTRACE,0|
+ (prog (t2)
+ (spadlet t2 nil)
+ (return
+ (do ((t3 |untraceList|l (cdr t3)) (|funName| nil))
+ ((or (atom t3)
+ (progn (setq |funName| (car t3)) nil))
+ (nreverse0 t2))
+ (seq
+ (exit
+ (setq t2 (cons (|lassocSub| |funName| |$mapSubNameAlist|) t2))))))))
+ (|removeTracedMapSigs| |untraceList|))))))
+
+@
+
+\subsection{defun transTraceItem}
+\begin{verbatim}
+;transTraceItem x ==
+; $doNotAddEmptyModeIfTrue: local:=true
+; atom x =>
+; (value:=get(x,"value",$InteractiveFrame)) and
+; (objMode value in '((Mode) (Domain) (SubDomain (Domain)))) =>
+; x := objVal value
+; (y:= domainToGenvar x) => y
+; x
+; UPPER_-CASE_-P (STRINGIMAGE x).(0) =>
+; y := unabbrev x
+; constructor?(y) => y
+; PAIRP(y) and constructor?(CAR y) => CAR y
+; (y:= domainToGenvar x) => y
+; x
+; x
+; VECP first x => transTraceItem devaluate first x
+; y:= domainToGenvar x => y
+; throwKeyedMsg("S2IT0018",[x])
+\end{verbatim}
+
+<<defun transTraceItem>>=
+(defun |transTraceItem| (|x|)
+ (prog (|$doNotAddEmptyModeIfTrue| |value| |y|)
+ (declare (special |$doNotAddEmptyModeIfTrue|))
+ (return
+ (progn
+ (spadlet |$doNotAddEmptyModeIfTrue| t)
+ (cond
+ ((atom |x|)
+ (cond
+ ((and (spadlet |value| (|get| |x| '|value| |$InteractiveFrame|))
+ (|member| (|objMode| |value|)
+ '((|Mode|) (|Domain|) (|SubDomain| (|Domain|)))))
+ (spadlet |x| (|objVal| |value|))
+ (cond
+ ((spadlet |y| (|domainToGenvar| |x|)) |y|)
+ (t |x|)))
+ ((upper-case-p (elt (stringimage |x|) 0))
+ (spadlet |y| (|unabbrev| |x|))
+ (cond
+ ((|constructor?| |y|) |y|)
+ ((and (pairp |y|) (|constructor?| (car |y|))) (car |y|))
+ ((spadlet |y| (|domainToGenvar| |x|)) |y|)
+ (t |x|)))
+ (t |x|)))
+ ((vecp (car |x|)) (|transTraceItem| (|devaluate| (car |x|))))
+ ((spadlet |y| (|domainToGenvar| |x|)) |y|)
+ (t (|throwKeyedMsg| 's2it0018 (cons |x| nil))))))))
+
+@
+
+\subsection{defun removeTracedMapSigs}
+\begin{verbatim}
+;removeTracedMapSigs untraceList ==
+; for name in untraceList repeat
+; REMPROP(name,$tracedMapSignatures)
+\end{verbatim}
+
+<<defun removeTracedMapSigs>>=
+(defun |removeTracedMapSigs| (|untraceList|)
+ (seq
+ (do ((t0 |untraceList| (cdr t0)) (|name| nil))
+ ((or (atom t0) (progn (setq |name| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (remprop |name| |$tracedMapSignatures|))))))
+
+@
+
+\subsection{defun coerceTraceArgs2E}
+\begin{verbatim}
+;coerceTraceArgs2E(traceName,subName,args) ==
+; MEMQ(name:= subName,$mathTraceList) =>
+; SPADSYSNAMEP PNAME name => coerceSpadArgs2E(reverse CDR reverse args)
+; [ ["=",name,objValUnwrap
coerceInteractive(objNewWrap(arg,type),$OutputForm)]
+; for name in '(arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11
arg12 arg13 arg14 arg15 arg16 arg17 arg18 arg19 )
+; for arg in args for type in CDR LASSOC(subName,
+; $tracedMapSignatures)]
+; SPADSYSNAMEP PNAME name => reverse CDR reverse args
+; args
+\end{verbatim}
+
+<<defun coerceTraceArgs2E>>=
+(defun |coerceTraceArgs2E| (|traceName| |subName| |args|)
+ (prog (|name|)
+ (return
+ (seq
+ (cond
+ ((memq (spadlet |name| |subName|) |$mathTraceList|)
+ (cond
+ ((spadsysnamep (pname |name|))
+ (|coerceSpadArgs2E| (reverse (cdr (reverse |args|)))))
+ (t
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 '(|arg1| |arg2| |arg3| |arg4| |arg5| |arg6| |arg7| |arg8|
+ |arg9| |arg10| |arg11| |arg12| |arg13| |arg14| |arg15|
+ |arg16| |arg17| |arg18| |arg19|) (cdr t1))
+ (|name| nil)
+ (t2 |args| (cdr t2))
+ (|arg| nil)
+ (t3 (cdr (lassoc |subName| |$tracedMapSignatures|)) (cdr t3))
+ (|type| nil))
+ ((or (atom t1)
+ (progn (setq |name| (car t1)) nil)
+ (atom t2)
+ (progn (setq |arg| (car t2)) nil)
+ (atom t3)
+ (progn (setq |type| (car t3)) nil))
+ (nreverse0 t0))
+ (seq
+ (exit
+ (setq t0
+ (cons
+ (cons '=
+ (cons |name|
+ (cons (|objValUnwrap|
+ (|coerceInteractive|
+ (|objNewWrap| |arg| |type|) |$OutputForm|))
+ nil)))
+ t0))))))))))
+ ((spadsysnamep (pname |name|)) (reverse (cdr (reverse |args|))))
+ (t |args|))))))
+
+@
+
+\subsection{defun coerceSpadArgs2E}
+\begin{verbatim}
+;coerceSpadArgs2E(args) ==
+; -- following binding is to prevent forcing calculation of stream elements
+; $streamCount:local := 0
+; [ ["=",name,objValUnwrap
coerceInteractive(objNewWrap(arg,type),$OutputForm)]
+; for name in '(arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11
arg12 arg13 arg14 arg15 arg16 arg17 arg18 arg19 )
+; for arg in args for type in CDR $tracedSpadModemap]
+\end{verbatim}
+
+<<defun coerceSpadArgs2E>>=
+(defun |coerceSpadArgs2E| (|args|)
+ (prog (|$streamCount|)
+ (declare (special |$streamCount|))
+ (return
+ (seq
+ (progn
+ (spadlet |$streamCount| 0)
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 '(|arg1| |arg2| |arg3| |arg4| |arg5| |arg6| |arg7| |arg8|
+ |arg9| |arg10| |arg11| |arg12| |arg13| |arg14| |arg15|
+ |arg16| |arg17| |arg18| |arg19|) (cdr t1))
+ (|name| nil)
+ (t2 |args| (cdr t2))
+ (|arg| nil)
+ (t3 (cdr |$tracedSpadModemap|) (cdr t3))
+ (|type| nil))
+ ((or (atom t1)
+ (progn (setq |name| (car t1)) nil)
+ (atom t2)
+ (progn (setq |arg| (car t2)) nil)
+ (atom t3)
+ (progn (setq |type| (car t3)) nil))
+ (nreverse0 t0))
+ (seq
+ (exit
+ (setq t0
+ (cons
+ (cons '=
+ (cons |name|
+ (cons (|objValUnwrap|
+ (|coerceInteractive|
+ (|objNewWrap| |arg| |type|)
+ |$OutputForm|)) nil)))
+ t0))))))))))))
+
+@
+
+\subsection{defun subTypes}
+\begin{verbatim}
+;subTypes(mm,sublist) ==
+; ATOM mm =>
+; (s:= LASSOC(mm,sublist)) => s
+; mm
+; [subTypes(m,sublist) for m in mm]
+\end{verbatim}
+
+<<defun subTypes>>=
+(defun |subTypes| (|mm| |sublist|)
+ (prog (|s|)
+ (return
+ (seq
+ (cond
+ ((atom |mm|)
+ (cond ((spadlet |s| (lassoc |mm| |sublist|)) |s|) (t |mm|)))
+ (t
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 |mm| (cdr t1)) (|m| nil))
+ ((or (atom t1) (progn (setq |m| (car t1)) nil)) (nreverse0 t0))
+ (seq
+ (exit
+ (setq t0 (cons (|subTypes| |m| |sublist|) t0)))))))))))))
+
+@
+
+\subsection{defun coerceTraceFunValue2E}
+\begin{verbatim}
+;coerceTraceFunValue2E(traceName,subName,value) ==
+; MEMQ(name:= subName,$mathTraceList) =>
+; SPADSYSNAMEP PNAME traceName => coerceSpadFunValue2E(value)
+; (u:=LASSOC(subName,$tracedMapSignatures)) =>
+; objValUnwrap coerceInteractive(objNewWrap(value,CAR u),$OutputForm)
+; value
+; value
+\end{verbatim}
+
+<<defun coerceTraceFunValue2E>>=
+(defun |coerceTraceFunValue2E| (|traceName| |subName| |value|)
+ (prog (|name| |u|)
+ (return
+ (cond
+ ((memq (spadlet |name| |subName|) |$mathTraceList|)
+ (cond
+ ((spadsysnamep (pname |traceName|)) (|coerceSpadFunValue2E| |value|))
+ ((spadlet |u| (lassoc |subName| |$tracedMapSignatures|))
+ (|objValUnwrap|
+ (|coerceInteractive|
+ (|objNewWrap| |value| (CAR |u|))
+ |$OutputForm|)))
+ (t |value|)))
+ (t |value|)))))
+
+@
+
+\subsection{defun coerceSpadFunValue2E}
+\begin{verbatim}
+;coerceSpadFunValue2E(value) ==
+; -- following binding is to prevent forcing calculation of stream elements
+; $streamCount:local := 0
+; objValUnwrap coerceInteractive(objNewWrap(value,CAR $tracedSpadModemap),
+; $OutputForm)
+\end{verbatim}
+
+<<defun coerceSpadFunValue2E>>=
+(defun |coerceSpadFunValue2E| (|value|)
+ (prog (|$streamCount|)
+ (declare (special |$streamCount|))
+ (return
+ (progn
+ (spadlet |$streamCount| 0)
+ (|objValUnwrap|
+ (|coerceInteractive|
+ (|objNewWrap| |value| (CAR |$tracedSpadModemap|))
+ |$OutputForm|))))))
+
+@
+
+\subsection{defun isListOfIdentifiers}
+\begin{verbatim}
+;isListOfIdentifiers l == and/[IDENTP x for x in l]
+\end{verbatim}
+
+<<defun isListOfIdentifiers>>=
+(defun |isListOfIdentifiers| (|l|)
+ (prog ()
+ (return
+ (seq
+ (prog (t0)
+ (spadlet t0 t)
+ (return
+ (do ((t1 nil (null t0)) (t2 |l| (cdr t2)) (|x| nil))
+ ((or t1 (atom t2) (progn (setq |x| (car t2)) nil)) t0)
+ (seq
+ (exit
+ (setq t0 (and t0 (identp |x|))))))))))))
+
+@
+
+\subsection{defun isListOfIdentifiersOrStrings}
+\begin{verbatim}
+;isListOfIdentifiersOrStrings l == and/[IDENTP x or STRINGP x for x in l]
+\end{verbatim}
+
+<<defun isListOfIdentifiersOrStrings>>=
+(defun |isListOfIdentifiersOrStrings| (|l|)
+ (prog ()
+ (return
+ (seq
+ (prog (t0)
+ (spadlet t0 t)
+ (return
+ (do ((t1 nil (null t0)) (t2 |l| (cdr t2)) (|x| nil))
+ ((or t1 (atom t2) (progn (setq |x| (car t2)) nil)) t0)
+ (seq
+ (exit
+ (setq t0 (and t0 (or (identp |x|) (stringp |x|)))))))))))))
+
+@
+
+\subsection{defun getMapSubNames}
+\begin{verbatim}
+;getMapSubNames(l) ==
+; subs:= nil
+; for mapName in l repeat
+; lmm:= get(mapName,'localModemap,$InteractiveFrame) =>
+; subs:= APPEND([ [mapName,:CADR mm] for mm in lmm],subs)
+; UNION(subs,getPreviousMapSubNames UNIONQ(_/TRACENAMES,
+; $lastUntraced))
+\end{verbatim}
+
+<<defun getMapSubNames>>=
+(defun |getMapSubNames| (|l|)
+ (prog (|lmm| |subs|)
+ (return
+ (seq
+ (progn
+ (spadlet |subs| nil)
+ (seq
+ (do ((t0 |l| (cdr t0)) (|mapName| nil))
+ ((or (atom t0) (progn (setq |mapName| (CAR t0)) nil)) nil)
+ (seq
+ (exit
+ (cond
+ ((spadlet |lmm|
+ (|get| |mapName| '|localModemap| |$InteractiveFrame|))
+ (exit
+ (spadlet |subs|
+ (append
+ (prog (t1)
+ (spadlet t1 nil)
+ (return
+ (do ((t2 |lmm| (cdr t2)) (|mm| nil))
+ ((or (atom t2)
+ (progn (setq |mm| (CAR t2)) nil)) (nreverse0 t1))
+ (seq
+ (exit
+ (setq t1 (cons (cons |mapName| (cadr |mm|)) t1)))))))
+ |subs|))))))))
+ (|union| |subs|
+ (|getPreviousMapSubNames| (unionq /tracenames |$lastUntraced|)))))))))
+
+@
+
+\subsection{defun getPreviousMapSubNames}
+\begin{verbatim}
+;getPreviousMapSubNames(traceNames) ==
+; subs:= nil
+; for mapName in ASSOCLEFT CAAR $InteractiveFrame repeat
+; lmm:= get(mapName,'localModemap,$InteractiveFrame) =>
+; MEMQ(CADAR lmm,traceNames) =>
+; for mm in lmm repeat
+; subs:= [ [mapName,:CADR mm],:subs]
+; subs
+\end{verbatim}
+
+<<defun getPreviousMapSubNames>>=
+(defun |getPreviousMapSubNames| (|traceNames|)
+ (prog (|lmm| |subs|)
+ (return
+ (seq
+ (progn
+ (spadlet |subs| nil)
+ (seq
+ (do ((t0 (assocleft (caar |$InteractiveFrame|)) (cdr t0))
+ (|mapName| nil))
+ ((or (atom t0) (progn (setq |mapName| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (cond
+ ((spadlet |lmm|
+ (|get| |mapName| '|localModemap| |$InteractiveFrame|))
+ (exit
+ (cond
+ ((memq (cadar |lmm|) |traceNames|)
+ (exit
+ (do ((t1 |lmm| (cdr t1)) (|mm| nil))
+ ((or (atom t1) (progn (setq |mm| (car t1)) nil)) nil)
+ (seq
+ (exit
+ (spadlet |subs|
+ (cons (cons |mapName| (cadr |mm|)) |subs|))))))))))))))
+ (exit |subs|)))))))
+
+@
+
+\subsection{defun lassocSub}
+\begin{verbatim}
+;lassocSub(x,subs) ==
+; y:= LASSQ(x,subs) => y
+; x
+\end{verbatim}
+
+<<defun lassocSub>>=
+(defun |lassocSub| (|x| |subs|)
+ (prog (|y|)
+ (return
+ (cond
+ ((spadlet |y| (lassq |x| |subs|)) |y|)
+ (t |x|)))))
+
+@
+
+\subsection{defun rassocSub}
+\begin{verbatim}
+;rassocSub(x,subs) ==
+; y:= RASSOC(x,subs) => y
+; x
+\end{verbatim}
+
+<<defun rassocSub>>=
+(defun |rassocSub| (|x| |subs|)
+ (prog (|y|)
+ (return
+ (cond
+ ((spadlet |y| (|rassoc| |x| |subs|)) |y|)
+ (t |x|)))))
+
+@
+
+\subsection{defun isUncompiledMap}
+\begin{verbatim}
+;isUncompiledMap(x) ==
+; y:= get(x,'value,$InteractiveFrame) =>
+; (CAAR y) = 'MAP and null get(x,'localModemap,$InteractiveFrame)
+\end{verbatim}
+
+<<defun isUncompiledMap>>=
+(defun |isUncompiledMap| (x)
+ (prog (y)
+ (return
+ (seq
+ (cond
+ ((spadlet y (|get| x '|value| |$InteractiveFrame|))
+ (exit
+ (and
+ (boot-equal (caar y) 'map)
+ (null (|get| x '|localModemap| |$InteractiveFrame|))))))))))
+
+@
+
+\subsection{defun isInterpOnlyMap}
+\begin{verbatim}
+;isInterpOnlyMap(map) ==
+; x:= get(map,'localModemap,$InteractiveFrame) =>
+; (CAAAR x) = 'interpOnly
+\end{verbatim}
+
+<<defun isInterpOnlyMap>>=
+(defun |isInterpOnlyMap| (map)
+ (prog (x)
+ (return
+ (seq
+ (cond
+ ((spadlet x (|get| map '|localModemap| |$InteractiveFrame|))
+ (exit
+ (boot-equal (caaar x) '|interpOnly|))))))))
+
+@
+
+\subsection{defun augmentTraceNames}
+\begin{verbatim}
+;augmentTraceNames(l,mapSubNames) ==
+; res:= nil
+; for traceName in l repeat
+; mml:= get(traceName,'localModemap,$InteractiveFrame) =>
+; res:= APPEND([CADR mm for mm in mml],res)
+; res:= [traceName,:res]
+; res
+\end{verbatim}
+
+<<defun augmentTraceNames>>=
+(defun |augmentTraceNames| (|l| |mapSubNames|)
+ (prog (|mml| |res|)
+ (return
+ (seq
+ (progn
+ (spadlet |res| nil)
+ (do ((t0 |l| (cdr t0)) (|traceName| nil))
+ ((or (atom t0) (progn (setq |traceName| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (cond
+ ((spadlet |mml|
+ (|get| |traceName| '|localModemap| |$InteractiveFrame|))
+ (spadlet |res|
+ (append
+ (prog (t1)
+ (spadlet t1 nil)
+ (return
+ (do ((t2 |mml| (cdr t2)) (|mm| nil))
+ ((or (atom t2)
+ (progn (setq |mm| (CAR t2)) nil))
+ (nreverse0 t1))
+ (seq
+ (exit
+ (setq t1 (cons (cadr |mm|) t1)))))))
+ |res|)))
+ (t (spadlet |res| (cons |traceName| |res|)))))))
+ |res|)))))
+@
+
+\subsection{defun isSubForRedundantMapName}
+\begin{verbatim}
+;isSubForRedundantMapName(subName) ==
+; mapName:= rassocSub(subName,$mapSubNameAlist) =>
+; tail:=MEMBER([mapName,:subName],$mapSubNameAlist) =>
+; MEMQ(mapName,CDR ASSOCLEFT tail)
+\end{verbatim}
+
+<<defun isSubForRedundantMapName>>=
+(defun |isSubForRedundantMapName| (|subName|)
+ (prog (|mapName| |tail|)
+ (return
+ (seq
+ (cond
+ ((spadlet |mapName| (|rassocSub| |subName| |$mapSubNameAlist|))
+ (exit
+ (cond
+ ((spadlet |tail|
+ (|member| (cons |mapName| |subName|) |$mapSubNameAlist|))
+ (exit
+ (memq |mapName| (cdr (assocleft |tail|)))))))))))))
+
+@
+
+\subsection{defun untraceMapSubNames}
+\begin{verbatim}
+;untraceMapSubNames traceNames ==
+; null($mapSubNameAlist:local:= getPreviousMapSubNames traceNames) => nil
+; for name in (subs:= ASSOCRIGHT $mapSubNameAlist)
+; | MEMQ(name,_/TRACENAMES) repeat
+; _/UNTRACE_,2(name,nil)
+; $lastUntraced:= SETDIFFERENCE($lastUntraced,subs)
+\end{verbatim}
+
+<<defun untraceMapSubNames>>=
+(defun |untraceMapSubNames| (|traceNames|)
+ (prog (|$mapSubNameAlist| |subs|)
+ (declare (special |$mapSubNameAlist|))
+ (return
+ (seq
+ (cond
+ ((null
+ (spadlet |$mapSubNameAlist| (|getPreviousMapSubNames| |traceNames|)))
+ nil)
+ (t
+ (do ((t0 (spadlet |subs| (assocright |$mapSubNameAlist|)) (CDR t0))
+ (|name| nil))
+ ((or (atom t0) (progn (setq |name| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (cond
+ ((memq |name| /tracenames)
+ (progn
+ (|/UNTRACE,2| |name| nil)
+ (spadlet |$lastUntraced|
+ (setdifference |$lastUntraced| |subs|))))))))))))))
+
+@
+
+\subsection{defmacro funfind}
+\begin{verbatim}
+;funfind("functor","opname") ==
+; ops:= isFunctor functor
+; [u for u in ops | u is [[ =opname,:.],:.]]
+\end{verbatim}
+
+<<defun funfind,LAM>>=
+(defun |funfind,LAM| (functor opname)
+ (prog (ops tmp1)
+ (return
+ (seq
+ (progn
+ (spadlet ops (|isFunctor| functor))
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 ops (cdr t1)) (|u| nil))
+ ((or (atom t1) (progn (setq |u| (car t1)) nil)) (nreverse0 t0))
+ (seq
+ (exit
+ (cond
+ ((and (pairp |u|)
+ (progn
+ (spadlet tmp1 (qcar |u|))
+ (and (pairp tmp1) (equal (qcar tmp1) opname))))
+ (setq t0 (cons |u| t0))))))))))))))
+
+@
+
+<<defmacro funfind>>=
+(defmacro |funfind| (&whole t0 &rest notused &aux t1)
+ (dsetq t1 t0)
+ (cons '|funfind,LAM| (vmlisp::wrap (cdr t1) '(quote quote))))
+
+@
+
+\subsection{defun isDomainOrPackage}
+\begin{verbatim}
+;isDomainOrPackage dom ==
+; REFVECP dom and #dom>0 and isFunctor opOf dom.(0)
+\end{verbatim}
+
+<<defun isDomainOrPackage>>=
+(defun |isDomainOrPackage| (dom)
+ (and
+ (refvecp dom)
+ (> (|#| dom) 0)
+ (|isFunctor| (|opOf| (elt dom 0)))))
+
+@
+
+\subsection{defun isTraceGensym}
+<<defun isTraceGensym>>=
+(defun |isTraceGensym| (x)
+ (gensymp x))
+
+@
+
+\subsection{defun spadTrace}
+\begin{verbatim}
+;spadTrace(domain,options) ==
+; $fromSpadTrace:= true
+; $tracedModemap:local:= nil
+; PAIRP domain and REFVECP CAR domain and (CAR domain).0 = 0 =>
+; aldorTrace(domain,options)
+; not isDomainOrPackage domain => userError '"bad argument to trace"
+; listOfOperations:=
+; [g x for x in getOption("OPS",options)] where
+; g x ==
+; STRINGP x => INTERN x
+; x
+; if listOfVariables := getOption("VARS",options) then
+; options := removeOption("VARS",options)
+; if listOfBreakVars := getOption("VARBREAK",options) then
+; options := removeOption("VARBREAK",options)
+; anyifTrue:= null listOfOperations
+; domainId:= opOf domain.(0)
+; currentEntry:= ASSOC(domain,_/TRACENAMES)
+; currentAlist:= KDR currentEntry
+; opStructureList:= flattenOperationAlist getOperationAlistFromLisplib
domainId
+; sigSlotNumberAlist:=
+; [triple
+; --new form is (<op> <signature> <slotNumber> <condition> <kind>)
+; for [op,sig,n,.,kind] in opStructureList | kind = 'ELT
+; and (anyifTrue or MEMQ(op,listOfOperations)) and
+; FIXP n and
+; isTraceable(triple:= [op,sig,n],domain)] where
+; isTraceable(x is [.,.,n,:.],domain) ==
+; atom domain.n => nil
+; functionSlot:= first domain.n
+; GENSYMP functionSlot =>
+; (reportSpadTrace("Already Traced",x); nil)
+; null (BPINAME functionSlot) =>
+; (reportSpadTrace("No function for",x); nil)
+; true
+; if listOfVariables then
+; for [.,.,n] in sigSlotNumberAlist repeat
+; fn := first domain.n
+; $letAssoc := AS_-INSERT(BPINAME fn,
+; listOfVariables,$letAssoc)
+; if listOfBreakVars then
+; for [.,.,n] in sigSlotNumberAlist repeat
+; fn := first domain.n
+; $letAssoc := AS_-INSERT(BPINAME fn,
+; [["BREAK",:listOfBreakVars]],$letAssoc)
+; for (pair:= [op,mm,n]) in sigSlotNumberAlist repeat
+; alias:= spadTraceAlias(domainId,op,n)
+; $tracedModemap:= subTypes(mm,constructSubst(domain.0))
+; traceName:= BPITRACE(first domain.n,alias, options)
+; NCONC(pair,[listOfVariables,first domain.n,traceName,alias])
+; RPLAC(first domain.n,traceName)
+; sigSlotNumberAlist:= [x for x in sigSlotNumberAlist | CDDDR x]
+; if $reportSpadTrace then
+; if $traceNoisely then printDashedLine()
+; for x in orderBySlotNumber sigSlotNumberAlist repeat
+; reportSpadTrace("TRACING",x)
+; if $letAssoc then SETLETPRINTFLAG true
+; currentEntry =>
+; RPLAC(rest currentEntry,[:sigSlotNumberAlist,:currentAlist])
+; SETQ(_/TRACENAMES,[ [domain,:sigSlotNumberAlist],:_/TRACENAMES])
+; spadReply()
+\end{verbatim}
+
+<<defun spadTrace,g>>=
+(defun |spadTrace,g| (|x|)
+ (seq
+ (if (stringp |x|) (exit (intern |x|)))
+ (exit |x|)))
+
+@
+
+<<defun spadTrace,isTraceable>>=
+(defun |spadTrace,isTraceable| (|x| |domain|)
+ (prog (|n| |functionSlot|)
+ (return
+ (seq
+ (progn
+ (spadlet |n| (caddr |x|))
+ |x|
+ (seq
+ (if (atom (elt |domain| |n|)) (exit nil))
+ (spadlet |functionSlot| (car (elt |domain| |n|)))
+ (if (gensymp |functionSlot|)
+ (exit (seq (|reportSpadTrace| '|Already Traced| |x|) (exit nil))))
+ (if (null (bpiname |functionSlot|))
+ (exit
+ (seq
+ (|reportSpadTrace| '|No function for| |x|)
+ (exit nil))))
+ (exit t)))))))
+
+@
+
+<<defun spadTrace>>=
+(defun |spadTrace| (|domain| |options|)
+ (prog (|$tracedModemap| |listOfOperations| |listOfVariables|
+ |listOfBreakVars| |anyifTrue| |domainId| |currentEntry|
+ |currentAlist| |opStructureList| |sig| |kind| |triple| |fn| |op|
+ |mm| |n| |alias| |traceName| |sigSlotNumberAlist|)
+ (declare (special |$tracedModemap|))
+ (return
+ (seq
+ (progn
+ (spadlet |$fromSpadTrace| t)
+ (spadlet |$tracedModemap| nil)
+ (cond
+ ((and (pairp |domain|)
+ (refvecp (car |domain|))
+ (eql (elt (car |domain|) 0) 0))
+ (|aldorTrace| |domain| |options|))
+ ((null (|isDomainOrPackage| |domain|))
+ (|userError| "bad argument to trace"))
+ (t
+ (spadlet |listOfOperations|
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 (|getOption| 'ops |options|) (cdr t1)) (|x| nil))
+ ((or (atom t1) (progn (setq |x| (car t1)) nil)) (nreverse0 t0))
+ (seq
+ (exit
+ (setq t0 (cons (|spadTrace,g| |x|) t0))))))))
+ (cond
+ ((spadlet |listOfVariables| (|getOption| 'vars |options|))
+ (spadlet |options| (|removeOption| 'vars |options|))))
+ (cond
+ ((spadlet |listOfBreakVars| (|getOption| 'varbreak |options|))
+ (spadlet |options| (|removeOption| 'varbreak |options|))))
+ (spadlet |anyifTrue| (null |listOfOperations|))
+ (spadlet |domainId| (|opOf| (elt |domain| 0)))
+ (spadlet |currentEntry| (|assoc| |domain| /tracenames))
+ (spadlet |currentAlist| (kdr |currentEntry|))
+ (spadlet |opStructureList|
+ (|flattenOperationAlist| (|getOperationAlistFromLisplib| |domainId|)))
+ (spadlet |sigSlotNumberAlist|
+ (prog (t2)
+ (spadlet t2 nil)
+ (return
+ (do ((t3 |opStructureList| (cdr t3)) (t4 nil))
+ ((or (atom t3)
+ (progn (setq t4 (CAR t3)) nil)
+ (progn
+ (progn
+ (spadlet |op| (car t4))
+ (spadlet |sig| (cadr t4))
+ (spadlet |n| (caddr t4))
+ (spadlet |kind| (car (cddddr t4))) t4)
+ nil))
+ (nreverse0 t2))
+ (seq
+ (exit
+ (cond
+ ((and (boot-equal |kind| 'ELT)
+ (or |anyifTrue| (memq |op| |listOfOperations|))
+ (fixp |n|)
+ (|spadTrace,isTraceable|
+ (spadlet |triple|
+ (cons |op| (cons |sig| (cons |n| nil)))) |domain|))
+ (setq t2 (cons |triple| t2))))))))))
+ (cond
+ (|listOfVariables|
+ (do ((t5 |sigSlotNumberAlist| (cdr t5)) (t6 nil))
+ ((or (atom t5)
+ (progn (setq t6 (car t5)) nil)
+ (progn (progn (spadlet |n| (caddr t6)) t6) nil))
+ nil)
+ (seq
+ (exit
+ (progn
+ (spadlet |fn| (car (elt |domain| |n|)))
+ (spadlet |$letAssoc|
+ (as-insert (bpiname |fn|) |listOfVariables| |$letAssoc|))))))))
+ (cond
+ (|listOfBreakVars|
+ (do ((t7 |sigSlotNumberAlist| (cdr t7)) (t8 nil))
+ ((or (atom t7)
+ (progn (setq t8 (car t7)) nil)
+ (progn (progn (spadlet |n| (caddr t8)) t8) nil))
+ nil)
+ (seq
+ (exit
+ (progn
+ (spadlet |fn| (car (elt |domain| |n|)))
+ (spadlet |$letAssoc|
+ (as-insert (bpiname |fn|)
+ (cons (cons 'break |listOfBreakVars|) nil) |$letAssoc|))))))))
+ (do ((t9 |sigSlotNumberAlist| (cdr t9)) (|pair| nil))
+ ((or (atom t9)
+ (progn (setq |pair| (car t9)) nil)
+ (progn
+ (progn
+ (spadlet |op| (car |pair|))
+ (spadlet |mm| (cadr |pair|))
+ (spadlet |n| (caddr |pair|))
+ |pair|)
+ nil))
+ nil)
+ (seq
+ (exit
+ (progn
+ (spadlet |alias| (|spadTraceAlias| |domainId| |op| |n|))
+ (spadlet |$tracedModemap|
+ (|subTypes| |mm| (|constructSubst| (elt |domain| 0))))
+ (spadlet |traceName|
+ (bpitrace (car (elt |domain| |n|)) |alias| |options|))
+ (nconc |pair|
+ (cons |listOfVariables|
+ (cons (car (elt |domain| |n|))
+ (cons |traceName| (cons |alias| nil)))))
+ (rplac (car (elt |domain| |n|)) |traceName|)))))
+ (spadlet |sigSlotNumberAlist|
+ (prog (t10)
+ (spadlet t10 nil)
+ (return
+ (do ((t11 |sigSlotNumberAlist| (cdr t11)) (|x| nil))
+ ((or (atom t11) (progn (setq |x| (car t11)) nil)) (nreverse0 t10))
+ (seq
+ (exit
+ (cond ((cdddr |x|) (setq t10 (cons |x| t10))))))))))
+ (cond
+ (|$reportSpadTrace|
+ (cond (|$traceNoisely| (|printDashedLine|)))
+ (do ((t12 (|orderBySlotNumber| |sigSlotNumberAlist|) (cdr t12))
+ (|x| nil))
+ ((or (atom t12)
+ (progn (setq |x| (car t12)) nil))
+ nil)
+ (seq (exit (|reportSpadTrace| 'tracing |x|))))))
+ (cond (|$letAssoc| (setletprintflag t)))
+ (cond
+ (|currentEntry|
+ (rplac (cdr |currentEntry|)
+ (append |sigSlotNumberAlist| |currentAlist|)))
+ (t
+ (setq /tracenames
+ (cons (cons |domain| |sigSlotNumberAlist|) /tracenames))
+ (|spadReply|))))))))))
+
+@
+
+\subsection{defun traceDomainLocalOps}
+\begin{verbatim}
+;traceDomainLocalOps(dom,lops,options) ==
+; sayMSG ['" ",'"The )local option has been withdrawn"]
+; sayMSG ['" ",'"Use )ltr to trace local functions."]
+; NIL
+\end{verbatim}
+
+<<defun traceDomainLocalOps>>=
+(defun |traceDomainLocalOps| (|dom| |lops| |options|)
+ (progn
+ (|sayMSG| (cons " " (cons "The )local option has been withdrawn" nil)))
+ (|sayMSG| (cons " " (cons "Use )ltr to trace local functions." nil)))
+ nil))
+
+@
+
+\subsection{defun untraceDomainLocalOps}
+\begin{verbatim}
+;-- abb := abbreviate dom
+;-- loadLibIfNotLoaded abb
+;-- actualLops := getLocalOpsFromLisplib abb
+;-- null actualLops =>
+;-- sayMSG ['" ",:bright abb,'"has no local functions to trace."]
+;-- lops = 'all => _/TRACE_,1(actualLops,options)
+;-- l := NIL
+;-- for lop in lops repeat
+;-- internalName := INTERN STRCONC(PNAME abb,'";",PNAME lop)
+;-- not MEMQ(internalName,actualLops) =>
+;-- sayMSG ['" ",:bright abb,'"does not have a local",
+;-- '" function called",:bright lop]
+;-- l := cons(internalName,l)
+;-- l => _/TRACE_,1(l,options)
+;-- nil
+;untraceDomainLocalOps(dom,lops) ==
+; sayMSG ['" ",:bright abb,'"has no local functions to untrace."]
+; NIL
+\end{verbatim}
+
+<<defun untraceDomainLocalOps>>=
+(defun |untraceDomainLocalOps| (|dom| |lops|)
+ (progn
+ (|sayMSG|
+ (cons " "
+ (append (|bright| |abb|) (cons "has no local functions to untrace." nil))))
+ nil))
+
+@
+
+\subsection{defun untraceAllDomainLocalOps}
+\begin{verbatim}
+;-- lops = "all" => untraceAllDomainLocalOps(dom)
+;-- abb := abbreviate dom
+;-- loadLibIfNotLoaded abb
+;-- actualLops := getLocalOpsFromLisplib abb
+;-- null actualLops =>
+;-- sayMSG ['" ",:bright abb,'"has no local functions to untrace."]
+;-- l := NIL
+;-- for lop in lops repeat
+;-- internalName := INTERN STRCONC(PNAME abb,'";",PNAME lop)
+;-- not MEMQ(internalName,actualLops) =>
+;-- sayMSG ['" ",:bright abb,'"does not have a local",
+;-- '" function called",:bright lop]
+;-- l := cons(internalName,l)
+;-- l => untrace l
+;-- nil
+;untraceAllDomainLocalOps(dom) == NIL
+\end{verbatim}
+
+<<defun untraceAllDomainLocalOps>>=
+(defun |untraceAllDomainLocalOps| (|dom|) nil)
+
+@
+
+\subsection{defun traceDomainConstructor}
+\begin{verbatim}
+;-- abb := abbreviate dom
+;-- actualLops := getLocalOpsFromLisplib abb
+;-- null (l := INTERSECTION(actualLops,_/TRACENAMES)) => NIL
+;-- _/UNTRACE_,1(l,NIL)
+;-- NIL
+;traceDomainConstructor(domainConstructor,options) ==
+; -- Trace all domains built with the given domain constructor,
+; -- including all presently instantiated domains, and all future
+; -- instantiations, while domain constructor is traced.
+; loadFunctor domainConstructor
+; listOfLocalOps := getOption("LOCAL",options)
+; if listOfLocalOps then
+; traceDomainLocalOps(domainConstructor,listOfLocalOps,
+; [opt for opt in options | opt isnt ['LOCAL,:.]])
+; listOfLocalOps and not getOption("OPS",options) => NIL
+; for [argl,.,:domain] in HGET($ConstructorCache,domainConstructor)
+; repeat spadTrace(domain,options)
+; SETQ(_/TRACENAMES,[domainConstructor,:_/TRACENAMES])
+; innerDomainConstructor := INTERN STRCONC(domainConstructor,'";")
+; if FBOUNDP innerDomainConstructor then domainConstructor :=
innerDomainConstructor
+; EMBED(domainConstructor,
+; ['LAMBDA, ['_&REST, 'args],
+; ['PROG, ['domain],
+; ['SETQ,'domain,['APPLY,domainConstructor,'args]],
+; ['spadTrace,'domain,MKQ options],
+; ['RETURN,'domain]]] )
+\end{verbatim}
+
+<<defun traceDomainConstructor>>=
+(defun |traceDomainConstructor| (|domainConstructor| |options|)
+ (prog (|listOfLocalOps| |argl| |domain| |innerDomainConstructor|)
+ (return
+ (seq
+ (progn
+ (|loadFunctor| |domainConstructor|)
+ (spadlet |listOfLocalOps| (|getOption| 'local |options|))
+ (cond
+ (|listOfLocalOps|
+ (|traceDomainLocalOps| |domainConstructor| |listOfLocalOps|
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 |options| (cdr t1)) (|opt| nil))
+ ((or (atom t1) (progn (setq |opt| (car t1)) nil)) (nreverse0 t0))
+ (seq
+ (exit
+ (cond
+ ((null (and (pairp |opt|) (eq (qcar |opt|) 'local)))
+ (setq t0 (cons |opt| t0))))))))))))
+ (cond
+ ((and |listOfLocalOps| (null (|getOption| 'ops |options|))) nil)
+ (t
+ (do ((t2 (hget |$ConstructorCache| |domainConstructor|) (cdr t2))
+ (t3 nil))
+ ((or (atom t2)
+ (progn (setq t3 (car t2)) nil)
+ (progn
+ (progn
+ (spadlet |argl| (car t3))
+ (spadlet |domain| (cddr t3)) t3)
+ nil))
+ nil)
+ (seq
+ (exit
+ (|spadTrace| |domain| |options|))))
+ (setq /tracenames (cons |domainConstructor| /tracenames))
+ (spadlet |innerDomainConstructor|
+ (intern (strconc |domainConstructor| ";")))
+ (cond
+ ((fboundp |innerDomainConstructor|)
+ (spadlet |domainConstructor| |innerDomainConstructor|)))
+ (embed |domainConstructor|
+ (cons 'lambda
+ (cons
+ (cons '&rest
+ (cons '|args| nil))
+ (cons
+ (cons 'prog
+ (cons
+ (cons '|domain| nil)
+ (cons
+ (cons 'setq
+ (cons '|domain|
+ (cons
+ (cons 'apply (cons |domainConstructor|
+ (cons '|args| nil))) nil)))
+ (cons
+ (cons '|spadTrace|
+ (cons '|domain|
+ (cons (mkq |options|) nil)))
+ (cons (cons 'return (cons '|domain| nil)) nil)))))
+ nil)))))))))))
+
+@
+
+\subsection{defun untraceDomainConstructor}
+\begin{verbatim}
+;untraceDomainConstructor domainConstructor ==
+; --untrace all the domains in domainConstructor, and unembed it
+; SETQ(_/TRACENAMES,
+; [df for df in _/TRACENAMES | keepTraced?(df, domainConstructor)]) where
+; keepTraced?(df, domainConstructor) ==
+; (df is [dc,:.]) and (isDomainOrPackage dc) and
+; ((KAR devaluate dc) = domainConstructor) =>
+; _/UNTRACE_,0 [dc]
+; false
+; true
+; untraceAllDomainLocalOps domainConstructor
+; innerDomainConstructor := INTERN STRCONC(domainConstructor,'";")
+; if FBOUNDP innerDomainConstructor then UNEMBED innerDomainConstructor
+; else UNEMBED domainConstructor
+; SETQ(_/TRACENAMES,DELETE(domainConstructor,_/TRACENAMES))
+\end{verbatim}
+
+<<defun untraceDomainConstructor,keepTraced?>>=
+(defun |untraceDomainConstructor,keepTraced?| (|df| |domainConstructor|)
+ (prog (|dc|)
+ (return
+ (seq
+ (if (and
+ (and
+ (and (pairp |df|) (progn (spadlet |dc| (qcar |df|)) t))
+ (|isDomainOrPackage| |dc|))
+ (boot-equal (kar (|devaluate| |dc|)) |domainConstructor|))
+ (exit (seq (|/UNTRACE,0| (cons |dc| nil)) (exit nil))))
+ (exit t)))))
+
+@
+
+<<defun untraceDomainConstructor>>=
+(defun |untraceDomainConstructor| (|domainConstructor|)
+ (prog (|innerDomainConstructor|)
+ (return
+ (seq
+ (progn
+ (setq /tracenames
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 /tracenames (cdr t1)) (|df| nil))
+ ((or (atom t1) (progn (setq |df| (car t1)) nil)) (nreverse0 t0))
+ (seq
+ (exit
+ (cond ((|untraceDomainConstructor,keepTraced?|
+ |df| |domainConstructor|)
+ (setq t0 (cons |df| t0))))))))))
+ (|untraceAllDomainLocalOps| |domainConstructor|)
+ (spadlet |innerDomainConstructor|
+ (intern (strconc |domainConstructor| ";")))
+ (cond
+ ((fboundp |innerDomainConstructor|) (unembed |innerDomainConstructor|))
+ (t (unembed |domainConstructor|)))
+ (setq /tracenames (|delete| |domainConstructor| /tracenames)))))))
+
+@
+
+\subsection{defun flattenOperationAlist}
+\begin{verbatim}
+;flattenOperationAlist(opAlist) ==
+; res:= nil
+; for [op,:mmList] in opAlist repeat
+; res:=[:res,:[[op,:mm] for mm in mmList]]
+; res
+\end{verbatim}
+
+<<defun flattenOperationAlist>>=
+(defun |flattenOperationAlist| (|opAlist|)
+ (prog (|op| |mmList| |res|)
+ (return
+ (seq
+ (progn
+ (spadlet |res| nil)
+ (do ((t0 |opAlist| (cdr t0)) (t1 nil))
+ ((or (atom t0)
+ (progn (setq t1 (car t0)) nil)
+ (progn
+ (progn (spadlet |op| (car t1)) (spadlet |mmList| (cdr t1)) t1)
+ nil))
+ nil)
+ (seq
+ (exit
+ (spadlet |res|
+ (append |res|
+ (prog (t2)
+ (spadlet t2 nil)
+ (return
+ (do ((t3 |mmList| (cdr t3)) (|mm| nil))
+ ((or (atom t3)
+ (progn (setq |mm| (car t3)) nil)) (nreverse0 t2))
+ (seq
+ (exit
+ (setq t2 (cons (cons |op| |mm|) t2))))))))))))
+ |res|)))))
+
+@
+
+\subsection{defun mapLetPrint}
+\begin{verbatim}
+;mapLetPrint(x,val,currentFunction) ==
+; x:= getAliasIfTracedMapParameter(x,currentFunction)
+; currentFunction:= getBpiNameIfTracedMap currentFunction
+; letPrint(x,val,currentFunction)
+\end{verbatim}
+
+<<defun mapLetPrint>>=
+(defun |mapLetPrint| (x val currentFunction)
+ (spadlet x (|getAliasIfTracedMapParameter| x currentFunction))
+ (spadlet currentFunction (|getBpiNameIfTracedMap| currentFunction))
+ (|letPrint| x val currentFunction))
+
+@
+
+\subsection{defun letPrint}
+\begin{verbatim}
+;-- This is the version for use when we have no idea
+;-- what print representation to use for the data object
+;letPrint(x,val,currentFunction) ==
+; if $letAssoc and
+; ((y:= LASSOC(currentFunction,$letAssoc)) or (y:=
LASSOC("all",$letAssoc))) then
+; if (y="all" or MEMQ(x,y)) and
+; not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then
+; sayBrightlyNT [:bright x,": "]
+; PRIN0 shortenForPrinting val
+; TERPRI()
+; if (y:= hasPair("BREAK",y)) and
+; (y="all" or MEMQ(x,y) and
+; (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then
+; break [:bright currentFunction,'"breaks after",:bright x,'":= ",
+; shortenForPrinting val]
+; val
+\end{verbatim}
+
+<<defun letPrint>>=
+(defun |letPrint| (|x| |val| |currentFunction|)
+ (prog (|y|)
+ (return
+ (progn
+ (cond ((and |$letAssoc|
+ (or
+ (spadlet |y| (lassoc |currentFunction| |$letAssoc|))
+ (spadlet |y| (lassoc '|all| |$letAssoc|))))
+ (cond
+ ((and (or (boot-equal |y| '|all|)
+ (memq |x| |y|))
+ (null
+ (or (is_genvar |x|) (|isSharpVarWithNum| |x|) (gensymp |x|))))
+ (|sayBrightlyNT| (append (|bright| |x|) (cons '|: | nil)))
+ (prin0 (|shortenForPrinting| |val|))
+ (terpri)))
+ (cond
+ ((and (spadlet |y| (|hasPair| 'break |y|))
+ (or (boot-equal |y| '|all|)
+ (and (memq |x| |y|)
+ (null (memq (elt (pname |x|) 0) '($ |#|)))
+ (null (gensymp |x|)))))
+ (|break|
+ (append
+ (|bright| |currentFunction|)
+ (cons "breaks after"
+ (append
+ (|bright| |x|)
+ (cons ":= " (cons (|shortenForPrinting| |val|) nil)))))))
+ (t nil))))
+ |val|))))
+
+@
+
+\subsection{defun letPrint2}
+\begin{verbatim}
+;-- This is the version for use when we have already
+;-- converted the data into type "Expression"
+;letPrint2(x,printform,currentFunction) ==
+; $BreakMode:local := nil
+; if $letAssoc and
+; ((y:= LASSOC(currentFunction,$letAssoc)) or (y:=
LASSOC("all",$letAssoc))) then
+; if (y="all" or MEMQ(x,y)) and
+; not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then
+; $BreakMode:='letPrint2
+; flag:=nil
+; CATCH('letPrint2,mathprint ["=",x,printform],flag)
+; if flag='letPrint2 then print printform
+; if (y:= hasPair("BREAK",y)) and
+; (y="all" or MEMQ(x,y) and
+; (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then
+; break [:bright currentFunction,'"breaks after",:bright x,":= ",
+; printform]
+; x
+\end{verbatim}
+
+<<defun letPrint2>>=
+(defun |letPrint2| (|x| |printform| |currentFunction|)
+ (prog (|$BreakMode| |flag| |y|)
+ (declare (special |$BreakMode|))
+ (return
+ (progn
+ (spadlet |$BreakMode| nil)
+ (cond
+ ((and |$letAssoc|
+ (or (spadlet |y| (lassoc |currentFunction| |$letAssoc|))
+ (spadlet |y| (lassoc '|all| |$letAssoc|))))
+ (cond
+ ((and
+ (or (boot-equal |y| '|all|) (memq |x| |y|))
+ (null (or (is_genvar |x|) (|isSharpVarWithNum| |x|) (gensymp |x|))))
+ (spadlet |$BreakMode| '|letPrint2|)
+ (spadlet |flag| nil)
+ (catch '|letPrint2|
+ (|mathprint| (cons '= (cons |x| (cons |printform| nil)))) |flag|)
+ (cond
+ ((boot-equal |flag| '|letPrint2|) (|print| |printform|))
+ (t nil))))
+ (cond
+ ((and
+ (spadlet |y| (|hasPair| 'break |y|))
+ (or (boot-equal |y| '|all|)
+ (and
+ (memq |x| |y|)
+ (null (memq (elt (pname |x|) 0) '($ |#|)))
+ (null (gensymp |x|)))))
+ (|break|
+ (append
+ (|bright| |currentFunction|)
+ (cons "breaks after"
+ (append (|bright| |x|) (cons '|:= | (cons |printform| nil)))))))
+ (t nil))))
+ |x|))))
+
+@
+
+\subsection{defun letPrint3}
+\begin{verbatim}
+;-- This is the version for use when we have our hands on a function
+;-- to convert the data into type "Expression"
+;letPrint3(x,xval,printfn,currentFunction) ==
+; $BreakMode:local := nil
+; if $letAssoc and
+; ((y:= LASSOC(currentFunction,$letAssoc)) or (y:=
LASSOC("all",$letAssoc))) then
+; if (y="all" or MEMQ(x,y)) and
+; not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then
+; $BreakMode:='letPrint2
+; flag:=nil
+; CATCH('letPrint2,mathprint ["=",x,SPADCALL(xval,printfn)],flag)
+; if flag='letPrint2 then print xval
+; if (y:= hasPair("BREAK",y)) and
+; (y="all" or MEMQ(x,y) and
+; (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then
+; break [:bright currentFunction,'"breaks after",:bright x,'":= ",
+; xval]
+; x
+\end{verbatim}
+
+<<defun letPrint3>>=
+(defun |letPrint3| (|x| |xval| |printfn| |currentFunction|)
+ (prog (|$BreakMode| |flag| |y|)
+ (declare (special |$BreakMode|))
+ (return
+ (progn
+ (spadlet |$BreakMode| nil)
+ (cond
+ ((and |$letAssoc|
+ (or (spadlet |y| (lassoc |currentFunction| |$letAssoc|))
+ (spadlet |y| (lassoc '|all| |$letAssoc|))))
+ (cond
+ ((and
+ (or (boot-equal |y| '|all|) (memq |x| |y|))
+ (null (or (is_genvar |x|) (|isSharpVarWithNum| |x|) (gensymp |x|))))
+ (spadlet |$BreakMode| '|letPrint2|)
+ (spadlet |flag| nil)
+ (catch '|letPrint2|
+ (|mathprint|
+ (cons '= (cons |x| (cons (spadcall |xval| |printfn|) nil))))
+ |flag|)
+ (cond
+ ((boot-equal |flag| '|letPrint2|) (|print| |xval|))
+ (t nil))))
+ (cond
+ ((and
+ (spadlet |y| (|hasPair| 'break |y|))
+ (or
+ (boot-equal |y| '|all|)
+ (and
+ (memq |x| |y|)
+ (null (memq (elt (pname |x|) 0) '($ |#|)))
+ (null (gensymp |x|)))))
+ (|break|
+ (append
+ (|bright| |currentFunction|)
+ (cons "breaks after"
+ (append (|bright| |x|) (cons ":= " (cons |xval| nil)))))))
+ (t nil))))
+ |x|))))
+
+@
+\subsection{defun getAliasIfTracedMapParameter}
+\begin{verbatim}
+;getAliasIfTracedMapParameter(x,currentFunction) ==
+; isSharpVarWithNum x =>
+; aliasList:= get(currentFunction,'alias,$InteractiveFrame) =>
+; aliasList.(STRING2PINT_-N(SUBSTRING(PNAME x,1,NIL),1)-1)
+; x
+\end{verbatim}
+
+<<defun getAliasIfTracedMapParameter>>=
+(defun |getAliasIfTracedMapParameter| (|x| |currentFunction|)
+ (prog (|aliasList|)
+ (return
+ (seq
+ (cond
+ ((|isSharpVarWithNum| |x|)
+ (cond
+ ((spadlet |aliasList|
+ (|get| |currentFunction| '|alias| |$InteractiveFrame|))
+ (exit
+ (elt |aliasList|
+ (spaddifference
+ (string2pint-n (substring (pname |x|) 1 nil) 1) 1))))))
+ (t |x|))))))
+
+@
+
+\subsection{defun getBpiNameIfTracedMap}
+\begin{verbatim}
+;getBpiNameIfTracedMap(name) ==
+; lmm:= get(name,'localModemap,$InteractiveFrame) =>
+; MEMQ(bpiName:= CADAR lmm,_/TRACENAMES) => bpiName
+; name
+\end{verbatim}
+
+<<defun getBpiNameIfTracedMap>>=
+(defun |getBpiNameIfTracedMap| (|name|)
+ (prog (|lmm| |bpiName|)
+ (return
+ (seq
+ (cond
+ ((spadlet |lmm| (|get| |name| '|localModemap| |$InteractiveFrame|))
+ (cond
+ ((memq (spadlet |bpiName| (cadar |lmm|)) /tracenames)
+ (exit |bpiName|))))
+ (t |name|))))))
+
+@
+
+\subsection{defun hasPair}
+\begin{verbatim}
+;hasPair(key,l) ==
+; atom l => nil
+; l is [ [ =key,:a],:.] => a
+; hasPair(key,rest l)
+\end{verbatim}
+
+<<defun hasPair>>=
+(defun |hasPair| (|key| |l|)
+ (prog (tmp1 |a|)
+ (return
+ (cond
+ ((atom |l|) nil)
+ ((and (pairp |l|)
+ (progn
+ (spadlet tmp1 (qcar |l|))
+ (and (pairp tmp1)
+ (equal (qcar tmp1) |key|)
+ (progn (spadlet |a| (qcdr tmp1)) t))))
+ |a|)
+ (t (|hasPair| |key| (cdr |l|)))))))
+
+@
+
+\subsection{defun shortenForPrinting}
+\begin{verbatim}
+;shortenForPrinting val ==
+; isDomainOrPackage val => devaluate val
+; val
+\end{verbatim}
+
+<<defun shortenForPrinting>>=
+(defun |shortenForPrinting| (|val|)
+ (if (|isDomainOrPackage| |val|)
+ (|devaluate| |val|)
+ |val|))
+
+@
+
+\subsection{defun spadTraceAlias}
+\begin{verbatim}
+;spadTraceAlias(domainId,op,n) ==
+; INTERNL(domainId,".",op,",",STRINGIMAGE n)
+\end{verbatim}
+
+<<defun spadTraceAlias>>=
+(defun |spadTraceAlias| (|domainId| |op| |n|)
+ (internl |domainId| (intern "." "boot") |op| '|,| (stringimage |n|)))
+
+@
+
+\subsection{defun getOption}
+\begin{verbatim}
+;getOption(opt,l) ==
+; y:= ASSOC(opt,l) => rest y
+\end{verbatim}
+
+<<defun getOption>>=
+(defun |getOption| (opt l)
+ (prog (y)
+ (return
+ (seq
+ (cond ((spadlet y (|assoc| opt l)) (exit (cdr y))))))))
+
+@
+
+\subsection{defun reportSpadTrace}
+\begin{verbatim}
+;reportSpadTrace(header,[op,sig,n,:t]) ==
+; null $traceNoisely => nil
+; msg:= [header,'%b,op,":",'%d,rest sig," -> ",first sig," in slot ",n]
+; namePart:= nil --(t is (.,.,name,:.) => (" named ",name); NIL)
+; tracePart:=
+; t is [y,:.] and not null y =>
+; (y="all" => ['%b,"all",'%d,"vars"]; [" vars: ",y])
+; NIL
+; sayBrightly [:msg,:namePart,:tracePart]
+\end{verbatim}
+
+<<defun reportSpadTrace>>=
+(defun |reportSpadTrace| (|header| t0)
+ (prog (|op| |sig| |n| |t| |msg| |namePart| |y| |tracePart|)
+ (return
+ (progn
+ (spadlet |op| (car t0))
+ (spadlet |sig| (cadr t0))
+ (spadlet |n| (caddr t0))
+ (spadlet |t| (cdddr t0))
+ (cond
+ ((null |$traceNoisely|) nil)
+ (t
+ (spadlet |msg|
+ (cons |header|
+ (cons '|%b|
+ (cons |op|
+ (cons '|:|
+ (cons '|%d|
+ (cons (CDR |sig|)
+ (cons '| -> |
+ (cons (car |sig|)
+ (cons '| in slot |
+ (cons |n| nil)))))))))))
+ (spadlet |namePart| nil)
+ (spadlet |tracePart|
+ (cond
+ ((and (pairp |t|) (progn (spadlet |y| (qcar |t|)) t) (null (null |y|)))
+ (cond
+ ((boot-equal |y| '|all|)
+ (cons '|%b| (cons '|all| (cons '|%d| (cons '|vars| nil)))))
+ (t (cons '| vars: | (cons |y| nil)))))
+ (t nil)))
+ (|sayBrightly| (append |msg| (append |namePart| |tracePart|)))))))))
+
+@
+
+\subsection{defun orderBySlotNumber}
+\begin{verbatim}
+;orderBySlotNumber l ==
+; ASSOCRIGHT orderList [ [n,:x] for (x:= [.,.,n,:.]) in l]
+\end{verbatim}
+
+<<defun orderBySlotNumber>>=
+(defun |orderBySlotNumber| (|l|)
+ (prog (|n|)
+ (return
+ (seq
+ (assocright
+ (|orderList|
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 |l| (cdr t1)) (|x| nil))
+ ((or (atom t1)
+ (progn (setq |x| (car t1)) nil)
+ (progn (progn (spadlet |n| (caddr |x|)) |x|) nil))
+ (nreverse0 t0))
+ (seq
+ (exit
+ (setq t0 (cons (cons |n| |x|) t0)))))))))))))
+
+@
+
+\subsection{defun /tracereply}
+\begin{verbatim}
+;_/TRACEREPLY() ==
+; null _/TRACENAMES => MAKESTRING '" Nothing is traced."
+; for x in _/TRACENAMES repeat
+; x is [d,:.] and isDomainOrPackage d =>
+; domainList:= [devaluate d,:domainList]
+; functionList:= [x,:functionList]
+; [:functionList,:domainList,"traced"]
+\end{verbatim}
+
+<<defun /tracereply>>=
+(defun /tracereply ()
+ (prog (|d| |domainList| |functionList|)
+ (return
+ (seq
+ (cond
+ ((null /tracenames) " Nothing is traced.")
+ (t
+ (do ((t0 /tracenames (cdr t0)) (|x| nil))
+ ((or (atom t0) (progn (setq |x| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (cond
+ ((and (pairp |x|)
+ (progn (spadlet |d| (qcar |x|)) t)
+ (|isDomainOrPackage| |d|))
+ (spadlet |domainList| (cons (|devaluate| |d|) |domainList|)))
+ (t
+ (spadlet |functionList| (cons |x| |functionList|)))))))
+ (append |functionList|
+ (append |domainList| (cons '|traced| nil)))))))))
+
+@
+
+\subsection{defun spadReply}
+\begin{verbatim}
+;spadReply() ==
+; [printName x for x in _/TRACENAMES] where
+; printName x ==
+; x is [d,:.] and isDomainOrPackage d => devaluate d
+; x
+\end{verbatim}
+
+<<defun spadReply,printName>>=
+(defun |spadReply,printName| (|x|)
+ (prog (|d|)
+ (return
+ (seq
+ (if (and (and (pairp |x|) (progn (spadlet |d| (qcar |x|)) t))
+ (|isDomainOrPackage| |d|))
+ (exit (|devaluate| |d|)))
+ (exit |x|)))))
+
+@
+
+<<defun spadReply>>=
+(defun |spadReply| ()
+ (prog ()
+ (return
+ (seq
+ (prog (t0)
+ (spadlet t0 nil)
+ (return
+ (do ((t1 /tracenames (cdr t1)) (|x| nil))
+ ((or (atom t1) (progn (setq |x| (car t1)) nil)) (nreverse0 t0))
+ (seq
+ (exit
+ (setq t0 (cons (|spadReply,printName| |x|) t0)))))))))))
+
+@
+
+\subsection{defun spadUntrace}
+\begin{verbatim}
+;spadUntrace(domain,options) ==
+; not isDomainOrPackage domain => userError '"bad argument to untrace"
+; anyifTrue:= null options
+; listOfOperations:= getOption("ops:",options)
+; domainId := devaluate domain
+; null (pair:= ASSOC(domain,_/TRACENAMES)) =>
+; sayMSG ['" No functions in",
+; :bright prefix2String domainId,'"are now traced."]
+; sigSlotNumberAlist:= rest pair
+; for (pair:= [op,sig,n,lv,bpiPointer,traceName,alias]) in sigSlotNumberAlist
|
+; anyifTrue or MEMQ(op,listOfOperations) repeat
+; BPIUNTRACE(traceName,alias)
+; RPLAC(first domain.n,bpiPointer)
+; RPLAC(CDDDR pair,nil)
+; if assocPair:=ASSOC(BPINAME bpiPointer,$letAssoc) then
+; $letAssoc := REMOVER($letAssoc,assocPair)
+; if null $letAssoc then SETLETPRINTFLAG nil
+; newSigSlotNumberAlist:= [x for x in sigSlotNumberAlist | CDDDR x]
+; newSigSlotNumberAlist => RPLAC(rest pair,newSigSlotNumberAlist)
+; SETQ(_/TRACENAMES,DELASC(domain,_/TRACENAMES))
+; spadReply()
+\end{verbatim}
+
+<<defun spadUntrace>>=
+(defun |spadUntrace| (|domain| |options|)
+ (prog (|anyifTrue| |listOfOperations| |domainId| |pair| |sigSlotNumberAlist|
+ |op| |sig| |n| |lv| |bpiPointer| |traceName| |alias| |assocPair|
+ |newSigSlotNumberAlist|)
+ (return
+ (seq
+ (cond
+ ((null (|isDomainOrPackage| |domain|))
+ (|userError| "bad argument to untrace"))
+ (t
+ (spadlet |anyifTrue| (null |options|))
+ (spadlet |listOfOperations| (|getOption| '|ops:| |options|))
+ (spadlet |domainId| (|devaluate| |domain|))
+ (cond
+ ((null (spadlet |pair| (|assoc| |domain| /tracenames)))
+ (|sayMSG|
+ (cons " No functions in"
+ (append
+ (|bright| (|prefix2String| |domainId|))
+ (cons "are now traced." nil)))))
+ (t
+ (spadlet |sigSlotNumberAlist| (cdr |pair|))
+ (do ((t0 |sigSlotNumberAlist| (cdr t0)) (|pair| nil))
+ ((or (atom t0)
+ (progn (setq |pair| (car t0)) nil)
+ (progn
+ (progn
+ (spadlet |op| (car |pair|))
+ (spadlet |sig| (cadr |pair|))
+ (spadlet |n| (caddr |pair|))
+ (spadlet |lv| (cadddr |pair|))
+ (spadlet |bpiPointer| (car (cddddr |pair|)))
+ (spadlet |traceName| (cadr (cddddr |pair|)))
+ (spadlet |alias| (caddr (cddddr |pair|)))
+ |pair|)
+ nil))
+ nil)
+ (seq
+ (exit
+ (cond
+ ((or |anyifTrue| (memq |op| |listOfOperations|))
+ (progn
+ (bpiuntrace |traceName| |alias|)
+ (rplac (car (elt |domain| |n|)) |bpiPointer|)
+ (rplac (cdddr |pair|) nil)
+ (cond
+ ((spadlet |assocPair|
+ (|assoc| (bpiname |bpiPointer|) |$letAssoc|))
+ (spadlet |$letAssoc| (remover |$letAssoc| |assocPair|))
+ (cond
+ ((null |$letAssoc|) (setletprintflag nil))
+ (t nil)))
+ (t nil))))))))
+ (spadlet |newSigSlotNumberAlist|
+ (prog (t1)
+ (spadlet t1 nil)
+ (return
+ (do ((t2 |sigSlotNumberAlist| (cdr t2)) (|x| nil))
+ ((or (atom t2) (progn (setq |x| (car t2)) nil)) (nreverse0 t1))
+ (seq
+ (exit
+ (cond ((cdddr |x|) (setq t1 (cons |x| t1))))))))))
+ (cond
+ (|newSigSlotNumberAlist|
+ (rplac (cdr |pair|) |newSigSlotNumberAlist|))
+ (t
+ (setq /tracenames (delasc |domain| /tracenames))
+ (|spadReply|)))))))))))
+
+@
+\subsection{defun prTraceNames}
+\begin{verbatim}
+;prTraceNames() ==
+; (for x in _/TRACENAMES repeat PRINT fn x; nil) where
+; fn x ==
+; x is [d,:t] and isDomainOrPackage d => [devaluate d,:t]
+; x
+\end{verbatim}
+
+<<defun prTraceNames,fn>>=
+(defun |prTraceNames,fn| (|x|)
+ (prog (|d| |t|)
+ (return
+ (seq
+ (if (and (and (pairp |x|)
+ (progn (spadlet |d| (qcar |x|)) (spadlet |t| (qcdr |x|)) t))
+ (|isDomainOrPackage| |d|))
+ (exit (cons (|devaluate| |d|) |t|)))
+ (exit |x|)))))
+
+@
+
+<<defun prTraceNames>>=
+(defun |prTraceNames| ()
+ (seq
+ (progn
+ (do ((t0 /tracenames (cdr t0)) (|x| nil))
+ ((or (atom t0) (progn (setq |x| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (print (|prTraceNames,fn| |x|))))) nil)))
+
+@
+
+\subsection{defun traceReply}
+\begin{verbatim}
+;traceReply() ==
+; $domains: local:= nil
+; $packages: local:= nil
+; $constructors: local:= nil
+; null _/TRACENAMES =>
+; sayMessage '" Nothing is traced now."
+; sayBrightly '" "
+; for x in _/TRACENAMES repeat
+; x is [d,:.] and (isDomainOrPackage d) => addTraceItem d
+; atom x =>
+; isFunctor x => addTraceItem x
+; (IS__GENVAR x =>
+; addTraceItem EVAL x; functionList:= [x,:functionList])
+; userError '"bad argument to trace"
+; functionList:= "append"/[ [rassocSub(x,$mapSubNameAlist),'" "]
+; for x in functionList | ^isSubForRedundantMapName x]
+; if functionList then
+; 2 = #functionList =>
+; sayMSG [" Function traced: ",:functionList]
+; (22 + sayBrightlyLength functionList) <= $LINELENGTH =>
+; sayMSG [" Functions traced: ",:functionList]
+; sayBrightly " Functions traced:"
+; sayBrightly flowSegmentedMsg(functionList,$LINELENGTH,6)
+; if $domains then
+; displayList:= concat(prefix2String first $domains,
+; [:concat('",",'" ",prefix2String x) for x in rest $domains])
+; if atom displayList then displayList:= [displayList]
+; sayBrightly '" Domains traced: "
+; sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6)
+; if $packages then
+; displayList:= concat(prefix2String first $packages,
+; [:concat(", ",prefix2String x) for x in rest $packages])
+; if atom displayList then displayList:= [displayList]
+; sayBrightly '" Packages traced: "
+; sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6)
+; if $constructors then
+; displayList:= concat(abbreviate first $constructors,
+; [:concat(", ",abbreviate x) for x in rest $constructors])
+; if atom displayList then displayList:= [displayList]
+; sayBrightly '" Parameterized constructors traced:"
+; sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6)
+\end{verbatim}
+
+<<defun traceReply>>=
+(defun |traceReply| ()
+ (prog (|$domains| |$packages| |$constructors| |d| |functionList|
+ |displayList|)
+ (declare (special |$domains| |$packages| |$constructors|))
+ (return
+ (seq
+ (progn
+ (spadlet |$domains| nil)
+ (spadlet |$packages| nil)
+ (spadlet |$constructors| nil)
+ (cond
+ ((null /tracenames) (|sayMessage| " Nothing is traced now."))
+ (t
+ (|sayBrightly| " ")
+ (do ((t0 /tracenames (cdr t0)) (|x| nil))
+ ((or (atom t0) (progn (setq |x| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (cond
+ ((and (pairp |x|)
+ (progn (spadlet |d| (qcar |x|)) t) (|isDomainOrPackage| |d|))
+ (|addTraceItem| |d|))
+ ((atom |x|)
+ (cond
+ ((|isFunctor| |x|) (|addTraceItem| |x|))
+ ((is_genvar |x|) (|addTraceItem| (EVAL |x|)))
+ (t (spadlet |functionList| (CONS |x| |functionList|)))))
+ (t (|userError| "bad argument to trace"))))))
+ (spadlet |functionList|
+ (prog (t1)
+ (spadlet t1 nil)
+ (return
+ (do ((t2 |functionList| (cdr t2)) (|x| nil))
+ ((or (atom t2) (progn (setq |x| (car t2)) nil)) t1)
+ (seq
+ (exit
+ (cond
+ ((null (|isSubForRedundantMapName| |x|))
+ (setq t1
+ (append t1
+ (cons (|rassocSub| |x| |$mapSubNameAlist|)
+ (cons " " nil))))))))))))
+ (cond
+ (|functionList|
+ (cond
+ ((eql 2 (|#| |functionList|))
+ (|sayMSG| (cons '| Function traced: | |functionList|)))
+ ((<= (PLUS 22 (|sayBrightlyLength| |functionList|)) $linelength)
+ (|sayMSG| (cons '| Functions traced: | |functionList|)))
+ (t
+ (|sayBrightly| " Functions traced:")
+ (|sayBrightly|
+ (|flowSegmentedMsg| |functionList| $linelength 6))))))
+ (cond
+ (|$domains|
+ (spadlet |displayList|
+ (|concat|
+ (|prefix2String| (CAR |$domains|))
+ (prog (t3)
+ (spadlet t3 nil)
+ (return
+ (do ((t4 (cdr |$domains|) (cdr t4)) (|x| nil))
+ ((or (atom t4) (progn (setq |x| (car t4)) nil)) t3)
+ (seq
+ (exit
+ (setq t3
+ (append t3 (|concat| "," " " (|prefix2String| |x|)))))))))))
+ (cond
+ ((atom |displayList|)
+ (spadlet |displayList| (cons |displayList| nil))))
+ (|sayBrightly| " Domains traced: ")
+ (|sayBrightly| (|flowSegmentedMsg| |displayList| $LINELENGTH 6))))
+ (cond
+ (|$packages|
+ (spadlet |displayList|
+ (|concat|
+ (|prefix2String| (CAR |$packages|))
+ (prog (t5)
+ (spadlet t5 nil)
+ (return
+ (do ((t6 (cdr |$packages|) (cdr t6)) (|x| nil))
+ ((or (atom t6) (progn (setq |x| (car t6)) nil)) t5)
+ (seq
+ (exit
+ (setq t5
+ (append t5 (|concat| '|, | (|prefix2String| |x|)))))))))))
+ (cond ((atom |displayList|)
+ (spadlet |displayList| (cons |displayList| nil))))
+ (|sayBrightly| " Packages traced: ")
+ (|sayBrightly| (|flowSegmentedMsg| |displayList| $linelength 6))))
+ (cond
+ (|$constructors|
+ (spadlet |displayList|
+ (|concat|
+ (|abbreviate| (CAR |$constructors|))
+ (prog (t7)
+ (spadlet t7 nil)
+ (return
+ (do ((t8 (cdr |$constructors|) (cdr t8)) (|x| nil))
+ ((or (atom t8) (progn (setq |x| (car t8)) nil)) t7)
+ (seq
+ (exit
+ (setq t7
+ (append t7 (|concat| '|, | (|abbreviate| |x|)))))))))))
+ (cond ((atom |displayList|)
+ (spadlet |displayList| (CONS |displayList| nil))))
+ (|sayBrightly| " Parameterized constructors traced:")
+ (|sayBrightly| (|flowSegmentedMsg| |displayList| $linelength 6)))
+ (t nil)))))))))
+
+@
+
+\subsection{defun addTraceItem}
+\begin{verbatim}
+;addTraceItem d ==
+; constructor? d => $constructors:=[d,:$constructors]
+; isDomain d => $domains:= [devaluate d,:$domains]
+; isDomainOrPackage d => $packages:= [devaluate d,:$packages]
+\end{verbatim}
+
+<<defun addTraceItem>>=
+(defun |addTraceItem| (|d|)
+ (cond
+ ((|constructor?| |d|)
+ (spadlet |$constructors| (cons |d| |$constructors|)))
+ ((|isDomain| |d|)
+ (spadlet |$domains| (cons (|devaluate| |d|) |$domains|)))
+ ((|isDomainOrPackage| |d|)
+ (spadlet |$packages| (cons (|devaluate| |d|) |$packages|)))))
+
+@
+
+\subsection{defun ?t}
+\begin{verbatim}
+;_?t() ==
+; null _/TRACENAMES => sayMSG bright '"nothing is traced"
+; for x in _/TRACENAMES | atom x and not IS__GENVAR x repeat
+; if llm:= get(x,'localModemap,$InteractiveFrame) then
+; x:= (LIST (CADAR llm))
+; sayMSG ['"Function",:bright rassocSub(x,$mapSubNameAlist),'"traced"]
+; for x in _/TRACENAMES | x is [d,:l] and isDomainOrPackage d repeat
+; suffix:=
+; isDomain d => '"domain"
+; '"package"
+; sayBrightly ['" Functions traced in ",suffix,'%b,devaluate d,'%d,":"]
+; for x in orderBySlotNumber l repeat reportSpadTrace(" ",take(4,x))
+; TERPRI()
+\end{verbatim}
+
+<<defun ?t>>=
+(defun |?t| ()
+ (prog (|llm| |x| |d| |l| |suffix|)
+ (return
+ (seq
+ (cond
+ ((null /tracenames) (|sayMSG| (|bright| "nothing is traced")))
+ (t
+ (do ((t0 /tracenames (cdr t0)) (|x| nil))
+ ((or (atom t0) (progn (setq |x| (car t0)) nil)) nil)
+ (seq
+ (exit
+ (cond
+ ((and (atom |x|) (null (is_genvar |x|)))
+ (progn
+ (cond
+ ((spadlet |llm| (|get| |x| '|localModemap| |$InteractiveFrame|))
+ (spadlet |x| (list (cadar |llm|)))))
+ (|sayMSG|
+ (cons "Function"
+ (append
+ (|bright| (|rassocSub| |x| |$mapSubNameAlist|))
+ (cons "traced" nil))))))))))
+ (do ((t1 /tracenames (cdr t1)) (|x| nil))
+ ((or (atom t1) (progn (setq |x| (car t1)) nil)) nil)
+ (seq
+ (exit
+ (cond
+ ((and (pairp |x|)
+ (progn (spadlet |d| (qcar |x|)) (spadlet |l| (qcdr |x|)) t)
+ (|isDomainOrPackage| |d|))
+ (progn
+ (spadlet |suffix| (cond ((|isDomain| |d|) "domain") (t "package")))
+ (|sayBrightly|
+ (cons " Functions traced in "
+ (cons |suffix|
+ (cons '|%b|
+ (cons (|devaluate| |d|)
+ (cons '|%d|
+ (cons ":" nil)))))))
+ (do ((t2 (|orderBySlotNumber| |l|) (cdr t2)) (|x| nil))
+ ((or (atom t2) (progn (setq |x| (car t2)) nil)) nil)
+ (seq
+ (exit
+ (|reportSpadTrace| '| | (TAKE 4 |x|)))))
+ (terpri)))))))))))))
+
+@
+\subsection{defun tracelet}
+\begin{verbatim}
+;tracelet(fn,vars) ==
+; if GENSYMP fn and stupidIsSpadFunction EVAL fn then
+; fn := EVAL fn
+; if COMPILED_-FUNCTION_-P fn then fn:=BPINAME fn
+; fn = 'Undef => nil
+; vars:=
+; vars="all" => "all"
+; l:= LASSOC(fn,$letAssoc) => UNION(vars,l)
+; vars
+; $letAssoc:= [ [fn,:vars],:$letAssoc]
+; if $letAssoc then SETLETPRINTFLAG true
+; $TRACELETFLAG : local := true
+; $QuickLet : local := false
+; ^MEMQ(fn,$traceletFunctions) and ^IS__GENVAR fn and COMPILED_-FUNCTION_-P
SYMBOL_-FUNCTION fn
+; and not stupidIsSpadFunction fn and not GENSYMP fn =>
+; ($traceletFunctions:= [fn,:$traceletFunctions]; compileBoot fn ;
+; $traceletFunctions:= DELETE(fn,$traceletFunctions) )
+\end{verbatim}
+
+<<defun tracelet>>=
+(defun |tracelet| (|fn| |vars|)
+ (prog ($traceletflag |$QuickLet| |l|)
+ (declare (special $traceletflag |$QuickLet|))
+ (return
+ (progn
+ (cond
+ ((and (gensymp |fn|) (|stupidIsSpadFunction| (eval |fn|)))
+ (spadlet |fn| (eval |fn|))
+ (cond
+ ((compiled-function-p |fn|) (spadlet |fn| (bpiname |fn|)))
+ (t nil))))
+ (cond
+ ((boot-equal |fn| '|Undef|) nil)
+ (t
+ (spadlet |vars|
+ (cond
+ ((boot-equal |vars| '|all|) '|all|)
+ ((spadlet |l| (lassoc |fn| |$letAssoc|)) (|union| |vars| |l|))
+ (t |vars|)))
+ (spadlet |$letAssoc| (cons (cons |fn| |vars|) |$letAssoc|))
+ (cond (|$letAssoc| (setletprintflag t)))
+ (spadlet $traceletflag t)
+ (spadlet |$QuickLet| nil)
+ (cond
+ ((and (null (memq |fn| |$traceletFunctions|))
+ (null (is_genvar |fn|))
+ (compiled-function-p (symbol-function |fn|))
+ (null (|stupidIsSpadFunction| |fn|))
+ (null (gensymp |fn|)))
+ (progn
+ (spadlet |$traceletFunctions| (cons |fn| |$traceletFunctions|))
+ (|compileBoot| |fn|)
+ (spadlet |$traceletFunctions|
+ (|delete| |fn| |$traceletFunctions|)))))))))))
+
+@
+\subsection{defun breaklet}
+\begin{verbatim}
+;breaklet(fn,vars) ==
+; --vars is "all" or a list of variables
+; --$letAssoc ==> (.. (=fn .. (BREAK . all))) OR (.. (=fn .. (BREAK . vl)))
+; if GENSYMP fn and stupidIsSpadFunction EVAL fn then
+; fn := EVAL fn
+; if COMPILED_-FUNCTION_-P fn then fn:= BPINAME fn
+; fn = "Undef" => nil
+; fnEntry:= LASSOC(fn,$letAssoc)
+; vars:=
+; pair:= ASSOC("BREAK",fnEntry) => UNION(vars,rest pair)
+; vars
+; $letAssoc:=
+; null fnEntry => [[fn,:LIST ["BREAK",:vars]],:$letAssoc]
+; pair => (RPLACD(pair,vars); $letAssoc)
+; if $letAssoc then SETLETPRINTFLAG true
+; $QuickLet:local := false
+; ^MEMQ(fn,$traceletFunctions) and not stupidIsSpadFunction fn
+; and not GENSYMP fn =>
+; $traceletFunctions:= [fn,:$traceletFunctions]
+; compileBoot fn
+; $traceletFunctions:= DELETE(fn,$traceletFunctions)
+\end{verbatim}
+
+;;; *** |breaklet| REDEFINED
+<<defun breaklet>>=
+(defun |breaklet| (|fn| |vars|)
+ (prog (|$QuickLet| |fnEntry| |pair|)
+ (declare (special |$QuickLet|))
+ (return
+ (progn
+ (cond
+ ((and (gensymp |fn|) (|stupidIsSpadFunction| (eval |fn|)))
+ (spadlet |fn| (eval |fn|))
+ (cond
+ ((compiled-function-p |fn|) (spadlet |fn| (bpiname |fn|)))
+ (t nil))))
+ (cond
+ ((boot-equal |fn| '|Undef|) nil)
+ (t
+ (spadlet |fnEntry| (lassoc |fn| |$letAssoc|))
+ (spadlet |vars|
+ (cond
+ ((spadlet |pair| (|assoc| 'break |fnEntry|))
+ (|union| |vars| (cdr |pair|)))
+ (t |vars|)))
+ (spadlet |$letAssoc|
+ (cond
+ ((null |fnEntry|)
+ (cons (cons |fn| (list (cons 'break |vars|))) |$letAssoc|))
+ (|pair| (rplacd |pair| |vars|) |$letAssoc|)))
+ (cond (|$letAssoc| (setletprintflag t)))
+ (spadlet |$QuickLet| nil)
+ (cond
+ ((and (null (memq |fn| |$traceletFunctions|))
+ (null (|stupidIsSpadFunction| |fn|))
+ (null (gensymp |fn|)))
+ (progn
+ (spadlet |$traceletFunctions| (cons |fn| |$traceletFunctions|))
+ (|compileBoot| |fn|)
+ (spadlet |$traceletFunctions|
+ (|delete| |fn| |$traceletFunctions|)))))))))))
+
+@
+\subsection{defun stupidIsSpadFunction}
+\begin{verbatim}
+;stupidIsSpadFunction fn ==
+; -- returns true if the function pname has a semi-colon in it
+; -- eventually, this will use isSpadFunction from luke boot
+; STRPOS('"_;",PNAME fn,0,NIL)
+\end{verbatim}
+
+<<defun stupidIsSpadFunction>>=
+(defun |stupidIsSpadFunction| (|fn|)
+ (strpos ";" (pname |fn|) 0 nil))
+
+@
+
+\subsection{defun break}
+\begin{verbatim}
+;break msg ==
+; condition:= MONITOR_,EVALTRAN(_/BREAKCONDITION,nil)
+; -- The next line is to try to deal with some reported cases of unwanted
+; -- backtraces appearing, MCD.
+; ENABLE_-BACKTRACE(nil)
+; EVAL condition =>
+; sayBrightly msg
+; INTERRUPT()
+\end{verbatim}
+
+;;; *** |break| REDEFINED
+
+<<defun break>>=
+(defun |break| (|msg|)
+ (prog (|condition|)
+ (return
+ (progn
+ (spadlet |condition| (|MONITOR,EVALTRAN| /breakcondition nil))
+ (enable-backtrace nil)
+ (cond ((eval |condition|) (progn (|sayBrightly| |msg|) (interrupt))))))))
+
+@
+\subsection{defun compileBoot}
+\begin{verbatim}
+;compileBoot fn == _/D_,1(LIST fn,'(_/COMP),nil,nil)
+\end{verbatim}
+
+<<defun compileBoot>>=
+(defun |compileBoot| (|fn|)
+ (|/D,1| (list |fn|) '(/comp) nil nil))
+
+@
+
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\cmdhead{undo}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -7265,7 +10339,7 @@ undoLocalModemapHack changeList ==
(return
(seq
(prog (tmp0)
- (spadlet tmp0 NIL)
+ (spadlet tmp0 nil)
(return
(do ((tmp1 changeList (cdr tmp1)) (pair nil))
((or (atom tmp1)
@@ -7535,6 +10609,7 @@ The command synonym {\tt )apropos} is equivalent to
\fnref{set}, and
\fnref{show}
+\subsection{defun what}
\begin{verbatim}
what l == whatSpad2Cmd l
\end{verbatim}
@@ -7544,6 +10619,7 @@ what l == whatSpad2Cmd l
@
+\subsection{defun whatSpad2Cmd}
\begin{verbatim}
whatSpad2Cmd l ==
$e:local := $EmptyEnvironment
@@ -7572,6 +10648,7 @@ whatSpad2Cmd l ==
printSynonyms(args)
\end{verbatim}
+\subsection{defun whatSpad2Cmd,fixpat}
<<defun whatSpad2Cmd,fixpat>>=
(defun |whatSpad2Cmd,fixpat| (|x|)
(prog (|x'|)
@@ -7582,6 +10659,8 @@ whatSpad2Cmd l ==
(exit (downcase |x|))))))
@
+
+\subsection{defun whatSpad2Cmd}
<<defun whatSpad2Cmd>>=
(defun |whatSpad2Cmd| (|l|)
(prog (|$e| |key0| |key| |args|)
@@ -7634,6 +10713,8 @@ whatSpad2Cmd l ==
(|printSynonyms| |args|)))))))))))))))
@
+
+\subsection{defun filterAndFormatConstructors}
\begin{verbatim}
filterAndFormatConstructors(constrType,label,patterns) ==
centerAndHighlight(label,$LINELENGTH,specialChar 'hbar)
@@ -7683,6 +10764,7 @@ filterAndFormatConstructors(constrType,label,patterns) ==
@
+\subsection{defun whatConstructors}
\begin{verbatim}
whatConstructors constrType ==
-- here constrType should be one of 'category, 'domain, 'package
@@ -7715,6 +10797,8 @@ whatConstructors constrType ==
t0))))))))))))))
@
+
+\subsection{defun apropos}
\begin{verbatim}
apropos l ==
-- l is a list of operation name fragments
@@ -7767,6 +10851,7 @@ apropos l ==
; )library top level command -- soon to be obsolete
+\subsection{defun with}
<<defun with>>=
(defun |with| (args)
(|library| args))
@@ -7776,6 +10861,7 @@ apropos l ==
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\cmdhead{workfiles}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\subsection{defun workfiles}
\begin{verbatim}
workfiles l == workfilesSpad2Cmd l
\end{verbatim}
@@ -7784,6 +10870,8 @@ workfiles l == workfilesSpad2Cmd l
(|workfilesSpad2Cmd| l))
@
+
+\subsection{defun workfilesSpad2Cmd}
\begin{verbatim}
workfilesSpad2Cmd args ==
args => throwKeyedMsg("S2IZ0047",NIL)
@@ -7831,7 +10919,7 @@ workfilesSpad2Cmd args ==
(|throwKeyedMsg| 's2iz0048 (cons |type| nil)))
((boot-equal |type1| '|delete|)
(spadlet |deleteFlag| t)))))))
- (do ((t2 |$options| (cdr t2)) (t3 NIL))
+ (do ((t2 |$options| (cdr t2)) (t3 nil))
((or (atom t2)
(progn (setq t3 (CAR t2)) nil)
(progn
@@ -7886,6 +10974,7 @@ workfilesSpad2Cmd args ==
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\cmdhead{zsystemdevelopment}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\subsection{defun zsystemdevelopment}
\begin{verbatim}
zsystemdevelopment l == zsystemDevelopmentSpad2Cmd l
\end{verbatim}
@@ -7894,6 +10983,8 @@ zsystemdevelopment l == zsystemDevelopmentSpad2Cmd l
(|zsystemDevelopmentSpad2Cmd| |l|))
@
+
+\subsection{defun zsystemDevelopmentSpad2Cmd}
\begin{verbatim}
zsystemDevelopmentSpad2Cmd l == zsystemdevelopment1 (l,$InteractiveMode)
\end{verbatim}
@@ -7902,6 +10993,8 @@ zsystemDevelopmentSpad2Cmd l == zsystemdevelopment1
(l,$InteractiveMode)
(|zsystemdevelopment1| |l| |$InteractiveMode|))
@
+
+\subsection{defun zsystemdevelopment1}
\begin{verbatim}
zsystemdevelopment1(l,im) ==
$InteractiveMode : local := im
@@ -7950,8 +11043,8 @@ zsystemdevelopment1(l,im) ==
(seq
(progn
(spadlet |$InteractiveMode| |im|)
- (spadlet |fromopt| NIL)
- (do ((t0 |$options| (cdr t0)) (t1 NIL))
+ (spadlet |fromopt| nil)
+ (do ((t0 |$options| (cdr t0)) (t1 nil))
((or (atom t0)
(progn (setq t1 (car t0)) nil)
(progn
@@ -7968,7 +11061,7 @@ zsystemdevelopment1(l,im) ==
(cond
((boot-equal |opt1| '|from|)
(spadlet |fromopt| (cons (cons 'from |optargs|) nil))))))))
- (do ((t2 |$options| (cdr t2)) (t3 NIL))
+ (do ((t2 |$options| (cdr t2)) (t3 nil))
((or (atom t2)
(progn (setq t3 (car t2)) nil)
(progn
@@ -8164,8 +11257,12 @@ load the file \verb|exposed.lsp| to set up the exposure
group information.
<<initvars>>
<<defun addNewInterpreterFrame>>
+<<defun addTraceItem>>
<<defun apropos>>
+<<defun augmentTraceNames>>
+<<defun break>>
+<<defun breaklet>>
<<defun browse>>
<<defun changeHistListLen>>
@@ -8174,6 +11271,11 @@ load the file \verb|exposed.lsp| to set up the exposure
group information.
<<defun cleanupLine>>
<<defun clearFrame>>
<<defun closeInterpreterFrame>>
+<<defun compileBoot>>
+<<defun coerceSpadArgs2E>>
+<<defun coerceSpadFunValue2E>>
+<<defun coerceTraceArgs2E>>
+<<defun coerceTraceFunValue2E>>
<<defun createCurrentInterpreterFrame>>
<<defun dewritify>>
@@ -8186,12 +11288,14 @@ load the file \verb|exposed.lsp| to set up the
exposure group information.
<<defun displayMacros>>
<<defun displayOperations>>
<<defun displaySpad2Cmd>>
+<<defun domainToGenvar>>
<<defun emptyInterpreterFrame>>
<<defun fetchOutput>>
<<defun filterAndFormatConstructors>>
<<defun findFrameInRing>>
+<<defun flattenOperationAlist>>
<<defun frame>>
<<defun frameEnvironment>>
<<defun frameExposureData>>
@@ -8207,9 +11311,18 @@ load the file \verb|exposed.lsp| to set up the exposure
group information.
<<defun frameNames>>
<<defun frameSpad2Cmd>>
+<<defun getAliasIfTracedMapParameter>>
+<<defun getBpiNameIfTracedMap>>
+<<defun genDomainTraceName>>
<<defun getenviron>>
+<<defun getMapSig>>
+<<defun getOption>>
+<<defun getTraceOption>>
+<<defun getTraceOptions>>
+<<defun getTraceOption,hn>>
<<defun gensymInt>>
+<<defun hasPair>>
<<defun histFileErase>>
<<defun history>>
<<defun histFileName>>
@@ -8227,12 +11340,31 @@ load the file \verb|exposed.lsp| to set up the
exposure group information.
<<defun intloop>>
<<defun intloopPrefix?>>
<<defun intloopReadConsole>>
-
+<<defun isDomainOrPackage>>
+<<defun isInterpOnlyMap>>
+<<defun isSubForRedundantMapName>>
+<<defun isTraceGensym>>
+<<defun isUncompiledMap>>
+
+<<defun lassocSub>>
+<<defun letPrint>>
+<<defun letPrint2>>
+<<defun letPrint3>>
<<defun loadExposureGroupData>>
+<<defmacro funfind>>
+<<defun funfind,LAM>>
+
+<<defun getMapSubNames>>
+<<defun getPreviousMapSubNames>>
+
+<<defun isListOfIdentifiers>>
+<<defun isListOfIdentifiersOrStrings>>
+
<<defun make-absolute-filename>>
<<defun makeHistFileName>>
<<defun makeInitialModemapFrame>>
+<<defun mapLetPrint>>
<<defun ncIntLoop>>
<<defun ncloopCommand>>
@@ -8246,10 +11378,17 @@ load the file \verb|exposed.lsp| to set up the
exposure group information.
<<defun oldHistFileName>>
<<defun openserver>>
+<<defun orderBySlotNumber>>
+<<defun pcounters>>
<<defun previousInterpreterFrame>>
+<<defun prTraceNames>>
+<<defun prTraceNames,fn>>
+<<defun pspacers>>
+<<defun ptimers>>
<<defun putHist>>
+<<defun rassocSub>>
<<defun readHiFi>>
<<defun reclaim>>
<<defun recordNewValue>>
@@ -8257,21 +11396,29 @@ load the file \verb|exposed.lsp| to set up the
exposure group information.
<<defun recordOldValue>>
<<defun recordOldValue0>>
<<defun recordFrame>>
+<<defun removeOption>>
+<<defun removeTracedMapSigs>>
<<defun removeUndoLines>>
+<<defun reportSpadTrace>>
<<defun reportUndo>>
<<defun reroot>>
+<<defun resetCounters>>
<<defun resetInCoreHist>>
+<<defun resetSpacers>>
+<<defun resetTimers>>
<<defun restart>>
<<defun restoreHistory>>
<<defun runspad>>
<<defun safeWritify>>
<<defun saveHistory>>
+<<defun saveMapSig>>
<<defun sayExample>>
<<defun ScanOrPairVec>>
<<defun setCurrentLine>>
<<defun setHistoryCore>>
<<defun set-restart-hook>>
+<<defun shortenForPrinting>>
<<defun showInOut>>
<<defun showInput>>
<<defun setIOindex>>
@@ -8280,10 +11427,33 @@ load the file \verb|exposed.lsp| to set up the
exposure group information.
<<defun spad-save>>
<<defun spadClosure?>>
<<defun SpadInterpretStream>>
+<<defun spadReply>>
+<<defun spadReply,printName>>
<<defun SPADRREAD>>
<<defun SPADRWRITE>>
<<defun SPADRWRITE0>>
+<<defun spadTrace>>
+<<defun spadTrace,isTraceable>>
+<<defun spadTrace,g>>
+<<defun spadTraceAlias>>
+<<defun spadUntrace>>
+<<defun stackTraceOptionError>>
<<defun statisticsInitialization>>
+<<defun stupidIsSpadFunction>>
+<<defun subTypes>>
+
+<<defun ?t>>
+<<defun trace>>
+<<defun trace1>>
+<<defun traceDomainConstructor>>
+<<defun traceDomainLocalOps>>
+<<defun tracelet>>
+<<defun /tracereply>>
+<<defun transOnlyOption>>
+<<defun traceOptionError>>
+<<defun traceReply>>
+<<defun traceSpad2Cmd>>
+<<defun transTraceItem>>
<<defun undo>>
<<defun undoChanges>>
@@ -8293,6 +11463,12 @@ load the file \verb|exposed.lsp| to set up the exposure
group information.
<<defun undoLocalModemapHack>>
<<defun undoSingleStep>>
<<defun undoSteps>>
+<<defun untrace>>
+<<defun untraceAllDomainLocalOps>>
+<<defun untraceDomainConstructor>>
+<<defun untraceDomainConstructor,keepTraced?>>
+<<defun untraceDomainLocalOps>>
+<<defun untraceMapSubNames>>
<<defun unwritable?>>
<<defun updateCurrentInterpreterFrame>>
<<defun updateFromCurrentInterpreterFrame>>
@@ -8318,6 +11494,8 @@ load the file \verb|exposed.lsp| to set up the exposure
group information.
<<defun zsystemdevelopment>>
<<defun zsystemdevelopment1>>
<<defun zsystemDevelopmentSpad2Cmd>>
+
+
@
\chapter{The Global Variables}
\section{Star Global Variables}
diff --git a/changelog b/changelog
index 9d2a7f5..a9ffdb8 100644
--- a/changelog
+++ b/changelog
@@ -1,3 +1,9 @@
+20090307 tpd src/axiom-website/patches.html 20090307.01.tpd.patch
+20090307 tpd src/interp/debugsys.lisp stop loading trace.clisp
+20090307 tpd src/interp/Makefile remove trace.boot
+20090307 tpd src/interp/trace.boot removed. moved to bookvol5
+20090307 tpd src/input/unittest1.input clean up breakage
+20090307 tpd books/bookvol5 add trace root code
20090305 tpd src/axiom-website/patches.html 20090305.01.tpd.patch
20090305 jxb books/bookvol10.3 fix Float outputFixed handling
20090305 jxb Johannes Grabmeier <address@hidden>
diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html
index b2dbc9c..3f6e161 100644
--- a/src/axiom-website/patches.html
+++ b/src/axiom-website/patches.html
@@ -989,5 +989,7 @@ bookvol10.4 add Nag documentation<br/>
bookvol5 add user level command roots<br/>
<a href="patches/20090305.01.tpd.patch">20090305.01.tpd.patch</a>
bookvol10.3 add Grabmeier/Waldek fixes to Float<br/>
+<a href="patches/20090307.01.tpd.patch">20090307.01.tpd.patch</a>
+bookvol5 add trace root<br/>
</body>
</html>
diff --git a/src/input/unittest1.input.pamphlet
b/src/input/unittest1.input.pamphlet
index 8a94acc..c5c9bd3 100644
--- a/src/input/unittest1.input.pamphlet
+++ b/src/input/unittest1.input.pamphlet
@@ -32,6 +32,7 @@ The )apropos command is the same as a )what command
<<*>>=
--S 2
)apropos matrix
+--R
--R
--ROperations whose names satisfy the above pattern(s):
--R
@@ -53,8 +54,9 @@ The )apropos command is the same as a )what command
--RwronskianMatrix zeroMatrix
--RzeroSquareMatrix
--R
---R To get more information about an operation such as identityMatrix
---R , issue the command )display op identityMatrix
+--R To get more information about an operation such as
+--R rectangularMatrix , issue the command )display op
+--R rectangularMatrix
--R------------------------------- Categories --------------------------------
--R
--RCategories with names matching patterns:
@@ -103,6 +105,7 @@ The )apropos command is the same as a )what command
--S 3
)what categories set
+--R
--R------------------------------- Categories --------------------------------
--R
--RCategories with names matching patterns:
@@ -121,6 +124,7 @@ The )apropos command is the same as a )what command
--S 4
)what commands set
+--R
--R--------------- System Commands for User Level: development ---------------
--R
--RSystem commands at this level matching patterns:
@@ -132,6 +136,7 @@ The )apropos command is the same as a )what command
--S 5
)what domains set
+--R
--R--------------------------------- Domains ---------------------------------
--R
--RDomains with names matching patterns:
@@ -154,6 +159,7 @@ The )apropos command is the same as a )what command
--S 6
)what operations set
+--R
--R
--ROperations whose names satisfy the above pattern(s):
--R
@@ -251,12 +257,14 @@ The )apropos command is the same as a )what command
--RzeroSetSplit
--RzeroSetSplitIntoTriangularSystems
--R
---R To get more information about an operation such as setMaxPoints ,
---R issue the command )display op setMaxPoints
+--R To get more information about an operation such as
+--R setAttributeButtonStep , issue the command )display op
+--R setAttributeButtonStep
--E 6
--S 7
)what packages set
+--R
--R-------------------------------- Packages ---------------------------------
--R
--RPackages with names matching patterns:
@@ -273,6 +281,7 @@ The )apropos command is the same as a )what command
--S 8
)what synonym set
+--R
--R------------------------- System Command Synonyms -------------------------
--R
--R No user-defined synonyms satisfying patterns:
@@ -282,6 +291,7 @@ The )apropos command is the same as a )what command
--S 9
)what things set
+--R
--R
--ROperations whose names satisfy the above pattern(s):
--R
@@ -379,8 +389,9 @@ The )apropos command is the same as a )what command
--RzeroSetSplit
--RzeroSetSplitIntoTriangularSystems
--R
---R To get more information about an operation such as setMaxPoints ,
---R issue the command )display op setMaxPoints
+--R To get more information about an operation such as
+--R setAttributeButtonStep , issue the command )display op
+--R setAttributeButtonStep
--R------------------------------- Categories --------------------------------
--R
--RCategories with names matching patterns:
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index 3586ffb..2ad3ebe 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -212,7 +212,6 @@ OBJS= ${OUT}/vmlisp.${O} ${OUT}/hash.${O} \
${OUT}/sockio.${O} ${OUT}/spad.${O} \
${OUT}/spaderror.${O} \
${OUT}/template.${O} ${OUT}/termrw.${O} \
- ${OUT}/trace.${O} \
${OUT}/union.${O} ${OUT}/daase.${O} \
${OUT}/fortcall.${O}
@@ -502,7 +501,6 @@ DOCFILES=${DOC}/alql.boot.dvi \
${DOC}/spaderror.lisp.dvi ${DOC}/spad.lisp.dvi \
${DOC}/sys-pkg.lisp.dvi ${DOC}/template.boot.dvi \
${DOC}/termrw.boot.dvi ${DOC}/topics.boot.dvi \
- ${DOC}/trace.boot.dvi \
${DOC}/union.lisp.dvi ${DOC}/unlisp.lisp.dvi \
${DOC}/util.lisp.dvi ${DOC}/varini.boot.dvi \
${DOC}/vmlisp.lisp.dvi ${DOC}/wi1.boot.dvi \
@@ -6025,48 +6023,6 @@ ${DOC}/termrw.boot.dvi: ${IN}/termrw.boot.pamphlet
@
-\subsection{trace.boot}
-<<trace.o (OUT from MID)>>=
-${OUT}/trace.${O}: ${MID}/trace.clisp
- @ echo 413 making ${OUT}/trace.${O} from ${MID}/trace.clisp
- @ (cd ${MID} ; \
- if [ -z "${NOISE}" ] ; then \
- echo '(progn (compile-file "${MID}/trace.clisp"' \
- ':output-file "${OUT}/trace.${O}") (${BYE}))' | ${DEPSYS} ; \
- else \
- echo '(progn (compile-file "${MID}/trace.clisp"' \
- ':output-file "${OUT}/trace.${O}") (${BYE}))' | ${DEPSYS} \
- >${TMP}/trace ; \
- fi )
-
-@
-<<trace.clisp (MID from IN)>>=
-${MID}/trace.clisp: ${IN}/trace.boot.pamphlet
- @ echo 414 making ${MID}/trace.clisp from ${IN}/trace.boot.pamphlet
- @ (cd ${MID} ; \
- ${TANGLE} ${IN}/trace.boot.pamphlet >trace.boot ; \
- if [ -z "${NOISE}" ] ; then \
- echo '(progn (boottran::boottocl "trace.boot") (${BYE}))' \
- | ${DEPSYS} ; \
- else \
- echo '(progn (boottran::boottocl "trace.boot") (${BYE}))' \
- | ${DEPSYS} >${TMP}/trace ; \
- fi ; \
- rm trace.boot )
-
-@
-<<trace.boot.dvi (DOC from IN)>>=
-${DOC}/trace.boot.dvi: ${IN}/trace.boot.pamphlet
- @echo 415 making ${DOC}/trace.boot.dvi from ${IN}/trace.boot.pamphlet
- @(cd ${DOC} ; \
- cp ${IN}/trace.boot.pamphlet ${DOC} ; \
- ${DOCUMENT} ${NOISE} trace.boot ; \
- rm -f ${DOC}/trace.boot.pamphlet ; \
- rm -f ${DOC}/trace.boot.tex ; \
- rm -f ${DOC}/trace.boot )
-
-@
-
\subsection{as.boot}
<<as.o (OUT from MID)>>=
${OUT}/as.${O}: ${MID}/as.clisp
@@ -9315,10 +9271,6 @@ clean:
<<topics.clisp (MID from IN)>>
<<topics.boot.dvi (DOC from IN)>>
-<<trace.o (OUT from MID)>>
-<<trace.clisp (MID from IN)>>
-<<trace.boot.dvi (DOC from IN)>>
-
<<union.o (OUT from MID)>>
<<union.lisp (MID from IN)>>
<<union.lisp.dvi (DOC from IN)>>
diff --git a/src/interp/debugsys.lisp.pamphlet
b/src/interp/debugsys.lisp.pamphlet
index 1674e8f..e1e1855 100644
--- a/src/interp/debugsys.lisp.pamphlet
+++ b/src/interp/debugsys.lisp.pamphlet
@@ -174,7 +174,6 @@ loaded by hand we need to establish a value.
(thesymb "/int/interp/spaderror.lisp")
(thesymb "/int/interp/template.clisp")
(thesymb "/int/interp/termrw.clisp")
- (thesymb "/int/interp/trace.clisp")
(thesymb "/int/interp/union.lisp")
(thesymb "/int/interp/daase.lisp")
(thesymb "/int/interp/fortcall.clisp"))
diff --git a/src/interp/trace.boot.pamphlet b/src/interp/trace.boot.pamphlet
deleted file mode 100644
index 184763b..0000000
--- a/src/interp/trace.boot.pamphlet
+++ /dev/null
@@ -1,849 +0,0 @@
-\documentclass{article}
-\usepackage{axiom}
-\begin{document}
-\title{\$SPAD/src/interp trace.boot}
-\author{The Axiom Team}
-\maketitle
-\begin{abstract}
-\end{abstract}
-\eject
-\tableofcontents
-\eject
-\section{License}
-<<license>>=
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- All rights reserved.
---
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are
--- met:
---
--- - Redistributions of source code must retain the above copyright
--- notice, this list of conditions and the following disclaimer.
---
--- - Redistributions in binary form must reproduce the above copyright
--- notice, this list of conditions and the following disclaimer in
--- the documentation and/or other materials provided with the
--- distribution.
---
--- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--- names of its contributors may be used to endorse or promote products
--- derived from this software without specific prior written permission.
---
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
--- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
--- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
--- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
--- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
--- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
--- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
--- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
--- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
--- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
--- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-@
-<<*>>=
-<<license>>
-
---% Code for tracing functions
-
--- This code supports the )trace system command and allows the
--- tracing of LISP, BOOT and SPAD functions and interpreter maps.
-
-SETANDFILEQ($traceNoisely,NIL) -- give trace and untrace messages
-
-SETANDFILEQ($reportSpadTrace,NIL) -- reports traced funs
-
-SETANDFILEQ($optionAlist,NIL)
-
-SETANDFILEQ($tracedMapSignatures, NIL)
-
-SETANDFILEQ($traceOptionList,'(
- after _
- before _
- break_
- cond_
- count_
- depth_
- local_
- mathprint _
- nonquietly_
- nt_
- of_
- only_
- ops_
- restore_
- timer_
- varbreak _
- vars_
- within _
- ))
-
-trace l == traceSpad2Cmd l
-
-traceSpad2Cmd l ==
- if l is ['Tuple, l1] then l := l1
- $mapSubNameAlist:= getMapSubNames(l)
- trace1 augmentTraceNames(l,$mapSubNameAlist)
- traceReply()
-
-trace1 l ==
- $traceNoisely: local := NIL
- if hasOption($options,'nonquietly) then $traceNoisely := true
- hasOption($options,'off) =>
- (ops := hasOption($options,'ops)) or
- (lops := hasOption($options,'local)) =>
- null l => throwKeyedMsg("S2IT0019",NIL)
- constructor := unabbrev
- atom l => l
- null rest l =>
- atom first l => first l
- first first l
- NIL
- not(isFunctor constructor) => throwKeyedMsg("S2IT0020",NIL)
- if ops then
- ops := getTraceOption ops
- NIL
- if lops then
- lops := rest getTraceOption lops
- untraceDomainLocalOps(constructor,lops)
- (1 < # $options) and not hasOption($options,'nonquietly) =>
- throwKeyedMsg("S2IT0021",NIL)
- untrace l
- hasOption($options,'stats) =>
- (1 < # $options) =>
- throwKeyedMsg("S2IT0001",['")trace ... )stats"])
- [.,:opt] := CAR $options
- -- look for )trace )stats to list the statistics
- -- )trace )stats reset to reset them
- null opt => -- list the statistics
- centerAndHighlight('"Traced function execution times",78,"-")
- ptimers ()
- SAY '" "
- centerAndHighlight('"Traced function execution counts",78,"-")
- pcounters ()
- selectOptionLC(first opt,'(reset),'optionError)
- resetSpacers()
- resetTimers()
- resetCounters()
- throwKeyedMsg("S2IT0002",NIL)
- a:= hasOption($options,'restore) =>
- null(oldL:= $lastUntraced) => nil
- newOptions:= DELETE(a,$options)
- null l => trace1 oldL
- for x in l repeat
- x is [domain,:opList] and VECP domain =>
- sayKeyedMsg("S2IT0003",[devaluate domain])
- $options:= [:newOptions,:LASSOC(x,$optionAlist)]
- trace1 LIST x
- null l => nil
- l is ["?"] => _?t()
- traceList:= [transTraceItem x for x in l] or return nil
- for x in traceList repeat $optionAlist:=
- ADDASSOC(x,$options,$optionAlist)
- optionList:= getTraceOptions $options
- argument:=
- domainList:= LASSOC("of",optionList) =>
- LASSOC("ops",optionList) =>
- throwKeyedMsg("S2IT0004",NIL)
- opList:=
- traceList => LIST ["ops",:traceList]
- nil
- varList:=
- y:= LASSOC("vars",optionList) => LIST ["vars",:y]
- nil
- [:domainList,:opList,:varList]
- optionList => [:traceList,:optionList]
- traceList
- _/TRACE_,0 [funName for funName in argument]
- saveMapSig [funName for funName in argument]
-
-getTraceOptions options ==
- $traceErrorStack: local := nil
- optionList:= [getTraceOption x for x in options]
- $traceErrorStack =>
- null rest $traceErrorStack =>
- [key,parms] := first $traceErrorStack
- throwKeyedMsg(key,['"",:parms])
- throwListOfKeyedMsgs("S2IT0017",[# $traceErrorStack],
- NREVERSE $traceErrorStack)
- optionList
-
-saveMapSig(funNames) ==
- for name in funNames repeat
- map:= RASSOC(name,$mapSubNameAlist) =>
- $tracedMapSignatures:= ADDASSOC(name,getMapSig(map,name),
- $tracedMapSignatures)
-
-getMapSig(mapName,subName) ==
- lmms:= get(mapName,'localModemap,$InteractiveFrame) =>
- for mm in lmms until sig repeat
- CADR mm = subName => sig:= CDAR mm
- sig
-
-getTraceOption (x is [key,:l]) ==
- key:= selectOptionLC(key,$traceOptionList,'traceOptionError)
- x := [key,:l]
- MEMQ(key,'(nonquietly timer nt)) => x
- key='break =>
- null l => ['break,'before]
- opts := [selectOptionLC(y,'(before after),NIL) for y in l]
- and/[IDENTP y for y in opts] => ['break,:opts]
- stackTraceOptionError ["S2IT0008",NIL]
- key='restore =>
- null l => x
- stackTraceOptionError ["S2IT0009",[STRCONC('")",object2String key)]]
- key='only => ['only,:transOnlyOption l]
- key='within =>
- l is [a] and IDENTP a => x
- stackTraceOptionError ["S2IT0010",['")within"]]
- MEMQ(key,'(cond before after)) =>
- key:=
- key="cond" => "when"
- key
- l is [a] => [key,:l]
- stackTraceOptionError ["S2IT0011",[STRCONC('")",object2String key)]]
- key='depth =>
- l is [n] and FIXP n => x
- stackTraceOptionError ["S2IT0012",['")depth"]]
- key='count =>
- (null l) or (l is [n] and FIXP n) => x
- stackTraceOptionError ["S2IT0012",['")count"]]
- key="of" =>
- ["of",:[hn y for y in l]] where
- hn x ==
- atom x and not UPPER_-CASE_-P (STRINGIMAGE x).(0) =>
- isDomainOrPackage EVAL x => x
- stackTraceOptionError ["S2IT0013",[x]]
- g:= domainToGenvar x => g
- stackTraceOptionError ["S2IT0013",[x]]
- MEMQ(key,'(local ops vars)) =>
- null l or l is ["all"] => [key,:"all"]
- isListOfIdentifiersOrStrings l => x
- stackTraceOptionError ["S2IT0015",[STRCONC('")",object2String key)]]
- key='varbreak =>
- null l or l is ["all"] => ["varbreak",:"all"]
- isListOfIdentifiers l => x
- stackTraceOptionError ["S2IT0016",[STRCONC('")",object2String key)]]
- key='mathprint =>
- null l => x
- stackTraceOptionError ["S2IT0009",[STRCONC('")",object2String key)]]
- key => throwKeyedMsg("S2IT0005",[key])
-
-traceOptionError(opt,keys) ==
- null keys => stackTraceOptionError ["S2IT0007",[opt]]
- commandAmbiguityError("trace option",opt,keys)
-
-resetTimers () ==
- for timer in _/TIMERLIST repeat
- SET(INTERN STRCONC(timer,'"_,TIMER"),0)
-
-resetSpacers () ==
- for spacer in _/SPACELIST repeat
- SET(INTERN STRCONC(spacer,'"_,SPACE"),0)
-
-resetCounters () ==
- for k in _/COUNTLIST repeat
- SET(INTERN STRCONC(k,'"_,COUNT"),0)
-
-ptimers() ==
- null _/TIMERLIST => sayBrightly '" no functions are timed"
- for timer in _/TIMERLIST repeat
- sayBrightly [" ",:bright timer,'_:,'" ",
- EVAL(INTERN STRCONC(timer,'"_,TIMER")) / float $timerTicksPerSecond,'"
sec."]
-
-pspacers() ==
- null _/SPACELIST => sayBrightly '" no functions have space monitored"
- for spacer in _/SPACELIST repeat
- sayBrightly [" ",:bright spacer,'_:,'" ",
- EVAL INTERN STRCONC(spacer,'"_,SPACE"),'" bytes"]
-
-pcounters() ==
- null _/COUNTLIST => sayBrightly '" no functions are being counted"
- for k in _/COUNTLIST repeat
- sayBrightly [" ",:bright k,'_:,'" ",
- EVAL INTERN STRCONC(k,'"_,COUNT"),'" times"]
-
-transOnlyOption l ==
- l is [n,:y] =>
- FIXP n => [n,:transOnlyOption y]
- MEMQ(n:= UPCASE n,'(V A C)) => [n,:transOnlyOption y]
- stackTraceOptionError ["S2IT0006",[n]]
- transOnlyOption y
- nil
-
-stackTraceOptionError x ==
- $traceErrorStack:= [x,:$traceErrorStack]
- nil
-
-removeOption(op,options) ==
- [optEntry for (optEntry:=[opt,:.]) in options | opt ^= op]
-
-domainToGenvar x ==
- $doNotAddEmptyModeIfTrue: local:= true
- (y:= unabbrevAndLoad x) and GETDATABASE(opOf y,'CONSTRUCTORKIND) = 'domain =>
- g:= genDomainTraceName y
- SET(g,evalDomain y)
- g
-
-genDomainTraceName y ==
- u:= LASSOC(y,$domainTraceNameAssoc) => u
- g:= GENVAR()
- $domainTraceNameAssoc:= [[y,:g],:$domainTraceNameAssoc]
- g
-
---this is now called from trace with the )off option
-untrace l ==
- $lastUntraced:=
- null l => COPY _/TRACENAMES
- l
- untraceList:= [transTraceItem x for x in l]
- _/UNTRACE_,0 [lassocSub(funName,$mapSubNameAlist) for
- funName in untraceList]
- removeTracedMapSigs untraceList
-
-transTraceItem x ==
- $doNotAddEmptyModeIfTrue: local:=true
- atom x =>
- (value:=get(x,"value",$InteractiveFrame)) and
- (objMode value in '((Mode) (Domain) (SubDomain (Domain)))) =>
- x := objVal value
- (y:= domainToGenvar x) => y
- x
- UPPER_-CASE_-P (STRINGIMAGE x).(0) =>
- y := unabbrev x
- constructor?(y) => y
- PAIRP(y) and constructor?(CAR y) => CAR y
- (y:= domainToGenvar x) => y
- x
- x
- VECP first x => transTraceItem devaluate first x
- y:= domainToGenvar x => y
- throwKeyedMsg("S2IT0018",[x])
-
-removeTracedMapSigs untraceList ==
- for name in untraceList repeat
- REMPROP(name,$tracedMapSignatures)
-
-coerceTraceArgs2E(traceName,subName,args) ==
- MEMQ(name:= subName,$mathTraceList) =>
- SPADSYSNAMEP PNAME name => coerceSpadArgs2E(reverse CDR reverse args)
- [["=",name,objValUnwrap
coerceInteractive(objNewWrap(arg,type),$OutputForm)]
- for name in '(arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11
arg12 arg13 arg14 arg15 arg16 arg17 arg18 arg19 )
- for arg in args for type in CDR LASSOC(subName,
- $tracedMapSignatures)]
- SPADSYSNAMEP PNAME name => reverse CDR reverse args
- args
-
-coerceSpadArgs2E(args) ==
- -- following binding is to prevent forcing calculation of stream elements
- $streamCount:local := 0
- [["=",name,objValUnwrap coerceInteractive(objNewWrap(arg,type),$OutputForm)]
- for name in '(arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11
arg12 arg13 arg14 arg15 arg16 arg17 arg18 arg19 )
- for arg in args for type in CDR $tracedSpadModemap]
-
-subTypes(mm,sublist) ==
- ATOM mm =>
- (s:= LASSOC(mm,sublist)) => s
- mm
- [subTypes(m,sublist) for m in mm]
-
-coerceTraceFunValue2E(traceName,subName,value) ==
- MEMQ(name:= subName,$mathTraceList) =>
- SPADSYSNAMEP PNAME traceName => coerceSpadFunValue2E(value)
- (u:=LASSOC(subName,$tracedMapSignatures)) =>
- objValUnwrap coerceInteractive(objNewWrap(value,CAR u),$OutputForm)
- value
- value
-
-coerceSpadFunValue2E(value) ==
- -- following binding is to prevent forcing calculation of stream elements
- $streamCount:local := 0
- objValUnwrap coerceInteractive(objNewWrap(value,CAR $tracedSpadModemap),
- $OutputForm)
-
-isListOfIdentifiers l == and/[IDENTP x for x in l]
-
-isListOfIdentifiersOrStrings l == and/[IDENTP x or STRINGP x for x in l]
-
-getMapSubNames(l) ==
- subs:= nil
- for mapName in l repeat
- lmm:= get(mapName,'localModemap,$InteractiveFrame) =>
- subs:= APPEND([[mapName,:CADR mm] for mm in lmm],subs)
- UNION(subs,getPreviousMapSubNames UNIONQ(_/TRACENAMES,
- $lastUntraced))
-
-getPreviousMapSubNames(traceNames) ==
- subs:= nil
- for mapName in ASSOCLEFT CAAR $InteractiveFrame repeat
- lmm:= get(mapName,'localModemap,$InteractiveFrame) =>
- MEMQ(CADAR lmm,traceNames) =>
- for mm in lmm repeat
- subs:= [[mapName,:CADR mm],:subs]
- subs
-
-lassocSub(x,subs) ==
- y:= LASSQ(x,subs) => y
- x
-
-rassocSub(x,subs) ==
- y:= RASSOC(x,subs) => y
- x
-
-isUncompiledMap(x) ==
- y:= get(x,'value,$InteractiveFrame) =>
- (CAAR y) = 'MAP and null get(x,'localModemap,$InteractiveFrame)
-
-isInterpOnlyMap(map) ==
- x:= get(map,'localModemap,$InteractiveFrame) =>
- (CAAAR x) = 'interpOnly
-
-augmentTraceNames(l,mapSubNames) ==
- res:= nil
- for traceName in l repeat
- mml:= get(traceName,'localModemap,$InteractiveFrame) =>
- res:= APPEND([CADR mm for mm in mml],res)
- res:= [traceName,:res]
- res
-
-isSubForRedundantMapName(subName) ==
- mapName:= rassocSub(subName,$mapSubNameAlist) =>
- tail:=MEMBER([mapName,:subName],$mapSubNameAlist) =>
- MEMQ(mapName,CDR ASSOCLEFT tail)
-
-untraceMapSubNames traceNames ==
- null($mapSubNameAlist:local:= getPreviousMapSubNames traceNames) => nil
- for name in (subs:= ASSOCRIGHT $mapSubNameAlist)
- | MEMQ(name,_/TRACENAMES) repeat
- _/UNTRACE_,2(name,nil)
- $lastUntraced:= SETDIFFERENCE($lastUntraced,subs)
-
-funfind("functor","opname") ==
- ops:= isFunctor functor
- [u for u in ops | u is [[ =opname,:.],:.]]
-
-isDomainOrPackage dom ==
- REFVECP dom and #dom>0 and isFunctor opOf dom.(0)
-
-isTraceGensym x == GENSYMP x
-
-spadTrace(domain,options) ==
- $fromSpadTrace:= true
- $tracedModemap:local:= nil
- PAIRP domain and REFVECP CAR domain and (CAR domain).0 = 0 =>
- aldorTrace(domain,options)
- not isDomainOrPackage domain => userError '"bad argument to trace"
- listOfOperations:=
- [g x for x in getOption("OPS",options)] where
- g x ==
- STRINGP x => INTERN x
- x
- if listOfVariables := getOption("VARS",options) then
- options := removeOption("VARS",options)
- if listOfBreakVars := getOption("VARBREAK",options) then
- options := removeOption("VARBREAK",options)
- anyifTrue:= null listOfOperations
- domainId:= opOf domain.(0)
- currentEntry:= ASSOC(domain,_/TRACENAMES)
- currentAlist:= KDR currentEntry
- opStructureList:= flattenOperationAlist getOperationAlistFromLisplib domainId
- sigSlotNumberAlist:=
- [triple
- --new form is (<op> <signature> <slotNumber> <condition> <kind>)
- for [op,sig,n,.,kind] in opStructureList | kind = 'ELT
- and (anyifTrue or MEMQ(op,listOfOperations)) and
- FIXP n and
- isTraceable(triple:= [op,sig,n],domain)] where
- isTraceable(x is [.,.,n,:.],domain) ==
- atom domain.n => nil
- functionSlot:= first domain.n
- GENSYMP functionSlot =>
- (reportSpadTrace("Already Traced",x); nil)
- null (BPINAME functionSlot) =>
- (reportSpadTrace("No function for",x); nil)
- true
- if listOfVariables then
- for [.,.,n] in sigSlotNumberAlist repeat
- fn := first domain.n
- $letAssoc := AS_-INSERT(BPINAME fn,
- listOfVariables,$letAssoc)
- if listOfBreakVars then
- for [.,.,n] in sigSlotNumberAlist repeat
- fn := first domain.n
- $letAssoc := AS_-INSERT(BPINAME fn,
- [["BREAK",:listOfBreakVars]],$letAssoc)
- for (pair:= [op,mm,n]) in sigSlotNumberAlist repeat
- alias:= spadTraceAlias(domainId,op,n)
- $tracedModemap:= subTypes(mm,constructSubst(domain.0))
- traceName:= BPITRACE(first domain.n,alias, options)
- NCONC(pair,[listOfVariables,first domain.n,traceName,alias])
- RPLAC(first domain.n,traceName)
- sigSlotNumberAlist:= [x for x in sigSlotNumberAlist | CDDDR x]
- if $reportSpadTrace then
- if $traceNoisely then printDashedLine()
- for x in orderBySlotNumber sigSlotNumberAlist repeat
- reportSpadTrace("TRACING",x)
- if $letAssoc then SETLETPRINTFLAG true
- currentEntry =>
- RPLAC(rest currentEntry,[:sigSlotNumberAlist,:currentAlist])
- SETQ(_/TRACENAMES,[[domain,:sigSlotNumberAlist],:_/TRACENAMES])
- spadReply()
-
-traceDomainLocalOps(dom,lops,options) ==
- sayMSG ['" ",'"The )local option has been withdrawn"]
- sayMSG ['" ",'"Use )ltr to trace local functions."]
- NIL
--- abb := abbreviate dom
--- loadLibIfNotLoaded abb
--- actualLops := getLocalOpsFromLisplib abb
--- null actualLops =>
--- sayMSG ['" ",:bright abb,'"has no local functions to trace."]
--- lops = 'all => _/TRACE_,1(actualLops,options)
--- l := NIL
--- for lop in lops repeat
--- internalName := INTERN STRCONC(PNAME abb,'";",PNAME lop)
--- not MEMQ(internalName,actualLops) =>
--- sayMSG ['" ",:bright abb,'"does not have a local",
--- '" function called",:bright lop]
--- l := cons(internalName,l)
--- l => _/TRACE_,1(l,options)
--- nil
-
-untraceDomainLocalOps(dom,lops) ==
- sayMSG ['" ",:bright abb,'"has no local functions to untrace."]
- NIL
--- lops = "all" => untraceAllDomainLocalOps(dom)
--- abb := abbreviate dom
--- loadLibIfNotLoaded abb
--- actualLops := getLocalOpsFromLisplib abb
--- null actualLops =>
--- sayMSG ['" ",:bright abb,'"has no local functions to untrace."]
--- l := NIL
--- for lop in lops repeat
--- internalName := INTERN STRCONC(PNAME abb,'";",PNAME lop)
--- not MEMQ(internalName,actualLops) =>
--- sayMSG ['" ",:bright abb,'"does not have a local",
--- '" function called",:bright lop]
--- l := cons(internalName,l)
--- l => untrace l
--- nil
-
-untraceAllDomainLocalOps(dom) == NIL
--- abb := abbreviate dom
--- actualLops := getLocalOpsFromLisplib abb
--- null (l := INTERSECTION(actualLops,_/TRACENAMES)) => NIL
--- _/UNTRACE_,1(l,NIL)
--- NIL
-
-traceDomainConstructor(domainConstructor,options) ==
- -- Trace all domains built with the given domain constructor,
- -- including all presently instantiated domains, and all future
- -- instantiations, while domain constructor is traced.
- loadFunctor domainConstructor
- listOfLocalOps := getOption("LOCAL",options)
- if listOfLocalOps then
- traceDomainLocalOps(domainConstructor,listOfLocalOps,
- [opt for opt in options | opt isnt ['LOCAL,:.]])
- listOfLocalOps and not getOption("OPS",options) => NIL
- for [argl,.,:domain] in HGET($ConstructorCache,domainConstructor)
- repeat spadTrace(domain,options)
- SETQ(_/TRACENAMES,[domainConstructor,:_/TRACENAMES])
- innerDomainConstructor := INTERN STRCONC(domainConstructor,'";")
- if FBOUNDP innerDomainConstructor then domainConstructor :=
innerDomainConstructor
- EMBED(domainConstructor,
- ['LAMBDA, ['_&REST, 'args],
- ['PROG, ['domain],
- ['SETQ,'domain,['APPLY,domainConstructor,'args]],
- ['spadTrace,'domain,MKQ options],
- ['RETURN,'domain]]] )
-
-untraceDomainConstructor domainConstructor ==
- --untrace all the domains in domainConstructor, and unembed it
- SETQ(_/TRACENAMES,
- [df for df in _/TRACENAMES | keepTraced?(df, domainConstructor)]) where
- keepTraced?(df, domainConstructor) ==
- (df is [dc,:.]) and (isDomainOrPackage dc) and
- ((KAR devaluate dc) = domainConstructor) =>
- _/UNTRACE_,0 [dc]
- false
- true
- untraceAllDomainLocalOps domainConstructor
- innerDomainConstructor := INTERN STRCONC(domainConstructor,'";")
- if FBOUNDP innerDomainConstructor then UNEMBED innerDomainConstructor
- else UNEMBED domainConstructor
- SETQ(_/TRACENAMES,DELETE(domainConstructor,_/TRACENAMES))
-
-flattenOperationAlist(opAlist) ==
- res:= nil
- for [op,:mmList] in opAlist repeat
- res:=[:res,:[[op,:mm] for mm in mmList]]
- res
-
-mapLetPrint(x,val,currentFunction) ==
- x:= getAliasIfTracedMapParameter(x,currentFunction)
- currentFunction:= getBpiNameIfTracedMap currentFunction
- letPrint(x,val,currentFunction)
-
--- This is the version for use when we have no idea
--- what print representation to use for the data object
-
-letPrint(x,val,currentFunction) ==
- if $letAssoc and
- ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= LASSOC("all",$letAssoc)))
then
- if (y="all" or MEMQ(x,y)) and
- not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then
- sayBrightlyNT [:bright x,": "]
- PRIN0 shortenForPrinting val
- TERPRI()
- if (y:= hasPair("BREAK",y)) and
- (y="all" or MEMQ(x,y) and
- (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then
- break [:bright currentFunction,'"breaks after",:bright x,'":= ",
- shortenForPrinting val]
- val
-
--- This is the version for use when we have already
--- converted the data into type "Expression"
-letPrint2(x,printform,currentFunction) ==
- $BreakMode:local := nil
- if $letAssoc and
- ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= LASSOC("all",$letAssoc)))
then
- if (y="all" or MEMQ(x,y)) and
- not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then
- $BreakMode:='letPrint2
- flag:=nil
- CATCH('letPrint2,mathprint ["=",x,printform],flag)
- if flag='letPrint2 then print printform
- if (y:= hasPair("BREAK",y)) and
- (y="all" or MEMQ(x,y) and
- (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then
- break [:bright currentFunction,'"breaks after",:bright x,":= ",
- printform]
- x
-
--- This is the version for use when we have our hands on a function
--- to convert the data into type "Expression"
-
-letPrint3(x,xval,printfn,currentFunction) ==
- $BreakMode:local := nil
- if $letAssoc and
- ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= LASSOC("all",$letAssoc)))
then
- if (y="all" or MEMQ(x,y)) and
- not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then
- $BreakMode:='letPrint2
- flag:=nil
- CATCH('letPrint2,mathprint ["=",x,SPADCALL(xval,printfn)],flag)
- if flag='letPrint2 then print xval
- if (y:= hasPair("BREAK",y)) and
- (y="all" or MEMQ(x,y) and
- (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then
- break [:bright currentFunction,'"breaks after",:bright x,'":= ",
- xval]
- x
-
-getAliasIfTracedMapParameter(x,currentFunction) ==
- isSharpVarWithNum x =>
- aliasList:= get(currentFunction,'alias,$InteractiveFrame) =>
- aliasList.(STRING2PINT_-N(SUBSTRING(PNAME x,1,NIL),1)-1)
- x
-
-getBpiNameIfTracedMap(name) ==
- lmm:= get(name,'localModemap,$InteractiveFrame) =>
- MEMQ(bpiName:= CADAR lmm,_/TRACENAMES) => bpiName
- name
-
-hasPair(key,l) ==
- atom l => nil
- l is [[ =key,:a],:.] => a
- hasPair(key,rest l)
-
-shortenForPrinting val ==
- isDomainOrPackage val => devaluate val
- val
-
-spadTraceAlias(domainId,op,n) ==
- INTERNL(domainId,".",op,",",STRINGIMAGE n)
-
-getOption(opt,l) ==
- y:= ASSOC(opt,l) => rest y
-
-reportSpadTrace(header,[op,sig,n,:t]) ==
- null $traceNoisely => nil
- msg:= [header,'%b,op,":",'%d,rest sig," -> ",first sig," in slot ",n]
- namePart:= nil --(t is (.,.,name,:.) => (" named ",name); NIL)
- tracePart:=
- t is [y,:.] and not null y =>
- (y="all" => ['%b,"all",'%d,"vars"]; [" vars: ",y])
- NIL
- sayBrightly [:msg,:namePart,:tracePart]
-
-orderBySlotNumber l ==
- ASSOCRIGHT orderList [[n,:x] for (x:= [.,.,n,:.]) in l]
-
-_/TRACEREPLY() ==
- null _/TRACENAMES => MAKESTRING '" Nothing is traced."
- for x in _/TRACENAMES repeat
- x is [d,:.] and isDomainOrPackage d =>
- domainList:= [devaluate d,:domainList]
- functionList:= [x,:functionList]
- [:functionList,:domainList,"traced"]
-
-spadReply() ==
- [printName x for x in _/TRACENAMES] where
- printName x ==
- x is [d,:.] and isDomainOrPackage d => devaluate d
- x
-
-spadUntrace(domain,options) ==
- not isDomainOrPackage domain => userError '"bad argument to untrace"
- anyifTrue:= null options
- listOfOperations:= getOption("ops:",options)
- domainId := devaluate domain
- null (pair:= ASSOC(domain,_/TRACENAMES)) =>
- sayMSG ['" No functions in",
- :bright prefix2String domainId,'"are now traced."]
- sigSlotNumberAlist:= rest pair
- for (pair:= [op,sig,n,lv,bpiPointer,traceName,alias]) in sigSlotNumberAlist |
- anyifTrue or MEMQ(op,listOfOperations) repeat
- BPIUNTRACE(traceName,alias)
- RPLAC(first domain.n,bpiPointer)
- RPLAC(CDDDR pair,nil)
- if assocPair:=ASSOC(BPINAME bpiPointer,$letAssoc) then
- $letAssoc := REMOVER($letAssoc,assocPair)
- if null $letAssoc then SETLETPRINTFLAG nil
- newSigSlotNumberAlist:= [x for x in sigSlotNumberAlist | CDDDR x]
- newSigSlotNumberAlist => RPLAC(rest pair,newSigSlotNumberAlist)
- SETQ(_/TRACENAMES,DELASC(domain,_/TRACENAMES))
- spadReply()
-
-prTraceNames() ==
- (for x in _/TRACENAMES repeat PRINT fn x; nil) where
- fn x ==
- x is [d,:t] and isDomainOrPackage d => [devaluate d,:t]
- x
-
-traceReply() ==
- $domains: local:= nil
- $packages: local:= nil
- $constructors: local:= nil
- null _/TRACENAMES =>
- sayMessage '" Nothing is traced now."
- sayBrightly '" "
- for x in _/TRACENAMES repeat
- x is [d,:.] and (isDomainOrPackage d) => addTraceItem d
- atom x =>
- isFunctor x => addTraceItem x
- (IS__GENVAR x =>
- addTraceItem EVAL x; functionList:= [x,:functionList])
- userError '"bad argument to trace"
- functionList:= "append"/[[rassocSub(x,$mapSubNameAlist),'" "]
- for x in functionList | ^isSubForRedundantMapName x]
- if functionList then
- 2 = #functionList =>
- sayMSG [" Function traced: ",:functionList]
- (22 + sayBrightlyLength functionList) <= $LINELENGTH =>
- sayMSG [" Functions traced: ",:functionList]
- sayBrightly " Functions traced:"
- sayBrightly flowSegmentedMsg(functionList,$LINELENGTH,6)
- if $domains then
- displayList:= concat(prefix2String first $domains,
- [:concat('",",'" ",prefix2String x) for x in rest $domains])
- if atom displayList then displayList:= [displayList]
- sayBrightly '" Domains traced: "
- sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6)
- if $packages then
- displayList:= concat(prefix2String first $packages,
- [:concat(", ",prefix2String x) for x in rest $packages])
- if atom displayList then displayList:= [displayList]
- sayBrightly '" Packages traced: "
- sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6)
- if $constructors then
- displayList:= concat(abbreviate first $constructors,
- [:concat(", ",abbreviate x) for x in rest $constructors])
- if atom displayList then displayList:= [displayList]
- sayBrightly '" Parameterized constructors traced:"
- sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6)
-
-addTraceItem d ==
- constructor? d => $constructors:=[d,:$constructors]
- isDomain d => $domains:= [devaluate d,:$domains]
- isDomainOrPackage d => $packages:= [devaluate d,:$packages]
-
-_?t() ==
- null _/TRACENAMES => sayMSG bright '"nothing is traced"
- for x in _/TRACENAMES | atom x and not IS__GENVAR x repeat
- if llm:= get(x,'localModemap,$InteractiveFrame) then
- x:= (LIST (CADAR llm))
- sayMSG ['"Function",:bright rassocSub(x,$mapSubNameAlist),'"traced"]
- for x in _/TRACENAMES | x is [d,:l] and isDomainOrPackage d repeat
- suffix:=
- isDomain d => '"domain"
- '"package"
- sayBrightly ['" Functions traced in ",suffix,'%b,devaluate d,'%d,":"]
- for x in orderBySlotNumber l repeat reportSpadTrace(" ",take(4,x))
- TERPRI()
-
-tracelet(fn,vars) ==
- if GENSYMP fn and stupidIsSpadFunction EVAL fn then
- fn := EVAL fn
- if COMPILED_-FUNCTION_-P fn then fn:=BPINAME fn
- fn = 'Undef => nil
- vars:=
- vars="all" => "all"
- l:= LASSOC(fn,$letAssoc) => UNION(vars,l)
- vars
- $letAssoc:= [[fn,:vars],:$letAssoc]
- if $letAssoc then SETLETPRINTFLAG true
- $TRACELETFLAG : local := true
- $QuickLet : local := false
- ^MEMQ(fn,$traceletFunctions) and ^IS__GENVAR fn and COMPILED_-FUNCTION_-P
SYMBOL_-FUNCTION fn
- and not stupidIsSpadFunction fn and not GENSYMP fn =>
- ($traceletFunctions:= [fn,:$traceletFunctions]; compileBoot fn ;
- $traceletFunctions:= DELETE(fn,$traceletFunctions) )
-
-breaklet(fn,vars) ==
- --vars is "all" or a list of variables
- --$letAssoc ==> (.. (=fn .. (BREAK . all))) OR (.. (=fn .. (BREAK . vl)))
- if GENSYMP fn and stupidIsSpadFunction EVAL fn then
- fn := EVAL fn
- if COMPILED_-FUNCTION_-P fn then fn:= BPINAME fn
- fn = "Undef" => nil
- fnEntry:= LASSOC(fn,$letAssoc)
- vars:=
- pair:= ASSOC("BREAK",fnEntry) => UNION(vars,rest pair)
- vars
- $letAssoc:=
- null fnEntry => [[fn,:LIST ["BREAK",:vars]],:$letAssoc]
- pair => (RPLACD(pair,vars); $letAssoc)
- if $letAssoc then SETLETPRINTFLAG true
- $QuickLet:local := false
- ^MEMQ(fn,$traceletFunctions) and not stupidIsSpadFunction fn
- and not GENSYMP fn =>
- $traceletFunctions:= [fn,:$traceletFunctions]
- compileBoot fn
- $traceletFunctions:= DELETE(fn,$traceletFunctions)
-
-stupidIsSpadFunction fn ==
- -- returns true if the function pname has a semi-colon in it
- -- eventually, this will use isSpadFunction from luke boot
- STRPOS('"_;",PNAME fn,0,NIL)
-
-break msg ==
- condition:= MONITOR_,EVALTRAN(_/BREAKCONDITION,nil)
- -- The next line is to try to deal with some reported cases of unwanted
- -- backtraces appearing, MCD.
- ENABLE_-BACKTRACE(nil)
- EVAL condition =>
- sayBrightly msg
- INTERRUPT()
-
-compileBoot fn == _/D_,1(LIST fn,'(_/COMP),nil,nil)
-
-@
-\eject
-\begin{thebibliography}{99}
-\bibitem{1} nothing
-\end{thebibliography}
-\end{document}
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Axiom-developer] 20090307.01.tpd.patch (bookvol5 add trace root),
daly <=