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 (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| (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. +<>= +(defvar |$traceNoisely| nil) + +@ + +This reports the traced functions +<>= +(defvar |$reportSpadTrace| nil) + +@ + +<>= +(defvar |$optionAlist| nil) + +@ + +<>= +(defvar |$tracedMapSignatures| nil) + +@ + +<>= +(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| (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| (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| (|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| (|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| (|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| (|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| (|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| (|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| (|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| () + (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| () + (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| () + (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| () + (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| () + (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| () + (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| (|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| (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| (|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| (|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| (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| (|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| (|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| (|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| (|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| (|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| (|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| (|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| (|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| (|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| (|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| (|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| (|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| (|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| (|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| (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| (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| (|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| (|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| (|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| (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| (&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| (dom) + (and + (refvecp dom) + (> (|#| dom) 0) + (|isFunctor| (|opOf| (elt dom 0))))) + +@ + +\subsection{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 ( ) +; 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| (|x|) + (seq + (if (stringp |x|) (exit (intern |x|))) + (exit |x|))) + +@ + +<>= +(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| (|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| (|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| (|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| (|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| (|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?| (|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| (|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| (|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| (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| (|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| (|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| (|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| (|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| (|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| (|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| (|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| (|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| (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| (|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| (|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 () + (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| (|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| () + (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| (|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| (|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| () + (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| () + (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| (|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| () + (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| (|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| (|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| (|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| (|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| (|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| (|x|) (prog (|x'|) @@ -7582,6 +10659,8 @@ whatSpad2Cmd l == (exit (downcase |x|)))))) @ + +\subsection{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| (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. <> <> +<> <> +<> +<> +<> <> <> @@ -8174,6 +11271,11 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> +<> +<> +<> +<> +<> <> <> @@ -8186,12 +11288,14 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> +<> <> <> <> <> +<> <> <> <> @@ -8207,9 +11311,18 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> +<> +<> +<> <> +<> +<> +<> +<> +<> <> +<> <> <> <> @@ -8227,12 +11340,31 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> - +<> +<> +<> +<> +<> + +<> +<> +<> +<> <> +<> +<> + +<> +<> + +<> +<> + <> <> <> +<> <> <> @@ -8246,10 +11378,17 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> +<> +<> <> +<> +<> +<> +<> <> +<> <> <> <> @@ -8257,21 +11396,29 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> +<> +<> <> +<> <> <> +<> <> +<> +<> <> <> <> <> <> +<> <> <> <> <> <> +<> <> <> <> @@ -8280,10 +11427,33 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> +<> +<> <> <> <> +<> +<> +<> +<> +<> +<> <> +<> +<> + +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> <> <> @@ -8293,6 +11463,12 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> +<> +<> +<> +<> +<> +<> <> <> <> @@ -8318,6 +11494,8 @@ load the file \verb|exposed.lsp| to set up the exposure group information. <> <> <> + + @ \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 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
bookvol5 add user level command roots
20090305.01.tpd.patch bookvol10.3 add Grabmeier/Waldek fixes to Float
+20090307.01.tpd.patch +bookvol5 add trace root
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} -<>= -${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 ) - -@ -<>= -${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 ) - -@ -<>= -${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} <>= ${OUT}/as.${O}: ${MID}/as.clisp @@ -9315,10 +9271,6 @@ clean: <> <> -<> -<> -<> - <> <> <> 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} -<>= --- 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. - -@ -<<*>>= -<> - ---% 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 ( ) - 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}