Initial population.

1 files changed, 729 insertions, 0 deletions

diff --git a/src/interp/clam.boot.pamphlet b/src/interp/clam.boot.pamphlet
new file mode 100644
index 00000000..d811c00a
--- /dev/null
+++ b/src/interp/clam.boot.pamphlet
@@ -0,0 +1,729 @@
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{/src/interp/clam.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>>
+
+)package "BOOT"
+
+--% Cache Lambda Facility
+-- for remembering previous values to functions
+ 
+--to CLAM a function f, there must be an entry on $clamList as follows:
+--    (functionName  --the name of the function to be CLAMed (e.g. f)
+--     kind          --"hash" or number of values to be stored in
+--                     circular list
+--     eqEtc         --the equal function to be used
+--                     (EQ, EQUAL, UEQUAL,..)
+--     "shift"       --(opt) for circular lists, shift most recently
+--                      used to front
+--     "count")      --(opt) use reference counts (see below)
+--
+-- Notes:
+--   Functions with "hash" as kind must give EQ, CVEC, or UEQUAL
+--   Functions with some other <identifier> as kind hashed as property
+--   lists with eqEtc used to compare entries
+--   Functions which have 0 arguments may only be CLAMmed when kind is
+--   identifier other than hash (circular/private hashtable for no args
+--   makes no sense)
+--
+--   Functions which have more than 1 argument must never be CLAMed with EQ
+--     since arguments are cached as lists
+--   For circular lists, "count" will do "shift"ing; entries with lowest
+--     use count are replaced
+--   For cache option without "count", all entries are cleared on garbage
+--     collection; For cache option with "count",
+--     entries have their use count set
+--     to 0 on garbage collection; those with 0 use count at garbage collection
+--     are cleared
+-- see definition of COMP,2 in COMP LISP which calls clamComp below
+ 
+-- see SETQ LISP for initial def of $hashNode
+ 
+compClam(op,argl,body,$clamList) ==
+  --similar to reportFunctionCompilation in SLAM BOOT
+  if $InteractiveMode then startTimingProcess 'compilation
+  if (u:= LASSQ(op,$clamList)) isnt [kind,eqEtc,:options]
+    then keyedSystemError("S2GE0004",[op])
+  $clamList:= nil            --clear to avoid looping
+  if u:= S_-(options,'(shift count)) then
+    keyedSystemError("S2GE0006",[op,:u])
+  shiftFl := MEMQ('shift,options)
+  countFl := MEMQ('count,options)
+  if #argl > 1 and eqEtc= 'EQ then
+    keyedSystemError("S2GE0007",[op])
+  (not IDENTP kind) and (not INTEGERP kind or kind < 1) =>
+    keyedSystemError("S2GE0005",[op])
+  IDENTP kind =>
+    shiftFl => keyedSystemError("S2GE0008",[op])
+    compHash(op,argl,body,(kind='hash => nil; kind),eqEtc,countFl)
+  cacheCount:= kind
+  if null argl then keyedSystemError("S2GE0009",[op])
+  phrase:=
+    cacheCount=1 => ['"computed value only"]
+    [:bright cacheCount,'"computed values"]
+  sayBrightly [:bright op,'"will save last",:phrase]
+  auxfn:= INTERNL(op,'";")
+  g1:= GENSYM()  --argument or argument list
+  [arg,computeValue] :=
+    argl is [.] => [[g1],[auxfn,g1]]  --g1 is a parameter
+    [g1,['APPLX,['function,auxfn],g1]]          --g1 is a parameter list
+  cacheName:= INTERNL(op,'";AL")
+  if $reportCounts=true then
+    hitCounter:= INTERNL(op,'";hit")
+    callCounter:= INTERNL(op,'";calls")
+    SET(hitCounter,0)
+    SET(callCounter,0)
+    callCountCode:= [['SETQ,callCounter,['QSADD1,callCounter]]]
+    hitCountCode:=  [['SETQ,hitCounter,['QSADD1,hitCounter]]]
+  g2:= GENSYM()  --length of cache or arg-value pair
+  g3:= GENSYM()  --value computed by calling function
+  lookUpFunction:=
+    shiftFl =>
+      countFl => 'assocCacheShiftCount
+      'assocCacheShift
+    countFl => 'assocCacheCount
+    'assocCache
+  returnFoundValue:=
+    countFl => ['CDDR,g3]
+    ['CDR,g3]
+  namePart:=
+    countFl => cacheName
+    MKQ cacheName
+  secondPredPair:=
+--   null argl => [cacheName]
+    [['SETQ,g3,[lookUpFunction,g1,namePart,eqEtc]],
+      :hitCountCode,
+        returnFoundValue]
+  resetCacheEntry:=
+    countFl => ['CONS,1,g2]
+    g2
+  thirdPredPair:=
+--   null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]]
+    ['(QUOTE T),
+      ['SETQ,g2,computeValue],
+        ['SETQ,g3,['CAR,cacheName]],
+          ['RPLACA,g3,g1],
+            ['RPLACD,g3,resetCacheEntry],
+              g2]
+  codeBody:= ['PROG,[g2,g3],
+                :callCountCode,
+                  ['RETURN,['COND,secondPredPair,thirdPredPair]]]
+  lamex:= ['LAM,arg,codeBody]
+  mainFunction:= [op,lamex]
+  computeFunction:= [auxfn,['LAMBDA,argl,:body]]
+ 
+  -- compile generated function stub
+  compileInteractive mainFunction
+ 
+  -- compile main body: this has already been compTran'ed
+  if $reportCompilation then
+    sayBrightlyI bright '"Generated LISP code for function:"
+    pp computeFunction
+  compileQuietly [computeFunction]
+ 
+  cacheType:= 'function
+  cacheResetCode:= ['SETQ,cacheName,['initCache,cacheCount]]
+  cacheCountCode:= ['countCircularAlist,cacheName,cacheCount]
+  cacheVector:= mkCacheVec(op,cacheName,cacheType,
+    cacheResetCode,cacheCountCode)
+  LAM_,EVALANDFILEACTQ ['PUT, MKQ op, MKQ 'cacheInfo, MKQ cacheVector]
+  LAM_,EVALANDFILEACTQ cacheResetCode
+  if $InteractiveMode then stopTimingProcess 'compilation
+  op
+ 
+compHash(op,argl,body,cacheNameOrNil,eqEtc,countFl) ==
+  --Note: when cacheNameOrNil^=nil, it names a global hashtable
+ 
+-- cacheNameOrNil => compHashGlobal(op,argl,body,cacheNameOrNil,eqEtc,countFl)
+--   This branch to compHashGlobal is now omitted; as a result,
+--   entries will be stored on the global hashtable in a uniform way:
+--        (<argument list>, <reference count>,:<value>)
+--   where the reference count is optional
+ 
+  if cacheNameOrNil and cacheNameOrNil^='_$ConstructorCache then
+    keyedSystemError("S2GE0010",[op])
+    --restriction due to omission of call to hputNewValue (see *** lines below)
+ 
+  if null argl then
+    null cacheNameOrNil => keyedSystemError("S2GE0011",[op])
+    nil
+  (not cacheNameOrNil) and (not MEMQ(eqEtc,'(EQ CVEC UEQUAL))) =>
+    keyedSystemError("S2GE0012",[op])
+--withWithout := (countFl => "with"; "without")
+--middle:=
+--  cacheNameOrNil => ["on","%b",cacheNameOrNil,"%d"]
+--  '"privately "
+--sayBrightly
+--  ["%b",op,"%d","hashes ",:middle,withWithout," reference counts"]
+  auxfn:= INTERNL(op,'";")
+  g1:= GENSYM()  --argument or argument list
+  [arg,cacheArgKey,computeValue] :=
+  --    arg: to be used as formal argument of lambda construction;
+  --    cacheArgKey: the form used to look up the value in the cache
+  --    computeValue: the form used to compute the value from arg
+    null argl => [nil,nil,[auxfn]]
+    argl is [.] =>
+      key:= (cacheNameOrNil => ['devaluate,g1]; g1)
+      [[g1],['LIST,key],[auxfn,g1]]  --g1 is a parameter
+    key:= (cacheNameOrNil => ['devaluateList,g1] ; g1)
+    [g1,key,['APPLY,['function,auxfn],g1]]   --g1 is a parameter list
+  cacheName:= cacheNameOrNil or INTERNL(op,'";AL")
+  if $reportCounts=true then
+    hitCounter:= INTERNL(op,'";hit")
+    callCounter:= INTERNL(op,'";calls")
+    SET(hitCounter,0)
+    SET(callCounter,0)
+    callCountCode:= [['SETQ,callCounter,['QSADD1,callCounter]]]
+    hitCountCode:=  [['SETQ,hitCounter,['QSADD1,hitCounter]]]
+  g2:= GENSYM()  --value computed by calling function
+  returnFoundValue:=
+    null argl =>
+    --  if we have a global hastable, functions with no arguments are
+    --  stored in the same format as those with several arguments, e.g.
+    --  to cache the value <val> given by f(), the structure
+    --  ((nil <count> <val>)) is stored in the cache
+      countFl => ['CDRwithIncrement,['CDAR,g2]]
+      ['CDAR,g2]
+    countFl => ['CDRwithIncrement,g2]
+    g2
+  getCode:=
+    null argl => ['HGET,cacheName,MKQ op]
+    cacheNameOrNil =>
+      eqEtc^='EQUAL =>
+        ['lassocShiftWithFunction,cacheArgKey,
+          ['HGET,cacheNameOrNil,MKQ op],MKQ eqEtc]
+      ['lassocShift,cacheArgKey,['HGET,cacheNameOrNil,MKQ op]]
+    ['HGET,cacheName,g1]
+  secondPredPair:= [['SETQ,g2,getCode],:hitCountCode,returnFoundValue]
+  putCode:=
+    null argl =>
+      cacheNameOrNil =>
+        countFl => ['CDDAR,['HPUT,cacheNameOrNil,MKQ op,
+                      ['LIST,['CONS,nil,['CONS,1,computeValue]]]]]
+        ['HPUT,cacheNameOrNil,MKQ op,['LIST,['CONS,nil,computeValue]]]
+      systemError '"unexpected"
+    cacheNameOrNil => computeValue
+    --countFl => ['CDR,['hputNewProp,cacheNameOrNil,MKQ op,cacheArgKey, --***
+    --             ['CONS,1,computeValue]]]                             --***
+    --['hputNewProp,cacheNameOrNil,MKQ op,cacheArgKey,computeValue]    --***
+    countFl => ['CDR,['HPUT,cacheName,g1,['CONS,1,computeValue]]]
+    ['HPUT,cacheName,g1,computeValue]
+  if cacheNameOrNil then putCode :=
+     ['UNWIND_-PROTECT,['PROG1,putCode,['SETQ,g2,'T]],
+                  ['COND,[['NOT,g2],['HREM,cacheName,MKQ op]]]]
+  thirdPredPair:= ['(QUOTE T),putCode]
+  codeBody:= ['PROG,[g2],
+               :callCountCode,['RETURN,['COND,secondPredPair,thirdPredPair]]]
+  lamex:= ['LAM,arg,codeBody]
+  mainFunction:= [op,lamex]
+  computeFunction:= [auxfn,['LAMBDA,argl,:body]]
+ 
+  -- compile generated function stub
+  compileInteractive mainFunction
+ 
+  -- compile main body: this has already been compTran'ed
+  if $reportCompilation then
+    sayBrightlyI bright '"Generated LISP code for function:"
+    pp computeFunction
+  compileQuietly [computeFunction]
+ 
+  if null cacheNameOrNil then
+    cacheType:=
+      countFl => 'hash_-tableWithCounts
+      'hash_-table
+    weakStrong:= (countFl => 'STRONG; 'WEAK)
+      --note: WEAK means that key/value pairs disappear at garbage collection
+    cacheResetCode:=
+      ['SETQ,cacheName,['MAKE_-HASHTABLE,MKQ eqEtc]]
+    cacheCountCode:= ['hashCount,cacheName]
+    cacheVector:=
+      mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode)
+    LAM_,EVALANDFILEACTQ ['PUT, MKQ op, MKQ 'cacheInfo, MKQ cacheVector]
+    LAM_,EVALANDFILEACTQ cacheResetCode
+  op
+ 
+compHashGlobal(op,argl,body,cacheName,eqEtc,countFl) ==
+  --Note: when cacheNameOrNil^=nil, it names a global hashtable
+ 
+  if (not MEMQ(eqEtc,'(UEQUAL))) then
+    sayBrightly "for hash option, only EQ, CVEC, and UEQUAL are allowed"
+  auxfn:= INTERNL(op,'";")
+  g1:= GENSYM()  --argument or argument list
+  [arg,cacheArgKey,computeValue] :=
+  --    arg: to be used as formal argument of lambda construction;
+  --    cacheArgKey: the form used to look up the value in the cache
+  --    computeValue: the form used to compute the value from arg
+    application:=
+      null argl => [auxfn]
+      argl is [.] => [auxfn,g1]  --g1 is a parameter
+      ['APPLX,['function,auxfn],g1]          --g1 is a parameter list
+    [g1,['consForHashLookup,MKQ op,g1],application]
+  g2:= GENSYM()  --value computed by calling function
+  returnFoundValue:=
+    countFl => ['CDRwithIncrement,g2]
+    g2
+  getCode:= ['HGET,cacheName,cacheArgKey]
+  secondPredPair:= [['SETQ,g2,getCode],returnFoundValue]
+  putForm:= ['CONS,MKQ op,g1]
+  putCode:=
+    countFl => ['HPUT,cacheName,putForm,['CONS,1,computeValue]]
+    ['HPUT,cacheName,putForm,computeValue]
+  thirdPredPair:= ['(QUOTE T),putCode]
+  codeBody:= ['PROG,[g2], ['RETURN,['COND,secondPredPair,thirdPredPair]]]
+  lamex:= ['LAM,arg,codeBody]
+  mainFunction:= [op,lamex]
+  computeFunction:= [auxfn,['LAMBDA,argl,:body]]
+  compileInteractive mainFunction
+  compileInteractive computeFunction
+  op
+ 
+consForHashLookup(a,b) ==
+  RPLACA($hashNode,a)
+  RPLACD($hashNode,b)
+  $hashNode
+ 
+CDRwithIncrement x ==
+  RPLACA(x,QSADD1 CAR x)
+  CDR x
+ 
+HGETandCount(hashTable,prop) ==
+  u:= HGET(hashTable,prop) or return nil
+  RPLACA(u,QSADD1 CAR u)
+  u
+ 
+clearClams() ==
+  for [fn,kind,:.] in $clamList | kind = 'hash or INTEGERP kind repeat
+    clearClam fn
+ 
+clearClam fn ==
+  infovec:= GETL(fn,'cacheInfo) or keyedSystemError("S2GE0003",[fn])
+  eval infovec.cacheReset
+ 
+reportAndClearClams() ==
+  cacheStats()
+  clearClams()
+ 
+clearConstructorCaches() ==
+  clearCategoryCaches()
+  CLRHASH $ConstructorCache
+ 
+clearConstructorCache(cname) ==
+  (kind := GETDATABASE(cname,'CONSTRUCTORKIND)) =>
+    kind = 'category => clearCategoryCache cname
+    HREM($ConstructorCache,cname)
+ 
+clearConstructorAndLisplibCaches() ==
+  clearClams()
+  clearConstructorCaches()
+ 
+clearCategoryCaches() ==
+  for name in allConstructors() repeat
+    if GETDATABASE(name,'CONSTRUCTORKIND) = 'category then
+      if BOUNDP(cacheName:= INTERNL STRCONC(PNAME name,'";AL"))
+            then SET(cacheName,nil)
+    if BOUNDP(cacheName:= INTERNL STRCONC(PNAME name,'";CAT"))
+          then SET(cacheName,nil)
+ 
+clearCategoryCache catName ==
+  cacheName:= INTERNL STRCONC(PNAME catName,'";AL")
+  SET(cacheName,nil)
+ 
+displayHashtable x ==
+  l:= NREVERSE SORTBY('CAR,[[opOf HGET(x,key),key] for key in HKEYS x])
+  for [a,b] in l repeat
+    sayBrightlyNT ['%b,a,'%d]
+    pp b
+ 
+cacheStats() ==
+  for [fn,kind,:u] in $clamList repeat
+    not MEMQ('count,u) =>
+      sayBrightly ["%b",fn,"%d","does not keep reference counts"]
+    INTEGERP kind => reportCircularCacheStats(fn,kind)
+    kind = 'hash => reportHashCacheStats fn
+    sayBrightly ["Unknown cache type for","%b",fn,"%d"]
+ 
+reportCircularCacheStats(fn,n) ==
+  infovec:= GETL(fn,'cacheInfo)
+  circList:= eval infovec.cacheName
+  numberUsed :=
+    +/[1 for i in 1..n for x in circList while x isnt [='_$failed,:.]]
+  sayBrightly ["%b",fn,"%d","has","%b",numberUsed,"%d","/ ",n," values cached"]
+  displayCacheFrequency mkCircularCountAlist(circList,n)
+  TERPRI()
+ 
+displayCacheFrequency al ==
+  al := NREVERSE SORTBY('CAR,al)
+  sayBrightlyNT "    #hits/#occurrences: "
+  for [a,:b] in al repeat sayBrightlyNT [a,"/",b,"  "]
+  TERPRI()
+ 
+mkCircularCountAlist(cl,len) ==
+  for [x,count,:.] in cl for i in 1..len while x ^= '_$failed repeat
+    u:= ASSOC(count,al) => RPLACD(u,1 + CDR u)
+    if INTEGERP $reportFavoritesIfNumber and count >= $reportFavoritesIfNumber then
+      sayBrightlyNT ["   ",count,"  "]
+      pp x
+    al:= [[count,:1],:al]
+  al
+ 
+reportHashCacheStats fn ==
+  infovec:= GETL(fn,'cacheInfo)
+  hashTable:= eval infovec.cacheName
+  hashValues:= [HGET(hashTable,key) for key in HKEYS hashTable]
+  sayBrightly [:bright fn,'"has",:bright(# hashValues),'"values cached."]
+  displayCacheFrequency mkHashCountAlist hashValues
+  TERPRI()
+ 
+mkHashCountAlist vl ==
+  for [count,:.] in vl repeat
+    u:= ASSOC(count,al) => RPLACD(u,1 + CDR u)
+    al:= [[count,:1],:al]
+  al
+ 
+clearHashReferenceCounts() ==
+  --free all cells with 0 reference counts; clear other counts to 0
+  for x in $clamList repeat
+    x.cacheType='hash_-tableWithCounts =>
+      remHashEntriesWith0Count eval x.cacheName
+    x.cacheType='hash_-table => CLRHASH eval x.cacheName
+ 
+remHashEntriesWith0Count $hashTable ==
+  MAPHASH(fn,$hashTable) where fn(key,obj) ==
+    CAR obj = 0 => HREM($hashTable,key)  --free store
+    nil
+ 
+initCache n ==
+  tail:= '(0 . $failed)
+  l:= [[$failed,:tail] for i in 1..n]
+  RPLACD(LASTNODE l,l)
+ 
+assocCache(x,cacheName,fn) ==
+  --fn=equality function; do not SHIFT or COUNT
+  al:= eval cacheName
+  forwardPointer:= al
+  val:= nil
+  until EQ(forwardPointer,al) repeat
+    FUNCALL(fn,CAAR forwardPointer,x) => return (val:= CAR forwardPointer)
+    backPointer:= forwardPointer
+    forwardPointer:= CDR forwardPointer
+  val => val
+  SET(cacheName,backPointer)
+  nil
+ 
+assocCacheShift(x,cacheName,fn) ==  --like ASSOC except that al is circular
+  --fn=equality function; SHIFT but do not COUNT
+  al:= eval cacheName
+  forwardPointer:= al
+  val:= nil
+  until EQ(forwardPointer,al) repeat
+    FUNCALL(fn, CAR (y:=CAR forwardPointer),x) =>
+      if not EQ(forwardPointer,al) then   --shift referenced entry to front
+        RPLACA(forwardPointer,CAR al)
+        RPLACA(al,y)
+      return (val:= y)
+    backPointer := forwardPointer      --CAR is slot replaced on failure
+    forwardPointer:= CDR forwardPointer
+  val => val
+  SET(cacheName,backPointer)
+  nil
+ 
+assocCacheShiftCount(x,al,fn) ==
+  -- if x is found, entry containing x becomes first element of list; if
+  -- x is not found, entry with smallest use count is shifted to front so
+  -- as to be replaced
+  --fn=equality function; COUNT and SHIFT
+  forwardPointer:= al
+  val:= nil
+  minCount:= 10000 --preset minCount but not newFrontPointer here
+  until EQ(forwardPointer,al) repeat
+    FUNCALL(fn, CAR (y:=CAR forwardPointer),x) =>
+      newFrontPointer := forwardPointer
+      RPLAC(CADR y,QSADD1 CADR y)         --increment use count
+      return (val:= y)
+    if QSLESSP(c := CADR y,minCount) then --initial c is 1 so is true 1st time
+      minCount := c
+      newFrontPointer := forwardPointer   --CAR is slot replaced on failure
+    forwardPointer:= CDR forwardPointer
+  if not EQ(newFrontPointer,al) then       --shift referenced entry to front
+    temp:= CAR newFrontPointer             --or entry with smallest count
+    RPLACA(newFrontPointer,CAR al)
+    RPLACA(al,temp)
+  val
+ 
+clamStats() ==
+  for [op,kind,:.] in $clamList repeat
+    cacheVec:= GETL(op,'cacheInfo) or systemErrorHere "clamStats"
+    prefix:=
+      $reportCounts^= true => nil
+      hitCounter:= INTERNL(op,'";hit")
+      callCounter:= INTERNL(op,'";calls")
+      res:= ["%b",eval hitCounter,"/",eval callCounter,"%d","calls to "]
+      SET(hitCounter,0)
+      SET(callCounter,0)
+      res
+    postString:=
+      cacheValue:= eval cacheVec.cacheName
+      kind = 'hash => [" (","%b",HASH_-TABLE_-COUNT cacheValue,"%d","entries)"]
+      empties:= numberOfEmptySlots eval cacheVec.cacheName
+      empties = 0 => nil
+      [" (","%b",kind-empties,"/",kind,"%d","slots used)"]
+    sayBrightly
+      [:prefix,op,:postString]
+ 
+numberOfEmptySlots cache==
+  count:= (CAAR cache ='$failed => 1; 0)
+  for x in tails rest cache while NE(x,cache) repeat
+    if CAAR x='$failed then count:= count+1
+  count
+ 
+addToSlam([name,:argnames],shell) ==
+  $mutableDomain => return nil
+  null argnames => addToConstructorCache(name,nil,shell)
+  args:= ['LIST,:[mkDevaluate a for a in argnames]]
+  addToConstructorCache(name,args,shell)
+ 
+addToConstructorCache(op,args,value) ==
+  ['haddProp,'$ConstructorCache,MKQ op,args,['CONS,1,value]]
+ 
+haddProp(ht,op,prop,val) ==
+  --called inside functors (except for union and record types ??)
+  --presently, ht always = $ConstructorCache
+  statRecordInstantiationEvent()
+  if $reportInstantiations = true or $reportEachInstantiation = true then
+    startTimingProcess 'debug
+    recordInstantiation(op,prop,false)
+    stopTimingProcess 'debug
+  u:= HGET(ht,op) =>     --hope that one exists most of the time
+    ASSOC(prop,u) => val     --value is already there--must = val; exit now
+    RPLACD(u,[CAR u,:CDR u])
+    RPLACA(u,[prop,:val])
+    $op: local := op
+    listTruncate(u,20)        --save at most 20 instantiations
+    val
+  HPUT(ht,op,[[prop,:val]])
+  val
+ 
+recordInstantiation(op,prop,dropIfTrue) ==
+  startTimingProcess 'debug
+  recordInstantiation1(op,prop,dropIfTrue)
+  stopTimingProcess 'debug
+ 
+recordInstantiation1(op,prop,dropIfTrue) ==
+  op in '(CategoryDefaults RepeatedSquaring) => nil--ignore defaults for now
+  if $reportEachInstantiation = true then
+    trailer:= (dropIfTrue => '"  dropped"; '"  instantiated")
+    if $insideCoerceInteractive= true then
+      $instantCoerceCount:= 1+$instantCoerceCount
+    if $insideCanCoerceFrom is [m1,m2] and null dropIfTrue then
+      $instantCanCoerceCount:= 1+$instantCanCoerceCount
+      xtra:=
+        ['" for ",outputDomainConstructor m1,'"-->",outputDomainConstructor m2]
+    if $insideEvalMmCondIfTrue = true and null dropIfTrue then
+      $instantMmCondCount:= $instantMmCondCount + 1
+    typeTimePrin ["CONCAT",outputDomainConstructor [op,:prop],trailer,:xtra]
+  null $reportInstantiations => nil
+  u:= HGET($instantRecord,op) =>     --hope that one exists most of the time
+    v := LASSOC(prop,u) =>
+      dropIfTrue => RPLAC(CDR v,1+CDR v)
+      RPLAC(CAR v,1+CAR v)
+    RPLACD(u,[CAR u,:CDR u])
+    val :=
+      dropIfTrue => [0,:1]
+      [1,:0]
+    RPLACA(u,[prop,:val])
+  val :=
+    dropIfTrue => [0,:1]
+    [1,:0]
+  HPUT($instantRecord,op,[[prop,:val]])
+ 
+reportInstantiations() ==
+  --assumed to be a hashtable with reference counts
+    conList:=
+      [:[[n,m,[key,:argList]] for [argList,n,:m] in HGET($instantRecord,key)]
+        for key in HKEYS $instantRecord]
+    sayBrightly ['"# instantiated/# dropped/domain name",
+      "%l",'"------------------------------------"]
+    nTotal:= mTotal:= rTotal := nForms:= 0
+    for [n,m,form] in NREVERSE SORTBY('CADDR,conList) repeat
+      nTotal:= nTotal+n; mTotal:= mTotal+m
+      if n > 1 then rTotal:= rTotal + n-1
+      nForms:= nForms + 1
+      typeTimePrin ['CONCATB,n,m,outputDomainConstructor form]
+    sayBrightly ["%b",'"Totals:","%d",nTotal,'" instantiated","%l",
+      '"         ",$instantCoerceCount,'" inside coerceInteractive","%l",
+       '"         ",$instantCanCoerceCount,'" inside canCoerceFrom","%l",
+        '"         ",$instantMmCondCount,'" inside evalMmCond","%l",
+         '"         ",rTotal,'" reinstantiated","%l",
+          '"         ",mTotal,'" dropped","%l",
+           '"         ",nForms,'" distinct domains instantiated/dropped"]
+ 
+hputNewProp(ht,op,argList,val) ==
+  --NOTE: obselete if lines *** are commented out
+  -- Warning!!!  This function should only be called for
+  -- $ConstructorCache slamming --- since it maps devaluate onto prop, an
+  -- argument list
+  --
+  -- This function may be called when property is already there; for
+  -- example, Polynomial applied to '(Integer), not finding it in the
+  -- cache will invoke Polynomial to compute it; inside of Polynomial is
+  -- a call to this function which will hputNewProp the property onto the
+  -- cache so that when this function is called by the outer Polynomial,
+  -- the value will always be there
+ 
+  prop:= [devaluate x for x in argList]
+  haddProp(ht,op,prop,val)
+ 
+listTruncate(l,n) ==
+  u:= l
+  n:= QSSUB1 n
+  while NEQ(n,0) and null atom u repeat
+    n:= QSSUB1 n
+    u:= QCDR u
+  if null atom u then
+    if null atom rest u and $reportInstantiations = true then
+      recordInstantiation($op,CAADR u,true)
+    RPLACD(u,nil)
+  l
+ 
+lassocShift(x,l) ==
+  y:= l
+  while not atom y repeat
+    EQUAL(x,CAR QCAR y) => return (result := QCAR y)
+    y:= QCDR y
+  result =>
+    if NEQ(y,l) then
+      QRPLACA(y,CAR l)
+      QRPLACA(l,result)
+    QCDR result
+  nil
+ 
+lassocShiftWithFunction(x,l,fn) ==
+  y:= l
+  while not atom y repeat
+    FUNCALL(fn,x,CAR QCAR y) => return (result := QCAR y)
+    y:= QCDR y
+  result =>
+    if NEQ(y,l) then
+      QRPLACA(y,CAR l)
+      QRPLACA(l,result)
+    QCDR result
+  nil
+ 
+lassocShiftQ(x,l) ==
+  y:= l
+  while not atom y repeat
+    EQ(x,CAR CAR y) => return (result := CAR y)
+    y:= CDR y
+  result =>
+    if NEQ(y,l) then
+      RPLACA(y,CAR l)
+      RPLACA(l,result)
+    CDR result
+  nil
+ 
+-- rassocShiftQ(x,l) ==
+--   y:= l
+--   while not atom y repeat
+--     EQ(x,CDR CAR y) => return (result := CAR y)
+--     y:= CDR y
+--   result =>
+--     if NEQ(y,l) then
+--       RPLACA(y,CAR l)
+--       RPLACA(l,result)
+--     CAR result
+--   nil
+ 
+globalHashtableStats(x,sortFn) ==
+  --assumed to be a hashtable with reference counts
+  keys:= HKEYS x
+  for key in keys repeat
+    u:= HGET(x,key)
+    for [argList,n,:.] in u repeat
+      not INTEGERP n =>   keyedSystemError("S2GE0013",[x])
+      argList1:= [constructor2ConstructorForm x for x in argList]
+      reportList:= [[n,key,argList1],:reportList]
+  sayBrightly ["%b","  USE  NAME ARGS","%d"]
+  for [n,fn,args] in NREVERSE SORTBY(sortFn,reportList) repeat
+    sayBrightlyNT [:rightJustifyString(n,6),"  ",fn,": "]
+    pp args
+ 
+constructor2ConstructorForm x ==
+  VECP x => x.0
+  x
+ 
+rightJustifyString(x,maxWidth) ==
+  size:= entryWidth x
+  size > maxWidth => keyedSystemError("S2GE0014",[x])
+  [fillerSpaces(maxWidth-size," "),x]
+ 
+domainEqualList(argl1,argl2) ==
+  --function used to match argument lists of constructors
+  while argl1 and argl2 repeat
+    item1:= devaluate CAR argl1
+    item2:= CAR argl2
+    partsMatch:=
+      item1 = item2 => true
+      false
+    null partsMatch => return nil
+    argl1:= rest argl1; argl2 := rest argl2
+  argl1 or argl2 => nil
+  true
+ 
+removeAllClams() ==
+  for [fun,:.] in $clamList repeat
+    sayBrightly ['"Un-clamming function",'%b,fun,'%d]
+    SET(fun,eval INTERN STRCONC(STRINGIMAGE fun,'";"))
+@
+
+
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}