diff options
Diffstat (limited to 'src/interp/trace.boot.pamphlet')
-rw-r--r-- | src/interp/trace.boot.pamphlet | 853 |
1 files changed, 853 insertions, 0 deletions
diff --git a/src/interp/trace.boot.pamphlet b/src/interp/trace.boot.pamphlet new file mode 100644 index 00000000..f6890cde --- /dev/null +++ b/src/interp/trace.boot.pamphlet @@ -0,0 +1,853 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/trace.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<<license>>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<<license>> + +--% Code for tracing functions + +-- This code supports the )trace system command and allows the +-- tracing of LISP, BOOT and SPAD functions and interpreter maps. + +SETANDFILEQ($traceNoisely,NIL) -- give trace and untrace messages + +SETANDFILEQ($reportSpadTrace,NIL) -- reports traced funs + +SETANDFILEQ($optionAlist,NIL) + +SETANDFILEQ($tracedMapSignatures, NIL) + +SETANDFILEQ($traceOptionList,'( + after _ + before _ + break_ + cond_ + count_ + depth_ + local_ + mathprint _ + nonquietly_ + nt_ + of_ + only_ + ops_ + restore_ + timer_ + varbreak _ + vars_ + within _ + )) + +trace l == traceSpad2Cmd l + +traceSpad2Cmd l == + if l is ['Tuple, l1] then l := l1 + $mapSubNameAlist:= getMapSubNames(l) + trace1 augmentTraceNames(l,$mapSubNameAlist) + traceReply() + +trace1 l == + $traceNoisely: local := NIL + if hasOption($options,'nonquietly) then $traceNoisely := true + hasOption($options,'off) => + (ops := hasOption($options,'ops)) or + (lops := hasOption($options,'local)) => + null l => throwKeyedMsg("S2IT0019",NIL) + constructor := unabbrev + atom l => l + null rest l => + atom first l => first l + first first l + NIL + not(isFunctor constructor) => throwKeyedMsg("S2IT0020",NIL) + if ops then + ops := getTraceOption ops + NIL + if lops then + lops := rest getTraceOption lops + untraceDomainLocalOps(constructor,lops) + (1 < # $options) and not hasOption($options,'nonquietly) => + throwKeyedMsg("S2IT0021",NIL) + untrace l + hasOption($options,'stats) => + (1 < # $options) => + throwKeyedMsg("S2IT0001",['")trace ... )stats"]) + [.,:opt] := CAR $options + -- look for )trace )stats to list the statistics + -- )trace )stats reset to reset them + null opt => -- list the statistics + centerAndHighlight('"Traced function execution times",78,"-") + ptimers () + SAY '" " + centerAndHighlight('"Traced function execution counts",78,"-") + pcounters () + selectOptionLC(first opt,'(reset),'optionError) + resetSpacers() + resetTimers() + resetCounters() + throwKeyedMsg("S2IT0002",NIL) + a:= hasOption($options,'restore) => + null(oldL:= $lastUntraced) => nil + newOptions:= delete(a,$options) + null l => trace1 oldL + for x in l repeat + x is [domain,:opList] and VECP domain => + sayKeyedMsg("S2IT0003",[devaluate domain]) + $options:= [:newOptions,:LASSOC(x,$optionAlist)] + trace1 LIST x + null l => nil + l is ["?"] => _?t() + traceList:= [transTraceItem x for x in l] or return nil + for x in traceList repeat $optionAlist:= + ADDASSOC(x,$options,$optionAlist) + optionList:= getTraceOptions $options + argument:= + domainList:= LASSOC("of",optionList) => + LASSOC("ops",optionList) => + throwKeyedMsg("S2IT0004",NIL) + opList:= + traceList => LIST ["ops",:traceList] + nil + varList:= + y:= LASSOC("vars",optionList) => LIST ["vars",:y] + nil + [:domainList,:opList,:varList] + optionList => [:traceList,:optionList] + traceList + _/TRACE_,0 [funName for funName in argument] + saveMapSig [funName for funName in argument] + +getTraceOptions options == + $traceErrorStack: local + optionList:= [getTraceOption x for x in options] + $traceErrorStack => + null rest $traceErrorStack => + [key,parms] := first $traceErrorStack + throwKeyedMsg(key,['"",:parms]) + throwListOfKeyedMsgs("S2IT0017",[# $traceErrorStack], + NREVERSE $traceErrorStack) + optionList + +saveMapSig(funNames) == + for name in funNames repeat + map:= rassoc(name,$mapSubNameAlist) => + $tracedMapSignatures:= ADDASSOC(name,getMapSig(map,name), + $tracedMapSignatures) + +getMapSig(mapName,subName) == + lmms:= get(mapName,'localModemap,$InteractiveFrame) => + for mm in lmms until sig repeat + CADR mm = subName => sig:= CDAR mm + sig + +getTraceOption (x is [key,:l]) == + key:= selectOptionLC(key,$traceOptionList,'traceOptionError) + x := [key,:l] + MEMQ(key,'(nonquietly timer nt)) => x + key='break => + null l => ['break,'before] + opts := [selectOptionLC(y,'(before after),NIL) for y in l] + and/[IDENTP y for y in opts] => ['break,:opts] + stackTraceOptionError ["S2IT0008",NIL] + key='restore => + null l => x + stackTraceOptionError ["S2IT0009",[STRCONC('")",object2String key)]] + key='only => ['only,:transOnlyOption l] + key='within => + l is [a] and IDENTP a => x + stackTraceOptionError ["S2IT0010",['")within"]] + MEMQ(key,'(cond before after)) => + key:= + key="cond" => "when" + key + l is [a] => [key,:l] + stackTraceOptionError ["S2IT0011",[STRCONC('")",object2String key)]] + key='depth => + l is [n] and FIXP n => x + stackTraceOptionError ["S2IT0012",['")depth"]] + key='count => + (null l) or (l is [n] and FIXP n) => x + stackTraceOptionError ["S2IT0012",['")count"]] + key="of" => + ["of",:[hn y for y in l]] where + hn x == + atom x and not UPPER_-CASE_-P (STRINGIMAGE x).(0) => + isDomainOrPackage EVAL x => x + stackTraceOptionError ["S2IT0013",[x]] + g:= domainToGenvar x => g + stackTraceOptionError ["S2IT0013",[x]] + MEMQ(key,'(local ops vars)) => + null l or l is ["all"] => [key,:"all"] + isListOfIdentifiersOrStrings l => x + stackTraceOptionError ["S2IT0015",[STRCONC('")",object2String key)]] + key='varbreak => + null l or l is ["all"] => ["varbreak",:"all"] + isListOfIdentifiers l => x + stackTraceOptionError ["S2IT0016",[STRCONC('")",object2String key)]] + key='mathprint => + null l => x + stackTraceOptionError ["S2IT0009",[STRCONC('")",object2String key)]] + key => throwKeyedMsg("S2IT0005",[key]) + +traceOptionError(opt,keys) == + null keys => stackTraceOptionError ["S2IT0007",[opt]] + commandAmbiguityError("trace option",opt,keys) + +resetTimers () == + for timer in _/TIMERLIST repeat + SET(INTERN STRCONC(timer,'"_,TIMER"),0) + +resetSpacers () == + for spacer in _/SPACELIST repeat + SET(INTERN STRCONC(spacer,'"_,SPACE"),0) + +resetCounters () == + for k in _/COUNTLIST repeat + SET(INTERN STRCONC(k,'"_,COUNT"),0) + +ptimers() == + null _/TIMERLIST => sayBrightly '" no functions are timed" + for timer in _/TIMERLIST repeat + sayBrightly [" ",:bright timer,'_:,'" ", + EVAL(INTERN STRCONC(timer,'"_,TIMER")) / float $timerTicksPerSecond,'" sec."] + +pspacers() == + null _/SPACELIST => sayBrightly '" no functions have space monitored" + for spacer in _/SPACELIST repeat + sayBrightly [" ",:bright spacer,'_:,'" ", + EVAL INTERN STRCONC(spacer,'"_,SPACE"),'" bytes"] + +pcounters() == + null _/COUNTLIST => sayBrightly '" no functions are being counted" + for k in _/COUNTLIST repeat + sayBrightly [" ",:bright k,'_:,'" ", + EVAL INTERN STRCONC(k,'"_,COUNT"),'" times"] + +transOnlyOption l == + l is [n,:y] => + FIXP n => [n,:transOnlyOption y] + MEMQ(n:= UPCASE n,'(V A C)) => [n,:transOnlyOption y] + stackTraceOptionError ["S2IT0006",[n]] + transOnlyOption y + nil + +stackTraceOptionError x == + $traceErrorStack:= [x,:$traceErrorStack] + nil + +removeOption(op,options) == + [optEntry for (optEntry:=[opt,:.]) in options | opt ^= op] + +domainToGenvar x == + $doNotAddEmptyModeIfTrue: local:= true + (y:= unabbrevAndLoad x) and GETDATABASE(opOf y,'CONSTRUCTORKIND) = 'domain => + g:= genDomainTraceName y + SET(g,evalDomain y) + g + +genDomainTraceName y == + u:= LASSOC(y,$domainTraceNameAssoc) => u + g:= GENVAR() + $domainTraceNameAssoc:= [[y,:g],:$domainTraceNameAssoc] + g + +--this is now called from trace with the )off option +untrace l == + $lastUntraced:= + null l => COPY _/TRACENAMES + l + untraceList:= [transTraceItem x for x in l] + _/UNTRACE_,0 [lassocSub(funName,$mapSubNameAlist) for + funName in untraceList] + removeTracedMapSigs untraceList + +transTraceItem x == + $doNotAddEmptyModeIfTrue: local:=true + atom x => + (value:=get(x,"value",$InteractiveFrame)) and + (objMode value in '((Mode) (Domain) (SubDomain (Domain)))) => + x := objVal value + (y:= domainToGenvar x) => y + x + UPPER_-CASE_-P (STRINGIMAGE x).(0) => + y := unabbrev x + constructor?(y) => y + PAIRP(y) and constructor?(CAR y) => CAR y + (y:= domainToGenvar x) => y + x + x + VECP first x => transTraceItem devaluate first x + y:= domainToGenvar x => y + throwKeyedMsg("S2IT0018",[x]) + +removeTracedMapSigs untraceList == + for name in untraceList repeat + REMPROP(name,$tracedMapSignatures) + +coerceTraceArgs2E(traceName,subName,args) == + MEMQ(name:= subName,$mathTraceList) => + SPADSYSNAMEP PNAME name => coerceSpadArgs2E(reverse CDR reverse args) + [["=",name,objValUnwrap coerceInteractive(objNewWrap(arg,type),$OutputForm)] + for name in '(arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11 arg12 arg13 arg14 arg15 arg16 arg17 arg18 arg19 ) + for arg in args for type in CDR LASSOC(subName, + $tracedMapSignatures)] + SPADSYSNAMEP PNAME name => reverse CDR reverse args + args + +coerceSpadArgs2E(args) == + -- following binding is to prevent forcing calculation of stream elements + $streamCount:local := 0 + [["=",name,objValUnwrap coerceInteractive(objNewWrap(arg,type),$OutputForm)] + for name in '(arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11 arg12 arg13 arg14 arg15 arg16 arg17 arg18 arg19 ) + for arg in args for type in CDR $tracedSpadModemap] + +subTypes(mm,sublist) == + ATOM mm => + (s:= LASSOC(mm,sublist)) => s + mm + [subTypes(m,sublist) for m in mm] + +coerceTraceFunValue2E(traceName,subName,value) == + MEMQ(name:= subName,$mathTraceList) => + SPADSYSNAMEP PNAME traceName => coerceSpadFunValue2E(value) + (u:=LASSOC(subName,$tracedMapSignatures)) => + objValUnwrap coerceInteractive(objNewWrap(value,CAR u),$OutputForm) + value + value + +coerceSpadFunValue2E(value) == + -- following binding is to prevent forcing calculation of stream elements + $streamCount:local := 0 + objValUnwrap coerceInteractive(objNewWrap(value,CAR $tracedSpadModemap), + $OutputForm) + +isListOfIdentifiers l == and/[IDENTP x for x in l] + +isListOfIdentifiersOrStrings l == and/[IDENTP x or STRINGP x for x in l] + +getMapSubNames(l) == + subs:= nil + for mapName in l repeat + lmm:= get(mapName,'localModemap,$InteractiveFrame) => + subs:= APPEND([[mapName,:CADR mm] for mm in lmm],subs) + union(subs,getPreviousMapSubNames UNIONQ(_/TRACENAMES, + $lastUntraced)) + +getPreviousMapSubNames(traceNames) == + subs:= nil + for mapName in ASSOCLEFT CAAR $InteractiveFrame repeat + lmm:= get(mapName,'localModemap,$InteractiveFrame) => + MEMQ(CADAR lmm,traceNames) => + for mm in lmm repeat + subs:= [[mapName,:CADR mm],:subs] + subs + +lassocSub(x,subs) == + y:= LASSQ(x,subs) => y + x + +rassocSub(x,subs) == + y:= rassoc(x,subs) => y + x + +isUncompiledMap(x) == + y:= get(x,'value,$InteractiveFrame) => + (CAAR y) = 'MAP and null get(x,'localModemap,$InteractiveFrame) + +isInterpOnlyMap(map) == + x:= get(map,'localModemap,$InteractiveFrame) => + (CAAAR x) = 'interpOnly + +augmentTraceNames(l,mapSubNames) == + res:= nil + for traceName in l repeat + mml:= get(traceName,'localModemap,$InteractiveFrame) => + res:= APPEND([CADR mm for mm in mml],res) + res:= [traceName,:res] + res + +isSubForRedundantMapName(subName) == + mapName:= rassocSub(subName,$mapSubNameAlist) => + tail:=member([mapName,:subName],$mapSubNameAlist) => + MEMQ(mapName,CDR ASSOCLEFT tail) + +untraceMapSubNames traceNames == + null($mapSubNameAlist:local:= getPreviousMapSubNames traceNames) => nil + for name in (subs:= ASSOCRIGHT $mapSubNameAlist) + | MEMQ(name,_/TRACENAMES) repeat + _/UNTRACE_,2(name,nil) + $lastUntraced:= SETDIFFERENCE($lastUntraced,subs) + +funfind("functor","opname") == + ops:= isFunctor functor + [u for u in ops | u is [[ =opname,:.],:.]] + +isDomainOrPackage dom == + REFVECP dom and #dom>0 and isFunctor opOf dom.(0) + +isTraceGensym x == GENSYMP x + +spadTrace(domain,options) == + $fromSpadTrace:= true + $tracedModemap:local:= nil + PAIRP domain and REFVECP CAR domain and (CAR domain).0 = 0 => + aldorTrace(domain,options) + not isDomainOrPackage domain => userError '"bad argument to trace" + listOfOperations:= + [g x for x in getOption("OPS",options)] where + g x == + STRINGP x => INTERN x + x + if listOfVariables := getOption("VARS",options) then + options := removeOption("VARS",options) + if listOfBreakVars := getOption("VARBREAK",options) then + options := removeOption("VARBREAK",options) + anyifTrue:= null listOfOperations + domainId:= opOf domain.(0) + currentEntry:= ASSOC(domain,_/TRACENAMES) + currentAlist:= KDR currentEntry + opStructureList:= flattenOperationAlist getOperationAlistFromLisplib domainId + sigSlotNumberAlist:= + [triple + --new form is (<op> <signature> <slotNumber> <condition> <kind>) + for [op,sig,n,.,kind] in opStructureList | kind = 'ELT + and (anyifTrue or MEMQ(op,listOfOperations)) and + FIXP n and + isTraceable(triple:= [op,sig,n],domain)] where + isTraceable(x is [.,.,n,:.],domain) == + atom domain.n => nil + functionSlot:= first domain.n + GENSYMP functionSlot => + (reportSpadTrace("Already Traced",x); nil) + null (BPINAME functionSlot) => + (reportSpadTrace("No function for",x); nil) + true + if listOfVariables then + for [.,.,n] in sigSlotNumberAlist repeat + fn := first domain.n + $letAssoc := AS_-INSERT(BPINAME fn, + listOfVariables,$letAssoc) + if listOfBreakVars then + for [.,.,n] in sigSlotNumberAlist repeat + fn := first domain.n + $letAssoc := AS_-INSERT(BPINAME fn, + [["BREAK",:listOfBreakVars]],$letAssoc) + for (pair:= [op,mm,n]) in sigSlotNumberAlist repeat + alias:= spadTraceAlias(domainId,op,n) + $tracedModemap:= subTypes(mm,constructSubst(domain.0)) + traceName:= BPITRACE(first domain.n,alias, options) + NCONC(pair,[listOfVariables,first domain.n,traceName,alias]) + RPLAC(first domain.n,traceName) + sigSlotNumberAlist:= [x for x in sigSlotNumberAlist | CDDDR x] + if $reportSpadTrace then + if $traceNoisely then printDashedLine() + for x in orderBySlotNumber sigSlotNumberAlist repeat + reportSpadTrace("TRACING",x) + if $letAssoc then SETLETPRINTFLAG true + currentEntry => + RPLAC(rest currentEntry,[:sigSlotNumberAlist,:currentAlist]) + SETQ(_/TRACENAMES,[[domain,:sigSlotNumberAlist],:_/TRACENAMES]) + spadReply() + +traceDomainLocalOps(dom,lops,options) == + sayMSG ['" ",'"The )local option has been withdrawn"] + sayMSG ['" ",'"Use )ltr to trace local functions."] + NIL +-- abb := abbreviate dom +-- loadLibIfNotLoaded abb +-- actualLops := getLocalOpsFromLisplib abb +-- null actualLops => +-- sayMSG ['" ",:bright abb,'"has no local functions to trace."] +-- lops = 'all => _/TRACE_,1(actualLops,options) +-- l := NIL +-- for lop in lops repeat +-- internalName := INTERN STRCONC(PNAME abb,'";",PNAME lop) +-- not MEMQ(internalName,actualLops) => +-- sayMSG ['" ",:bright abb,'"does not have a local", +-- '" function called",:bright lop] +-- l := cons(internalName,l) +-- l => _/TRACE_,1(l,options) +-- nil + +untraceDomainLocalOps(dom,lops) == + sayMSG ['" ",:bright abb,'"has no local functions to untrace."] + NIL +-- lops = "all" => untraceAllDomainLocalOps(dom) +-- abb := abbreviate dom +-- loadLibIfNotLoaded abb +-- actualLops := getLocalOpsFromLisplib abb +-- null actualLops => +-- sayMSG ['" ",:bright abb,'"has no local functions to untrace."] +-- l := NIL +-- for lop in lops repeat +-- internalName := INTERN STRCONC(PNAME abb,'";",PNAME lop) +-- not MEMQ(internalName,actualLops) => +-- sayMSG ['" ",:bright abb,'"does not have a local", +-- '" function called",:bright lop] +-- l := cons(internalName,l) +-- l => untrace l +-- nil + +untraceAllDomainLocalOps(dom) == NIL +-- abb := abbreviate dom +-- actualLops := getLocalOpsFromLisplib abb +-- null (l := intersection(actualLops,_/TRACENAMES)) => NIL +-- _/UNTRACE_,1(l,NIL) +-- NIL + +traceDomainConstructor(domainConstructor,options) == + -- Trace all domains built with the given domain constructor, + -- including all presently instantiated domains, and all future + -- instantiations, while domain constructor is traced. + loadFunctor domainConstructor + listOfLocalOps := getOption("LOCAL",options) + if listOfLocalOps then + traceDomainLocalOps(domainConstructor,listOfLocalOps, + [opt for opt in options | opt isnt ['LOCAL,:.]]) + listOfLocalOps and not getOption("OPS",options) => NIL + for [argl,.,:domain] in HGET($ConstructorCache,domainConstructor) + repeat spadTrace(domain,options) + SETQ(_/TRACENAMES,[domainConstructor,:_/TRACENAMES]) + innerDomainConstructor := INTERN STRCONC(domainConstructor,'";") + if FBOUNDP innerDomainConstructor then domainConstructor := innerDomainConstructor + EMBED(domainConstructor, + ['LAMBDA, ['_&REST, 'args], + ['PROG, ['domain], + ['SETQ,'domain,['APPLY,domainConstructor,'args]], + ['spadTrace,'domain,MKQ options], + ['RETURN,'domain]]] ) + +untraceDomainConstructor domainConstructor == + --untrace all the domains in domainConstructor, and unembed it + SETQ(_/TRACENAMES, + [df for df in _/TRACENAMES | keepTraced?(df, domainConstructor)]) where + keepTraced?(df, domainConstructor) == + (df is [dc,:.]) and (isDomainOrPackage dc) and + ((KAR devaluate dc) = domainConstructor) => + _/UNTRACE_,0 [dc] + false + true + untraceAllDomainLocalOps domainConstructor + innerDomainConstructor := INTERN STRCONC(domainConstructor,'";") + if FBOUNDP innerDomainConstructor then UNEMBED innerDomainConstructor + else UNEMBED domainConstructor + SETQ(_/TRACENAMES,delete(domainConstructor,_/TRACENAMES)) + +flattenOperationAlist(opAlist) == + res:= nil + for [op,:mmList] in opAlist repeat + res:=[:res,:[[op,:mm] for mm in mmList]] + res + +mapLetPrint(x,val,currentFunction) == + x:= getAliasIfTracedMapParameter(x,currentFunction) + currentFunction:= getBpiNameIfTracedMap currentFunction + letPrint(x,val,currentFunction) + +-- This is the version for use when we have no idea +-- what print representation to use for the data object + +letPrint(x,val,currentFunction) == + if $letAssoc and + ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= LASSOC("all",$letAssoc))) then + if (y="all" or MEMQ(x,y)) and + not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then + sayBrightlyNT [:bright x,": "] + PRIN0 shortenForPrinting val + TERPRI() + if (y:= hasPair("BREAK",y)) and + (y="all" or MEMQ(x,y) and + (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then + break [:bright currentFunction,'"breaks after",:bright x,'":= ", + shortenForPrinting val] + val + +-- This is the version for use when we have already +-- converted the data into type "Expression" +letPrint2(x,printform,currentFunction) == + $BreakMode:local + 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 + 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} |