diff --git a/changelog b/changelog index 6ff3d2d..694be24 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,8 @@ +20090813 tpd src/axiom-website/patches.html 20090813.01.tpd.patch +20090813 tpd src/interp/Makefile move clam.boot to clam.lisp +20090813 tpd src/interp/debugsys.lisp change astr.clisp to clam.lisp +20090813 tpd src/interp/clam.lisp added, rewritten from clam.boot +20090813 tpd src/interp/clam.boot removed, rewritten to clam.lisp 20090812 tpd src/axiom-website/patches.html 20090812.02.tpd.patch 20090812 tpd src/interp/Makefile move cformat.boot to cformat.lisp 20090812 tpd src/interp/debugsys.lisp change astr.clisp to cformat.lisp diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index d01dc62..2b1549f 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1778,6 +1778,8 @@ dq.lisp rewrite from boot to lisp
cattable.lisp rewrite from boot to lisp
20090812.02.tpd.patch cformat.lisp rewrite from boot to lisp
+20090813.01.tpd.patch +clam.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index c82c99b..adce7d1 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -416,7 +416,7 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/br-con.boot.dvi \ ${DOC}/category.boot.dvi \ ${DOC}/c-doc.boot.dvi \ - ${DOC}/cfuns.lisp.dvi ${DOC}/clam.boot.dvi \ + ${DOC}/cfuns.lisp.dvi \ ${DOC}/clammed.boot.dvi ${DOC}/compat.boot.dvi \ ${DOC}/compiler.boot.dvi \ ${DOC}/compress.boot.dvi \ @@ -739,7 +739,7 @@ ${DEPSYS}: ${DEP} ${OUT}/sys-pkg.${LISP} ${OUT}/nocompil.${LISP} \ ${OUT}/postprop.${LISP} \ ${OUT}/g-boot.${LISP} ${OUT}/c-util.${LISP} \ ${OUT}/g-util.${LISP} \ - ${OUT}/clam.${LISP} \ + ${OUT}/clam.lisp \ ${OUT}/slam.${LISP} ${LOADSYS} @ echo 3 making ${DEPSYS} @ echo '${PROCLAIMS}' > ${OUT}/makedep.lisp @@ -768,7 +768,7 @@ ${DEPSYS}: ${DEP} ${OUT}/sys-pkg.${LISP} ${OUT}/nocompil.${LISP} \ ':output-file "${OUT}/postprop.${O}"))' >> ${OUT}/makedep.lisp @ echo '(load "${OUT}/postprop")' >> ${OUT}/makedep.lisp @ echo '(unless (probe-file "${OUT}/clam.${O}")' \ - '(compile-file "${OUT}/clam.${LISP}"' \ + '(compile-file "${OUT}/clam.lisp"' \ ':output-file "${OUT}/clam.${O}"))' >> ${OUT}/makedep.lisp @ echo '(load "${OUT}/clam")' >> ${OUT}/makedep.lisp @ echo '(unless (probe-file "${OUT}/slam.${O}")' \ @@ -1625,6 +1625,7 @@ ${MID}/alql.lisp: ${IN}/alql.lisp.pamphlet ${TANGLE} ${IN}/alql.lisp.pamphlet >alql.lisp ) @ + \subsection{buildom.lisp} <>= ${OUT}/buildom.${O}: ${MID}/buildom.lisp @@ -2534,62 +2535,34 @@ ${DOC}/c-doc.boot.dvi: ${IN}/c-doc.boot.pamphlet @ -\subsection{clam.boot \cite{61}} -Note that the {\bf clam.boot.pamphlet} file contains both the -original {\bf boot} code and a saved copy of the {\bf clam.clisp} -code. We need to keep the translated code around so we can bootstrap -the system. In other words, we need this boot code translated so we -can build the boot translator. - -{\bf note: if you change the boot code in clam.boot.pamphlet -you must translate this code to lisp and store the resulting lisp -code back into the clam.boot.pamphlet file. this is not automated.} -<>= -${OUT}/clam.${LISP}: ${IN}/clam.boot.pamphlet - @ echo 221 making ${OUT}/clam.${LISP} from ${IN}/clam.boot.pamphlet - @ rm -f ${OUT}/clam.${O} - @( cd ${OUT} ; \ - ${TANGLE} -Rclam.clisp ${IN}/clam.boot.pamphlet >clam.${LISP} ) - -@ +\subsection{clam.lisp} <>= -${OUT}/clam.${O}: ${MID}/clam.clisp - @ echo 222 making ${OUT}/clam.${O} from ${MID}/clam.clisp - @ (cd ${MID} ; \ +${OUT}/clam.${O}: ${MID}/clam.lisp + @ echo 136 making ${OUT}/clam.${O} from ${MID}/clam.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/clam.clisp"' \ + echo '(progn (compile-file "${MID}/clam.lisp"' \ ':output-file "${OUT}/clam.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/clam.clisp"' \ + echo '(progn (compile-file "${MID}/clam.lisp"' \ ':output-file "${OUT}/clam.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/clam.clisp: ${IN}/clam.boot.pamphlet - @ echo 223 making ${MID}/clam.clisp from ${IN}/clam.boot.pamphlet +<>= +${MID}/clam.lisp: ${IN}/clam.lisp.pamphlet + @ echo 137 making ${MID}/clam.lisp from ${IN}/clam.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/clam.boot.pamphlet >clam.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "clam.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "clam.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm clam.boot ) + ${TANGLE} ${IN}/clam.lisp.pamphlet >clam.lisp ) @ -<>= -${DOC}/clam.boot.dvi: ${IN}/clam.boot.pamphlet - @echo 224 making ${DOC}/clam.boot.dvi from ${IN}/clam.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/clam.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} clam.boot ; \ - rm -f ${DOC}/clam.boot.pamphlet ; \ - rm -f ${DOC}/clam.boot.tex ; \ - rm -f ${DOC}/clam.boot ) +<>= +${OUT}/clam.lisp: ${IN}/clam.lisp.pamphlet + @ echo 221 making ${OUT}/clam.lisp from ${IN}/clam.boot.pamphlet + @ rm -f ${OUT}/clam.${O} + @( cd ${OUT} ; \ + ${TANGLE} ${IN}/clam.lisp.pamphlet >clam.lisp ) @ @@ -6840,8 +6813,7 @@ clean: <> <> -<> -<> +<> <> <> @@ -7418,7 +7390,6 @@ pp \bibitem{57} {\bf \$SPAD/src/interp/nag-s.boot.pamphlet} \bibitem{58} {\bf \$SPAD/src/interp/category.boot.pamphlet} \bibitem{60} {\bf \$SPAD/src/interp/c-doc.boot.pamphlet} -\bibitem{61} {\bf \$SPAD/src/interp/clam.boot.pamphlet} \bibitem{62} {\bf \$SPAD/src/interp/clammed.boot.pamphlet} \bibitem{63} {\bf \$SPAD/src/interp/compat.boot.pamphlet} \bibitem{64} {\bf \$SPAD/src/interp/compiler.boot.pamphlet} diff --git a/src/interp/clam.boot.pamphlet b/src/interp/clam.boot.pamphlet deleted file mode 100644 index 5519cd5..0000000 --- a/src/interp/clam.boot.pamphlet +++ /dev/null @@ -1,3048 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp clam.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{Bootstrap Code issue} -This file contains both the {\bf boot} code and the {\bf Lisp} -code that is the result of the {\bf boot to lisp} translation. -We need to keep the translated code around so we can bootstrap -the system. In other words, we need this boot code translated -so we can build the boot translator. - -{\bf NOTE WELL: IF YOU CHANGE THIS BOOT CODE YOU MUST TRANSLATE -THIS CODE TO LISP AND STORE THE RESULTING LISP CODE BACK INTO -THIS FILE.} - -See the {\bf clam.clisp} section below. -\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. - -@ -<<*>>= -<> - ---% 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:= GET(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:= GET(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:= GET(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:= GET(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,'";")) -@ -\section{clam.clisp} -<>= - -(in-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 - -;;; *** |compClam| REDEFINED - -(DEFUN |compClam| (|op| |argl| |body| |$clamList|) - (DECLARE (SPECIAL |$clamList|)) - (PROG (|ISTMP#1| |kind| |ISTMP#2| |eqEtc| |options| |u| |shiftFl| |countFl| - |cacheCount| |phrase| |auxfn| |g1| |LETTMP#1| |arg| |computeValue| - |cacheName| |hitCounter| |callCounter| |callCountCode| |hitCountCode| - |g2| |g3| |lookUpFunction| |returnFoundValue| |namePart| - |secondPredPair| |resetCacheEntry| |thirdPredPair| |codeBody| |lamex| - |mainFunction| |computeFunction| |cacheType| |cacheResetCode| - |cacheCountCode| |cacheVector|) - (RETURN - (PROGN - (COND - (|$InteractiveMode| (|startTimingProcess| (QUOTE |compilation|)))) - (COND - ((NULL - (PROGN - (SPADLET |ISTMP#1| (SPADLET |u| (LASSQ |op| |$clamList|))) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |kind| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |eqEtc| (QCAR |ISTMP#2|)) - (SPADLET |options| (QCDR |ISTMP#2|)) (QUOTE T))))))) - (|keyedSystemError| (QUOTE S2GE0004) (CONS |op| NIL)))) - (SPADLET |$clamList| NIL) - (COND - ((SPADLET |u| (S- |options| (QUOTE (|shift| |count|)))) - (|keyedSystemError| (QUOTE S2GE0006) (CONS |op| |u|)))) - (SPADLET |shiftFl| (MEMQ (QUOTE |shift|) |options|)) - (SPADLET |countFl| (MEMQ (QUOTE |count|) |options|)) - (COND - ((AND (> (|#| |argl|) 1) (BOOT-EQUAL |eqEtc| (QUOTE EQ))) - (|keyedSystemError| (QUOTE S2GE0007) (CONS |op| NIL)))) - (COND - ((AND (NULL (IDENTP |kind|)) (OR (NULL (INTEGERP |kind|)) (> 1 |kind|))) - (|keyedSystemError| (QUOTE S2GE0005) (CONS |op| NIL))) - ((IDENTP |kind|) - (COND - (|shiftFl| - (|keyedSystemError| (QUOTE S2GE0008) (CONS |op| NIL))) - ((QUOTE T) - (|compHash| |op| |argl| |body| - (COND - ((BOOT-EQUAL |kind| (QUOTE |hash|)) NIL) - ((QUOTE T) |kind|)) - |eqEtc| |countFl|)))) - ((QUOTE T) - (SPADLET |cacheCount| |kind|) - (COND - ((NULL |argl|) (|keyedSystemError| (QUOTE S2GE0009) (CONS |op| NIL)))) - (SPADLET |phrase| - (COND - ((EQL |cacheCount| 1) (CONS (MAKESTRING "computed value only") NIL)) - ((QUOTE T) - (APPEND - (|bright| |cacheCount|) - (CONS (MAKESTRING "computed values") NIL))))) - (|sayBrightly| - (APPEND (|bright| |op|) (CONS (MAKESTRING "will save last") |phrase|))) - (SPADLET |auxfn| (INTERNL |op| (MAKESTRING ";"))) - (SPADLET |g1| (GENSYM)) - (SPADLET |LETTMP#1| - (COND - ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) - (CONS (CONS |g1| NIL) (CONS (CONS |auxfn| (CONS |g1| NIL)) NIL))) - ((QUOTE T) - (CONS - |g1| - (CONS - (CONS - (QUOTE APPLX) - (CONS - (CONS (QUOTE |function|) (CONS |auxfn| NIL)) - (CONS |g1| NIL))) - NIL))))) - (SPADLET |arg| (CAR |LETTMP#1|)) - (SPADLET |computeValue| (CADR |LETTMP#1|)) - (SPADLET |cacheName| (INTERNL |op| (MAKESTRING ";AL"))) - (COND - ((BOOT-EQUAL |$reportCounts| (QUOTE T)) - (SPADLET |hitCounter| (INTERNL |op| (MAKESTRING ";hit"))) - (SPADLET |callCounter| (INTERNL |op| (MAKESTRING ";calls"))) - (SET |hitCounter| 0) - (SET |callCounter| 0) - (SPADLET |callCountCode| - (CONS - (CONS - (QUOTE SETQ) - (CONS - |callCounter| - (CONS (CONS (QUOTE QSADD1) (CONS |callCounter| NIL)) NIL))) - NIL)) - (SPADLET |hitCountCode| - (CONS - (CONS - (QUOTE SETQ) - (CONS - |hitCounter| - (CONS (CONS (QUOTE QSADD1) (CONS |hitCounter| NIL)) NIL))) - NIL)))) - (SPADLET |g2| (GENSYM)) - (SPADLET |g3| (GENSYM)) - (SPADLET |lookUpFunction| - (COND - (|shiftFl| - (COND - (|countFl| (QUOTE |assocCacheShiftCount|)) - ((QUOTE T) (QUOTE |assocCacheShift|)))) - (|countFl| (QUOTE |assocCacheCount|)) - ((QUOTE T) (QUOTE |assocCache|)))) - (SPADLET |returnFoundValue| - (COND - (|countFl| (CONS (QUOTE CDDR) (CONS |g3| NIL))) - ((QUOTE T) (CONS (QUOTE CDR) (CONS |g3| NIL))))) - (SPADLET |namePart| - (COND (|countFl| |cacheName|) ((QUOTE T) (MKQ |cacheName|)))) - (SPADLET |secondPredPair| - (CONS - (CONS - (QUOTE SETQ) - (CONS - |g3| - (CONS - (CONS - |lookUpFunction| - (CONS |g1| (CONS |namePart| (CONS |eqEtc| NIL)))) - NIL))) - (APPEND |hitCountCode| (CONS |returnFoundValue| NIL)))) - (SPADLET |resetCacheEntry| - (COND - (|countFl| - (CONS (QUOTE CONS) (CONS 1 (CONS |g2| NIL)))) ((QUOTE T) |g2|))) - (SPADLET |thirdPredPair| - (CONS - (QUOTE (QUOTE T)) - (CONS - (CONS (QUOTE SETQ) (CONS |g2| (CONS |computeValue| NIL))) - (CONS - (CONS - (QUOTE SETQ) - (CONS |g3| (CONS (CONS (QUOTE CAR) (CONS |cacheName| NIL)) NIL))) - (CONS - (CONS (QUOTE RPLACA) (CONS |g3| (CONS |g1| NIL))) - (CONS - (CONS (QUOTE RPLACD) (CONS |g3| (CONS |resetCacheEntry| NIL))) - (CONS |g2| NIL))))))) - (SPADLET |codeBody| - (CONS - (QUOTE PROG) - (CONS - (CONS |g2| (CONS |g3| NIL)) - (APPEND |callCountCode| - (CONS - (CONS - (QUOTE RETURN) - (CONS - (CONS - (QUOTE COND) - (CONS |secondPredPair| (CONS |thirdPredPair| NIL))) - NIL)) - NIL))))) - (SPADLET |lamex| (CONS (QUOTE LAM) (CONS |arg| (CONS |codeBody| NIL)))) - (SPADLET |mainFunction| (CONS |op| (CONS |lamex| NIL))) - (SPADLET |computeFunction| - (CONS |auxfn| (CONS (CONS (QUOTE LAMBDA) (CONS |argl| |body|)) NIL))) - (|compileInteractive| |mainFunction|) - (COND - (|$reportCompilation| - (|sayBrightlyI| - (|bright| (MAKESTRING "Generated LISP code for function:"))) - (|pp| |computeFunction|))) - (|compileQuietly| (CONS |computeFunction| NIL)) - (SPADLET |cacheType| (QUOTE |function|)) - (SPADLET |cacheResetCode| - (CONS - (QUOTE SETQ) - (CONS - |cacheName| - (CONS (CONS (QUOTE |initCache|) (CONS |cacheCount| NIL)) NIL)))) - (SPADLET |cacheCountCode| - (CONS - (QUOTE |countCircularAlist|) - (CONS |cacheName| (CONS |cacheCount| NIL)))) - (SPADLET |cacheVector| - (|mkCacheVec| |op| |cacheName| |cacheType| |cacheResetCode| - |cacheCountCode|)) - (|LAM,EVALANDFILEACTQ| - (CONS - (QUOTE PUT) - (CONS - (MKQ |op|) - (CONS - (MKQ (QUOTE |cacheInfo|)) - (CONS (MKQ |cacheVector|) NIL))))) - (|LAM,EVALANDFILEACTQ| |cacheResetCode|) - (COND (|$InteractiveMode| (|stopTimingProcess| (QUOTE |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 - -;;; *** |compHash| REDEFINED - -(DEFUN |compHash| (|op| |argl| |body| |cacheNameOrNil| |eqEtc| |countFl|) - (PROG (|auxfn| |g1| |key| |LETTMP#1| |arg| |cacheArgKey| |computeValue| - |cacheName| |hitCounter| |callCounter| |callCountCode| |hitCountCode| - |g2| |returnFoundValue| |getCode| |secondPredPair| |putCode| - |thirdPredPair| |codeBody| |lamex| |mainFunction| |computeFunction| - |cacheType| |weakStrong| |cacheResetCode| |cacheCountCode| - |cacheVector|) - (RETURN - (PROGN - (COND - ((AND - |cacheNameOrNil| - (NEQUAL |cacheNameOrNil| (QUOTE |$ConstructorCache|))) - (|keyedSystemError| (QUOTE S2GE0010) (CONS |op| NIL)))) - (COND - ((NULL |argl|) - (COND - ((NULL |cacheNameOrNil|) - (|keyedSystemError| (QUOTE S2GE0011) (CONS |op| NIL))) - ((QUOTE T) NIL)))) - (COND - ((AND - (NULL |cacheNameOrNil|) - (NULL (MEMQ |eqEtc| (QUOTE (EQ CVEC UEQUAL))))) - (|keyedSystemError| (QUOTE S2GE0012) (CONS |op| NIL))) - ((QUOTE T) - (SPADLET |auxfn| (INTERNL |op| (MAKESTRING ";"))) - (SPADLET |g1| (GENSYM)) - (SPADLET |LETTMP#1| - (COND - ((NULL |argl|) (CONS NIL (CONS NIL (CONS (CONS |auxfn| NIL) NIL)))) - ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) - (SPADLET |key| - (COND - (|cacheNameOrNil| (CONS (QUOTE |devaluate|) (CONS |g1| NIL))) - ((QUOTE T) |g1|))) - (CONS - (CONS |g1| NIL) - (CONS - (CONS (QUOTE LIST) (CONS |key| NIL)) - (CONS (CONS |auxfn| (CONS |g1| NIL)) NIL)))) - ((QUOTE T) - (SPADLET |key| - (COND - (|cacheNameOrNil| (CONS (QUOTE |devaluateList|) (CONS |g1| NIL))) - ((QUOTE T) |g1|))) - (CONS - |g1| - (CONS - |key| - (CONS - (CONS - (QUOTE APPLY) - (CONS - (CONS (QUOTE |function|) (CONS |auxfn| NIL)) - (CONS |g1| NIL))) - NIL)))))) - (SPADLET |arg| (CAR |LETTMP#1|)) - (SPADLET |cacheArgKey| (CADR |LETTMP#1|)) - (SPADLET |computeValue| (CADDR |LETTMP#1|)) - (SPADLET |cacheName| - (OR |cacheNameOrNil| (INTERNL |op| (MAKESTRING ";AL")))) - (COND - ((BOOT-EQUAL |$reportCounts| (QUOTE T)) - (SPADLET |hitCounter| (INTERNL |op| (MAKESTRING ";hit"))) - (SPADLET |callCounter| (INTERNL |op| (MAKESTRING ";calls"))) - (SET |hitCounter| 0) - (SET |callCounter| 0) - (SPADLET |callCountCode| - (CONS - (CONS - (QUOTE SETQ) - (CONS - |callCounter| - (CONS (CONS (QUOTE QSADD1) (CONS |callCounter| NIL)) NIL))) - NIL)) - (SPADLET |hitCountCode| - (CONS - (CONS - (QUOTE SETQ) - (CONS - |hitCounter| - (CONS (CONS (QUOTE QSADD1) (CONS |hitCounter| NIL)) NIL))) - NIL)))) - (SPADLET |g2| (GENSYM)) - (SPADLET |returnFoundValue| - (COND - ((NULL |argl|) - (COND - (|countFl| - (CONS - (QUOTE |CDRwithIncrement|) - (CONS (CONS (QUOTE CDAR) (CONS |g2| NIL)) NIL))) - ((QUOTE T) (CONS (QUOTE CDAR) (CONS |g2| NIL))))) - (|countFl| (CONS (QUOTE |CDRwithIncrement|) (CONS |g2| NIL))) - ((QUOTE T) |g2|))) - (SPADLET |getCode| - (COND - ((NULL |argl|) - (CONS (QUOTE HGET) (CONS |cacheName| (CONS (MKQ |op|) NIL)))) - (|cacheNameOrNil| - (COND - ((NEQUAL |eqEtc| (QUOTE EQUAL)) - (CONS - (QUOTE |lassocShiftWithFunction|) - (CONS - |cacheArgKey| - (CONS - (CONS - (QUOTE HGET) - (CONS |cacheNameOrNil| (CONS (MKQ |op|) NIL))) - (CONS (MKQ |eqEtc|) NIL))))) - ((QUOTE T) - (CONS - (QUOTE |lassocShift|) - (CONS - |cacheArgKey| - (CONS - (CONS - (QUOTE HGET) - (CONS |cacheNameOrNil| (CONS (MKQ |op|) NIL))) - NIL)))))) - ((QUOTE T) (CONS (QUOTE HGET) (CONS |cacheName| (CONS |g1| NIL)))))) - (SPADLET |secondPredPair| - (CONS - (CONS (QUOTE SETQ) (CONS |g2| (CONS |getCode| NIL))) - (APPEND |hitCountCode| (CONS |returnFoundValue| NIL)))) - (SPADLET |putCode| - (COND - ((NULL |argl|) - (COND - (|cacheNameOrNil| - (COND - (|countFl| - (CONS - (QUOTE CDDAR) - (CONS - (CONS - (QUOTE HPUT) - (CONS - |cacheNameOrNil| - (CONS - (MKQ |op|) - (CONS - (CONS - (QUOTE LIST) - (CONS - (CONS - (QUOTE CONS) - (CONS - NIL - (CONS - (CONS - (QUOTE CONS) - (CONS 1 (CONS |computeValue| NIL))) NIL))) - NIL)) - NIL)))) - NIL))) - ((QUOTE T) - (CONS - (QUOTE HPUT) - (CONS - |cacheNameOrNil| - (CONS - (MKQ |op|) - (CONS - (CONS - (QUOTE LIST) - (CONS - (CONS (QUOTE CONS) (CONS NIL (CONS |computeValue| NIL))) - NIL)) - NIL))))))) - ((QUOTE T) (|systemError| (MAKESTRING "unexpected"))))) - (|cacheNameOrNil| |computeValue|) - (|countFl| - (CONS - (QUOTE CDR) - (CONS - (CONS - (QUOTE HPUT) - (CONS - |cacheName| - (CONS - |g1| - (CONS - (CONS (QUOTE CONS) (CONS 1 (CONS |computeValue| NIL))) - NIL)))) - NIL))) - ((QUOTE T) - (CONS - (QUOTE HPUT) - (CONS |cacheName| (CONS |g1| (CONS |computeValue| NIL))))))) - (COND - (|cacheNameOrNil| - (SPADLET |putCode| - (CONS - (QUOTE UNWIND-PROTECT) - (CONS - (CONS - (QUOTE PROG1) - (CONS - |putCode| - (CONS (CONS (QUOTE SETQ) (CONS |g2| (CONS (QUOTE T) NIL))) NIL))) - (CONS - (CONS - (QUOTE COND) - (CONS - (CONS - (CONS (QUOTE NOT) (CONS |g2| NIL)) - (CONS - (CONS (QUOTE HREM) (CONS |cacheName| (CONS (MKQ |op|) NIL))) - NIL)) - NIL)) - NIL)))))) - (SPADLET |thirdPredPair| (CONS (QUOTE (QUOTE T)) (CONS |putCode| NIL))) - (SPADLET |codeBody| - (CONS - (QUOTE PROG) - (CONS - (CONS |g2| NIL) - (APPEND - |callCountCode| - (CONS - (CONS - (QUOTE RETURN) - (CONS - (CONS - (QUOTE COND) (CONS |secondPredPair| (CONS |thirdPredPair| NIL))) - NIL)) - NIL))))) - (SPADLET |lamex| (CONS (QUOTE LAM) (CONS |arg| (CONS |codeBody| NIL)))) - (SPADLET |mainFunction| (CONS |op| (CONS |lamex| NIL))) - (SPADLET |computeFunction| - (CONS |auxfn| (CONS (CONS (QUOTE LAMBDA) (CONS |argl| |body|)) NIL))) - (|compileInteractive| |mainFunction|) - (COND - (|$reportCompilation| - (|sayBrightlyI| - (|bright| - (MAKESTRING "Generated LISP code for function:"))) - (|pp| |computeFunction|))) - (|compileQuietly| (CONS |computeFunction| NIL)) - (COND - ((NULL |cacheNameOrNil|) - (SPADLET |cacheType| - (COND - (|countFl| (QUOTE |hash-tableWithCounts|)) - ((QUOTE T) (QUOTE |hash-table|)))) - (SPADLET |weakStrong| - (COND (|countFl| (QUOTE STRONG)) ((QUOTE T) (QUOTE WEAK)))) - (SPADLET |cacheResetCode| - (CONS - (QUOTE SETQ) - (CONS - |cacheName| - (CONS - (CONS (QUOTE MAKE-HASHTABLE) (CONS (MKQ |eqEtc|) NIL)) - NIL)))) - (SPADLET |cacheCountCode| - (CONS (QUOTE |hashCount|) (CONS |cacheName| NIL))) - (SPADLET |cacheVector| - (|mkCacheVec| |op| |cacheName| |cacheType| |cacheResetCode| - |cacheCountCode|)) - (|LAM,EVALANDFILEACTQ| - (CONS - (QUOTE PUT) - (CONS - (MKQ |op|) - (CONS (MKQ (QUOTE |cacheInfo|)) (CONS (MKQ |cacheVector|) NIL))))) - (|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 - -;;; *** |compHashGlobal| REDEFINED - -(DEFUN |compHashGlobal| (|op| |argl| |body| |cacheName| |eqEtc| |countFl|) - (PROG (|auxfn| |g1| |application| |LETTMP#1| |arg| |cacheArgKey| - |computeValue| |g2| |returnFoundValue| |getCode| |secondPredPair| - |putForm| |putCode| |thirdPredPair| |codeBody| |lamex| |mainFunction| - |computeFunction|) - (RETURN - (PROGN - (COND - ((NULL (MEMQ |eqEtc| (QUOTE (UEQUAL)))) - (|sayBrightly| - (MAKESTRING - "for hash option, only EQ, CVEC, and UEQUAL are allowed")))) - (SPADLET |auxfn| (INTERNL |op| (MAKESTRING ";"))) - (SPADLET |g1| (GENSYM)) - (SPADLET |LETTMP#1| - (PROGN - (SPADLET |application| - (COND - ((NULL |argl|) (CONS |auxfn| NIL)) - ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) - (CONS |auxfn| (CONS |g1| NIL))) - ((QUOTE T) - (CONS - (QUOTE APPLX) - (CONS - (CONS (QUOTE |function|) (CONS |auxfn| NIL)) - (CONS |g1| NIL)))))) - (CONS - |g1| - (CONS - (CONS (QUOTE |consForHashLookup|) (CONS (MKQ |op|) (CONS |g1| NIL))) - (CONS |application| NIL))))) - (SPADLET |arg| (CAR |LETTMP#1|)) - (SPADLET |cacheArgKey| (CADR |LETTMP#1|)) - (SPADLET |computeValue| (CADDR |LETTMP#1|)) - (SPADLET |g2| (GENSYM)) - (SPADLET |returnFoundValue| - (COND - (|countFl| (CONS (QUOTE |CDRwithIncrement|) (CONS |g2| NIL))) - ((QUOTE T) |g2|))) - (SPADLET |getCode| - (CONS (QUOTE HGET) (CONS |cacheName| (CONS |cacheArgKey| NIL)))) - (SPADLET |secondPredPair| - (CONS - (CONS (QUOTE SETQ) (CONS |g2| (CONS |getCode| NIL))) - (CONS |returnFoundValue| NIL))) - (SPADLET |putForm| (CONS (QUOTE CONS) (CONS (MKQ |op|) (CONS |g1| NIL)))) - (SPADLET |putCode| - (COND - (|countFl| - (CONS - (QUOTE HPUT) - (CONS - |cacheName| - (CONS - |putForm| - (CONS (CONS (QUOTE CONS) (CONS 1 (CONS |computeValue| NIL))) NIL))))) - ((QUOTE T) - (CONS - (QUOTE HPUT) - (CONS |cacheName| (CONS |putForm| (CONS |computeValue| NIL))))))) - (SPADLET |thirdPredPair| (CONS (QUOTE (QUOTE T)) (CONS |putCode| NIL))) - (SPADLET |codeBody| - (CONS - (QUOTE PROG) - (CONS - (CONS |g2| NIL) - (CONS - (CONS - (QUOTE RETURN) - (CONS - (CONS - (QUOTE COND) - (CONS |secondPredPair| (CONS |thirdPredPair| NIL))) - NIL)) - NIL)))) - (SPADLET |lamex| (CONS (QUOTE LAM) (CONS |arg| (CONS |codeBody| NIL)))) - (SPADLET |mainFunction| (CONS |op| (CONS |lamex| NIL))) - (SPADLET |computeFunction| - (CONS |auxfn| (CONS (CONS (QUOTE LAMBDA) (CONS |argl| |body|)) NIL))) - (|compileInteractive| |mainFunction|) - (|compileInteractive| |computeFunction|) - |op|)))) -; -;consForHashLookup(a,b) == -; RPLACA($hashNode,a) -; RPLACD($hashNode,b) -; $hashNode - -;;; *** |consForHashLookup| REDEFINED - -(DEFUN |consForHashLookup| (|a| |b|) - (PROGN (RPLACA |$hashNode| |a|) (RPLACD |$hashNode| |b|) |$hashNode|)) -; -;CDRwithIncrement x == -; RPLACA(x,QSADD1 CAR x) -; CDR x - -;;; *** |CDRwithIncrement| REDEFINED - -(DEFUN |CDRwithIncrement| (|x|) - (PROGN (RPLACA |x| (QSADD1 (CAR |x|))) (CDR |x|))) -; -;HGETandCount(hashTable,prop) == -; u:= HGET(hashTable,prop) or return nil -; RPLACA(u,QSADD1 CAR u) -; u - -;;; *** |HGETandCount| REDEFINED - -(DEFUN |HGETandCount| (|hashTable| |prop|) - (PROG (|u|) - (RETURN - (PROGN - (SPADLET |u| (OR (HGET |hashTable| |prop|) (RETURN NIL))) - (RPLACA |u| (QSADD1 (CAR |u|))) |u|)))) -; -;clearClams() == -; for [fn,kind,:.] in $clamList | kind = 'hash or INTEGERP kind repeat -; clearClam fn - -;;; *** |clearClams| REDEFINED - -(DEFUN |clearClams| NIL - (PROG (|fn| |kind|) - (RETURN - (SEQ - (DO ((#0=#:G2474 |$clamList| (CDR #0#)) (#1=#:G2465 NIL)) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN (SPADLET |fn| (CAR #1#)) (SPADLET |kind| (CADR #1#)) #1#) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((OR (BOOT-EQUAL |kind| (QUOTE |hash|)) (INTEGERP |kind|)) - (|clearClam| |fn|)))))))))) -; -;clearClam fn == -; infovec:= GET(fn,'cacheInfo) or keyedSystemError("S2GE0003",[fn]) -; eval infovec.cacheReset - -;;; *** |clearClam| REDEFINED - -(DEFUN |clearClam| (|fn|) - (PROG (|infovec|) - (RETURN - (PROGN - (SPADLET |infovec| - (OR - (GETL |fn| (QUOTE |cacheInfo|)) - (|keyedSystemError| (QUOTE S2GE0003) (CONS |fn| NIL)))) - (|eval| (CADDDR |infovec|)))))) -; -;reportAndClearClams() == -; cacheStats() -; clearClams() - -;;; *** |reportAndClearClams| REDEFINED - -(DEFUN |reportAndClearClams| NIL (PROGN (|cacheStats|) (|clearClams|))) -; -;clearConstructorCaches() == -; clearCategoryCaches() -; CLRHASH $ConstructorCache - -;;; *** |clearConstructorCaches| REDEFINED - -(DEFUN |clearConstructorCaches| NIL - (PROGN (|clearCategoryCaches|) (CLRHASH |$ConstructorCache|))) -; -;clearConstructorCache(cname) == -; (kind := GETDATABASE(cname,'CONSTRUCTORKIND)) => -; kind = 'category => clearCategoryCache cname -; HREM($ConstructorCache,cname) - -;;; *** |clearConstructorCache| REDEFINED - -(DEFUN |clearConstructorCache| (|cname|) - (PROG (|kind|) - (RETURN - (SEQ - (COND - ((SPADLET |kind| (GETDATABASE |cname| (QUOTE CONSTRUCTORKIND))) - (EXIT - (COND - ((BOOT-EQUAL |kind| (QUOTE |category|)) - (|clearCategoryCache| |cname|)) - ((QUOTE T) (HREM |$ConstructorCache| |cname|)))))))))) -; -;clearConstructorAndLisplibCaches() == -; clearClams() -; clearConstructorCaches() - -;;; *** |clearConstructorAndLisplibCaches| REDEFINED - -(DEFUN |clearConstructorAndLisplibCaches| NIL - (PROGN (|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) - -;;; *** |clearCategoryCaches| REDEFINED - -(DEFUN |clearCategoryCaches| NIL - (PROG (|cacheName|) - (RETURN - (SEQ - (DO ((#0=#:G2514 (|allConstructors|) (CDR #0#)) (|name| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |name| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (COND - ((BOOT-EQUAL - (GETDATABASE |name| (QUOTE CONSTRUCTORKIND)) - (QUOTE |category|)) - (COND - ((BOUNDP - (SPADLET |cacheName| - (INTERNL (STRCONC (PNAME |name|) (MAKESTRING ";AL"))))) - (SET |cacheName| NIL)) - ((QUOTE T) NIL)))) - (COND - ((BOUNDP - (SPADLET |cacheName| - (INTERNL (STRCONC (PNAME |name|) (MAKESTRING ";CAT"))))) - (SET |cacheName| NIL)) - ((QUOTE T) NIL)))))))))) -; -;clearCategoryCache catName == -; cacheName:= INTERNL STRCONC(PNAME catName,'";AL") -; SET(cacheName,nil) - -;;; *** |clearCategoryCache| REDEFINED - -(DEFUN |clearCategoryCache| (|catName|) - (PROG (|cacheName|) - (RETURN - (PROGN - (SPADLET |cacheName| - (INTERNL (STRCONC (PNAME |catName|) (MAKESTRING ";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 - -;;; *** |displayHashtable| REDEFINED - -(DEFUN |displayHashtable| (|x|) - (PROG (|l| |a| |b|) - (RETURN - (SEQ - (PROGN - (SPADLET |l| - (NREVERSE - (SORTBY - (QUOTE CAR) - (PROG (#0=#:G2540) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G2545 (HKEYS |x|) (CDR #1#)) (|key| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |key| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# - (CONS - (CONS (|opOf| (HGET |x| |key|)) (CONS |key| NIL)) - #0#)))))))))) - (DO ((#2=#:G2557 |l| (CDR #2#)) (#3=#:G2531 NIL)) - ((OR - (ATOM #2#) - (PROGN (SETQ #3# (CAR #2#)) NIL) - (PROGN - (PROGN (SPADLET |a| (CAR #3#)) (SPADLET |b| (CADR #3#)) #3#) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (|sayBrightlyNT| - (CONS (QUOTE |%b|) (CONS |a| (CONS (QUOTE |%d|) NIL)))) - (|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"] - -;;; *** |cacheStats| REDEFINED - -(DEFUN |cacheStats| NIL - (PROG (|fn| |kind| |u|) - (RETURN - (SEQ - (DO ((#0=#:G2581 |$clamList| (CDR #0#)) (#1=#:G2572 NIL)) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |fn| (CAR #1#)) - (SPADLET |kind| (CADR #1#)) - (SPADLET |u| (CDDR #1#)) - #1#) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((NULL (MEMQ (QUOTE |count|) |u|)) - (|sayBrightly| - (CONS - (MAKESTRING "%b") - (CONS - |fn| - (CONS - (MAKESTRING "%d") - (CONS (MAKESTRING "does not keep reference counts") NIL)))))) - ((INTEGERP |kind|) (|reportCircularCacheStats| |fn| |kind|)) - ((BOOT-EQUAL |kind| (QUOTE |hash|)) (|reportHashCacheStats| |fn|)) - ((QUOTE T) - (|sayBrightly| - (CONS - (MAKESTRING "Unknown cache type for") - (CONS - (MAKESTRING "%b") - (CONS |fn| (CONS (MAKESTRING "%d") NIL)))))))))))))) -; -;reportCircularCacheStats(fn,n) == -; infovec:= GET(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() - -;;; *** |reportCircularCacheStats| REDEFINED - -(DEFUN |reportCircularCacheStats| (|fn| |n|) - (PROG (|infovec| |circList| |numberUsed|) - (RETURN - (SEQ - (PROGN - (SPADLET |infovec| (GETL |fn| (QUOTE |cacheInfo|))) - (SPADLET |circList| (|eval| (CADR |infovec|))) - (SPADLET |numberUsed| - (PROG (#0=#:G2595) - (SPADLET #0# 0) - (RETURN - (DO ((|i| 1 (QSADD1 |i|)) (#1=#:G2602 |circList| (CDR #1#)) (|x| NIL)) - ((OR - (QSGREATERP |i| |n|) - (ATOM #1#) - (PROGN (SETQ |x| (CAR #1#)) NIL) - (NULL - (NULL (AND (PAIRP |x|) (EQUAL (QCAR |x|) (QUOTE |$failed|)))))) - #0#) - (SEQ (EXIT (SETQ #0# (PLUS #0# 1)))))))) - (|sayBrightly| - (CONS - (MAKESTRING "%b") - (CONS - |fn| - (CONS - (MAKESTRING "%d") - (CONS - (MAKESTRING "has") - (CONS - (MAKESTRING "%b") - (CONS - |numberUsed| - (CONS - (MAKESTRING "%d") - (CONS - (MAKESTRING "/ ") - (CONS |n| (CONS (MAKESTRING " values cached") NIL))))))))))) - (|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() - -;;; *** |displayCacheFrequency| REDEFINED - -(DEFUN |displayCacheFrequency| (|al|) - (PROG (|a| |b|) - (RETURN - (SEQ - (PROGN - (SPADLET |al| (NREVERSE (SORTBY (QUOTE CAR) |al|))) - (|sayBrightlyNT| (QUOTE | #hits/#occurrences: |)) - (DO ((#0=#:G2626 |al| (CDR #0#)) (#1=#:G2617 NIL)) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN (SPADLET |a| (CAR #1#)) (SPADLET |b| (CDR #1#)) #1#) NIL)) - NIL) - (SEQ - (EXIT - (|sayBrightlyNT| - (CONS |a| (CONS (QUOTE /) (CONS |b| (CONS (QUOTE | |) NIL)))))))) - (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 - -;;; *** |mkCircularCountAlist| REDEFINED - -(DEFUN |mkCircularCountAlist| (|cl| |len|) - (PROG (|x| |count| |u| |al|) - (RETURN - (SEQ - (PROGN - (DO - ((#0=#:G2652 |cl| (CDR #0#)) (#1=#:G2641 NIL) (|i| 1 (QSADD1 |i|))) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN (SPADLET |x| (CAR #1#)) (SPADLET |count| (CADR #1#)) #1#) NIL) - (QSGREATERP |i| |len|) - (NULL (NEQUAL |x| (QUOTE |$failed|)))) - NIL) - (SEQ - (EXIT - (COND - ((SPADLET |u| (|assoc| |count| |al|)) (RPLACD |u| (PLUS 1 (CDR |u|)))) - ((QUOTE T) - (COND - ((AND - (INTEGERP |$reportFavoritesIfNumber|) - (>= |count| |$reportFavoritesIfNumber|)) - (|sayBrightlyNT| - (CONS (QUOTE | |) (CONS |count| (CONS (QUOTE | |) NIL)))) - (|pp| |x|))) - (SPADLET |al| (CONS (CONS |count| 1) |al|))))))) - |al|))))) -; -;reportHashCacheStats fn == -; infovec:= GET(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() - -;;; *** |reportHashCacheStats| REDEFINED - -(DEFUN |reportHashCacheStats| (|fn|) - (PROG (|infovec| |hashTable| |hashValues|) - (RETURN - (SEQ - (PROGN - (SPADLET |infovec| (GETL |fn| (QUOTE |cacheInfo|))) - (SPADLET |hashTable| (|eval| (CADR |infovec|))) - (SPADLET |hashValues| - (PROG (#0=#:G2673) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G2678 (HKEYS |hashTable|) (CDR #1#)) (|key| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |key| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (HGET |hashTable| |key|) #0#)))))))) - (|sayBrightly| - (APPEND - (|bright| |fn|) - (CONS - (MAKESTRING "has") - (APPEND - (|bright| (|#| |hashValues|)) - (CONS (MAKESTRING "values cached.") NIL))))) - (|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 - -;;; *** |mkHashCountAlist| REDEFINED - -(DEFUN |mkHashCountAlist| (|vl|) - (PROG (|count| |u| |al|) - (RETURN - (SEQ - (PROGN - (DO ((#0=#:G2700 |vl| (CDR #0#)) (#1=#:G2692 NIL)) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN (PROGN (SPADLET |count| (CAR #1#)) #1#) NIL)) - NIL) - (SEQ - (EXIT - (COND - ((SPADLET |u| (|assoc| |count| |al|)) - (RPLACD |u| (PLUS 1 (CDR |u|)))) - ((QUOTE T) - (SPADLET |al| (CONS (CONS |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 - -;;; *** |clearHashReferenceCounts| REDEFINED - -(DEFUN |clearHashReferenceCounts| NIL - (SEQ - (DO ((#0=#:G2717 |$clamList| (CDR #0#)) (|x| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL (CADDR |x|) (QUOTE |hash-tableWithCounts|)) - (|remHashEntriesWith0Count| (|eval| (CADR |x|)))) - ((BOOT-EQUAL (CADDR |x|) (QUOTE |hash-table|)) - (CLRHASH (|eval| (CADR |x|)))))))))) -; -;remHashEntriesWith0Count $hashTable == -; MAPHASH(fn,$hashTable) where fn(key,obj) == -; CAR obj = 0 => HREM($hashTable,key) --free store -; nil - -;;; *** |remHashEntriesWith0Count,fn| REDEFINED - -(DEFUN |remHashEntriesWith0Count,fn| (|key| |obj|) - (SEQ - (IF (EQL (CAR |obj|) 0) (EXIT (HREM |$hashTable| |key|))) - (EXIT NIL))) - -;;; *** |remHashEntriesWith0Count| REDEFINED - -(DEFUN |remHashEntriesWith0Count| (|$hashTable|) - (DECLARE (SPECIAL |$hashTable|)) - (MAPHASH |remHashEntriesWith0Count,fn| |$hashTable|)) -; -;initCache n == -; tail:= '(0 . $failed) -; l:= [[$failed,:tail] for i in 1..n] -; RPLACD(LASTNODE l,l) - -;;; *** |initCache| REDEFINED - -(DEFUN |initCache| (|n|) - (PROG (|tail| |l|) - (RETURN - (SEQ - (PROGN - (SPADLET |tail| (QUOTE (0 . |$failed|))) - (SPADLET |l| - (PROG (#0=#:G2740) - (SPADLET #0# NIL) - (RETURN - (DO ((|i| 1 (QSADD1 |i|))) - ((QSGREATERP |i| |n|) (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (CONS |$failed| |tail|) #0#)))))))) - (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 - -;;; *** |assocCache| REDEFINED - -(DEFUN |assocCache| (|x| |cacheName| |fn|) - (PROG (|al| |val| |backPointer| |forwardPointer|) - (RETURN - (SEQ - (PROGN - (SPADLET |al| (|eval| |cacheName|)) - (SPADLET |forwardPointer| |al|) - (SPADLET |val| NIL) - (DO ((#0=#:G2759 NIL (EQ |forwardPointer| |al|))) - (#0# NIL) - (SEQ - (EXIT - (COND - ((FUNCALL |fn| (CAAR |forwardPointer|) |x|) - (RETURN (SPADLET |val| (CAR |forwardPointer|)))) - ((QUOTE T) - (SPADLET |backPointer| |forwardPointer|) - (SPADLET |forwardPointer| (CDR |forwardPointer|))))))) - (COND (|val| |val|) ((QUOTE T) (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 - -;;; *** |assocCacheShift| REDEFINED - -(DEFUN |assocCacheShift| (|x| |cacheName| |fn|) - (PROG (|al| |y| |val| |backPointer| |forwardPointer|) - (RETURN - (SEQ - (PROGN - (SPADLET |al| (|eval| |cacheName|)) - (SPADLET |forwardPointer| |al|) - (SPADLET |val| NIL) - (DO ((#0=#:G2779 NIL (EQ |forwardPointer| |al|))) - (#0# NIL) - (SEQ - (EXIT - (COND - ((FUNCALL |fn| (CAR (SPADLET |y| (CAR |forwardPointer|))) |x|) - (COND - ((NULL (EQ |forwardPointer| |al|)) - (RPLACA |forwardPointer| (CAR |al|)) - (RPLACA |al| |y|))) - (RETURN (SPADLET |val| |y|))) - ((QUOTE T) - (SPADLET |backPointer| |forwardPointer|) - (SPADLET |forwardPointer| (CDR |forwardPointer|))))))) - (COND (|val| |val|) ((QUOTE T) (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 - -;;; *** |assocCacheShiftCount| REDEFINED - -(DEFUN |assocCacheShiftCount| (|x| |al| |fn|) - (PROG (|y| |val| |c| |minCount| |newFrontPointer| |forwardPointer| |temp|) - (RETURN - (SEQ - (PROGN - (SPADLET |forwardPointer| |al|) - (SPADLET |val| NIL) - (SPADLET |minCount| 10000) - (DO ((#0=#:G2801 NIL (EQ |forwardPointer| |al|))) - (#0# NIL) - (SEQ - (EXIT - (COND - ((FUNCALL |fn| (CAR (SPADLET |y| (CAR |forwardPointer|))) |x|) - (SPADLET |newFrontPointer| |forwardPointer|) - (RPLAC (CADR |y|) (QSADD1 (CADR |y|))) - (RETURN (SPADLET |val| |y|))) - ((QUOTE T) - (COND - ((QSLESSP (SPADLET |c| (CADR |y|)) |minCount|) - (SPADLET |minCount| |c|) - (SPADLET |newFrontPointer| |forwardPointer|))) - (SPADLET |forwardPointer| (CDR |forwardPointer|))))))) - (COND - ((NULL (EQ |newFrontPointer| |al|)) - (SPADLET |temp| (CAR |newFrontPointer|)) - (RPLACA |newFrontPointer| (CAR |al|)) - (RPLACA |al| |temp|))) - |val|))))) -; -;clamStats() == -; for [op,kind,:.] in $clamList repeat -; cacheVec:= GET(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] - -;;; *** |clamStats| REDEFINED - -(DEFUN |clamStats| NIL - (PROG (|op| |kind| |cacheVec| |hitCounter| |callCounter| |res| |prefix| - |cacheValue| |empties| |postString|) - (RETURN - (SEQ - (DO ((#0=#:G2836 |$clamList| (CDR #0#)) (#1=#:G2822 NIL)) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN (SPADLET |op| (CAR #1#)) (SPADLET |kind| (CADR #1#)) #1#) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |cacheVec| - (OR - (GETL |op| (QUOTE |cacheInfo|)) - (|systemErrorHere| (QUOTE |clamStats|)))) - (SPADLET |prefix| - (COND - ((NEQUAL |$reportCounts| (QUOTE T)) NIL) - ((QUOTE T) - (SPADLET |hitCounter| (INTERNL |op| (MAKESTRING ";hit"))) - (SPADLET |callCounter| (INTERNL |op| (MAKESTRING ";calls"))) - (SPADLET |res| - (CONS - (QUOTE |%b|) - (CONS - (|eval| |hitCounter|) - (CONS - (QUOTE /) - (CONS - (|eval| |callCounter|) - (CONS (QUOTE |%d|) (CONS (QUOTE |calls to |) NIL))))))) - (SET |hitCounter| 0) (SET |callCounter| 0) |res|))) - (SPADLET |postString| - (PROGN - (SPADLET |cacheValue| (|eval| (CADR |cacheVec|))) - (COND - ((BOOT-EQUAL |kind| (QUOTE |hash|)) - (CONS - (QUOTE | (|) - (CONS - (QUOTE |%b|) - (CONS - (HASH-TABLE-COUNT |cacheValue|) - (CONS (QUOTE |%d|) (CONS (QUOTE |entries)|) NIL)))))) - ((QUOTE T) - (SPADLET |empties| - (|numberOfEmptySlots| (|eval| (CADR |cacheVec|)))) - (COND - ((EQL |empties| 0) NIL) - ((QUOTE T) - (CONS - (QUOTE | (|) - (CONS - (QUOTE |%b|) - (CONS - (SPADDIFFERENCE |kind| |empties|) - (CONS - (QUOTE /) - (CONS - |kind| - (CONS - (QUOTE |%d|) - (CONS (QUOTE |slots used)|) NIL))))))))))))) - (|sayBrightly| (APPEND |prefix| (CONS |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 - -;;; *** |numberOfEmptySlots| REDEFINED - -(DEFUN |numberOfEmptySlots| (|cache|) - (PROG (|count|) - (RETURN - (SEQ - (PROGN - (SPADLET |count| - (COND ((BOOT-EQUAL (CAAR |cache|) (QUOTE |$failed|)) 1) ((QUOTE T) 0))) - (DO ((|x| (CDR |cache|) (CDR |x|))) - ((OR (ATOM |x|) (NULL (NE |x| |cache|))) NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL (CAAR |x|) (QUOTE |$failed|)) - (SPADLET |count| (PLUS |count| 1))) - ((QUOTE T) NIL))))) - |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) - -;;; *** |addToSlam| REDEFINED - -(DEFUN |addToSlam| (#0=#:G2872 |shell|) - (PROG (|name| |argnames| |args|) - (RETURN - (SEQ - (PROGN - (SPADLET |name| (CAR #0#)) - (SPADLET |argnames| (CDR #0#)) - (COND - (|$mutableDomain| (RETURN NIL)) - ((NULL |argnames|) (|addToConstructorCache| |name| NIL |shell|)) - ((QUOTE T) - (SPADLET |args| - (CONS - (QUOTE LIST) - (PROG (#1=#:G2885) - (SPADLET #1# NIL) - (RETURN - (DO ((#2=#:G2890 |argnames| (CDR #2#)) (|a| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |a| (CAR #2#)) NIL)) - (NREVERSE0 #1#)) - (SEQ (EXIT (SETQ #1# (CONS (|mkDevaluate| |a|) #1#))))))))) - (|addToConstructorCache| |name| |args| |shell|)))))))) -; -;addToConstructorCache(op,args,value) == -; ['haddProp,'$ConstructorCache,MKQ op,args,['CONS,1,value]] - -;;; *** |addToConstructorCache| REDEFINED - -(DEFUN |addToConstructorCache| (|op| |args| |value|) - (CONS - (QUOTE |haddProp|) - (CONS - (QUOTE |$ConstructorCache|) - (CONS - (MKQ |op|) - (CONS - |args| - (CONS (CONS (QUOTE CONS) (CONS 1 (CONS |value| NIL))) NIL)))))) -; -;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 - -;;; *** |haddProp| REDEFINED - -(DEFUN |haddProp| (|ht| |op| |prop| |val|) - (PROG (|$op| |u|) - (DECLARE (SPECIAL |$op|)) - (RETURN - (PROGN - (|statRecordInstantiationEvent|) - (COND - ((OR - (BOOT-EQUAL |$reportInstantiations| (QUOTE T)) - (BOOT-EQUAL |$reportEachInstantiation| (QUOTE T))) - (|startTimingProcess| (QUOTE |debug|)) - (|recordInstantiation| |op| |prop| NIL) - (|stopTimingProcess| (QUOTE |debug|)))) - (COND - ((SPADLET |u| (HGET |ht| |op|)) - (COND - ((|assoc| |prop| |u|) |val|) - ((QUOTE T) - (RPLACD |u| (CONS (CAR |u|) (CDR |u|))) - (RPLACA |u| (CONS |prop| |val|)) - (SPADLET |$op| |op|) (|listTruncate| |u| 20) |val|))) - ((QUOTE T) (HPUT |ht| |op| (CONS (CONS |prop| |val|) NIL)) |val|)))))) -; -;recordInstantiation(op,prop,dropIfTrue) == -; startTimingProcess 'debug -; recordInstantiation1(op,prop,dropIfTrue) -; stopTimingProcess 'debug - -;;; *** |recordInstantiation| REDEFINED - -(DEFUN |recordInstantiation| (|op| |prop| |dropIfTrue|) - (PROGN - (|startTimingProcess| (QUOTE |debug|)) - (|recordInstantiation1| |op| |prop| |dropIfTrue|) - (|stopTimingProcess| (QUOTE |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]]) - -;;; *** |recordInstantiation1| REDEFINED - -(DEFUN |recordInstantiation1| (|op| |prop| |dropIfTrue|) - (PROG (|trailer| |m1| |ISTMP#1| |m2| |xtra| |u| |v| |val|) - (RETURN - (COND - ((|member| |op| (QUOTE (|CategoryDefaults| |RepeatedSquaring|))) NIL) - ((QUOTE T) - (COND - ((BOOT-EQUAL |$reportEachInstantiation| (QUOTE T)) - (SPADLET |trailer| - (COND - (|dropIfTrue| (MAKESTRING " dropped")) - ((QUOTE T) (MAKESTRING " instantiated")))) - (COND - ((BOOT-EQUAL |$insideCoerceInteractive| (QUOTE T)) - (SPADLET |$instantCoerceCount| (PLUS 1 |$instantCoerceCount|)))) - (COND - ((AND - (PAIRP |$insideCanCoerceFrom|) - (PROGN - (SPADLET |m1| (QCAR |$insideCanCoerceFrom|)) - (SPADLET |ISTMP#1| (QCDR |$insideCanCoerceFrom|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |m2| (QCAR |ISTMP#1|)) (QUOTE T)))) - (NULL |dropIfTrue|)) - (SPADLET |$instantCanCoerceCount| (PLUS 1 |$instantCanCoerceCount|)) - (SPADLET |xtra| - (CONS - (MAKESTRING " for ") - (CONS - (|outputDomainConstructor| |m1|) - (CONS - (MAKESTRING "-->") - (CONS (|outputDomainConstructor| |m2|) NIL))))))) - (COND - ((AND - (BOOT-EQUAL |$insideEvalMmCondIfTrue| (QUOTE T)) - (NULL |dropIfTrue|)) - (SPADLET |$instantMmCondCount| (PLUS |$instantMmCondCount| 1)))) - (|typeTimePrin| - (CONS - (QUOTE CONCAT) - (CONS - (|outputDomainConstructor| (CONS |op| |prop|)) - (CONS |trailer| |xtra|)))))) - (COND - ((NULL |$reportInstantiations|) NIL) - ((SPADLET |u| (HGET |$instantRecord| |op|)) - (COND - ((SPADLET |v| (LASSOC |prop| |u|)) - (COND - (|dropIfTrue| (RPLAC (CDR |v|) (PLUS 1 (CDR |v|)))) - ((QUOTE T) (RPLAC (CAR |v|) (PLUS 1 (CAR |v|)))))) - ((QUOTE T) - (RPLACD |u| (CONS (CAR |u|) (CDR |u|))) - (SPADLET |val| - (COND (|dropIfTrue| (CONS 0 1)) ((QUOTE T) (CONS 1 0)))) - (RPLACA |u| (CONS |prop| |val|))))) - ((QUOTE T) - (SPADLET |val| - (COND (|dropIfTrue| (CONS 0 1)) ((QUOTE T) (CONS 1 0)))) - (HPUT |$instantRecord| |op| (CONS (CONS |prop| |val|) NIL))))))))) -; -;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"] - -;;; *** |reportInstantiations| REDEFINED - -(DEFUN |reportInstantiations| NIL - (PROG (|argList| |conList| |n| |m| |form| |nTotal| |mTotal| |rTotal| - |nForms|) - (RETURN - (SEQ - (PROGN - (SPADLET |conList| - (PROG (#0=#:G2964) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G2973 (HKEYS |$instantRecord|) (CDR #1#)) (|key| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |key| (CAR #1#)) NIL)) #0#) - (SEQ - (EXIT - (SETQ #0# - (APPEND - #0# - (PROG (#2=#:G2984) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G2990 (HGET |$instantRecord| |key|) (CDR #3#)) - (#4=#:G2952 NIL)) - ((OR - (ATOM #3#) - (PROGN (SETQ #4# (CAR #3#)) NIL) - (PROGN - (PROGN - (SPADLET |argList| (CAR #4#)) - (SPADLET |n| (CADR #4#)) - (SPADLET |m| (CDDR #4#)) #4#) - NIL)) - (NREVERSE0 #2#)) - (SEQ - (EXIT - (SETQ #2# - (CONS - (CONS |n| (CONS |m| (CONS (CONS |key| |argList|) NIL))) - #2#))))))))))))))) - (|sayBrightly| - (CONS - (MAKESTRING "# instantiated/# dropped/domain name") - (CONS - (MAKESTRING "%l") - (CONS (MAKESTRING "------------------------------------") NIL)))) - (SPADLET |nTotal| - (SPADLET |mTotal| (SPADLET |rTotal| (SPADLET |nForms| 0)))) - (DO ((#5=#:G3006 (NREVERSE (SORTBY (QUOTE CADDR) |conList|)) (CDR #5#)) - (#6=#:G2958 NIL)) - ((OR - (ATOM #5#) - (PROGN (SETQ #6# (CAR #5#)) NIL) - (PROGN - (PROGN - (SPADLET |n| (CAR #6#)) - (SPADLET |m| (CADR #6#)) - (SPADLET |form| (CADDR #6#)) - #6#) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |nTotal| (PLUS |nTotal| |n|)) - (SPADLET |mTotal| (PLUS |mTotal| |m|)) - (COND - ((> |n| 1) - (SPADLET |rTotal| (SPADDIFFERENCE (PLUS |rTotal| |n|) 1)))) - (SPADLET |nForms| (PLUS |nForms| 1)) - (|typeTimePrin| - (CONS - (QUOTE CONCATB) - (CONS - |n| - (CONS |m| (CONS (|outputDomainConstructor| |form|) NIL))))))))) - (|sayBrightly| - (CONS - (MAKESTRING "%b") - (CONS - (MAKESTRING "Totals:") - (CONS - (MAKESTRING "%d") - (CONS - |nTotal| - (CONS - (MAKESTRING " instantiated") - (CONS - (MAKESTRING "%l") - (CONS - (MAKESTRING " ") - (CONS - |$instantCoerceCount| - (CONS - (MAKESTRING " inside coerceInteractive") - (CONS - (MAKESTRING "%l") - (CONS - (MAKESTRING " ") - (CONS - |$instantCanCoerceCount| - (CONS - (MAKESTRING " inside canCoerceFrom") - (CONS - (MAKESTRING "%l") - (CONS - (MAKESTRING " ") - (CONS - |$instantMmCondCount| - (CONS - (MAKESTRING " inside evalMmCond") - (CONS - (MAKESTRING "%l") - (CONS - (MAKESTRING " ") - (CONS - |rTotal| - (CONS - (MAKESTRING " reinstantiated") - (CONS - (MAKESTRING "%l") - (CONS - (MAKESTRING " ") - (CONS - |mTotal| - (CONS - (MAKESTRING " dropped") - (CONS - (MAKESTRING "%l") - (CONS - (MAKESTRING " ") - (CONS - |nForms| - (CONS - (MAKESTRING - " distinct domains instantiated/dropped") - NIL))))))))))))))))))))))))))))))))))) -; -;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) - -;;; *** |hputNewProp| REDEFINED - -(DEFUN |hputNewProp| (|ht| |op| |argList| |val|) - (PROG (|prop|) - (RETURN - (SEQ - (PROGN - (SPADLET |prop| - (PROG (#0=#:G3038) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G3043 |argList| (CDR #1#)) (|x| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (|devaluate| |x|) #0#)))))))) - (|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 - -;;; *** |listTruncate| REDEFINED - -(DEFUN |listTruncate| (|l| |n|) - (PROG (|u|) - (RETURN - (SEQ - (PROGN - (SPADLET |u| |l|) - (SPADLET |n| (QSSUB1 |n|)) - (DO NIL - ((NULL (AND (NEQ |n| 0) (NULL (ATOM |u|)))) NIL) - (SEQ (EXIT (PROGN (SPADLET |n| (QSSUB1 |n|)) (SPADLET |u| (QCDR |u|)))))) - (COND - ((NULL (ATOM |u|)) - (COND - ((AND - (NULL (ATOM (CDR |u|))) - (BOOT-EQUAL |$reportInstantiations| (QUOTE T))) - (|recordInstantiation| |$op| (CAADR |u|) (QUOTE T)))) - (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 - -;;; *** |lassocShift| REDEFINED - -(DEFUN |lassocShift| (|x| |l|) - (PROG (|result| |y|) - (RETURN - (SEQ - (PROGN - (SPADLET |y| |l|) - (DO NIL - ((NULL (NULL (ATOM |y|))) NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |x| (CAR (QCAR |y|))) - (RETURN (SPADLET |result| (QCAR |y|)))) - ((QUOTE T) (SPADLET |y| (QCDR |y|))))))) - (COND - (|result| - (COND - ((NEQ |y| |l|) (QRPLACA |y| (CAR |l|)) (QRPLACA |l| |result|))) - (QCDR |result|)) - ((QUOTE T) 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 - -;;; *** |lassocShiftWithFunction| REDEFINED - -(DEFUN |lassocShiftWithFunction| (|x| |l| |fn|) - (PROG (|result| |y|) - (RETURN - (SEQ - (PROGN - (SPADLET |y| |l|) - (DO NIL - ((NULL (NULL (ATOM |y|))) NIL) - (SEQ - (EXIT - (COND - ((FUNCALL |fn| |x| (CAR (QCAR |y|))) - (RETURN (SPADLET |result| (QCAR |y|)))) - ((QUOTE T) (SPADLET |y| (QCDR |y|))))))) - (COND - (|result| - (COND ((NEQ |y| |l|) (QRPLACA |y| (CAR |l|)) (QRPLACA |l| |result|))) - (QCDR |result|)) - ((QUOTE T) 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 - -;;; *** |lassocShiftQ| REDEFINED - -(DEFUN |lassocShiftQ| (|x| |l|) - (PROG (|result| |y|) - (RETURN - (SEQ - (PROGN - (SPADLET |y| |l|) - (DO NIL - ((NULL (NULL (ATOM |y|))) NIL) - (SEQ - (EXIT - (COND - ((EQ |x| (CAR (CAR |y|))) (RETURN (SPADLET |result| (CAR |y|)))) - ((QUOTE T) (SPADLET |y| (CDR |y|))))))) - (COND - (|result| - (COND ((NEQ |y| |l|) (RPLACA |y| (CAR |l|)) (RPLACA |l| |result|))) - (CDR |result|)) - ((QUOTE T) 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 - -;;; *** |globalHashtableStats| REDEFINED - -(DEFUN |globalHashtableStats| (|x| |sortFn|) - (PROG (|keys| |u| |argList| |argList1| |reportList| |n| |fn| |args|) - (RETURN - (SEQ - (PROGN - (SPADLET |keys| (HKEYS |x|)) - (DO ((#0=#:G3141 |keys| (CDR #0#)) (|key| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |key| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |u| (HGET |x| |key|)) - (DO ((#1=#:G3151 |u| (CDR #1#)) (#2=#:G3121 NIL)) - ((OR - (ATOM #1#) - (PROGN (SETQ #2# (CAR #1#)) NIL) - (PROGN - (PROGN - (SPADLET |argList| (CAR #2#)) - (SPADLET |n| (CADR #2#)) #2#) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((NULL (INTEGERP |n|)) - (|keyedSystemError| (QUOTE S2GE0013) (CONS |x| NIL))) - ((QUOTE T) - (SPADLET |argList1| - (PROG (#3=#:G3162) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G3167 |argList| (CDR #4#)) (|x| NIL)) - ((OR - (ATOM #4#) - (PROGN (SETQ |x| (CAR #4#)) NIL)) - (NREVERSE0 #3#)) - (SEQ - (EXIT - (SETQ #3# - (CONS (|constructor2ConstructorForm| |x|) #3#)))))))) - (SPADLET |reportList| - (CONS - (CONS |n| (CONS |key| (CONS |argList1| NIL))) - |reportList|))))))))))) - (|sayBrightly| - (CONS - (MAKESTRING "%b") - (CONS (MAKESTRING " USE NAME ARGS") (CONS (MAKESTRING "%d") NIL)))) - (DO ((#5=#:G3179 (NREVERSE (SORTBY |sortFn| |reportList|)) (CDR #5#)) - (#6=#:G3127 NIL)) - ((OR - (ATOM #5#) - (PROGN (SETQ #6# (CAR #5#)) NIL) - (PROGN - (PROGN - (SPADLET |n| (CAR #6#)) - (SPADLET |fn| (CADR #6#)) - (SPADLET |args| (CADDR #6#)) - #6#) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (|sayBrightlyNT| - (APPEND - (|rightJustifyString| |n| 6) - (CONS (QUOTE | |) (CONS |fn| (CONS (QUOTE |: |) NIL))))) - (|pp| |args|)))))))))) -; -;constructor2ConstructorForm x == -; VECP x => x.0 -; x - -;;; *** |constructor2ConstructorForm| REDEFINED - -(DEFUN |constructor2ConstructorForm| (|x|) - (COND ((VECP |x|) (ELT |x| 0)) ((QUOTE T) |x|))) -; -;rightJustifyString(x,maxWidth) == -; size:= entryWidth x -; size > maxWidth => keyedSystemError("S2GE0014",[x]) -; [fillerSpaces(maxWidth-size," "),x] - -;;; *** |rightJustifyString| REDEFINED - -(DEFUN |rightJustifyString| (|x| |maxWidth|) - (PROG (SIZE) - (RETURN - (PROGN - (SPADLET SIZE (|entryWidth| |x|)) - (COND - ((> SIZE |maxWidth|) (|keyedSystemError| (QUOTE S2GE0014) (CONS |x| NIL))) - ((QUOTE T) - (CONS - (|fillerSpaces| (SPADDIFFERENCE |maxWidth| SIZE) (QUOTE | |)) - (CONS |x| NIL)))))))) -; -;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 - -;;; *** |domainEqualList| REDEFINED - -(DEFUN |domainEqualList| (|argl1| |argl2|) - (PROG (|item1| |item2| |partsMatch|) - (RETURN - (SEQ - (PROGN - (DO NIL - ((NULL (AND |argl1| |argl2|)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |item1| (|devaluate| (CAR |argl1|))) - (SPADLET |item2| (CAR |argl2|)) - (SPADLET |partsMatch| - (COND ((BOOT-EQUAL |item1| |item2|) (QUOTE T)) ((QUOTE T) NIL))) - (COND - ((NULL |partsMatch|) (RETURN NIL)) - ((QUOTE T) - (SPADLET |argl1| (CDR |argl1|)) - (SPADLET |argl2| (CDR |argl2|)))))))) - (COND ((OR |argl1| |argl2|) NIL) ((QUOTE T) (QUOTE T)))))))) -; -;removeAllClams() == -; for [fun,:.] in $clamList repeat -; sayBrightly ['"Un-clamming function",'%b,fun,'%d] -; SET(fun,eval INTERN STRCONC(STRINGIMAGE fun,'";")) - -;;; *** |removeAllClams| REDEFINED - -(DEFUN |removeAllClams| NIL - (PROG (|fun|) - (RETURN - (SEQ - (DO ((#0=#:G3239 |$clamList| (CDR #0#)) (#1=#:G3230 NIL)) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN (PROGN (SPADLET |fun| (CAR #1#)) #1#) NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (|sayBrightly| - (CONS - (MAKESTRING "Un-clamming function") - (CONS (QUOTE |%b|) (CONS |fun| (CONS (QUOTE |%d|) NIL))))) - (SET |fun| - (|eval| - (INTERN (STRCONC (STRINGIMAGE |fun|) (MAKESTRING ";"))))))))))))) - -;;;Boot translation finished for clam.boot - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/clam.lisp.pamphlet b/src/interp/clam.lisp.pamphlet new file mode 100644 index 0000000..0a538e5 --- /dev/null +++ b/src/interp/clam.lisp.pamphlet @@ -0,0 +1,2327 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp clam.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(in-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 + +;;; *** |compClam| REDEFINED + +(DEFUN |compClam| (|op| |argl| |body| |$clamList|) + (DECLARE (SPECIAL |$clamList|)) + (PROG (|ISTMP#1| |kind| |ISTMP#2| |eqEtc| |options| |u| |shiftFl| |countFl| + |cacheCount| |phrase| |auxfn| |g1| |LETTMP#1| |arg| |computeValue| + |cacheName| |hitCounter| |callCounter| |callCountCode| |hitCountCode| + |g2| |g3| |lookUpFunction| |returnFoundValue| |namePart| + |secondPredPair| |resetCacheEntry| |thirdPredPair| |codeBody| |lamex| + |mainFunction| |computeFunction| |cacheType| |cacheResetCode| + |cacheCountCode| |cacheVector|) + (RETURN + (PROGN + (COND + (|$InteractiveMode| (|startTimingProcess| (QUOTE |compilation|)))) + (COND + ((NULL + (PROGN + (SPADLET |ISTMP#1| (SPADLET |u| (LASSQ |op| |$clamList|))) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |kind| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |eqEtc| (QCAR |ISTMP#2|)) + (SPADLET |options| (QCDR |ISTMP#2|)) (QUOTE T))))))) + (|keyedSystemError| (QUOTE S2GE0004) (CONS |op| NIL)))) + (SPADLET |$clamList| NIL) + (COND + ((SPADLET |u| (S- |options| (QUOTE (|shift| |count|)))) + (|keyedSystemError| (QUOTE S2GE0006) (CONS |op| |u|)))) + (SPADLET |shiftFl| (MEMQ (QUOTE |shift|) |options|)) + (SPADLET |countFl| (MEMQ (QUOTE |count|) |options|)) + (COND + ((AND (> (|#| |argl|) 1) (BOOT-EQUAL |eqEtc| (QUOTE EQ))) + (|keyedSystemError| (QUOTE S2GE0007) (CONS |op| NIL)))) + (COND + ((AND (NULL (IDENTP |kind|)) (OR (NULL (INTEGERP |kind|)) (> 1 |kind|))) + (|keyedSystemError| (QUOTE S2GE0005) (CONS |op| NIL))) + ((IDENTP |kind|) + (COND + (|shiftFl| + (|keyedSystemError| (QUOTE S2GE0008) (CONS |op| NIL))) + ((QUOTE T) + (|compHash| |op| |argl| |body| + (COND + ((BOOT-EQUAL |kind| (QUOTE |hash|)) NIL) + ((QUOTE T) |kind|)) + |eqEtc| |countFl|)))) + ((QUOTE T) + (SPADLET |cacheCount| |kind|) + (COND + ((NULL |argl|) (|keyedSystemError| (QUOTE S2GE0009) (CONS |op| NIL)))) + (SPADLET |phrase| + (COND + ((EQL |cacheCount| 1) (CONS (MAKESTRING "computed value only") NIL)) + ((QUOTE T) + (APPEND + (|bright| |cacheCount|) + (CONS (MAKESTRING "computed values") NIL))))) + (|sayBrightly| + (APPEND (|bright| |op|) (CONS (MAKESTRING "will save last") |phrase|))) + (SPADLET |auxfn| (INTERNL |op| (MAKESTRING ";"))) + (SPADLET |g1| (GENSYM)) + (SPADLET |LETTMP#1| + (COND + ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) + (CONS (CONS |g1| NIL) (CONS (CONS |auxfn| (CONS |g1| NIL)) NIL))) + ((QUOTE T) + (CONS + |g1| + (CONS + (CONS + (QUOTE APPLX) + (CONS + (CONS (QUOTE |function|) (CONS |auxfn| NIL)) + (CONS |g1| NIL))) + NIL))))) + (SPADLET |arg| (CAR |LETTMP#1|)) + (SPADLET |computeValue| (CADR |LETTMP#1|)) + (SPADLET |cacheName| (INTERNL |op| (MAKESTRING ";AL"))) + (COND + ((BOOT-EQUAL |$reportCounts| (QUOTE T)) + (SPADLET |hitCounter| (INTERNL |op| (MAKESTRING ";hit"))) + (SPADLET |callCounter| (INTERNL |op| (MAKESTRING ";calls"))) + (SET |hitCounter| 0) + (SET |callCounter| 0) + (SPADLET |callCountCode| + (CONS + (CONS + (QUOTE SETQ) + (CONS + |callCounter| + (CONS (CONS (QUOTE QSADD1) (CONS |callCounter| NIL)) NIL))) + NIL)) + (SPADLET |hitCountCode| + (CONS + (CONS + (QUOTE SETQ) + (CONS + |hitCounter| + (CONS (CONS (QUOTE QSADD1) (CONS |hitCounter| NIL)) NIL))) + NIL)))) + (SPADLET |g2| (GENSYM)) + (SPADLET |g3| (GENSYM)) + (SPADLET |lookUpFunction| + (COND + (|shiftFl| + (COND + (|countFl| (QUOTE |assocCacheShiftCount|)) + ((QUOTE T) (QUOTE |assocCacheShift|)))) + (|countFl| (QUOTE |assocCacheCount|)) + ((QUOTE T) (QUOTE |assocCache|)))) + (SPADLET |returnFoundValue| + (COND + (|countFl| (CONS (QUOTE CDDR) (CONS |g3| NIL))) + ((QUOTE T) (CONS (QUOTE CDR) (CONS |g3| NIL))))) + (SPADLET |namePart| + (COND (|countFl| |cacheName|) ((QUOTE T) (MKQ |cacheName|)))) + (SPADLET |secondPredPair| + (CONS + (CONS + (QUOTE SETQ) + (CONS + |g3| + (CONS + (CONS + |lookUpFunction| + (CONS |g1| (CONS |namePart| (CONS |eqEtc| NIL)))) + NIL))) + (APPEND |hitCountCode| (CONS |returnFoundValue| NIL)))) + (SPADLET |resetCacheEntry| + (COND + (|countFl| + (CONS (QUOTE CONS) (CONS 1 (CONS |g2| NIL)))) ((QUOTE T) |g2|))) + (SPADLET |thirdPredPair| + (CONS + (QUOTE (QUOTE T)) + (CONS + (CONS (QUOTE SETQ) (CONS |g2| (CONS |computeValue| NIL))) + (CONS + (CONS + (QUOTE SETQ) + (CONS |g3| (CONS (CONS (QUOTE CAR) (CONS |cacheName| NIL)) NIL))) + (CONS + (CONS (QUOTE RPLACA) (CONS |g3| (CONS |g1| NIL))) + (CONS + (CONS (QUOTE RPLACD) (CONS |g3| (CONS |resetCacheEntry| NIL))) + (CONS |g2| NIL))))))) + (SPADLET |codeBody| + (CONS + (QUOTE PROG) + (CONS + (CONS |g2| (CONS |g3| NIL)) + (APPEND |callCountCode| + (CONS + (CONS + (QUOTE RETURN) + (CONS + (CONS + (QUOTE COND) + (CONS |secondPredPair| (CONS |thirdPredPair| NIL))) + NIL)) + NIL))))) + (SPADLET |lamex| (CONS (QUOTE LAM) (CONS |arg| (CONS |codeBody| NIL)))) + (SPADLET |mainFunction| (CONS |op| (CONS |lamex| NIL))) + (SPADLET |computeFunction| + (CONS |auxfn| (CONS (CONS (QUOTE LAMBDA) (CONS |argl| |body|)) NIL))) + (|compileInteractive| |mainFunction|) + (COND + (|$reportCompilation| + (|sayBrightlyI| + (|bright| (MAKESTRING "Generated LISP code for function:"))) + (|pp| |computeFunction|))) + (|compileQuietly| (CONS |computeFunction| NIL)) + (SPADLET |cacheType| (QUOTE |function|)) + (SPADLET |cacheResetCode| + (CONS + (QUOTE SETQ) + (CONS + |cacheName| + (CONS (CONS (QUOTE |initCache|) (CONS |cacheCount| NIL)) NIL)))) + (SPADLET |cacheCountCode| + (CONS + (QUOTE |countCircularAlist|) + (CONS |cacheName| (CONS |cacheCount| NIL)))) + (SPADLET |cacheVector| + (|mkCacheVec| |op| |cacheName| |cacheType| |cacheResetCode| + |cacheCountCode|)) + (|LAM,EVALANDFILEACTQ| + (CONS + (QUOTE PUT) + (CONS + (MKQ |op|) + (CONS + (MKQ (QUOTE |cacheInfo|)) + (CONS (MKQ |cacheVector|) NIL))))) + (|LAM,EVALANDFILEACTQ| |cacheResetCode|) + (COND (|$InteractiveMode| (|stopTimingProcess| (QUOTE |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 + +;;; *** |compHash| REDEFINED + +(DEFUN |compHash| (|op| |argl| |body| |cacheNameOrNil| |eqEtc| |countFl|) + (PROG (|auxfn| |g1| |key| |LETTMP#1| |arg| |cacheArgKey| |computeValue| + |cacheName| |hitCounter| |callCounter| |callCountCode| |hitCountCode| + |g2| |returnFoundValue| |getCode| |secondPredPair| |putCode| + |thirdPredPair| |codeBody| |lamex| |mainFunction| |computeFunction| + |cacheType| |weakStrong| |cacheResetCode| |cacheCountCode| + |cacheVector|) + (RETURN + (PROGN + (COND + ((AND + |cacheNameOrNil| + (NEQUAL |cacheNameOrNil| (QUOTE |$ConstructorCache|))) + (|keyedSystemError| (QUOTE S2GE0010) (CONS |op| NIL)))) + (COND + ((NULL |argl|) + (COND + ((NULL |cacheNameOrNil|) + (|keyedSystemError| (QUOTE S2GE0011) (CONS |op| NIL))) + ((QUOTE T) NIL)))) + (COND + ((AND + (NULL |cacheNameOrNil|) + (NULL (MEMQ |eqEtc| (QUOTE (EQ CVEC UEQUAL))))) + (|keyedSystemError| (QUOTE S2GE0012) (CONS |op| NIL))) + ((QUOTE T) + (SPADLET |auxfn| (INTERNL |op| (MAKESTRING ";"))) + (SPADLET |g1| (GENSYM)) + (SPADLET |LETTMP#1| + (COND + ((NULL |argl|) (CONS NIL (CONS NIL (CONS (CONS |auxfn| NIL) NIL)))) + ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) + (SPADLET |key| + (COND + (|cacheNameOrNil| (CONS (QUOTE |devaluate|) (CONS |g1| NIL))) + ((QUOTE T) |g1|))) + (CONS + (CONS |g1| NIL) + (CONS + (CONS (QUOTE LIST) (CONS |key| NIL)) + (CONS (CONS |auxfn| (CONS |g1| NIL)) NIL)))) + ((QUOTE T) + (SPADLET |key| + (COND + (|cacheNameOrNil| (CONS (QUOTE |devaluateList|) (CONS |g1| NIL))) + ((QUOTE T) |g1|))) + (CONS + |g1| + (CONS + |key| + (CONS + (CONS + (QUOTE APPLY) + (CONS + (CONS (QUOTE |function|) (CONS |auxfn| NIL)) + (CONS |g1| NIL))) + NIL)))))) + (SPADLET |arg| (CAR |LETTMP#1|)) + (SPADLET |cacheArgKey| (CADR |LETTMP#1|)) + (SPADLET |computeValue| (CADDR |LETTMP#1|)) + (SPADLET |cacheName| + (OR |cacheNameOrNil| (INTERNL |op| (MAKESTRING ";AL")))) + (COND + ((BOOT-EQUAL |$reportCounts| (QUOTE T)) + (SPADLET |hitCounter| (INTERNL |op| (MAKESTRING ";hit"))) + (SPADLET |callCounter| (INTERNL |op| (MAKESTRING ";calls"))) + (SET |hitCounter| 0) + (SET |callCounter| 0) + (SPADLET |callCountCode| + (CONS + (CONS + (QUOTE SETQ) + (CONS + |callCounter| + (CONS (CONS (QUOTE QSADD1) (CONS |callCounter| NIL)) NIL))) + NIL)) + (SPADLET |hitCountCode| + (CONS + (CONS + (QUOTE SETQ) + (CONS + |hitCounter| + (CONS (CONS (QUOTE QSADD1) (CONS |hitCounter| NIL)) NIL))) + NIL)))) + (SPADLET |g2| (GENSYM)) + (SPADLET |returnFoundValue| + (COND + ((NULL |argl|) + (COND + (|countFl| + (CONS + (QUOTE |CDRwithIncrement|) + (CONS (CONS (QUOTE CDAR) (CONS |g2| NIL)) NIL))) + ((QUOTE T) (CONS (QUOTE CDAR) (CONS |g2| NIL))))) + (|countFl| (CONS (QUOTE |CDRwithIncrement|) (CONS |g2| NIL))) + ((QUOTE T) |g2|))) + (SPADLET |getCode| + (COND + ((NULL |argl|) + (CONS (QUOTE HGET) (CONS |cacheName| (CONS (MKQ |op|) NIL)))) + (|cacheNameOrNil| + (COND + ((NEQUAL |eqEtc| (QUOTE EQUAL)) + (CONS + (QUOTE |lassocShiftWithFunction|) + (CONS + |cacheArgKey| + (CONS + (CONS + (QUOTE HGET) + (CONS |cacheNameOrNil| (CONS (MKQ |op|) NIL))) + (CONS (MKQ |eqEtc|) NIL))))) + ((QUOTE T) + (CONS + (QUOTE |lassocShift|) + (CONS + |cacheArgKey| + (CONS + (CONS + (QUOTE HGET) + (CONS |cacheNameOrNil| (CONS (MKQ |op|) NIL))) + NIL)))))) + ((QUOTE T) (CONS (QUOTE HGET) (CONS |cacheName| (CONS |g1| NIL)))))) + (SPADLET |secondPredPair| + (CONS + (CONS (QUOTE SETQ) (CONS |g2| (CONS |getCode| NIL))) + (APPEND |hitCountCode| (CONS |returnFoundValue| NIL)))) + (SPADLET |putCode| + (COND + ((NULL |argl|) + (COND + (|cacheNameOrNil| + (COND + (|countFl| + (CONS + (QUOTE CDDAR) + (CONS + (CONS + (QUOTE HPUT) + (CONS + |cacheNameOrNil| + (CONS + (MKQ |op|) + (CONS + (CONS + (QUOTE LIST) + (CONS + (CONS + (QUOTE CONS) + (CONS + NIL + (CONS + (CONS + (QUOTE CONS) + (CONS 1 (CONS |computeValue| NIL))) NIL))) + NIL)) + NIL)))) + NIL))) + ((QUOTE T) + (CONS + (QUOTE HPUT) + (CONS + |cacheNameOrNil| + (CONS + (MKQ |op|) + (CONS + (CONS + (QUOTE LIST) + (CONS + (CONS (QUOTE CONS) (CONS NIL (CONS |computeValue| NIL))) + NIL)) + NIL))))))) + ((QUOTE T) (|systemError| (MAKESTRING "unexpected"))))) + (|cacheNameOrNil| |computeValue|) + (|countFl| + (CONS + (QUOTE CDR) + (CONS + (CONS + (QUOTE HPUT) + (CONS + |cacheName| + (CONS + |g1| + (CONS + (CONS (QUOTE CONS) (CONS 1 (CONS |computeValue| NIL))) + NIL)))) + NIL))) + ((QUOTE T) + (CONS + (QUOTE HPUT) + (CONS |cacheName| (CONS |g1| (CONS |computeValue| NIL))))))) + (COND + (|cacheNameOrNil| + (SPADLET |putCode| + (CONS + (QUOTE UNWIND-PROTECT) + (CONS + (CONS + (QUOTE PROG1) + (CONS + |putCode| + (CONS (CONS (QUOTE SETQ) (CONS |g2| (CONS (QUOTE T) NIL))) NIL))) + (CONS + (CONS + (QUOTE COND) + (CONS + (CONS + (CONS (QUOTE NOT) (CONS |g2| NIL)) + (CONS + (CONS (QUOTE HREM) (CONS |cacheName| (CONS (MKQ |op|) NIL))) + NIL)) + NIL)) + NIL)))))) + (SPADLET |thirdPredPair| (CONS (QUOTE (QUOTE T)) (CONS |putCode| NIL))) + (SPADLET |codeBody| + (CONS + (QUOTE PROG) + (CONS + (CONS |g2| NIL) + (APPEND + |callCountCode| + (CONS + (CONS + (QUOTE RETURN) + (CONS + (CONS + (QUOTE COND) (CONS |secondPredPair| (CONS |thirdPredPair| NIL))) + NIL)) + NIL))))) + (SPADLET |lamex| (CONS (QUOTE LAM) (CONS |arg| (CONS |codeBody| NIL)))) + (SPADLET |mainFunction| (CONS |op| (CONS |lamex| NIL))) + (SPADLET |computeFunction| + (CONS |auxfn| (CONS (CONS (QUOTE LAMBDA) (CONS |argl| |body|)) NIL))) + (|compileInteractive| |mainFunction|) + (COND + (|$reportCompilation| + (|sayBrightlyI| + (|bright| + (MAKESTRING "Generated LISP code for function:"))) + (|pp| |computeFunction|))) + (|compileQuietly| (CONS |computeFunction| NIL)) + (COND + ((NULL |cacheNameOrNil|) + (SPADLET |cacheType| + (COND + (|countFl| (QUOTE |hash-tableWithCounts|)) + ((QUOTE T) (QUOTE |hash-table|)))) + (SPADLET |weakStrong| + (COND (|countFl| (QUOTE STRONG)) ((QUOTE T) (QUOTE WEAK)))) + (SPADLET |cacheResetCode| + (CONS + (QUOTE SETQ) + (CONS + |cacheName| + (CONS + (CONS (QUOTE MAKE-HASHTABLE) (CONS (MKQ |eqEtc|) NIL)) + NIL)))) + (SPADLET |cacheCountCode| + (CONS (QUOTE |hashCount|) (CONS |cacheName| NIL))) + (SPADLET |cacheVector| + (|mkCacheVec| |op| |cacheName| |cacheType| |cacheResetCode| + |cacheCountCode|)) + (|LAM,EVALANDFILEACTQ| + (CONS + (QUOTE PUT) + (CONS + (MKQ |op|) + (CONS (MKQ (QUOTE |cacheInfo|)) (CONS (MKQ |cacheVector|) NIL))))) + (|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 + +;;; *** |compHashGlobal| REDEFINED + +(DEFUN |compHashGlobal| (|op| |argl| |body| |cacheName| |eqEtc| |countFl|) + (PROG (|auxfn| |g1| |application| |LETTMP#1| |arg| |cacheArgKey| + |computeValue| |g2| |returnFoundValue| |getCode| |secondPredPair| + |putForm| |putCode| |thirdPredPair| |codeBody| |lamex| |mainFunction| + |computeFunction|) + (RETURN + (PROGN + (COND + ((NULL (MEMQ |eqEtc| (QUOTE (UEQUAL)))) + (|sayBrightly| + (MAKESTRING + "for hash option, only EQ, CVEC, and UEQUAL are allowed")))) + (SPADLET |auxfn| (INTERNL |op| (MAKESTRING ";"))) + (SPADLET |g1| (GENSYM)) + (SPADLET |LETTMP#1| + (PROGN + (SPADLET |application| + (COND + ((NULL |argl|) (CONS |auxfn| NIL)) + ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) + (CONS |auxfn| (CONS |g1| NIL))) + ((QUOTE T) + (CONS + (QUOTE APPLX) + (CONS + (CONS (QUOTE |function|) (CONS |auxfn| NIL)) + (CONS |g1| NIL)))))) + (CONS + |g1| + (CONS + (CONS (QUOTE |consForHashLookup|) (CONS (MKQ |op|) (CONS |g1| NIL))) + (CONS |application| NIL))))) + (SPADLET |arg| (CAR |LETTMP#1|)) + (SPADLET |cacheArgKey| (CADR |LETTMP#1|)) + (SPADLET |computeValue| (CADDR |LETTMP#1|)) + (SPADLET |g2| (GENSYM)) + (SPADLET |returnFoundValue| + (COND + (|countFl| (CONS (QUOTE |CDRwithIncrement|) (CONS |g2| NIL))) + ((QUOTE T) |g2|))) + (SPADLET |getCode| + (CONS (QUOTE HGET) (CONS |cacheName| (CONS |cacheArgKey| NIL)))) + (SPADLET |secondPredPair| + (CONS + (CONS (QUOTE SETQ) (CONS |g2| (CONS |getCode| NIL))) + (CONS |returnFoundValue| NIL))) + (SPADLET |putForm| (CONS (QUOTE CONS) (CONS (MKQ |op|) (CONS |g1| NIL)))) + (SPADLET |putCode| + (COND + (|countFl| + (CONS + (QUOTE HPUT) + (CONS + |cacheName| + (CONS + |putForm| + (CONS (CONS (QUOTE CONS) (CONS 1 (CONS |computeValue| NIL))) NIL))))) + ((QUOTE T) + (CONS + (QUOTE HPUT) + (CONS |cacheName| (CONS |putForm| (CONS |computeValue| NIL))))))) + (SPADLET |thirdPredPair| (CONS (QUOTE (QUOTE T)) (CONS |putCode| NIL))) + (SPADLET |codeBody| + (CONS + (QUOTE PROG) + (CONS + (CONS |g2| NIL) + (CONS + (CONS + (QUOTE RETURN) + (CONS + (CONS + (QUOTE COND) + (CONS |secondPredPair| (CONS |thirdPredPair| NIL))) + NIL)) + NIL)))) + (SPADLET |lamex| (CONS (QUOTE LAM) (CONS |arg| (CONS |codeBody| NIL)))) + (SPADLET |mainFunction| (CONS |op| (CONS |lamex| NIL))) + (SPADLET |computeFunction| + (CONS |auxfn| (CONS (CONS (QUOTE LAMBDA) (CONS |argl| |body|)) NIL))) + (|compileInteractive| |mainFunction|) + (|compileInteractive| |computeFunction|) + |op|)))) +; +;consForHashLookup(a,b) == +; RPLACA($hashNode,a) +; RPLACD($hashNode,b) +; $hashNode + +;;; *** |consForHashLookup| REDEFINED + +(DEFUN |consForHashLookup| (|a| |b|) + (PROGN (RPLACA |$hashNode| |a|) (RPLACD |$hashNode| |b|) |$hashNode|)) +; +;CDRwithIncrement x == +; RPLACA(x,QSADD1 CAR x) +; CDR x + +;;; *** |CDRwithIncrement| REDEFINED + +(DEFUN |CDRwithIncrement| (|x|) + (PROGN (RPLACA |x| (QSADD1 (CAR |x|))) (CDR |x|))) +; +;HGETandCount(hashTable,prop) == +; u:= HGET(hashTable,prop) or return nil +; RPLACA(u,QSADD1 CAR u) +; u + +;;; *** |HGETandCount| REDEFINED + +(DEFUN |HGETandCount| (|hashTable| |prop|) + (PROG (|u|) + (RETURN + (PROGN + (SPADLET |u| (OR (HGET |hashTable| |prop|) (RETURN NIL))) + (RPLACA |u| (QSADD1 (CAR |u|))) |u|)))) +; +;clearClams() == +; for [fn,kind,:.] in $clamList | kind = 'hash or INTEGERP kind repeat +; clearClam fn + +;;; *** |clearClams| REDEFINED + +(DEFUN |clearClams| NIL + (PROG (|fn| |kind|) + (RETURN + (SEQ + (DO ((#0=#:G2474 |$clamList| (CDR #0#)) (#1=#:G2465 NIL)) + ((OR + (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |fn| (CAR #1#)) (SPADLET |kind| (CADR #1#)) #1#) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((OR (BOOT-EQUAL |kind| (QUOTE |hash|)) (INTEGERP |kind|)) + (|clearClam| |fn|)))))))))) +; +;clearClam fn == +; infovec:= GET(fn,'cacheInfo) or keyedSystemError("S2GE0003",[fn]) +; eval infovec.cacheReset + +;;; *** |clearClam| REDEFINED + +(DEFUN |clearClam| (|fn|) + (PROG (|infovec|) + (RETURN + (PROGN + (SPADLET |infovec| + (OR + (GETL |fn| (QUOTE |cacheInfo|)) + (|keyedSystemError| (QUOTE S2GE0003) (CONS |fn| NIL)))) + (|eval| (CADDDR |infovec|)))))) +; +;reportAndClearClams() == +; cacheStats() +; clearClams() + +;;; *** |reportAndClearClams| REDEFINED + +(DEFUN |reportAndClearClams| NIL (PROGN (|cacheStats|) (|clearClams|))) +; +;clearConstructorCaches() == +; clearCategoryCaches() +; CLRHASH $ConstructorCache + +;;; *** |clearConstructorCaches| REDEFINED + +(DEFUN |clearConstructorCaches| NIL + (PROGN (|clearCategoryCaches|) (CLRHASH |$ConstructorCache|))) +; +;clearConstructorCache(cname) == +; (kind := GETDATABASE(cname,'CONSTRUCTORKIND)) => +; kind = 'category => clearCategoryCache cname +; HREM($ConstructorCache,cname) + +;;; *** |clearConstructorCache| REDEFINED + +(DEFUN |clearConstructorCache| (|cname|) + (PROG (|kind|) + (RETURN + (SEQ + (COND + ((SPADLET |kind| (GETDATABASE |cname| (QUOTE CONSTRUCTORKIND))) + (EXIT + (COND + ((BOOT-EQUAL |kind| (QUOTE |category|)) + (|clearCategoryCache| |cname|)) + ((QUOTE T) (HREM |$ConstructorCache| |cname|)))))))))) +; +;clearConstructorAndLisplibCaches() == +; clearClams() +; clearConstructorCaches() + +;;; *** |clearConstructorAndLisplibCaches| REDEFINED + +(DEFUN |clearConstructorAndLisplibCaches| NIL + (PROGN (|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) + +;;; *** |clearCategoryCaches| REDEFINED + +(DEFUN |clearCategoryCaches| NIL + (PROG (|cacheName|) + (RETURN + (SEQ + (DO ((#0=#:G2514 (|allConstructors|) (CDR #0#)) (|name| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |name| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (COND + ((BOOT-EQUAL + (GETDATABASE |name| (QUOTE CONSTRUCTORKIND)) + (QUOTE |category|)) + (COND + ((BOUNDP + (SPADLET |cacheName| + (INTERNL (STRCONC (PNAME |name|) (MAKESTRING ";AL"))))) + (SET |cacheName| NIL)) + ((QUOTE T) NIL)))) + (COND + ((BOUNDP + (SPADLET |cacheName| + (INTERNL (STRCONC (PNAME |name|) (MAKESTRING ";CAT"))))) + (SET |cacheName| NIL)) + ((QUOTE T) NIL)))))))))) +; +;clearCategoryCache catName == +; cacheName:= INTERNL STRCONC(PNAME catName,'";AL") +; SET(cacheName,nil) + +;;; *** |clearCategoryCache| REDEFINED + +(DEFUN |clearCategoryCache| (|catName|) + (PROG (|cacheName|) + (RETURN + (PROGN + (SPADLET |cacheName| + (INTERNL (STRCONC (PNAME |catName|) (MAKESTRING ";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 + +;;; *** |displayHashtable| REDEFINED + +(DEFUN |displayHashtable| (|x|) + (PROG (|l| |a| |b|) + (RETURN + (SEQ + (PROGN + (SPADLET |l| + (NREVERSE + (SORTBY + (QUOTE CAR) + (PROG (#0=#:G2540) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G2545 (HKEYS |x|) (CDR #1#)) (|key| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |key| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (CONS (|opOf| (HGET |x| |key|)) (CONS |key| NIL)) + #0#)))))))))) + (DO ((#2=#:G2557 |l| (CDR #2#)) (#3=#:G2531 NIL)) + ((OR + (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN + (PROGN (SPADLET |a| (CAR #3#)) (SPADLET |b| (CADR #3#)) #3#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (|sayBrightlyNT| + (CONS (QUOTE |%b|) (CONS |a| (CONS (QUOTE |%d|) NIL)))) + (|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"] + +;;; *** |cacheStats| REDEFINED + +(DEFUN |cacheStats| NIL + (PROG (|fn| |kind| |u|) + (RETURN + (SEQ + (DO ((#0=#:G2581 |$clamList| (CDR #0#)) (#1=#:G2572 NIL)) + ((OR + (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |fn| (CAR #1#)) + (SPADLET |kind| (CADR #1#)) + (SPADLET |u| (CDDR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL (MEMQ (QUOTE |count|) |u|)) + (|sayBrightly| + (CONS + (MAKESTRING "%b") + (CONS + |fn| + (CONS + (MAKESTRING "%d") + (CONS (MAKESTRING "does not keep reference counts") NIL)))))) + ((INTEGERP |kind|) (|reportCircularCacheStats| |fn| |kind|)) + ((BOOT-EQUAL |kind| (QUOTE |hash|)) (|reportHashCacheStats| |fn|)) + ((QUOTE T) + (|sayBrightly| + (CONS + (MAKESTRING "Unknown cache type for") + (CONS + (MAKESTRING "%b") + (CONS |fn| (CONS (MAKESTRING "%d") NIL)))))))))))))) +; +;reportCircularCacheStats(fn,n) == +; infovec:= GET(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() + +;;; *** |reportCircularCacheStats| REDEFINED + +(DEFUN |reportCircularCacheStats| (|fn| |n|) + (PROG (|infovec| |circList| |numberUsed|) + (RETURN + (SEQ + (PROGN + (SPADLET |infovec| (GETL |fn| (QUOTE |cacheInfo|))) + (SPADLET |circList| (|eval| (CADR |infovec|))) + (SPADLET |numberUsed| + (PROG (#0=#:G2595) + (SPADLET #0# 0) + (RETURN + (DO ((|i| 1 (QSADD1 |i|)) (#1=#:G2602 |circList| (CDR #1#)) (|x| NIL)) + ((OR + (QSGREATERP |i| |n|) + (ATOM #1#) + (PROGN (SETQ |x| (CAR #1#)) NIL) + (NULL + (NULL (AND (PAIRP |x|) (EQUAL (QCAR |x|) (QUOTE |$failed|)))))) + #0#) + (SEQ (EXIT (SETQ #0# (PLUS #0# 1)))))))) + (|sayBrightly| + (CONS + (MAKESTRING "%b") + (CONS + |fn| + (CONS + (MAKESTRING "%d") + (CONS + (MAKESTRING "has") + (CONS + (MAKESTRING "%b") + (CONS + |numberUsed| + (CONS + (MAKESTRING "%d") + (CONS + (MAKESTRING "/ ") + (CONS |n| (CONS (MAKESTRING " values cached") NIL))))))))))) + (|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() + +;;; *** |displayCacheFrequency| REDEFINED + +(DEFUN |displayCacheFrequency| (|al|) + (PROG (|a| |b|) + (RETURN + (SEQ + (PROGN + (SPADLET |al| (NREVERSE (SORTBY (QUOTE CAR) |al|))) + (|sayBrightlyNT| (QUOTE | #hits/#occurrences: |)) + (DO ((#0=#:G2626 |al| (CDR #0#)) (#1=#:G2617 NIL)) + ((OR + (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |a| (CAR #1#)) (SPADLET |b| (CDR #1#)) #1#) NIL)) + NIL) + (SEQ + (EXIT + (|sayBrightlyNT| + (CONS |a| (CONS (QUOTE /) (CONS |b| (CONS (QUOTE | |) NIL)))))))) + (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 + +;;; *** |mkCircularCountAlist| REDEFINED + +(DEFUN |mkCircularCountAlist| (|cl| |len|) + (PROG (|x| |count| |u| |al|) + (RETURN + (SEQ + (PROGN + (DO + ((#0=#:G2652 |cl| (CDR #0#)) (#1=#:G2641 NIL) (|i| 1 (QSADD1 |i|))) + ((OR + (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |x| (CAR #1#)) (SPADLET |count| (CADR #1#)) #1#) NIL) + (QSGREATERP |i| |len|) + (NULL (NEQUAL |x| (QUOTE |$failed|)))) + NIL) + (SEQ + (EXIT + (COND + ((SPADLET |u| (|assoc| |count| |al|)) (RPLACD |u| (PLUS 1 (CDR |u|)))) + ((QUOTE T) + (COND + ((AND + (INTEGERP |$reportFavoritesIfNumber|) + (>= |count| |$reportFavoritesIfNumber|)) + (|sayBrightlyNT| + (CONS (QUOTE | |) (CONS |count| (CONS (QUOTE | |) NIL)))) + (|pp| |x|))) + (SPADLET |al| (CONS (CONS |count| 1) |al|))))))) + |al|))))) +; +;reportHashCacheStats fn == +; infovec:= GET(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() + +;;; *** |reportHashCacheStats| REDEFINED + +(DEFUN |reportHashCacheStats| (|fn|) + (PROG (|infovec| |hashTable| |hashValues|) + (RETURN + (SEQ + (PROGN + (SPADLET |infovec| (GETL |fn| (QUOTE |cacheInfo|))) + (SPADLET |hashTable| (|eval| (CADR |infovec|))) + (SPADLET |hashValues| + (PROG (#0=#:G2673) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G2678 (HKEYS |hashTable|) (CDR #1#)) (|key| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |key| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (HGET |hashTable| |key|) #0#)))))))) + (|sayBrightly| + (APPEND + (|bright| |fn|) + (CONS + (MAKESTRING "has") + (APPEND + (|bright| (|#| |hashValues|)) + (CONS (MAKESTRING "values cached.") NIL))))) + (|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 + +;;; *** |mkHashCountAlist| REDEFINED + +(DEFUN |mkHashCountAlist| (|vl|) + (PROG (|count| |u| |al|) + (RETURN + (SEQ + (PROGN + (DO ((#0=#:G2700 |vl| (CDR #0#)) (#1=#:G2692 NIL)) + ((OR + (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN (PROGN (SPADLET |count| (CAR #1#)) #1#) NIL)) + NIL) + (SEQ + (EXIT + (COND + ((SPADLET |u| (|assoc| |count| |al|)) + (RPLACD |u| (PLUS 1 (CDR |u|)))) + ((QUOTE T) + (SPADLET |al| (CONS (CONS |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 + +;;; *** |clearHashReferenceCounts| REDEFINED + +(DEFUN |clearHashReferenceCounts| NIL + (SEQ + (DO ((#0=#:G2717 |$clamList| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL (CADDR |x|) (QUOTE |hash-tableWithCounts|)) + (|remHashEntriesWith0Count| (|eval| (CADR |x|)))) + ((BOOT-EQUAL (CADDR |x|) (QUOTE |hash-table|)) + (CLRHASH (|eval| (CADR |x|)))))))))) +; +;remHashEntriesWith0Count $hashTable == +; MAPHASH(fn,$hashTable) where fn(key,obj) == +; CAR obj = 0 => HREM($hashTable,key) --free store +; nil + +;;; *** |remHashEntriesWith0Count,fn| REDEFINED + +(DEFUN |remHashEntriesWith0Count,fn| (|key| |obj|) + (SEQ + (IF (EQL (CAR |obj|) 0) (EXIT (HREM |$hashTable| |key|))) + (EXIT NIL))) + +;;; *** |remHashEntriesWith0Count| REDEFINED + +(DEFUN |remHashEntriesWith0Count| (|$hashTable|) + (DECLARE (SPECIAL |$hashTable|)) + (MAPHASH |remHashEntriesWith0Count,fn| |$hashTable|)) +; +;initCache n == +; tail:= '(0 . $failed) +; l:= [[$failed,:tail] for i in 1..n] +; RPLACD(LASTNODE l,l) + +;;; *** |initCache| REDEFINED + +(DEFUN |initCache| (|n|) + (PROG (|tail| |l|) + (RETURN + (SEQ + (PROGN + (SPADLET |tail| (QUOTE (0 . |$failed|))) + (SPADLET |l| + (PROG (#0=#:G2740) + (SPADLET #0# NIL) + (RETURN + (DO ((|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| |n|) (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (CONS |$failed| |tail|) #0#)))))))) + (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 + +;;; *** |assocCache| REDEFINED + +(DEFUN |assocCache| (|x| |cacheName| |fn|) + (PROG (|al| |val| |backPointer| |forwardPointer|) + (RETURN + (SEQ + (PROGN + (SPADLET |al| (|eval| |cacheName|)) + (SPADLET |forwardPointer| |al|) + (SPADLET |val| NIL) + (DO ((#0=#:G2759 NIL (EQ |forwardPointer| |al|))) + (#0# NIL) + (SEQ + (EXIT + (COND + ((FUNCALL |fn| (CAAR |forwardPointer|) |x|) + (RETURN (SPADLET |val| (CAR |forwardPointer|)))) + ((QUOTE T) + (SPADLET |backPointer| |forwardPointer|) + (SPADLET |forwardPointer| (CDR |forwardPointer|))))))) + (COND (|val| |val|) ((QUOTE T) (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 + +;;; *** |assocCacheShift| REDEFINED + +(DEFUN |assocCacheShift| (|x| |cacheName| |fn|) + (PROG (|al| |y| |val| |backPointer| |forwardPointer|) + (RETURN + (SEQ + (PROGN + (SPADLET |al| (|eval| |cacheName|)) + (SPADLET |forwardPointer| |al|) + (SPADLET |val| NIL) + (DO ((#0=#:G2779 NIL (EQ |forwardPointer| |al|))) + (#0# NIL) + (SEQ + (EXIT + (COND + ((FUNCALL |fn| (CAR (SPADLET |y| (CAR |forwardPointer|))) |x|) + (COND + ((NULL (EQ |forwardPointer| |al|)) + (RPLACA |forwardPointer| (CAR |al|)) + (RPLACA |al| |y|))) + (RETURN (SPADLET |val| |y|))) + ((QUOTE T) + (SPADLET |backPointer| |forwardPointer|) + (SPADLET |forwardPointer| (CDR |forwardPointer|))))))) + (COND (|val| |val|) ((QUOTE T) (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 + +;;; *** |assocCacheShiftCount| REDEFINED + +(DEFUN |assocCacheShiftCount| (|x| |al| |fn|) + (PROG (|y| |val| |c| |minCount| |newFrontPointer| |forwardPointer| |temp|) + (RETURN + (SEQ + (PROGN + (SPADLET |forwardPointer| |al|) + (SPADLET |val| NIL) + (SPADLET |minCount| 10000) + (DO ((#0=#:G2801 NIL (EQ |forwardPointer| |al|))) + (#0# NIL) + (SEQ + (EXIT + (COND + ((FUNCALL |fn| (CAR (SPADLET |y| (CAR |forwardPointer|))) |x|) + (SPADLET |newFrontPointer| |forwardPointer|) + (RPLAC (CADR |y|) (QSADD1 (CADR |y|))) + (RETURN (SPADLET |val| |y|))) + ((QUOTE T) + (COND + ((QSLESSP (SPADLET |c| (CADR |y|)) |minCount|) + (SPADLET |minCount| |c|) + (SPADLET |newFrontPointer| |forwardPointer|))) + (SPADLET |forwardPointer| (CDR |forwardPointer|))))))) + (COND + ((NULL (EQ |newFrontPointer| |al|)) + (SPADLET |temp| (CAR |newFrontPointer|)) + (RPLACA |newFrontPointer| (CAR |al|)) + (RPLACA |al| |temp|))) + |val|))))) +; +;clamStats() == +; for [op,kind,:.] in $clamList repeat +; cacheVec:= GET(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] + +;;; *** |clamStats| REDEFINED + +(DEFUN |clamStats| NIL + (PROG (|op| |kind| |cacheVec| |hitCounter| |callCounter| |res| |prefix| + |cacheValue| |empties| |postString|) + (RETURN + (SEQ + (DO ((#0=#:G2836 |$clamList| (CDR #0#)) (#1=#:G2822 NIL)) + ((OR + (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |op| (CAR #1#)) (SPADLET |kind| (CADR #1#)) #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |cacheVec| + (OR + (GETL |op| (QUOTE |cacheInfo|)) + (|systemErrorHere| (QUOTE |clamStats|)))) + (SPADLET |prefix| + (COND + ((NEQUAL |$reportCounts| (QUOTE T)) NIL) + ((QUOTE T) + (SPADLET |hitCounter| (INTERNL |op| (MAKESTRING ";hit"))) + (SPADLET |callCounter| (INTERNL |op| (MAKESTRING ";calls"))) + (SPADLET |res| + (CONS + (QUOTE |%b|) + (CONS + (|eval| |hitCounter|) + (CONS + (QUOTE /) + (CONS + (|eval| |callCounter|) + (CONS (QUOTE |%d|) (CONS (QUOTE |calls to |) NIL))))))) + (SET |hitCounter| 0) (SET |callCounter| 0) |res|))) + (SPADLET |postString| + (PROGN + (SPADLET |cacheValue| (|eval| (CADR |cacheVec|))) + (COND + ((BOOT-EQUAL |kind| (QUOTE |hash|)) + (CONS + (QUOTE | (|) + (CONS + (QUOTE |%b|) + (CONS + (HASH-TABLE-COUNT |cacheValue|) + (CONS (QUOTE |%d|) (CONS (QUOTE |entries)|) NIL)))))) + ((QUOTE T) + (SPADLET |empties| + (|numberOfEmptySlots| (|eval| (CADR |cacheVec|)))) + (COND + ((EQL |empties| 0) NIL) + ((QUOTE T) + (CONS + (QUOTE | (|) + (CONS + (QUOTE |%b|) + (CONS + (SPADDIFFERENCE |kind| |empties|) + (CONS + (QUOTE /) + (CONS + |kind| + (CONS + (QUOTE |%d|) + (CONS (QUOTE |slots used)|) NIL))))))))))))) + (|sayBrightly| (APPEND |prefix| (CONS |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 + +;;; *** |numberOfEmptySlots| REDEFINED + +(DEFUN |numberOfEmptySlots| (|cache|) + (PROG (|count|) + (RETURN + (SEQ + (PROGN + (SPADLET |count| + (COND ((BOOT-EQUAL (CAAR |cache|) (QUOTE |$failed|)) 1) ((QUOTE T) 0))) + (DO ((|x| (CDR |cache|) (CDR |x|))) + ((OR (ATOM |x|) (NULL (NE |x| |cache|))) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL (CAAR |x|) (QUOTE |$failed|)) + (SPADLET |count| (PLUS |count| 1))) + ((QUOTE T) NIL))))) + |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) + +;;; *** |addToSlam| REDEFINED + +(DEFUN |addToSlam| (#0=#:G2872 |shell|) + (PROG (|name| |argnames| |args|) + (RETURN + (SEQ + (PROGN + (SPADLET |name| (CAR #0#)) + (SPADLET |argnames| (CDR #0#)) + (COND + (|$mutableDomain| (RETURN NIL)) + ((NULL |argnames|) (|addToConstructorCache| |name| NIL |shell|)) + ((QUOTE T) + (SPADLET |args| + (CONS + (QUOTE LIST) + (PROG (#1=#:G2885) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=#:G2890 |argnames| (CDR #2#)) (|a| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |a| (CAR #2#)) NIL)) + (NREVERSE0 #1#)) + (SEQ (EXIT (SETQ #1# (CONS (|mkDevaluate| |a|) #1#))))))))) + (|addToConstructorCache| |name| |args| |shell|)))))))) +; +;addToConstructorCache(op,args,value) == +; ['haddProp,'$ConstructorCache,MKQ op,args,['CONS,1,value]] + +;;; *** |addToConstructorCache| REDEFINED + +(DEFUN |addToConstructorCache| (|op| |args| |value|) + (CONS + (QUOTE |haddProp|) + (CONS + (QUOTE |$ConstructorCache|) + (CONS + (MKQ |op|) + (CONS + |args| + (CONS (CONS (QUOTE CONS) (CONS 1 (CONS |value| NIL))) NIL)))))) +; +;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 + +;;; *** |haddProp| REDEFINED + +(DEFUN |haddProp| (|ht| |op| |prop| |val|) + (PROG (|$op| |u|) + (DECLARE (SPECIAL |$op|)) + (RETURN + (PROGN + (|statRecordInstantiationEvent|) + (COND + ((OR + (BOOT-EQUAL |$reportInstantiations| (QUOTE T)) + (BOOT-EQUAL |$reportEachInstantiation| (QUOTE T))) + (|startTimingProcess| (QUOTE |debug|)) + (|recordInstantiation| |op| |prop| NIL) + (|stopTimingProcess| (QUOTE |debug|)))) + (COND + ((SPADLET |u| (HGET |ht| |op|)) + (COND + ((|assoc| |prop| |u|) |val|) + ((QUOTE T) + (RPLACD |u| (CONS (CAR |u|) (CDR |u|))) + (RPLACA |u| (CONS |prop| |val|)) + (SPADLET |$op| |op|) (|listTruncate| |u| 20) |val|))) + ((QUOTE T) (HPUT |ht| |op| (CONS (CONS |prop| |val|) NIL)) |val|)))))) +; +;recordInstantiation(op,prop,dropIfTrue) == +; startTimingProcess 'debug +; recordInstantiation1(op,prop,dropIfTrue) +; stopTimingProcess 'debug + +;;; *** |recordInstantiation| REDEFINED + +(DEFUN |recordInstantiation| (|op| |prop| |dropIfTrue|) + (PROGN + (|startTimingProcess| (QUOTE |debug|)) + (|recordInstantiation1| |op| |prop| |dropIfTrue|) + (|stopTimingProcess| (QUOTE |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]]) + +;;; *** |recordInstantiation1| REDEFINED + +(DEFUN |recordInstantiation1| (|op| |prop| |dropIfTrue|) + (PROG (|trailer| |m1| |ISTMP#1| |m2| |xtra| |u| |v| |val|) + (RETURN + (COND + ((|member| |op| (QUOTE (|CategoryDefaults| |RepeatedSquaring|))) NIL) + ((QUOTE T) + (COND + ((BOOT-EQUAL |$reportEachInstantiation| (QUOTE T)) + (SPADLET |trailer| + (COND + (|dropIfTrue| (MAKESTRING " dropped")) + ((QUOTE T) (MAKESTRING " instantiated")))) + (COND + ((BOOT-EQUAL |$insideCoerceInteractive| (QUOTE T)) + (SPADLET |$instantCoerceCount| (PLUS 1 |$instantCoerceCount|)))) + (COND + ((AND + (PAIRP |$insideCanCoerceFrom|) + (PROGN + (SPADLET |m1| (QCAR |$insideCanCoerceFrom|)) + (SPADLET |ISTMP#1| (QCDR |$insideCanCoerceFrom|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |m2| (QCAR |ISTMP#1|)) (QUOTE T)))) + (NULL |dropIfTrue|)) + (SPADLET |$instantCanCoerceCount| (PLUS 1 |$instantCanCoerceCount|)) + (SPADLET |xtra| + (CONS + (MAKESTRING " for ") + (CONS + (|outputDomainConstructor| |m1|) + (CONS + (MAKESTRING "-->") + (CONS (|outputDomainConstructor| |m2|) NIL))))))) + (COND + ((AND + (BOOT-EQUAL |$insideEvalMmCondIfTrue| (QUOTE T)) + (NULL |dropIfTrue|)) + (SPADLET |$instantMmCondCount| (PLUS |$instantMmCondCount| 1)))) + (|typeTimePrin| + (CONS + (QUOTE CONCAT) + (CONS + (|outputDomainConstructor| (CONS |op| |prop|)) + (CONS |trailer| |xtra|)))))) + (COND + ((NULL |$reportInstantiations|) NIL) + ((SPADLET |u| (HGET |$instantRecord| |op|)) + (COND + ((SPADLET |v| (LASSOC |prop| |u|)) + (COND + (|dropIfTrue| (RPLAC (CDR |v|) (PLUS 1 (CDR |v|)))) + ((QUOTE T) (RPLAC (CAR |v|) (PLUS 1 (CAR |v|)))))) + ((QUOTE T) + (RPLACD |u| (CONS (CAR |u|) (CDR |u|))) + (SPADLET |val| + (COND (|dropIfTrue| (CONS 0 1)) ((QUOTE T) (CONS 1 0)))) + (RPLACA |u| (CONS |prop| |val|))))) + ((QUOTE T) + (SPADLET |val| + (COND (|dropIfTrue| (CONS 0 1)) ((QUOTE T) (CONS 1 0)))) + (HPUT |$instantRecord| |op| (CONS (CONS |prop| |val|) NIL))))))))) +; +;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"] + +;;; *** |reportInstantiations| REDEFINED + +(DEFUN |reportInstantiations| NIL + (PROG (|argList| |conList| |n| |m| |form| |nTotal| |mTotal| |rTotal| + |nForms|) + (RETURN + (SEQ + (PROGN + (SPADLET |conList| + (PROG (#0=#:G2964) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G2973 (HKEYS |$instantRecord|) (CDR #1#)) (|key| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |key| (CAR #1#)) NIL)) #0#) + (SEQ + (EXIT + (SETQ #0# + (APPEND + #0# + (PROG (#2=#:G2984) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G2990 (HGET |$instantRecord| |key|) (CDR #3#)) + (#4=#:G2952 NIL)) + ((OR + (ATOM #3#) + (PROGN (SETQ #4# (CAR #3#)) NIL) + (PROGN + (PROGN + (SPADLET |argList| (CAR #4#)) + (SPADLET |n| (CADR #4#)) + (SPADLET |m| (CDDR #4#)) #4#) + NIL)) + (NREVERSE0 #2#)) + (SEQ + (EXIT + (SETQ #2# + (CONS + (CONS |n| (CONS |m| (CONS (CONS |key| |argList|) NIL))) + #2#))))))))))))))) + (|sayBrightly| + (CONS + (MAKESTRING "# instantiated/# dropped/domain name") + (CONS + (MAKESTRING "%l") + (CONS (MAKESTRING "------------------------------------") NIL)))) + (SPADLET |nTotal| + (SPADLET |mTotal| (SPADLET |rTotal| (SPADLET |nForms| 0)))) + (DO ((#5=#:G3006 (NREVERSE (SORTBY (QUOTE CADDR) |conList|)) (CDR #5#)) + (#6=#:G2958 NIL)) + ((OR + (ATOM #5#) + (PROGN (SETQ #6# (CAR #5#)) NIL) + (PROGN + (PROGN + (SPADLET |n| (CAR #6#)) + (SPADLET |m| (CADR #6#)) + (SPADLET |form| (CADDR #6#)) + #6#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |nTotal| (PLUS |nTotal| |n|)) + (SPADLET |mTotal| (PLUS |mTotal| |m|)) + (COND + ((> |n| 1) + (SPADLET |rTotal| (SPADDIFFERENCE (PLUS |rTotal| |n|) 1)))) + (SPADLET |nForms| (PLUS |nForms| 1)) + (|typeTimePrin| + (CONS + (QUOTE CONCATB) + (CONS + |n| + (CONS |m| (CONS (|outputDomainConstructor| |form|) NIL))))))))) + (|sayBrightly| + (CONS + (MAKESTRING "%b") + (CONS + (MAKESTRING "Totals:") + (CONS + (MAKESTRING "%d") + (CONS + |nTotal| + (CONS + (MAKESTRING " instantiated") + (CONS + (MAKESTRING "%l") + (CONS + (MAKESTRING " ") + (CONS + |$instantCoerceCount| + (CONS + (MAKESTRING " inside coerceInteractive") + (CONS + (MAKESTRING "%l") + (CONS + (MAKESTRING " ") + (CONS + |$instantCanCoerceCount| + (CONS + (MAKESTRING " inside canCoerceFrom") + (CONS + (MAKESTRING "%l") + (CONS + (MAKESTRING " ") + (CONS + |$instantMmCondCount| + (CONS + (MAKESTRING " inside evalMmCond") + (CONS + (MAKESTRING "%l") + (CONS + (MAKESTRING " ") + (CONS + |rTotal| + (CONS + (MAKESTRING " reinstantiated") + (CONS + (MAKESTRING "%l") + (CONS + (MAKESTRING " ") + (CONS + |mTotal| + (CONS + (MAKESTRING " dropped") + (CONS + (MAKESTRING "%l") + (CONS + (MAKESTRING " ") + (CONS + |nForms| + (CONS + (MAKESTRING + " distinct domains instantiated/dropped") + NIL))))))))))))))))))))))))))))))))))) +; +;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) + +;;; *** |hputNewProp| REDEFINED + +(DEFUN |hputNewProp| (|ht| |op| |argList| |val|) + (PROG (|prop|) + (RETURN + (SEQ + (PROGN + (SPADLET |prop| + (PROG (#0=#:G3038) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G3043 |argList| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|devaluate| |x|) #0#)))))))) + (|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 + +;;; *** |listTruncate| REDEFINED + +(DEFUN |listTruncate| (|l| |n|) + (PROG (|u|) + (RETURN + (SEQ + (PROGN + (SPADLET |u| |l|) + (SPADLET |n| (QSSUB1 |n|)) + (DO NIL + ((NULL (AND (NEQ |n| 0) (NULL (ATOM |u|)))) NIL) + (SEQ (EXIT (PROGN (SPADLET |n| (QSSUB1 |n|)) (SPADLET |u| (QCDR |u|)))))) + (COND + ((NULL (ATOM |u|)) + (COND + ((AND + (NULL (ATOM (CDR |u|))) + (BOOT-EQUAL |$reportInstantiations| (QUOTE T))) + (|recordInstantiation| |$op| (CAADR |u|) (QUOTE T)))) + (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 + +;;; *** |lassocShift| REDEFINED + +(DEFUN |lassocShift| (|x| |l|) + (PROG (|result| |y|) + (RETURN + (SEQ + (PROGN + (SPADLET |y| |l|) + (DO NIL + ((NULL (NULL (ATOM |y|))) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |x| (CAR (QCAR |y|))) + (RETURN (SPADLET |result| (QCAR |y|)))) + ((QUOTE T) (SPADLET |y| (QCDR |y|))))))) + (COND + (|result| + (COND + ((NEQ |y| |l|) (QRPLACA |y| (CAR |l|)) (QRPLACA |l| |result|))) + (QCDR |result|)) + ((QUOTE T) 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 + +;;; *** |lassocShiftWithFunction| REDEFINED + +(DEFUN |lassocShiftWithFunction| (|x| |l| |fn|) + (PROG (|result| |y|) + (RETURN + (SEQ + (PROGN + (SPADLET |y| |l|) + (DO NIL + ((NULL (NULL (ATOM |y|))) NIL) + (SEQ + (EXIT + (COND + ((FUNCALL |fn| |x| (CAR (QCAR |y|))) + (RETURN (SPADLET |result| (QCAR |y|)))) + ((QUOTE T) (SPADLET |y| (QCDR |y|))))))) + (COND + (|result| + (COND ((NEQ |y| |l|) (QRPLACA |y| (CAR |l|)) (QRPLACA |l| |result|))) + (QCDR |result|)) + ((QUOTE T) 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 + +;;; *** |lassocShiftQ| REDEFINED + +(DEFUN |lassocShiftQ| (|x| |l|) + (PROG (|result| |y|) + (RETURN + (SEQ + (PROGN + (SPADLET |y| |l|) + (DO NIL + ((NULL (NULL (ATOM |y|))) NIL) + (SEQ + (EXIT + (COND + ((EQ |x| (CAR (CAR |y|))) (RETURN (SPADLET |result| (CAR |y|)))) + ((QUOTE T) (SPADLET |y| (CDR |y|))))))) + (COND + (|result| + (COND ((NEQ |y| |l|) (RPLACA |y| (CAR |l|)) (RPLACA |l| |result|))) + (CDR |result|)) + ((QUOTE T) 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 + +;;; *** |globalHashtableStats| REDEFINED + +(DEFUN |globalHashtableStats| (|x| |sortFn|) + (PROG (|keys| |u| |argList| |argList1| |reportList| |n| |fn| |args|) + (RETURN + (SEQ + (PROGN + (SPADLET |keys| (HKEYS |x|)) + (DO ((#0=#:G3141 |keys| (CDR #0#)) (|key| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |key| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |u| (HGET |x| |key|)) + (DO ((#1=#:G3151 |u| (CDR #1#)) (#2=#:G3121 NIL)) + ((OR + (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |argList| (CAR #2#)) + (SPADLET |n| (CADR #2#)) #2#) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL (INTEGERP |n|)) + (|keyedSystemError| (QUOTE S2GE0013) (CONS |x| NIL))) + ((QUOTE T) + (SPADLET |argList1| + (PROG (#3=#:G3162) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G3167 |argList| (CDR #4#)) (|x| NIL)) + ((OR + (ATOM #4#) + (PROGN (SETQ |x| (CAR #4#)) NIL)) + (NREVERSE0 #3#)) + (SEQ + (EXIT + (SETQ #3# + (CONS (|constructor2ConstructorForm| |x|) #3#)))))))) + (SPADLET |reportList| + (CONS + (CONS |n| (CONS |key| (CONS |argList1| NIL))) + |reportList|))))))))))) + (|sayBrightly| + (CONS + (MAKESTRING "%b") + (CONS (MAKESTRING " USE NAME ARGS") (CONS (MAKESTRING "%d") NIL)))) + (DO ((#5=#:G3179 (NREVERSE (SORTBY |sortFn| |reportList|)) (CDR #5#)) + (#6=#:G3127 NIL)) + ((OR + (ATOM #5#) + (PROGN (SETQ #6# (CAR #5#)) NIL) + (PROGN + (PROGN + (SPADLET |n| (CAR #6#)) + (SPADLET |fn| (CADR #6#)) + (SPADLET |args| (CADDR #6#)) + #6#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (|sayBrightlyNT| + (APPEND + (|rightJustifyString| |n| 6) + (CONS (QUOTE | |) (CONS |fn| (CONS (QUOTE |: |) NIL))))) + (|pp| |args|)))))))))) +; +;constructor2ConstructorForm x == +; VECP x => x.0 +; x + +;;; *** |constructor2ConstructorForm| REDEFINED + +(DEFUN |constructor2ConstructorForm| (|x|) + (COND ((VECP |x|) (ELT |x| 0)) ((QUOTE T) |x|))) +; +;rightJustifyString(x,maxWidth) == +; size:= entryWidth x +; size > maxWidth => keyedSystemError("S2GE0014",[x]) +; [fillerSpaces(maxWidth-size," "),x] + +;;; *** |rightJustifyString| REDEFINED + +(DEFUN |rightJustifyString| (|x| |maxWidth|) + (PROG (SIZE) + (RETURN + (PROGN + (SPADLET SIZE (|entryWidth| |x|)) + (COND + ((> SIZE |maxWidth|) (|keyedSystemError| (QUOTE S2GE0014) (CONS |x| NIL))) + ((QUOTE T) + (CONS + (|fillerSpaces| (SPADDIFFERENCE |maxWidth| SIZE) (QUOTE | |)) + (CONS |x| NIL)))))))) +; +;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 + +;;; *** |domainEqualList| REDEFINED + +(DEFUN |domainEqualList| (|argl1| |argl2|) + (PROG (|item1| |item2| |partsMatch|) + (RETURN + (SEQ + (PROGN + (DO NIL + ((NULL (AND |argl1| |argl2|)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |item1| (|devaluate| (CAR |argl1|))) + (SPADLET |item2| (CAR |argl2|)) + (SPADLET |partsMatch| + (COND ((BOOT-EQUAL |item1| |item2|) (QUOTE T)) ((QUOTE T) NIL))) + (COND + ((NULL |partsMatch|) (RETURN NIL)) + ((QUOTE T) + (SPADLET |argl1| (CDR |argl1|)) + (SPADLET |argl2| (CDR |argl2|)))))))) + (COND ((OR |argl1| |argl2|) NIL) ((QUOTE T) (QUOTE T)))))))) +; +;removeAllClams() == +; for [fun,:.] in $clamList repeat +; sayBrightly ['"Un-clamming function",'%b,fun,'%d] +; SET(fun,eval INTERN STRCONC(STRINGIMAGE fun,'";")) + +;;; *** |removeAllClams| REDEFINED + +(DEFUN |removeAllClams| NIL + (PROG (|fun|) + (RETURN + (SEQ + (DO ((#0=#:G3239 |$clamList| (CDR #0#)) (#1=#:G3230 NIL)) + ((OR + (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN (PROGN (SPADLET |fun| (CAR #1#)) #1#) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (|sayBrightly| + (CONS + (MAKESTRING "Un-clamming function") + (CONS (QUOTE |%b|) (CONS |fun| (CONS (QUOTE |%d|) NIL))))) + (SET |fun| + (|eval| + (INTERN (STRCONC (STRINGIMAGE |fun|) (MAKESTRING ";"))))))))))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/debugsys.lisp.pamphlet b/src/interp/debugsys.lisp.pamphlet index 063c847..83dbcde 100644 --- a/src/interp/debugsys.lisp.pamphlet +++ b/src/interp/debugsys.lisp.pamphlet @@ -91,7 +91,7 @@ loaded by hand we need to establish a value. (thesymb "/int/interp/cattable.lisp") (thesymb "/int/interp/cformat.lisp") (thesymb (concatenate 'string "/obj/" *sys* "/interp/cfuns.o")) - (thesymb "/int/interp/clam.clisp") + (thesymb "/int/interp/clam.lisp") (thesymb "/int/interp/clammed.clisp") (thesymb "/int/interp/compat.clisp") (thesymb "/int/interp/compress.clisp")