aboutsummaryrefslogtreecommitdiff
path: root/src/interp/clam.boot
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2007-09-20 03:47:46 +0000
committerdos-reis <gdr@axiomatics.org>2007-09-20 03:47:46 +0000
commit9b71e0a1f285fc207709cf8e90721160af299127 (patch)
tree3e64539a50da8370ac70d3556a34b4ddb67627bc /src/interp/clam.boot
parenta0ea803003aecec7b3dfa8a0c1126fc439519d8f (diff)
downloadopen-axiom-9b71e0a1f285fc207709cf8e90721160af299127.tar.gz
remove pamphlets - part 3
Diffstat (limited to 'src/interp/clam.boot')
-rw-r--r--src/interp/clam.boot702
1 files changed, 702 insertions, 0 deletions
diff --git a/src/interp/clam.boot b/src/interp/clam.boot
new file mode 100644
index 00000000..3095753f
--- /dev/null
+++ b/src/interp/clam.boot
@@ -0,0 +1,702 @@
+-- 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.
+
+
+)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,'";"))