diff options
Diffstat (limited to 'src/interp/trace.boot.pamphlet')
| -rw-r--r-- | src/interp/trace.boot.pamphlet | 856 |
1 files changed, 0 insertions, 856 deletions
diff --git a/src/interp/trace.boot.pamphlet b/src/interp/trace.boot.pamphlet deleted file mode 100644 index 1563ea98..00000000 --- a/src/interp/trace.boot.pamphlet +++ /dev/null @@ -1,856 +0,0 @@ -\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 _ - )) - - -SETANDFILEQ($lastUntraced,NIL) - -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} |