path: root/src/interp/trace.boot

-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2008, Gabriel Dos Reis.
-- 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.


import '"debug"
)package "BOOT"

--% Code for tracing functions

-- This code supports the )trace system command and allows the
-- tracing of LISP, BOOT and SPAD functions and interpreter maps.

$traceNoisely := NIL  -- give trace and untrace messages

$reportSpadTrace := NIL  -- reports traced funs

$optionAlist := NIL

$tracedMapSignatures := NIL

$traceOptionList == '(
    after _
    before _
    break_
    cond_
    count_
    depth_
    local_
    mathprint _
    nonquietly_
    nt_
    of_
    only_
    ops_
    restore_
    timer_
    varbreak _
    vars_
    within _
    )


$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)