From 9b71e0a1f285fc207709cf8e90721160af299127 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 03:47:46 +0000 Subject: remove pamphlets - part 3 --- src/interp/clam.boot.pamphlet | 729 ------------------------------------------ 1 file changed, 729 deletions(-) delete mode 100644 src/interp/clam.boot.pamphlet (limited to 'src/interp/clam.boot.pamphlet') diff --git a/src/interp/clam.boot.pamphlet b/src/interp/clam.boot.pamphlet deleted file mode 100644 index d811c00a..00000000 --- a/src/interp/clam.boot.pamphlet +++ /dev/null @@ -1,729 +0,0 @@ -\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} -<>= --- 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 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: --- (, ,:) --- 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 given by f(), the structure - -- ((nil )) 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} -- cgit v1.2.3