diff --git a/changelog b/changelog index f6e4cb8..99eca0e 100644 --- a/changelog +++ b/changelog @@ -1,15 +1,22 @@ -20090825 tpd src/axiom-website/patches.html 20090826.03.tpd.patch -20090825 tpd src/interp/Makefile move server.boot to server.lisp -20090825 tpd src/interp/server.lisp added, rewritten from server.boot -20090825 tpd src/interp/server.boot removed, rewritten to server.lisp -20090825 tpd src/axiom-website/patches.html 20090826.02.tpd.patch -20090825 tpd src/interp/Makefile move serror.boot to serror.lisp -20090825 tpd src/interp/serror.lisp added, rewritten from serror.boot -20090825 tpd src/interp/serror.boot removed, rewritten to serror.lisp -20090825 tpd src/axiom-website/patches.html 20090826.01.tpd.patch -20090825 tpd src/interp/Makefile move scan.boot to scan.lisp -20090825 tpd src/interp/scan.lisp added, rewritten from scan.boot -20090825 tpd src/interp/scan.boot removed, rewritten to scan.lisp +20090826 tpd src/axiom-website/patches.html 20090826.04.tpd.patch +20090826 tpd src/interp/Makefile move simpbool.boot to simpbool.lisp +20090826 tpd src/interp/simpbool.lisp added, rewritten from simpbool.boot +20090826 tpd src/interp/simpbool.boot removed, rewritten to simpbool.lisp +20090826 tpd src/interp/Makefile move slam.boot to slam.lisp +20090826 tpd src/interp/slam.lisp added, rewritten from slam.boot +20090826 tpd src/interp/slam.boot removed, rewritten to slam.lisp +20090826 tpd src/axiom-website/patches.html 20090826.03.tpd.patch +20090826 tpd src/interp/Makefile move server.boot to server.lisp +20090826 tpd src/interp/server.lisp added, rewritten from server.boot +20090826 tpd src/interp/server.boot removed, rewritten to server.lisp +20090826 tpd src/axiom-website/patches.html 20090826.02.tpd.patch +20090826 tpd src/interp/Makefile move serror.boot to serror.lisp +20090826 tpd src/interp/serror.lisp added, rewritten from serror.boot +20090826 tpd src/interp/serror.boot removed, rewritten to serror.lisp +20090826 tpd src/axiom-website/patches.html 20090826.01.tpd.patch +20090826 tpd src/interp/Makefile move scan.boot to scan.lisp +20090826 tpd src/interp/scan.lisp added, rewritten from scan.boot +20090826 tpd src/interp/scan.boot removed, rewritten to scan.lisp 20090825 tpd src/axiom-website/patches.html 20090825.05.tpd.patch 20090825 tpd src/interp/Makefile move rulesets.boot to rulesets.lisp 20090825 tpd src/interp/rulesets.lisp added, rewritten from rulesets.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 34b199f..85a0c57 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1902,5 +1902,7 @@ scan.lisp rewrite from boot to lisp
serror.lisp rewrite from boot to lisp
20090826.03.tpd.patch server.lisp rewrite from boot to lisp
+20090826.04.tpd.patch +simpbool.lisp,slam.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 9c8c4be..e4a1ef2 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -645,11 +645,11 @@ ${DEPSYS}: ${DEP} ${OUT}/sys-pkg.${LISP} ${OUT}/nocompil.${LISP} \ ${OUT}/bookvol5.${LISP} ${OUT}/util.${LISP} \ ${OUT}/parsing.${LISP} ${OUT}/fnewmeta.${LISP} \ ${OUT}/newaux.${LISP} \ - ${OUT}/postprop.${LISP} \ + ${OUT}/postprop.lisp \ ${OUT}/g-boot.lisp ${OUT}/c-util.${LISP} \ ${OUT}/g-util.lisp \ ${OUT}/clam.lisp \ - ${OUT}/slam.${LISP} ${LOADSYS} + ${OUT}/slam.lisp ${LOADSYS} @ echo 3 making ${DEPSYS} @ echo '${PROCLAIMS}' > ${OUT}/makedep.lisp @ echo '(push :oldboot *features*)' >>${OUT}/makedep.lisp @@ -673,7 +673,7 @@ ${DEPSYS}: ${DEP} ${OUT}/sys-pkg.${LISP} ${OUT}/nocompil.${LISP} \ ':output-file "${OUT}/newaux.${O}"))' >> ${OUT}/makedep.lisp @ echo '(load "${OUT}/newaux")' >> ${OUT}/makedep.lisp @ echo '(unless (probe-file "${OUT}/postprop.${O}")' \ - '(compile-file "${OUT}/postprop.${LISP}"' \ + '(compile-file "${OUT}/postprop.lisp"' \ ':output-file "${OUT}/postprop.${O}"))' >> ${OUT}/makedep.lisp @ echo '(load "${OUT}/postprop")' >> ${OUT}/makedep.lisp @ echo '(unless (probe-file "${OUT}/clam.${O}")' \ @@ -681,7 +681,7 @@ ${DEPSYS}: ${DEP} ${OUT}/sys-pkg.${LISP} ${OUT}/nocompil.${LISP} \ ':output-file "${OUT}/clam.${O}"))' >> ${OUT}/makedep.lisp @ echo '(load "${OUT}/clam")' >> ${OUT}/makedep.lisp @ echo '(unless (probe-file "${OUT}/slam.${O}")' \ - '(compile-file "${OUT}/slam.${LISP}"' \ + '(compile-file "${OUT}/slam.lisp"' \ ':output-file "${OUT}/slam.${O}"))' >> ${OUT}/makedep.lisp @ echo '(load "${OUT}/slam")' >> ${OUT}/makedep.lisp @ echo '(unless (probe-file "${OUT}/g-boot.${O}")' \ @@ -1324,14 +1324,14 @@ ${DOC}/patches.lisp.dvi: ${IN}/patches.lisp.pamphlet \subsection{postprop.lisp \cite{30}} <>= -${AUTO}/postprop.${LISP}: ${OUT}/postprop.${LISP} - @ echo 102 making ${AUTO}/postprop.${LISP} from ${OUT}/postprop.${LISP} - @ cp ${OUT}/postprop.${LISP} ${AUTO} +${AUTO}/postprop.lisp: ${OUT}/postprop.lisp + @ echo 102 making ${AUTO}/postprop.lisp from ${OUT}/postprop.lisp + @ cp ${OUT}/postprop.lisp ${AUTO} @ <>= -${OUT}/postprop.${LISP}: ${MID}/postprop.lisp - @ echo 103 making ${OUT}/postprop.${LISP} from ${MID}/postprop.lisp +${OUT}/postprop.lisp: ${MID}/postprop.lisp + @ echo 103 making ${OUT}/postprop.lisp from ${MID}/postprop.lisp @ rm -f ${OUT}/postprop.${O} @ cp ${MID}/postprop.lisp ${OUT}/postprop.${LISP} @@ -1344,18 +1344,6 @@ ${MID}/postprop.lisp: ${IN}/postprop.lisp.pamphlet ${TANGLE} ${IN}/postprop.lisp.pamphlet >postprop.lisp ) @ -<>= -${DOC}/postprop.lisp.dvi: ${IN}/postprop.lisp.pamphlet - @echo 105 making ${DOC}/postprop.lisp.dvi \ - from ${IN}/postprop.lisp.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/postprop.lisp.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} postprop.lisp ; \ - rm -f ${DOC}/postprop.lisp.pamphlet ; \ - rm -f ${DOC}/postprop.lisp.tex ; \ - rm -f ${DOC}/postprop.lisp ) - -@ \subsection{sockio.lisp \cite{33}} <>= @@ -3933,107 +3921,62 @@ ${MID}/server.lisp: ${IN}/server.lisp.pamphlet @ -\subsection{simpbool.boot} +\subsection{simpbool.lisp} <>= -${OUT}/simpbool.${O}: ${MID}/simpbool.clisp - @ echo 400 making ${OUT}/simpbool.${O} from ${MID}/simpbool.clisp - @ (cd ${MID} ; \ +${OUT}/simpbool.${O}: ${MID}/simpbool.lisp + @ echo 136 making ${OUT}/simpbool.${O} from ${MID}/simpbool.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/simpbool.clisp"' \ - ':output-file "${OUT}/simpbool.${O}") (${BYE}))' \ - | ${DEPSYS} ; \ + echo '(progn (compile-file "${MID}/simpbool.lisp"' \ + ':output-file "${OUT}/simpbool.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/simpbool.clisp"' \ - ':output-file "${OUT}/simpbool.${O}") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ + echo '(progn (compile-file "${MID}/simpbool.lisp"' \ + ':output-file "${OUT}/simpbool.${O}") (${BYE}))' | ${DEPSYS} \ + >${TMP}/trace ; \ fi ) @ -<>= -${MID}/simpbool.clisp: ${IN}/simpbool.boot.pamphlet - @ echo 401 making ${MID}/simpbool.clisp \ - from ${IN}/simpbool.boot.pamphlet +<>= +${MID}/simpbool.lisp: ${IN}/simpbool.lisp.pamphlet + @ echo 137 making ${MID}/simpbool.lisp from \ + ${IN}/simpbool.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/simpbool.boot.pamphlet >simpbool.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "simpbool.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "simpbool.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm simpbool.boot ) + ${TANGLE} ${IN}/simpbool.lisp.pamphlet >simpbool.lisp ) @ -<>= -${DOC}/simpbool.boot.dvi: ${IN}/simpbool.boot.pamphlet - @echo 402 making ${DOC}/simpbool.boot.dvi \ - from ${IN}/simpbool.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/simpbool.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} simpbool.boot ; \ - rm -f ${DOC}/simpbool.boot.pamphlet ; \ - rm -f ${DOC}/simpbool.boot.tex ; \ - rm -f ${DOC}/simpbool.boot ) -@ +\subsection{slam.lisp \cite{30}} +<>= +${AUTO}/slam.lisp: ${OUT}/slam.lisp + @ echo 102 making ${AUTO}/slam.lisp from ${OUT}/slam.lisp + @ cp ${OUT}/slam.lisp ${AUTO} -\subsection{slam.boot} -Note that the {\bf slam.boot.pamphlet} file contains both the -original {\bf boot} code and a saved copy of the {\bf slam.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 slam.boot.pamphlet -you must translate this code to lisp and store the resulting lisp -code back into the slam.boot.pamphlet file. this is not automated.} -<>= -${OUT}/slam.${LISP}: ${IN}/slam.boot.pamphlet - @ echo 403 making ${OUT}/slam.${LISP} from ${IN}/slam.boot.pamphlet +@ +<>= +${OUT}/slam.lisp: ${MID}/slam.lisp + @ echo 103 making ${OUT}/slam.lisp from ${MID}/slam.lisp @ rm -f ${OUT}/slam.${O} - @( cd ${OUT} ; \ - ${TANGLE} -Rslam.clisp ${IN}/slam.boot.pamphlet >slam.${LISP} ) + @ cp ${MID}/slam.lisp ${OUT}/slam.lisp @ -<>= -${OUT}/slam.${O}: ${MID}/slam.clisp - @ echo 404 making ${OUT}/slam.${O} from ${MID}/slam.clisp +<>= +${MID}/slam.lisp: ${IN}/slam.lisp.pamphlet + @ echo 104 making ${MID}/slam.lisp \ + from ${IN}/slam.lisp.pamphlet @ (cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/slam.clisp"' \ - ':output-file "${OUT}/slam.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/slam.clisp"' \ - ':output-file "${OUT}/slam.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) + ${TANGLE} ${IN}/slam.lisp.pamphlet >slam.lisp ) @ -<>= -${MID}/slam.clisp: ${IN}/slam.boot.pamphlet - @ echo 405 making ${MID}/slam.clisp from ${IN}/slam.boot.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/slam.boot.pamphlet >slam.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "slam.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "slam.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm slam.boot ) - -@ -<>= -${DOC}/slam.boot.dvi: ${IN}/slam.boot.pamphlet - @echo 406 making ${DOC}/slam.boot.dvi from ${IN}/slam.boot.pamphlet +<>= +${DOC}/postprop.lisp.dvi: ${IN}/postprop.lisp.pamphlet + @echo 105 making ${DOC}/postprop.lisp.dvi \ + from ${IN}/postprop.lisp.pamphlet @(cd ${DOC} ; \ - cp ${IN}/slam.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} slam.boot ; \ - rm -f ${DOC}/slam.boot.pamphlet ; \ - rm -f ${DOC}/slam.boot.tex ; \ - rm -f ${DOC}/slam.boot ) + cp ${IN}/postprop.lisp.pamphlet ${DOC} ; \ + ${DOCUMENT} ${NOISE} postprop.lisp ; \ + rm -f ${DOC}/postprop.lisp.pamphlet ; \ + rm -f ${DOC}/postprop.lisp.tex ; \ + rm -f ${DOC}/postprop.lisp ) @ @@ -6028,7 +5971,6 @@ clean: <> <> <> -<> <> <> @@ -6077,13 +6019,11 @@ clean: <> <> -<> -<> +<> -<> -<> -<> -<> +<> +<> +<> <> <> diff --git a/src/interp/simpbool.boot.pamphlet b/src/interp/simpbool.boot.pamphlet deleted file mode 100644 index 7660ae0..0000000 --- a/src/interp/simpbool.boot.pamphlet +++ /dev/null @@ -1,223 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp simpbool.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -simpBool x == dnf2pf reduceDnf be x - -reduceDnf u == --- (OR (AND ..b..) b) ==> (OR b ) - atom u => u - for x in u repeat - ok := true - for y in u repeat - x = y => 'skip - dnfContains(x,y) => return (ok := false) - ok = true => acc := [x,:acc] - NREVERSE acc - -dnfContains([a,b],[c,d]) == fn(a,c) and fn(b,d) where - fn(x,y) == and/[MEMBER(u,x) for u in y] - -prove x == - world := [p for y in listOfUserIds x | (p := getPredicate y)] => - 'false = be MKPF([['NOT,x],:world],'AND) => true - 'false = be MKPF([x,:world],'AND) => false - x - 'false = (y := be x) => 'false - y = 'true => true - dnf2pf y - -simpBoolGiven(x,world) == - world => - 'false = be MKPF([['NOT,x],:world],'AND) => true - 'false = (y := be MKPF([x,:world],'AND)) => false - (u := andReduce(dnf2pf y,world)) is ['AND,:v] and - (w := SETDIFFERENCE(v,world)) ^= v => simpBool ['AND,:w] - u - 'false = (y := be x) => false - 'true = y => true - dnf2pf y - -andReduce(x,y) == - x is ['AND,:r] => - y is ['AND,:s] => MKPF(S_-(r,s),'AND) - MKPF(S_-(r,[s]),'AND) - x -dnf2pf(x) == - x = 'true => 'T - x = 'false => nil - atom x => x - MKPF( - [MKPF([:[k for k in b],:[['not,k] for k in a]],'AND) for [a,b] in x],'OR) -be x == b2dnf x -b2dnf x == - x = 'T => 'true - x = NIL => 'false - atom x => bassert x - [op,:argl] := x - MEMQ(op,'(AND and)) => band argl - MEMQ(op,'(OR or)) => bor argl - MEMQ(op,'(NOT not)) => bnot first argl - bassert x -band x == - x is [h,:t] => andDnf(b2dnf h,band t) - 'true -bor x == - x is [a,:b] => orDnf(b2dnf a,bor b) - 'false -bnot x == notDnf b2dnf x -bassert x == [[nil,[x]]] -bassertNot x == [[[x],nil]] -------------------------Disjunctive Normal Form Code----------------------- --- dnf is true | false | [coaf ... ] --- coaf is true | false | [item ... ] --- item is anything - -orDnf(a,b) == -- or: (dnf, dnf) -> dnf - a = 'false => b - b = 'false => a - a = 'true or b = 'true => 'true - null a => b --null list means false - a is [c] = coafOrDnf(c,b) - coafOrDnf(first a,orDnf(rest a,b)) - -andDnf(a,b) == -- and: (dnf, dnf) -> dnf - a = 'true => b - b = 'true => a - a = 'false or b = 'false => 'false - null a => 'false --null list means false - a is [c] => coafAndDnf(c,b) - x := coafAndDnf(first a,b) - y := andDnf(rest a,b) - x = 'false => y - y = 'false => x - ordUnion(x,y) - -notDnf l == -- not: dnf -> dnf - l = 'true => 'false - l = 'false => 'true - null l => 'true --null list means false - l is [x] => notCoaf x - andDnf(notCoaf first l,notDnf rest l) - -coafOrDnf(a,l) == -- or: (coaf, dnf) -> dnf - a = 'true or l = 'true => 'true - a = 'false => l - MEMBER(a,l) => l - y := notCoaf a - x := ordIntersection(y,l) - null x => orDel(a,l) - x = l => 'true - x = y => ordSetDiff(l,x) - ordUnion(notDnf ordSetDiff(y,x),l) - -coafAndDnf(a,b) == --and: (coaf, dnf) -> dnf - a = 'true => b - a = 'false => 'false - [c,:r] := b - null r => coafAndCoaf(a,c) - x := coafAndCoaf(a,c) --dnf - y := coafAndDnf(a,r) --dnf - x = 'false => y - y = 'false => x - ordUnion(x,y) - -coafAndCoaf([a,b],[p,q]) == --and: (coaf,coaf) -> dnf - ordIntersection(a,q) or ordIntersection(b,p) => 'false - [[ordUnion(a,p),ordUnion(b,q)]] - -notCoaf [a,b] == [:[[nil,[x]] for x in a],:[[[x],nil] for x in b]] - -list1 l == - l isnt [h,:t] => nil - null h => list1 t - [[h,nil,nil],:list1 t] -list2 l == - l isnt [h,:t] => nil - null h => list2 t - [[nil,h,nil],:list2 t] -list3 l == - l isnt [h,:t] => nil - null h => list3 t - [[nil,nil,h],:list3 t] -orDel(a,l) == - l is [h,:t] => - a = h => t - ?ORDER(a,h) => [a,:l] - [h,:orDel(a,t)] - [a] -ordList l == - l is [h,:t] and t => orDel(h,ordList t) - l -ordUnion(a,b) == - a isnt [c,:r] => b - b isnt [d,:s] => a - c=d => [c,:ordUnion(r,s)] - ?ORDER(a,b) => [c,:ordUnion(r,b)] - [d,:ordUnion(s,a)] -ordIntersection(a,b) == - a isnt [h,:t] => nil - MEMBER(h,b) => [h,:ordIntersection(t,b)] - ordIntersection(t,b) -ordSetDiff(a,b) == - b isnt [h,:t] => a - MEMBER(h,a) => ordSetDiff(DELETE(h,a),t) - ordSetDiff(a,t) -------------- -testPredList u == - for x in u repeat - y := simpBool x - x = y => nil - pp x - pp '"==========>" - pp y -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/simpbool.lisp.pamphlet b/src/interp/simpbool.lisp.pamphlet new file mode 100644 index 0000000..3d95e2c --- /dev/null +++ b/src/interp/simpbool.lisp.pamphlet @@ -0,0 +1,721 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp simpbool.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;simpBool x == dnf2pf reduceDnf be x + +(DEFUN |simpBool| (|x|) (|dnf2pf| (|reduceDnf| (|be| |x|)))) + +;reduceDnf u == +;-- (OR (AND ..b..) b) ==> (OR b ) +; atom u => u +; for x in u repeat +; ok := true +; for y in u repeat +; x = y => 'skip +; dnfContains(x,y) => return (ok := false) +; ok = true => acc := [x,:acc] +; NREVERSE acc + +(DEFUN |reduceDnf| (|u|) + (PROG (|ok| |acc|) + (RETURN + (SEQ (COND + ((ATOM |u|) |u|) + ('T + (DO ((G166069 |u| (CDR G166069)) (|x| NIL)) + ((OR (ATOM G166069) + (PROGN (SETQ |x| (CAR G166069)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |ok| 'T) + (DO ((G166078 |u| (CDR G166078)) + (|y| NIL)) + ((OR (ATOM G166078) + (PROGN + (SETQ |y| (CAR G166078)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((BOOT-EQUAL |x| |y|) '|skip|) + ((|dnfContains| |x| |y|) + (RETURN (SPADLET |ok| NIL))))))) + (COND + ((BOOT-EQUAL |ok| 'T) + (SPADLET |acc| (CONS |x| |acc|)))))))) + (NREVERSE |acc|))))))) + +;dnfContains([a,b],[c,d]) == fn(a,c) and fn(b,d) where +; fn(x,y) == and/[MEMBER(u,x) for u in y] + +(DEFUN |dnfContains,fn| (|x| |y|) + (PROG () + (RETURN + (SEQ (PROG (G166090) + (SPADLET G166090 'T) + (RETURN + (DO ((G166096 NIL (NULL G166090)) + (G166097 |y| (CDR G166097)) (|u| NIL)) + ((OR G166096 (ATOM G166097) + (PROGN (SETQ |u| (CAR G166097)) NIL)) + G166090) + (SEQ (EXIT (SETQ G166090 + (AND G166090 (|member| |u| |x|)))))))))))) + + +(DEFUN |dnfContains| (G166109 G166118) + (PROG (|c| |d| |a| |b|) + (RETURN + (PROGN + (SPADLET |c| (CAR G166118)) + (SPADLET |d| (CADR G166118)) + (SPADLET |a| (CAR G166109)) + (SPADLET |b| (CADR G166109)) + (AND (|dnfContains,fn| |a| |c|) (|dnfContains,fn| |b| |d|)))))) + +;prove x == +; world := [p for y in listOfUserIds x | (p := getPredicate y)] => +; 'false = be MKPF([['NOT,x],:world],'AND) => true +; 'false = be MKPF([x,:world],'AND) => false +; x +; 'false = (y := be x) => 'false +; y = 'true => true +; dnf2pf y + +(DEFUN |prove| (|x|) + (PROG (|p| |world| |y|) + (RETURN + (SEQ (COND + ((SPADLET |world| + (PROG (G166145) + (SPADLET G166145 NIL) + (RETURN + (DO ((G166151 (|listOfUserIds| |x|) + (CDR G166151)) + (|y| NIL)) + ((OR (ATOM G166151) + (PROGN + (SETQ |y| (CAR G166151)) + NIL)) + (NREVERSE0 G166145)) + (SEQ (EXIT (COND + ((SPADLET |p| + (|getPredicate| |y|)) + (SETQ G166145 + (CONS |p| G166145)))))))))) + (COND + ((BOOT-EQUAL '|false| + (|be| (MKPF (CONS (CONS 'NOT (CONS |x| NIL)) + |world|) + 'AND))) + 'T) + ((BOOT-EQUAL '|false| + (|be| (MKPF (CONS |x| |world|) 'AND))) + NIL) + ('T |x|))) + ((BOOT-EQUAL '|false| (SPADLET |y| (|be| |x|))) '|false|) + ((BOOT-EQUAL |y| '|true|) 'T) + ('T (|dnf2pf| |y|))))))) + +;simpBoolGiven(x,world) == +; world => +; 'false = be MKPF([['NOT,x],:world],'AND) => true +; 'false = (y := be MKPF([x,:world],'AND)) => false +; (u := andReduce(dnf2pf y,world)) is ['AND,:v] and +; (w := SETDIFFERENCE(v,world)) ^= v => simpBool ['AND,:w] +; u +; 'false = (y := be x) => false +; 'true = y => true +; dnf2pf y + +(DEFUN |simpBoolGiven| (|x| |world|) + (PROG (|u| |ISTMP#1| |v| |w| |y|) + (RETURN + (COND + (|world| (COND + ((BOOT-EQUAL '|false| + (|be| (MKPF (CONS (CONS 'NOT (CONS |x| NIL)) + |world|) + 'AND))) + 'T) + ((BOOT-EQUAL '|false| + (SPADLET |y| + (|be| (MKPF (CONS |x| |world|) 'AND)))) + NIL) + ((AND (PROGN + (SPADLET |ISTMP#1| + (SPADLET |u| + (|andReduce| (|dnf2pf| |y|) + |world|))) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'AND) + (PROGN + (SPADLET |v| (QCDR |ISTMP#1|)) + 'T))) + (NEQUAL (SPADLET |w| + (SETDIFFERENCE |v| |world|)) + |v|)) + (|simpBool| (CONS 'AND |w|))) + ('T |u|))) + ((BOOT-EQUAL '|false| (SPADLET |y| (|be| |x|))) NIL) + ((BOOT-EQUAL '|true| |y|) 'T) + ('T (|dnf2pf| |y|)))))) + +;andReduce(x,y) == +; x is ['AND,:r] => +; y is ['AND,:s] => MKPF(S_-(r,s),'AND) +; MKPF(S_-(r,[s]),'AND) +; x + +(DEFUN |andReduce| (|x| |y|) + (PROG (|r| |s|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'AND) + (PROGN (SPADLET |r| (QCDR |x|)) 'T)) + (COND + ((AND (PAIRP |y|) (EQ (QCAR |y|) 'AND) + (PROGN (SPADLET |s| (QCDR |y|)) 'T)) + (MKPF (S- |r| |s|) 'AND)) + ('T (MKPF (S- |r| (CONS |s| NIL)) 'AND)))) + ('T |x|))))) + +;dnf2pf(x) == +; x = 'true => 'T +; x = 'false => nil +; atom x => x +; MKPF( +; [MKPF([:[k for k in b],:[['not,k] for k in a]],'AND) for [a,b] in x],'OR) + +(DEFUN |dnf2pf| (|x|) + (PROG (|a| |b|) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |x| '|true|) 'T) + ((BOOT-EQUAL |x| '|false|) NIL) + ((ATOM |x|) |x|) + ('T + (MKPF (PROG (G166196) + (SPADLET G166196 NIL) + (RETURN + (DO ((G166202 |x| (CDR G166202)) + (G166186 NIL)) + ((OR (ATOM G166202) + (PROGN + (SETQ G166186 (CAR G166202)) + NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G166186)) + (SPADLET |b| (CADR G166186)) + G166186) + NIL)) + (NREVERSE0 G166196)) + (SEQ (EXIT (SETQ G166196 + (CONS + (MKPF + (APPEND + (PROG (G166213) + (SPADLET G166213 NIL) + (RETURN + (DO + ((G166218 |b| + (CDR G166218)) + (|k| NIL)) + ((OR (ATOM G166218) + (PROGN + (SETQ |k| + (CAR G166218)) + NIL)) + (NREVERSE0 G166213)) + (SEQ + (EXIT + (SETQ G166213 + (CONS |k| G166213))))))) + (PROG (G166228) + (SPADLET G166228 NIL) + (RETURN + (DO + ((G166233 |a| + (CDR G166233)) + (|k| NIL)) + ((OR (ATOM G166233) + (PROGN + (SETQ |k| + (CAR G166233)) + NIL)) + (NREVERSE0 G166228)) + (SEQ + (EXIT + (SETQ G166228 + (CONS + (CONS '|not| + (CONS |k| NIL)) + G166228)))))))) + 'AND) + G166196))))))) + 'OR))))))) + +;be x == b2dnf x + +(DEFUN |be| (|x|) (|b2dnf| |x|)) + +;b2dnf x == +; x = 'T => 'true +; x = NIL => 'false +; atom x => bassert x +; [op,:argl] := x +; MEMQ(op,'(AND and)) => band argl +; MEMQ(op,'(OR or)) => bor argl +; MEMQ(op,'(NOT not)) => bnot first argl +; bassert x + +(DEFUN |b2dnf| (|x|) + (PROG (|op| |argl|) + (RETURN + (COND + ((BOOT-EQUAL |x| 'T) '|true|) + ((NULL |x|) '|false|) + ((ATOM |x|) (|bassert| |x|)) + ('T (SPADLET |op| (CAR |x|)) (SPADLET |argl| (CDR |x|)) + (COND + ((MEMQ |op| '(AND |and|)) (|band| |argl|)) + ((MEMQ |op| '(OR |or|)) (|bor| |argl|)) + ((MEMQ |op| '(NOT |not|)) (|bnot| (CAR |argl|))) + ('T (|bassert| |x|)))))))) + +;band x == +; x is [h,:t] => andDnf(b2dnf h,band t) +; 'true + +(DEFUN |band| (|x|) + (PROG (|h| |t|) + (RETURN + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |h| (QCAR |x|)) + (SPADLET |t| (QCDR |x|)) + 'T)) + (|andDnf| (|b2dnf| |h|) (|band| |t|))) + ('T '|true|))))) + +;bor x == +; x is [a,:b] => orDnf(b2dnf a,bor b) +; 'false + +(DEFUN |bor| (|x|) + (PROG (|a| |b|) + (RETURN + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |a| (QCAR |x|)) + (SPADLET |b| (QCDR |x|)) + 'T)) + (|orDnf| (|b2dnf| |a|) (|bor| |b|))) + ('T '|false|))))) + +;bnot x == notDnf b2dnf x + +(DEFUN |bnot| (|x|) (|notDnf| (|b2dnf| |x|))) + +;bassert x == [[nil,[x]]] + +(DEFUN |bassert| (|x|) + (CONS (CONS NIL (CONS (CONS |x| NIL) NIL)) NIL)) + +;bassertNot x == [[[x],nil]] + +(DEFUN |bassertNot| (|x|) + (CONS (CONS (CONS |x| NIL) (CONS NIL NIL)) NIL)) + +;------------------------Disjunctive Normal Form Code----------------------- +;-- dnf is true | false | [coaf ... ] +;-- coaf is true | false | [item ... ] +;-- item is anything +;orDnf(a,b) == -- or: (dnf, dnf) -> dnf +; a = 'false => b +; b = 'false => a +; a = 'true or b = 'true => 'true +; null a => b --null list means false +; a is [c] = coafOrDnf(c,b) +; coafOrDnf(first a,orDnf(rest a,b)) + +(DEFUN |orDnf| (|a| |b|) + (PROG (|c|) + (RETURN + (COND + ((BOOT-EQUAL |a| '|false|) |b|) + ((BOOT-EQUAL |b| '|false|) |a|) + ((OR (BOOT-EQUAL |a| '|true|) (BOOT-EQUAL |b| '|true|)) + '|true|) + ((NULL |a|) |b|) + ('T + (BOOT-EQUAL + (AND (PAIRP |a|) (EQ (QCDR |a|) NIL) + (PROGN (SPADLET |c| (QCAR |a|)) 'T)) + (|coafOrDnf| |c| |b|)) + (|coafOrDnf| (CAR |a|) (|orDnf| (CDR |a|) |b|))))))) + +;andDnf(a,b) == -- and: (dnf, dnf) -> dnf +; a = 'true => b +; b = 'true => a +; a = 'false or b = 'false => 'false +; null a => 'false --null list means false +; a is [c] => coafAndDnf(c,b) +; x := coafAndDnf(first a,b) +; y := andDnf(rest a,b) +; x = 'false => y +; y = 'false => x +; ordUnion(x,y) + +(DEFUN |andDnf| (|a| |b|) + (PROG (|c| |x| |y|) + (RETURN + (COND + ((BOOT-EQUAL |a| '|true|) |b|) + ((BOOT-EQUAL |b| '|true|) |a|) + ((OR (BOOT-EQUAL |a| '|false|) (BOOT-EQUAL |b| '|false|)) + '|false|) + ((NULL |a|) '|false|) + ((AND (PAIRP |a|) (EQ (QCDR |a|) NIL) + (PROGN (SPADLET |c| (QCAR |a|)) 'T)) + (|coafAndDnf| |c| |b|)) + ('T (SPADLET |x| (|coafAndDnf| (CAR |a|) |b|)) + (SPADLET |y| (|andDnf| (CDR |a|) |b|)) + (COND + ((BOOT-EQUAL |x| '|false|) |y|) + ((BOOT-EQUAL |y| '|false|) |x|) + ('T (|ordUnion| |x| |y|)))))))) + +;notDnf l == -- not: dnf -> dnf +; l = 'true => 'false +; l = 'false => 'true +; null l => 'true --null list means false +; l is [x] => notCoaf x +; andDnf(notCoaf first l,notDnf rest l) + +(DEFUN |notDnf| (|l|) + (PROG (|x|) + (RETURN + (COND + ((BOOT-EQUAL |l| '|true|) '|false|) + ((BOOT-EQUAL |l| '|false|) '|true|) + ((NULL |l|) '|true|) + ((AND (PAIRP |l|) (EQ (QCDR |l|) NIL) + (PROGN (SPADLET |x| (QCAR |l|)) 'T)) + (|notCoaf| |x|)) + ('T (|andDnf| (|notCoaf| (CAR |l|)) (|notDnf| (CDR |l|)))))))) + +;coafOrDnf(a,l) == -- or: (coaf, dnf) -> dnf +; a = 'true or l = 'true => 'true +; a = 'false => l +; MEMBER(a,l) => l +; y := notCoaf a +; x := ordIntersection(y,l) +; null x => orDel(a,l) +; x = l => 'true +; x = y => ordSetDiff(l,x) +; ordUnion(notDnf ordSetDiff(y,x),l) + +(DEFUN |coafOrDnf| (|a| |l|) + (PROG (|y| |x|) + (RETURN + (COND + ((OR (BOOT-EQUAL |a| '|true|) (BOOT-EQUAL |l| '|true|)) + '|true|) + ((BOOT-EQUAL |a| '|false|) |l|) + ((|member| |a| |l|) |l|) + ('T (SPADLET |y| (|notCoaf| |a|)) + (SPADLET |x| (|ordIntersection| |y| |l|)) + (COND + ((NULL |x|) (|orDel| |a| |l|)) + ((BOOT-EQUAL |x| |l|) '|true|) + ((BOOT-EQUAL |x| |y|) (|ordSetDiff| |l| |x|)) + ('T (|ordUnion| (|notDnf| (|ordSetDiff| |y| |x|)) |l|)))))))) + +;coafAndDnf(a,b) == --and: (coaf, dnf) -> dnf +; a = 'true => b +; a = 'false => 'false +; [c,:r] := b +; null r => coafAndCoaf(a,c) +; x := coafAndCoaf(a,c) --dnf +; y := coafAndDnf(a,r) --dnf +; x = 'false => y +; y = 'false => x +; ordUnion(x,y) + +(DEFUN |coafAndDnf| (|a| |b|) + (PROG (|c| |r| |x| |y|) + (RETURN + (COND + ((BOOT-EQUAL |a| '|true|) |b|) + ((BOOT-EQUAL |a| '|false|) '|false|) + ('T (SPADLET |c| (CAR |b|)) (SPADLET |r| (CDR |b|)) + (COND + ((NULL |r|) (|coafAndCoaf| |a| |c|)) + ('T (SPADLET |x| (|coafAndCoaf| |a| |c|)) + (SPADLET |y| (|coafAndDnf| |a| |r|)) + (COND + ((BOOT-EQUAL |x| '|false|) |y|) + ((BOOT-EQUAL |y| '|false|) |x|) + ('T (|ordUnion| |x| |y|)))))))))) + +;coafAndCoaf([a,b],[p,q]) == --and: (coaf,coaf) -> dnf +; ordIntersection(a,q) or ordIntersection(b,p) => 'false +; [[ordUnion(a,p),ordUnion(b,q)]] + +(DEFUN |coafAndCoaf| (G166321 G166330) + (PROG (|p| |q| |a| |b|) + (RETURN + (PROGN + (SPADLET |p| (CAR G166330)) + (SPADLET |q| (CADR G166330)) + (SPADLET |a| (CAR G166321)) + (SPADLET |b| (CADR G166321)) + (COND + ((OR (|ordIntersection| |a| |q|) (|ordIntersection| |b| |p|)) + '|false|) + ('T + (CONS (CONS (|ordUnion| |a| |p|) + (CONS (|ordUnion| |b| |q|) NIL)) + NIL))))))) + +;notCoaf [a,b] == [:[[nil,[x]] for x in a],:[[[x],nil] for x in b]] + +(DEFUN |notCoaf| (G166350) + (PROG (|a| |b|) + (RETURN + (SEQ (PROGN + (SPADLET |a| (CAR G166350)) + (SPADLET |b| (CADR G166350)) + (APPEND (PROG (G166363) + (SPADLET G166363 NIL) + (RETURN + (DO ((G166368 |a| (CDR G166368)) + (|x| NIL)) + ((OR (ATOM G166368) + (PROGN + (SETQ |x| (CAR G166368)) + NIL)) + (NREVERSE0 G166363)) + (SEQ (EXIT (SETQ G166363 + (CONS + (CONS NIL + (CONS (CONS |x| NIL) NIL)) + G166363))))))) + (PROG (G166378) + (SPADLET G166378 NIL) + (RETURN + (DO ((G166383 |b| (CDR G166383)) + (|x| NIL)) + ((OR (ATOM G166383) + (PROGN + (SETQ |x| (CAR G166383)) + NIL)) + (NREVERSE0 G166378)) + (SEQ (EXIT (SETQ G166378 + (CONS + (CONS (CONS |x| NIL) + (CONS NIL NIL)) + G166378))))))))))))) + +;list1 l == +; l isnt [h,:t] => nil +; null h => list1 t +; [[h,nil,nil],:list1 t] + +(DEFUN |list1| (|l|) + (PROG (|h| |t|) + (RETURN + (COND + ((NULL (AND (PAIRP |l|) + (PROGN + (SPADLET |h| (QCAR |l|)) + (SPADLET |t| (QCDR |l|)) + 'T))) + NIL) + ((NULL |h|) (|list1| |t|)) + ('T (CONS (CONS |h| (CONS NIL (CONS NIL NIL))) (|list1| |t|))))))) + +;list2 l == +; l isnt [h,:t] => nil +; null h => list2 t +; [[nil,h,nil],:list2 t] + +(DEFUN |list2| (|l|) + (PROG (|h| |t|) + (RETURN + (COND + ((NULL (AND (PAIRP |l|) + (PROGN + (SPADLET |h| (QCAR |l|)) + (SPADLET |t| (QCDR |l|)) + 'T))) + NIL) + ((NULL |h|) (|list2| |t|)) + ('T (CONS (CONS NIL (CONS |h| (CONS NIL NIL))) (|list2| |t|))))))) + +;list3 l == +; l isnt [h,:t] => nil +; null h => list3 t +; [[nil,nil,h],:list3 t] + +(DEFUN |list3| (|l|) + (PROG (|h| |t|) + (RETURN + (COND + ((NULL (AND (PAIRP |l|) + (PROGN + (SPADLET |h| (QCAR |l|)) + (SPADLET |t| (QCDR |l|)) + 'T))) + NIL) + ((NULL |h|) (|list3| |t|)) + ('T (CONS (CONS NIL (CONS NIL (CONS |h| NIL))) (|list3| |t|))))))) + +;orDel(a,l) == +; l is [h,:t] => +; a = h => t +; ?ORDER(a,h) => [a,:l] +; [h,:orDel(a,t)] +; [a] + +(DEFUN |orDel| (|a| |l|) + (PROG (|h| |t|) + (RETURN + (COND + ((AND (PAIRP |l|) + (PROGN + (SPADLET |h| (QCAR |l|)) + (SPADLET |t| (QCDR |l|)) + 'T)) + (COND + ((BOOT-EQUAL |a| |h|) |t|) + ((?ORDER |a| |h|) (CONS |a| |l|)) + ('T (CONS |h| (|orDel| |a| |t|))))) + ('T (CONS |a| NIL)))))) + +;ordList l == +; l is [h,:t] and t => orDel(h,ordList t) +; l + +(DEFUN |ordList| (|l|) + (PROG (|h| |t|) + (RETURN + (COND + ((AND (PAIRP |l|) + (PROGN + (SPADLET |h| (QCAR |l|)) + (SPADLET |t| (QCDR |l|)) + 'T) + |t|) + (|orDel| |h| (|ordList| |t|))) + ('T |l|))))) + +;ordUnion(a,b) == +; a isnt [c,:r] => b +; b isnt [d,:s] => a +; c=d => [c,:ordUnion(r,s)] +; ?ORDER(a,b) => [c,:ordUnion(r,b)] +; [d,:ordUnion(s,a)] + +(DEFUN |ordUnion| (|a| |b|) + (PROG (|c| |r| |d| |s|) + (RETURN + (COND + ((NULL (AND (PAIRP |a|) + (PROGN + (SPADLET |c| (QCAR |a|)) + (SPADLET |r| (QCDR |a|)) + 'T))) + |b|) + ((NULL (AND (PAIRP |b|) + (PROGN + (SPADLET |d| (QCAR |b|)) + (SPADLET |s| (QCDR |b|)) + 'T))) + |a|) + ((BOOT-EQUAL |c| |d|) (CONS |c| (|ordUnion| |r| |s|))) + ((?ORDER |a| |b|) (CONS |c| (|ordUnion| |r| |b|))) + ('T (CONS |d| (|ordUnion| |s| |a|))))))) + +;ordIntersection(a,b) == +; a isnt [h,:t] => nil +; MEMBER(h,b) => [h,:ordIntersection(t,b)] +; ordIntersection(t,b) + +(DEFUN |ordIntersection| (|a| |b|) + (PROG (|h| |t|) + (RETURN + (COND + ((NULL (AND (PAIRP |a|) + (PROGN + (SPADLET |h| (QCAR |a|)) + (SPADLET |t| (QCDR |a|)) + 'T))) + NIL) + ((|member| |h| |b|) (CONS |h| (|ordIntersection| |t| |b|))) + ('T (|ordIntersection| |t| |b|)))))) + +;ordSetDiff(a,b) == +; b isnt [h,:t] => a +; MEMBER(h,a) => ordSetDiff(DELETE(h,a),t) +; ordSetDiff(a,t) + +(DEFUN |ordSetDiff| (|a| |b|) + (PROG (|h| |t|) + (RETURN + (COND + ((NULL (AND (PAIRP |b|) + (PROGN + (SPADLET |h| (QCAR |b|)) + (SPADLET |t| (QCDR |b|)) + 'T))) + |a|) + ((|member| |h| |a|) (|ordSetDiff| (|delete| |h| |a|) |t|)) + ('T (|ordSetDiff| |a| |t|)))))) + +;------------- +;testPredList u == +; for x in u repeat +; y := simpBool x +; x = y => nil +; pp x +; pp '"==========>" +; pp y + +(DEFUN |testPredList| (|u|) + (PROG (|y|) + (RETURN + (SEQ (DO ((G166480 |u| (CDR G166480)) (|x| NIL)) + ((OR (ATOM G166480) + (PROGN (SETQ |x| (CAR G166480)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |y| (|simpBool| |x|)) + (COND + ((BOOT-EQUAL |x| |y|) NIL) + ('T (|pp| |x|) + (|pp| (MAKESTRING "==========>")) + (|pp| |y|))))))))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/slam.boot.pamphlet b/src/interp/slam.boot.pamphlet deleted file mode 100644 index 76d3bc4..0000000 --- a/src/interp/slam.boot.pamphlet +++ /dev/null @@ -1,749 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp slam.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -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 slam.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. - -@ -<<*>>= -<> - -reportFunctionCompilation(op,nam,argl,body,isRecursive) == - -- for an alternate definition of this function which does not allow - -- dynamic caching, see SLAMOLD BOOT ---+ - $compiledOpNameList := [nam] - minivectorName := makeInternalMapMinivectorName(nam) - $minivectorNames := [[op,:minivectorName],:$minivectorNames] - body := SUBST(minivectorName,"$$$",body) - if $compilingInputFile then - $minivectorCode := [:$minivectorCode,minivectorName] - SET(minivectorName,LIST2REFVEC $minivector) - argl := COPY argl -- play it safe for optimization - init := - not(isRecursive and $compileRecurrence and #argl = 1) => nil - NRTisRecurrenceRelation(nam,body,minivectorName) - init => compileRecurrenceRelation(op,nam,argl,body,init) - cacheCount:= getCacheCount op - cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body) - cacheCount = 0 or null argl => - function:= [nam,['LAMBDA,[:argl,'envArg],body]] - compileInteractive function - nam - num := - FIXP cacheCount => - cacheCount < 1 => - keyedSystemError("S2IM0019",[cacheCount,op]) - cacheCount - keyedSystemError("S2IM0019",[cacheCount,op]) - sayKeyedMsg("S2IX0003",[op,num]) - auxfn := mkAuxiliaryName nam - g1:= GENSYM() --argument or argument list - [arg,computeValue] := - null argl => [nil,[auxfn]] - argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter - [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list - cacheName := mkCacheName nam - g2:= GENSYM() --length of cache or arg-value pair - g3:= GENSYM() --value computed by calling function - secondPredPair:= - null argl => [cacheName] - [['SETQ,g3,['assocCircular,g1,cacheName]],['CDR,g3]] - thirdPredPair:= - null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] - ['(QUOTE T), - ['SETQ,g2,computeValue], - ['SETQ,g3, - ['CAR,['SETQ,cacheName,['predCircular,cacheName,cacheCount]]]], - ['RPLACA,g3,g1], - ['RPLACD,g3,g2], - g2] - codeBody:= - ['PROG,[g2,g3],['RETURN,['COND,secondPredPair,thirdPredPair]]] - -- cannot use envArg in next statement without redoing much - -- of above. - lamex:= ['LAM,arg,codeBody] - mainFunction:= [nam,lamex] - computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] - compileInteractive mainFunction - compileInteractive computeFunction - cacheType:= 'function - cacheResetCode:= ['SETQ,cacheName,['mkCircularAlist,cacheCount]] - cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] - cacheVector:= - mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) - $e:= put(nam,'cacheInfo, cacheVector,$e) - eval cacheResetCode - SETANDFILE(cacheName,mkCircularAlist cacheCount) - nam - -getCacheCount fn == - n:= LASSOC(fn,$cacheAlist) => n - $cacheCount - -reportFunctionCacheAll(op,nam,argl,body) == - sayKeyedMsg("S2IX0004",[op]) - auxfn:= mkAuxiliaryName nam - g1:= GENSYM() --argument or argument list - [arg,computeValue] := - null argl => [['envArg],[auxfn, 'envArg]] - argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter - [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list - if null argl then g1:=nil - cacheName:= mkCacheName nam - g2:= GENSYM() --value computed by calling function - secondPredPair:= [['SETQ,g2,['HGET,cacheName,g1]],g2] - thirdPredPair:= ['(QUOTE T),['HPUT,cacheName,g1,computeValue]] - codeBody:= ['PROG,[g2],['RETURN,['COND,secondPredPair,thirdPredPair]]] - lamex:= ['LAM,arg,codeBody] - mainFunction:= [nam,lamex] - computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] - compileInteractive mainFunction - compileInteractive computeFunction - cacheType:= 'hash_-table - cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,''UEQUAL]] - cacheCountCode:= ['hashCount,cacheName] - cacheVector:= - mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) - $e:= put(nam,'cacheInfo, cacheVector,$e) - eval cacheResetCode - nam - -hashCount table == - +/[ADD1 nodeCount HGET(table,key) for key in HKEYS table] - -mkCircularAlist n == - l:= [[$failed,:$failed] for i in 1..n] - RPLACD(LASTNODE l,l) - -countCircularAlist(cal,n) == - +/[nodeCount x for x in cal for i in 1..n] - -predCircular(al,n) == - for i in 1..QSSUB1 n repeat al:= QCDR al - al - -assocCircular(x,al) == --like ASSOC except that al is circular - forwardPointer:= al - val:= nil - until EQ(forwardPointer,al) repeat - EQUAL(CAAR forwardPointer,x) => return (val:= CAR forwardPointer) - forwardPointer:= CDR forwardPointer - val - -compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) == - k:= #initCode - extraArgumentCode := - extraArguments := [x for x in argl | x ^= sharpArg] => - extraArguments is [x] => x - ['LIST,:extraArguments] - nil - g:= GENSYM() - gIndex:= GENSYM() - gsList:= [GENSYM() for x in initCode] - auxfn := mkAuxiliaryName(nam) - $compiledOpNameList := [:$compiledOpNameList,auxfn] - stateNam:= GENVAR() - stateVar:= GENSYM() - stateVal:= GENSYM() - lastArg := INTERNL STRCONC('"#",STRINGIMAGE QSADD1 LENGTH argl) - decomposeCode:= - [['LET,gIndex,['ELT,lastArg,0]],:[['LET,g,['ELT,lastArg,i]] - for g in gsList for i in 1..]] - gsRev:= REVERSE gsList - rotateCode:= [['LET,p,q] for p in gsRev for q in [:rest gsRev,g]] - advanceCode:= ['LET,gIndex,['ADD1,gIndex]] - - newTripleCode := ['LIST,sharpArg,:gsList] - newStateCode := - null extraArguments => ['SETQ,stateNam,newTripleCode] - ['HPUT,stateNam,extraArgumentCode,newTripleCode] - - computeFunction:= [auxfn,['LAM,cargl,cbody]] where - cargl:= [:argl,lastArg] - returnValue:= ['PROGN,newStateCode,first gsList] - cbody:= - endTest:= - ['COND, [['EQL,sharpArg,gIndex],['RETURN,returnValue]]] - newValueCode:= ['LET,g,SUBST(gIndex,sharpArg, - EQSUBSTLIST(gsList,rest $TriangleVariableList,body))] - ['PROGN,:decomposeCode, - ['REPEAT,['WHILE,'T],['PROGN,endTest,advanceCode, - newValueCode,:rotateCode]]] - fromScratchInit:= - [['LET,gIndex,n],:[['LET,g,x] for g in gsList for x in initCode]] - continueInit:= - [['LET,gIndex,['ELT,stateVar,0]], - :[['LET,g,['ELT,stateVar,i]] for g in gsList for i in 1..]] - mainFunction:= [nam,['LAM,margl,mbody]] where - margl:= [:argl,'envArg] - max:= GENSYM() - tripleCode := ['CONS,n,['LIST,:initCode]] - - -- initialSetCode initializes the global variable if necessary and - -- also binds "stateVar" to its current value - initialSetCode := - initialValueCode := - extraArguments => ['MAKE_-HASHTABLE,''UEQUAL] - tripleCode - cacheResetCode := ['SETQ,stateNam,initialValueCode] - ['COND,[['NULL,['AND,['BOUNDP,MKQ stateNam], _ - ['PAIRP,stateNam]]], _ - ['LET,stateVar,cacheResetCode]], _ - [''T, ['LET,stateVar,stateNam]]] - - -- when there are extra arguments, initialResetCode resets "stateVar" - -- to the hashtable entry for the extra arguments - initialResetCode := - null extraArguments => nil - [['LET,stateVar,['OR, - ['HGET,stateVar,extraArgumentCode], - ['HPUT,stateVar,extraArgumentCode,tripleCode]]]] - - mbody := - preset := [initialSetCode,:initialResetCode,['LET,max,['ELT,stateVar,0]]] - phrase1:= [['AND,['LET,max,['ELT,stateVar,0]],['GE,sharpArg,max]], - [auxfn,:argl,stateVar]] - phrase2:= [['GT,sharpArg,['SETQ,max,['DIFFERENCE,max,k]]], - ['ELT,stateVar,['QSADD1,['QSDIFFERENCE,k,['DIFFERENCE,sharpArg,max]]]]] - phrase3:= [['GT,sharpArg,n],[auxfn,:argl,['LIST,n,:initCode]]] - phrase4:= [['GT,sharpArg,n-k], - ['ELT,['LIST,:initCode],['QSDIFFERENCE,n,sharpArg]]] - phrase5:= ['(QUOTE T),['recurrenceError,MKQ op,sharpArg]] - ['PROGN,:preset,['COND,phrase1,phrase2,phrase3,phrase4,phrase5]] - sayKeyedMsg("S2IX0001",[op]) - compileInteractive computeFunction - compileInteractive mainFunction - cacheType:= 'recurrence - cacheCountCode:= ['nodeCount,stateNam] - cacheVector:= mkCacheVec(op,stateNam,cacheType,cacheResetCode,cacheCountCode) - $e:= put(nam,'cacheInfo, cacheVector,$e) - nam - -nodeCount x == NUMOFNODES x - -recurrenceError(op,arg) == throwKeyedMsg("S2IX0002",[op,arg]) - -mkCacheVec(op,nam,kind,resetCode,countCode) == - [op,nam,kind,resetCode,countCode] - --- reportCacheStore vl == --- sayMSG concat(centerString('"Name",22,'" ")," Kind #Cells") --- sayMSG concat(centerString('"----",22,'" ")," ---- ------") --- for x in vl repeat reportCacheStoreFor x --- --- op2String op == --- u:= linearFormatName op --- atom u => PNAME u --- "STRCONC"/u --- --- reportCacheStorePrint(op,kind,count) == --- ops:= op2String op --- opString:= centerString(ops,22,'" ") --- kindString:= centerString(PNAME kind,10,'" ") --- countString:= centerString(count,19,'" ") --- sayMSG concat(opString,kindString,countString) --- --- reportCacheStoreFor op == --- u:= getI(op,'localModemap) => --- for [['local,target,:.],[.,fn],:.] in u repeat --- [op1,cacheName,kind,.,countCode]:= getI(fn,'cacheInfo) or --- keyedSystemError("S2GE0016",['"reportCacheStoreFor", --- '"missing cache information vector"]) --- reportCacheStorePrint(op,kind,eval countCode) --- true --- u:= getI(op,"cache") => --- reportCacheStorePrint(op,'variable,nodeCount u) --- nil - -clearCache x == - get(x,'localModemap,$e) or get(x,'mapBody,$e) => - for [map,:sub] in $mapSubNameAlist repeat - map=x => _/UNTRACE_,2(sub,NIL) - $e:= putHist(x,'localModemap,nil,$e) - $e:= putHist(x,'mapBody,nil,$e) - $e:= putHist(x,'localVars,nil,$e) - sayKeyedMsg("S2IX0007",[x]) - -clearLocalModemaps x == - u:= get(x,"localModemap",$e) => - for sub in ASSOCRIGHT $mapSubNameAlist repeat - _/UNTRACE_,2(sub,NIL) - $e:= putHist(x,"localModemap",nil,$e) - for mm in u repeat - [.,fn,:.] := mm - if def:= get(fn,'definition,$e) then - $e:= putHist(x,'value,mkObj(def,$EmptyMode),$e) - if cacheVec:= get(fn,'cacheInfo,$e) then - SET(cacheVec.cacheName,NIL) - -- now clear the property list of the identifier - $e := addIntSymTabBinding(x,nil,$e) - sayKeyedMsg("S2IX0007",[x]) - -compileInteractive fn == - if $InteractiveMode then startTimingProcess 'compilation - --following not used for common lisp - --removeUnnecessaryLastArguments CADR fn - if $reportCompilation then - sayBrightlyI bright '"Generated LISP code for function:" - pp fn - optfn := - $InteractiveMode => [timedOptimization fn] - [fn] - result := compQuietly optfn - if $InteractiveMode then stopTimingProcess 'compilation - result - -clearAllSlams x == - fn(x,nil) where - fn(thoseToClear,thoseCleared) == - for x in thoseToClear | not MEMQ(x,thoseCleared) repeat - slamListName:= mkCacheName x - SET(slamListName,nil) - thoseCleared:= ADJOIN(x,thoseCleared) - someMoreToClear:= - setDifference(LASSOC(x,$functorDependencyAlist),[:thoseToClear,: - thoseCleared]) - NCONC(thoseToClear,someMoreToClear) - -clearSlam("functor")== - id:= mkCacheName functor - SET(id,nil) -@ -\section{slam.clisp} -<>= - -(IN-PACKAGE "BOOT" ) - -; -;reportFunctionCompilation(op,nam,argl,body,isRecursive) == -; -- for an alternate definition of this function which does not allow -; -- dynamic caching, see SLAMOLD BOOT -;--+ -; $compiledOpNameList := [nam] -; minivectorName := makeInternalMapMinivectorName(nam) -; $minivectorNames := [[op,:minivectorName],:$minivectorNames] -; body := SUBST(minivectorName,"$$$",body) -; if $compilingInputFile then -; $minivectorCode := [:$minivectorCode,minivectorName] -; SET(minivectorName,LIST2REFVEC $minivector) -; argl := COPY argl -- play it safe for optimization -; init := -; not(isRecursive and $compileRecurrence and #argl = 1) => nil -; NRTisRecurrenceRelation(nam,body,minivectorName) -; init => compileRecurrenceRelation(op,nam,argl,body,init) -; cacheCount:= getCacheCount op -; cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body) -; cacheCount = 0 or null argl => -; function:= [nam,['LAMBDA,[:argl,'envArg],body]] -; compileInteractive function -; nam -; num := -; FIXP cacheCount => -; cacheCount < 1 => -; keyedSystemError("S2IM0019",[cacheCount,op]) -; cacheCount -; keyedSystemError("S2IM0019",[cacheCount,op]) -; sayKeyedMsg("S2IX0003",[op,num]) -; auxfn := mkAuxiliaryName nam -; g1:= GENSYM() --argument or argument list -; [arg,computeValue] := -; null argl => [nil,[auxfn]] -; argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter -; [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list -; cacheName := mkCacheName nam -; g2:= GENSYM() --length of cache or arg-value pair -; g3:= GENSYM() --value computed by calling function -; secondPredPair:= -; null argl => [cacheName] -; [['SETQ,g3,['assocCircular,g1,cacheName]],['CDR,g3]] -; thirdPredPair:= -; null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] -; ['(QUOTE T), -; ['SETQ,g2,computeValue], -; ['SETQ,g3, -; ['CAR,['SETQ,cacheName,['predCircular,cacheName,cacheCount]]]], -; ['RPLACA,g3,g1], -; ['RPLACD,g3,g2], -; g2] -; codeBody:= -; ['PROG,[g2,g3],['RETURN,['COND,secondPredPair,thirdPredPair]]] -; -- cannot use envArg in next statement without redoing much -; -- of above. -; lamex:= ['LAM,arg,codeBody] -; mainFunction:= [nam,lamex] -; computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] -; compileInteractive mainFunction -; compileInteractive computeFunction -; cacheType:= 'function -; cacheResetCode:= ['SETQ,cacheName,['mkCircularAlist,cacheCount]] -; cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] -; cacheVector:= -; mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) -; $e:= put(nam,'cacheInfo, cacheVector,$e) -; eval cacheResetCode -; SETANDFILE(cacheName,mkCircularAlist cacheCount) -; nam - -;;; *** |reportFunctionCompilation| REDEFINED - -(DEFUN |reportFunctionCompilation| (|op| |nam| |argl| |body| |isRecursive|) (PROG (|minivectorName| |init| |cacheCount| |function| |num| |auxfn| |g1| |LETTMP#1| |arg| |computeValue| |cacheName| |g2| |g3| |secondPredPair| |thirdPredPair| |codeBody| |lamex| |mainFunction| |computeFunction| |cacheType| |cacheResetCode| |cacheCountCode| |cacheVector|) (RETURN (PROGN (SPADLET |$compiledOpNameList| (CONS |nam| NIL)) (SPADLET |minivectorName| (|makeInternalMapMinivectorName| |nam|)) (SPADLET |$minivectorNames| (CONS (CONS |op| |minivectorName|) |$minivectorNames|)) (SPADLET |body| (MSUBST |minivectorName| (QUOTE $$$) |body|)) (COND (|$compilingInputFile| (SPADLET |$minivectorCode| (APPEND |$minivectorCode| (CONS |minivectorName| NIL))))) (SET |minivectorName| (LIST2REFVEC |$minivector|)) (SPADLET |argl| (COPY |argl|)) (SPADLET |init| (COND ((NULL (AND |isRecursive| |$compileRecurrence| (EQL (|#| |argl|) 1))) NIL) ((QUOTE T) (|NRTisRecurrenceRelation| |nam| |body| |minivectorName|)))) (COND (|init| (|compileRecurrenceRelation| |op| |nam| |argl| |body| |init|)) ((QUOTE T) (SPADLET |cacheCount| (|getCacheCount| |op|)) (COND ((BOOT-EQUAL |cacheCount| (QUOTE |all|)) (|reportFunctionCacheAll| |op| |nam| |argl| |body|)) ((OR (EQL |cacheCount| 0) (NULL |argl|)) (SPADLET |function| (CONS |nam| (CONS (CONS (QUOTE LAMBDA) (CONS (APPEND |argl| (CONS (QUOTE |envArg|) NIL)) (CONS |body| NIL))) NIL))) (|compileInteractive| |function|) |nam|) ((QUOTE T) (SPADLET |num| (COND ((FIXP |cacheCount|) (COND ((> 1 |cacheCount|) (|keyedSystemError| (QUOTE S2IM0019) (CONS |cacheCount| (CONS |op| NIL)))) ((QUOTE T) |cacheCount|))) ((QUOTE T) (|keyedSystemError| (QUOTE S2IM0019) (CONS |cacheCount| (CONS |op| NIL)))))) (|sayKeyedMsg| (QUOTE S2IX0003) (CONS |op| (CONS |num| NIL))) (SPADLET |auxfn| (|mkAuxiliaryName| |nam|)) (SPADLET |g1| (GENSYM)) (SPADLET |LETTMP#1| (COND ((NULL |argl|) (CONS NIL (CONS (CONS |auxfn| NIL) NIL))) ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) (CONS (CONS |g1| (CONS (QUOTE |envArg|) NIL)) (CONS (CONS |auxfn| (CONS |g1| (CONS (QUOTE |envArg|) NIL))) NIL))) ((QUOTE T) (CONS |g1| (CONS (CONS (QUOTE APPLX) (CONS (MKQ |auxfn|) (CONS |g1| NIL))) NIL))))) (SPADLET |arg| (CAR |LETTMP#1|)) (SPADLET |computeValue| (CADR |LETTMP#1|)) (SPADLET |cacheName| (|mkCacheName| |nam|)) (SPADLET |g2| (GENSYM)) (SPADLET |g3| (GENSYM)) (SPADLET |secondPredPair| (COND ((NULL |argl|) (CONS |cacheName| NIL)) ((QUOTE T) (CONS (CONS (QUOTE SETQ) (CONS |g3| (CONS (CONS (QUOTE |assocCircular|) (CONS |g1| (CONS |cacheName| NIL))) NIL))) (CONS (CONS (QUOTE CDR) (CONS |g3| NIL)) NIL))))) (SPADLET |thirdPredPair| (COND ((NULL |argl|) (CONS (QUOTE (QUOTE T)) (CONS (CONS (QUOTE SETQ) (CONS |cacheName| (CONS |computeValue| NIL))) NIL))) ((QUOTE T) (CONS (QUOTE (QUOTE T)) (CONS (CONS (QUOTE SETQ) (CONS |g2| (CONS |computeValue| NIL))) (CONS (CONS (QUOTE SETQ) (CONS |g3| (CONS (CONS (QUOTE CAR) (CONS (CONS (QUOTE SETQ) (CONS |cacheName| (CONS (CONS (QUOTE |predCircular|) (CONS |cacheName| (CONS |cacheCount| NIL))) NIL))) NIL)) NIL))) (CONS (CONS (QUOTE RPLACA) (CONS |g3| (CONS |g1| NIL))) (CONS (CONS (QUOTE RPLACD) (CONS |g3| (CONS |g2| NIL))) (CONS |g2| NIL))))))))) (SPADLET |codeBody| (CONS (QUOTE PROG) (CONS (CONS |g2| (CONS |g3| 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 |nam| (CONS |lamex| NIL))) (SPADLET |computeFunction| (CONS |auxfn| (CONS (CONS (QUOTE LAMBDA) (CONS (APPEND |argl| (CONS (QUOTE |envArg|) NIL)) (CONS |body| NIL))) NIL))) (|compileInteractive| |mainFunction|) (|compileInteractive| |computeFunction|) (SPADLET |cacheType| (QUOTE |function|)) (SPADLET |cacheResetCode| (CONS (QUOTE SETQ) (CONS |cacheName| (CONS (CONS (QUOTE |mkCircularAlist|) (CONS |cacheCount| NIL)) NIL)))) (SPADLET |cacheCountCode| (CONS (QUOTE |countCircularAlist|) (CONS |cacheName| (CONS |cacheCount| NIL)))) (SPADLET |cacheVector| (|mkCacheVec| |op| |cacheName| |cacheType| |cacheResetCode| |cacheCountCode|)) (SPADLET |$e| (|put| |nam| (QUOTE |cacheInfo|) |cacheVector| |$e|)) (|eval| |cacheResetCode|) (SETANDFILE |cacheName| (|mkCircularAlist| |cacheCount|)) |nam|)))))))) -; -;getCacheCount fn == -; n:= LASSOC(fn,$cacheAlist) => n -; $cacheCount - -;;; *** |getCacheCount| REDEFINED - -(DEFUN |getCacheCount| (|fn|) (PROG (|n|) (RETURN (COND ((SPADLET |n| (LASSOC |fn| |$cacheAlist|)) |n|) ((QUOTE T) |$cacheCount|))))) -; -;reportFunctionCacheAll(op,nam,argl,body) == -; sayKeyedMsg("S2IX0004",[op]) -; auxfn:= mkAuxiliaryName nam -; g1:= GENSYM() --argument or argument list -; [arg,computeValue] := -; null argl => [['envArg],[auxfn, 'envArg]] -; argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter -; [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list -; if null argl then g1:=nil -; cacheName:= mkCacheName nam -; g2:= GENSYM() --value computed by calling function -; secondPredPair:= [['SETQ,g2,['HGET,cacheName,g1]],g2] -; thirdPredPair:= ['(QUOTE T),['HPUT,cacheName,g1,computeValue]] -; codeBody:= ['PROG,[g2],['RETURN,['COND,secondPredPair,thirdPredPair]]] -; lamex:= ['LAM,arg,codeBody] -; mainFunction:= [nam,lamex] -; computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] -; compileInteractive mainFunction -; compileInteractive computeFunction -; cacheType:= 'hash_-table -; cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,''UEQUAL]] -; cacheCountCode:= ['hashCount,cacheName] -; cacheVector:= -; mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) -; $e:= put(nam,'cacheInfo, cacheVector,$e) -; eval cacheResetCode -; nam - -;;; *** |reportFunctionCacheAll| REDEFINED - -(DEFUN |reportFunctionCacheAll| (|op| |nam| |argl| |body|) (PROG (|auxfn| |LETTMP#1| |arg| |computeValue| |g1| |cacheName| |g2| |secondPredPair| |thirdPredPair| |codeBody| |lamex| |mainFunction| |computeFunction| |cacheType| |cacheResetCode| |cacheCountCode| |cacheVector|) (RETURN (PROGN (|sayKeyedMsg| (QUOTE S2IX0004) (CONS |op| NIL)) (SPADLET |auxfn| (|mkAuxiliaryName| |nam|)) (SPADLET |g1| (GENSYM)) (SPADLET |LETTMP#1| (COND ((NULL |argl|) (CONS (CONS (QUOTE |envArg|) NIL) (CONS (CONS |auxfn| (CONS (QUOTE |envArg|) NIL)) NIL))) ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) (CONS (CONS |g1| (CONS (QUOTE |envArg|) NIL)) (CONS (CONS |auxfn| (CONS |g1| (CONS (QUOTE |envArg|) NIL))) NIL))) ((QUOTE T) (CONS |g1| (CONS (CONS (QUOTE APPLX) (CONS (MKQ |auxfn|) (CONS |g1| NIL))) NIL))))) (SPADLET |arg| (CAR |LETTMP#1|)) (SPADLET |computeValue| (CADR |LETTMP#1|)) (COND ((NULL |argl|) (SPADLET |g1| NIL))) (SPADLET |cacheName| (|mkCacheName| |nam|)) (SPADLET |g2| (GENSYM)) (SPADLET |secondPredPair| (CONS (CONS (QUOTE SETQ) (CONS |g2| (CONS (CONS (QUOTE HGET) (CONS |cacheName| (CONS |g1| NIL))) NIL))) (CONS |g2| NIL))) (SPADLET |thirdPredPair| (CONS (QUOTE (QUOTE T)) (CONS (CONS (QUOTE HPUT) (CONS |cacheName| (CONS |g1| (CONS |computeValue| NIL)))) 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 |nam| (CONS |lamex| NIL))) (SPADLET |computeFunction| (CONS |auxfn| (CONS (CONS (QUOTE LAMBDA) (CONS (APPEND |argl| (CONS (QUOTE |envArg|) NIL)) (CONS |body| NIL))) NIL))) (|compileInteractive| |mainFunction|) (|compileInteractive| |computeFunction|) (SPADLET |cacheType| (QUOTE |hash-table|)) (SPADLET |cacheResetCode| (CONS (QUOTE SETQ) (CONS |cacheName| (CONS (CONS (QUOTE MAKE-HASHTABLE) (CONS (QUOTE (QUOTE UEQUAL)) NIL)) NIL)))) (SPADLET |cacheCountCode| (CONS (QUOTE |hashCount|) (CONS |cacheName| NIL))) (SPADLET |cacheVector| (|mkCacheVec| |op| |cacheName| |cacheType| |cacheResetCode| |cacheCountCode|)) (SPADLET |$e| (|put| |nam| (QUOTE |cacheInfo|) |cacheVector| |$e|)) (|eval| |cacheResetCode|) |nam|)))) -; -;hashCount table == -; +/[ADD1 nodeCount HGET(table,key) for key in HKEYS table] - -;;; *** |hashCount| REDEFINED - -(DEFUN |hashCount| (|table|) (PROG NIL (RETURN (SEQ (PROG (#0=#:G2271) (SPADLET #0# 0) (RETURN (DO ((#1=#:G2276 (HKEYS |table|) (CDR #1#)) (|key| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |key| (CAR #1#)) NIL)) #0#) (SEQ (EXIT (SETQ #0# (PLUS #0# (ADD1 (|nodeCount| (HGET |table| |key|)))))))))))))) -; -;mkCircularAlist n == -; l:= [[$failed,:$failed] for i in 1..n] -; RPLACD(LASTNODE l,l) - -;;; *** |mkCircularAlist| REDEFINED - -(DEFUN |mkCircularAlist| (|n|) (PROG (|l|) (RETURN (SEQ (PROGN (SPADLET |l| (PROG (#0=#:G2291) (SPADLET #0# NIL) (RETURN (DO ((|i| 1 (QSADD1 |i|))) ((QSGREATERP |i| |n|) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (CONS |$failed| |$failed|) #0#)))))))) (RPLACD (LASTNODE |l|) |l|)))))) -; -;countCircularAlist(cal,n) == -; +/[nodeCount x for x in cal for i in 1..n] - -;;; *** |countCircularAlist| REDEFINED - -(DEFUN |countCircularAlist| (|cal| |n|) (PROG NIL (RETURN (SEQ (PROG (#0=#:G2304) (SPADLET #0# 0) (RETURN (DO ((#1=#:G2310 |cal| (CDR #1#)) (|x| NIL) (|i| 1 (QSADD1 |i|))) ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL) (QSGREATERP |i| |n|)) #0#) (SEQ (EXIT (SETQ #0# (PLUS #0# (|nodeCount| |x|)))))))))))) -; -;predCircular(al,n) == -; for i in 1..QSSUB1 n repeat al:= QCDR al -; al - -;;; *** |predCircular| REDEFINED - -(DEFUN |predCircular| (|al| |n|) (SEQ (PROGN (DO ((#0=#:G2325 (QSSUB1 |n|)) (|i| 1 (QSADD1 |i|))) ((QSGREATERP |i| #0#) NIL) (SEQ (EXIT (SPADLET |al| (QCDR |al|))))) |al|))) -; -;assocCircular(x,al) == --like ASSOC except that al is circular -; forwardPointer:= al -; val:= nil -; until EQ(forwardPointer,al) repeat -; EQUAL(CAAR forwardPointer,x) => return (val:= CAR forwardPointer) -; forwardPointer:= CDR forwardPointer -; val - -;;; *** |assocCircular| REDEFINED - -(DEFUN |assocCircular| (|x| |al|) (PROG (|val| |forwardPointer|) (RETURN (SEQ (PROGN (SPADLET |forwardPointer| |al|) (SPADLET |val| NIL) (DO ((#0=#:G2338 NIL (EQ |forwardPointer| |al|))) (#0# NIL) (SEQ (EXIT (COND ((BOOT-EQUAL (CAAR |forwardPointer|) |x|) (RETURN (SPADLET |val| (CAR |forwardPointer|)))) ((QUOTE T) (SPADLET |forwardPointer| (CDR |forwardPointer|))))))) |val|))))) -; -;compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) == -; k:= #initCode -; extraArgumentCode := -; extraArguments := [x for x in argl | x ^= sharpArg] => -; extraArguments is [x] => x -; ['LIST,:extraArguments] -; nil -; g:= GENSYM() -; gIndex:= GENSYM() -; gsList:= [GENSYM() for x in initCode] -; auxfn := mkAuxiliaryName(nam) -; $compiledOpNameList := [:$compiledOpNameList,auxfn] -; stateNam:= GENVAR() -; stateVar:= GENSYM() -; stateVal:= GENSYM() -; lastArg := INTERNL STRCONC('"#",STRINGIMAGE QSADD1 LENGTH argl) -; decomposeCode:= -; [['LET,gIndex,['ELT,lastArg,0]],:[['LET,g,['ELT,lastArg,i]] -; for g in gsList for i in 1..]] -; gsRev:= REVERSE gsList -; rotateCode:= [['LET,p,q] for p in gsRev for q in [:rest gsRev,g]] -; advanceCode:= ['LET,gIndex,['ADD1,gIndex]] -; -; newTripleCode := ['LIST,sharpArg,:gsList] -; newStateCode := -; null extraArguments => ['SETQ,stateNam,newTripleCode] -; ['HPUT,stateNam,extraArgumentCode,newTripleCode] -; -; computeFunction:= [auxfn,['LAM,cargl,cbody]] where -; cargl:= [:argl,lastArg] -; returnValue:= ['PROGN,newStateCode,first gsList] -; cbody:= -; endTest:= -; ['COND, [['EQL,sharpArg,gIndex],['RETURN,returnValue]]] -; newValueCode:= ['LET,g,SUBST(gIndex,sharpArg, -; EQSUBSTLIST(gsList,rest $TriangleVariableList,body))] -; ['PROGN,:decomposeCode, -; ['REPEAT,['WHILE,'T],['PROGN,endTest,advanceCode, -; newValueCode,:rotateCode]]] -; fromScratchInit:= -; [['LET,gIndex,n],:[['LET,g,x] for g in gsList for x in initCode]] -; continueInit:= -; [['LET,gIndex,['ELT,stateVar,0]], -; :[['LET,g,['ELT,stateVar,i]] for g in gsList for i in 1..]] -; mainFunction:= [nam,['LAM,margl,mbody]] where -; margl:= [:argl,'envArg] -; max:= GENSYM() -; tripleCode := ['CONS,n,['LIST,:initCode]] -; -; -- initialSetCode initializes the global variable if necessary and -; -- also binds "stateVar" to its current value -; initialSetCode := -; initialValueCode := -; extraArguments => ['MAKE_-HASHTABLE,''UEQUAL] -; tripleCode -; cacheResetCode := ['SETQ,stateNam,initialValueCode] -; ['COND,[['NULL,['AND,['BOUNDP,MKQ stateNam], _ -; ['PAIRP,stateNam]]], _ -; ['LET,stateVar,cacheResetCode]], _ -; [''T, ['LET,stateVar,stateNam]]] -; -; -- when there are extra arguments, initialResetCode resets "stateVar" -; -- to the hashtable entry for the extra arguments -; initialResetCode := -; null extraArguments => nil -; [['LET,stateVar,['OR, -; ['HGET,stateVar,extraArgumentCode], -; ['HPUT,stateVar,extraArgumentCode,tripleCode]]]] -; -; mbody := -; preset := [initialSetCode,:initialResetCode,['LET,max,['ELT,stateVar,0]]] -; phrase1:= [['AND,['LET,max,['ELT,stateVar,0]],['GE,sharpArg,max]], -; [auxfn,:argl,stateVar]] -; phrase2:= [['GT,sharpArg,['SETQ,max,['DIFFERENCE,max,k]]], -; ['ELT,stateVar,['QSADD1,['QSDIFFERENCE,k,['DIFFERENCE,sharpArg,max]]]]] -; phrase3:= [['GT,sharpArg,n],[auxfn,:argl,['LIST,n,:initCode]]] -; phrase4:= [['GT,sharpArg,n-k], -; ['ELT,['LIST,:initCode],['QSDIFFERENCE,n,sharpArg]]] -; phrase5:= ['(QUOTE T),['recurrenceError,MKQ op,sharpArg]] -; ['PROGN,:preset,['COND,phrase1,phrase2,phrase3,phrase4,phrase5]] -; sayKeyedMsg("S2IX0001",[op]) -; compileInteractive computeFunction -; compileInteractive mainFunction -; cacheType:= 'recurrence -; cacheCountCode:= ['nodeCount,stateNam] -; cacheVector:= mkCacheVec(op,stateNam,cacheType,cacheResetCode,cacheCountCode) -; $e:= put(nam,'cacheInfo, cacheVector,$e) -; nam - -;;; *** |compileRecurrenceRelation| REDEFINED - -(DEFUN |compileRecurrenceRelation| (|op| |nam| |argl| |junk| #0=#:G2369) (PROG (|body| |sharpArg| |n| |initCode| |k| |extraArguments| |x| |extraArgumentCode| |g| |gIndex| |gsList| |auxfn| |stateNam| |stateVar| |stateVal| |lastArg| |decomposeCode| |gsRev| |rotateCode| |advanceCode| |newTripleCode| |newStateCode| |cargl| |returnValue| |endTest| |newValueCode| |cbody| |computeFunction| |fromScratchInit| |continueInit| |margl| |max| |tripleCode| |initialValueCode| |cacheResetCode| |initialSetCode| |initialResetCode| |preset| |phrase1| |phrase2| |phrase3| |phrase4| |phrase5| |mbody| |mainFunction| |cacheType| |cacheCountCode| |cacheVector|) (RETURN (SEQ (PROGN (SPADLET |body| (CAR #0#)) (SPADLET |sharpArg| (CADR #0#)) (SPADLET |n| (CADDR #0#)) (SPADLET |initCode| (CDDDR #0#)) (SPADLET |k| (|#| |initCode|)) (SPADLET |extraArgumentCode| (COND ((SPADLET |extraArguments| (PROG (#1=#:G2400) (SPADLET #1# NIL) (RETURN (DO ((#2=#:G2406 |argl| (CDR #2#)) (|x| NIL)) ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) (NREVERSE0 #1#)) (SEQ (EXIT (COND ((NEQUAL |x| |sharpArg|) (SETQ #1# (CONS |x| #1#)))))))))) (COND ((AND (PAIRP |extraArguments|) (EQ (QCDR |extraArguments|) NIL) (PROGN (SPADLET |x| (QCAR |extraArguments|)) (QUOTE T))) |x|) ((QUOTE T) (CONS (QUOTE LIST) |extraArguments|)))) ((QUOTE T) NIL))) (SPADLET |g| (GENSYM)) (SPADLET |gIndex| (GENSYM)) (SPADLET |gsList| (PROG (#3=#:G2416) (SPADLET #3# NIL) (RETURN (DO ((#4=#:G2421 |initCode| (CDR #4#)) (|x| NIL)) ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) (NREVERSE0 #3#)) (SEQ (EXIT (SETQ #3# (CONS (GENSYM) #3#)))))))) (SPADLET |auxfn| (|mkAuxiliaryName| |nam|)) (SPADLET |$compiledOpNameList| (APPEND |$compiledOpNameList| (CONS |auxfn| NIL))) (SPADLET |stateNam| (GENVAR)) (SPADLET |stateVar| (GENSYM)) (SPADLET |stateVal| (GENSYM)) (SPADLET |lastArg| (INTERNL (STRCONC (MAKESTRING "#") (STRINGIMAGE (QSADD1 (LENGTH |argl|)))))) (SPADLET |decomposeCode| (CONS (CONS (QUOTE LET) (CONS |gIndex| (CONS (CONS (QUOTE ELT) (CONS |lastArg| (CONS 0 NIL))) NIL))) (PROG (#5=#:G2432) (SPADLET #5# NIL) (RETURN (DO ((#6=#:G2438 |gsList| (CDR #6#)) (|g| NIL) (|i| 1 (QSADD1 |i|))) ((OR (ATOM #6#) (PROGN (SETQ |g| (CAR #6#)) NIL)) (NREVERSE0 #5#)) (SEQ (EXIT (SETQ #5# (CONS (CONS (QUOTE LET) (CONS |g| (CONS (CONS (QUOTE ELT) (CONS |lastArg| (CONS |i| NIL))) NIL))) #5#))))))))) (SPADLET |gsRev| (REVERSE |gsList|)) (SPADLET |rotateCode| (PROG (#7=#:G2449) (SPADLET #7# NIL) (RETURN (DO ((#8=#:G2455 |gsRev| (CDR #8#)) (|p| NIL) (#9=#:G2456 (APPEND (CDR |gsRev|) (CONS |g| NIL)) (CDR #9#)) (|q| NIL)) ((OR (ATOM #8#) (PROGN (SETQ |p| (CAR #8#)) NIL) (ATOM #9#) (PROGN (SETQ |q| (CAR #9#)) NIL)) (NREVERSE0 #7#)) (SEQ (EXIT (SETQ #7# (CONS (CONS (QUOTE LET) (CONS |p| (CONS |q| NIL))) #7#)))))))) (SPADLET |advanceCode| (CONS (QUOTE LET) (CONS |gIndex| (CONS (CONS (QUOTE ADD1) (CONS |gIndex| NIL)) NIL)))) (SPADLET |newTripleCode| (CONS (QUOTE LIST) (CONS |sharpArg| |gsList|))) (SPADLET |newStateCode| (COND ((NULL |extraArguments|) (CONS (QUOTE SETQ) (CONS |stateNam| (CONS |newTripleCode| NIL)))) ((QUOTE T) (CONS (QUOTE HPUT) (CONS |stateNam| (CONS |extraArgumentCode| (CONS |newTripleCode| NIL))))))) (SPADLET |cargl| (APPEND |argl| (CONS |lastArg| NIL))) (SPADLET |returnValue| (CONS (QUOTE PROGN) (CONS |newStateCode| (CONS (CAR |gsList|) NIL)))) (SPADLET |cbody| (PROGN (SPADLET |endTest| (CONS (QUOTE COND) (CONS (CONS (CONS (QUOTE EQL) (CONS |sharpArg| (CONS |gIndex| NIL))) (CONS (CONS (QUOTE RETURN) (CONS |returnValue| NIL)) NIL)) NIL))) (SPADLET |newValueCode| (CONS (QUOTE LET) (CONS |g| (CONS (MSUBST |gIndex| |sharpArg| (EQSUBSTLIST |gsList| (CDR |$TriangleVariableList|) |body|)) NIL)))) (CONS (QUOTE PROGN) (APPEND |decomposeCode| (CONS (CONS (QUOTE REPEAT) (CONS (CONS (QUOTE WHILE) (CONS (QUOTE T) NIL)) (CONS (CONS (QUOTE PROGN) (CONS |endTest| (CONS |advanceCode| (CONS |newValueCode| |rotateCode|)))) NIL))) NIL))))) (SPADLET |computeFunction| (CONS |auxfn| (CONS (CONS (QUOTE LAM) (CONS |cargl| (CONS |cbody| NIL))) NIL))) (SPADLET |fromScratchInit| (CONS (CONS (QUOTE LET) (CONS |gIndex| (CONS |n| NIL))) (PROG (#10=#:G2470) (SPADLET #10# NIL) (RETURN (DO ((#11=#:G2476 |gsList| (CDR #11#)) (|g| NIL) (#12=#:G2477 |initCode| (CDR #12#)) (|x| NIL)) ((OR (ATOM #11#) (PROGN (SETQ |g| (CAR #11#)) NIL) (ATOM #12#) (PROGN (SETQ |x| (CAR #12#)) NIL)) (NREVERSE0 #10#)) (SEQ (EXIT (SETQ #10# (CONS (CONS (QUOTE LET) (CONS |g| (CONS |x| NIL))) #10#))))))))) (SPADLET |continueInit| (CONS (CONS (QUOTE LET) (CONS |gIndex| (CONS (CONS (QUOTE ELT) (CONS |stateVar| (CONS 0 NIL))) NIL))) (PROG (#13=#:G2491) (SPADLET #13# NIL) (RETURN (DO ((#14=#:G2497 |gsList| (CDR #14#)) (|g| NIL) (|i| 1 (QSADD1 |i|))) ((OR (ATOM #14#) (PROGN (SETQ |g| (CAR #14#)) NIL)) (NREVERSE0 #13#)) (SEQ (EXIT (SETQ #13# (CONS (CONS (QUOTE LET) (CONS |g| (CONS (CONS (QUOTE ELT) (CONS |stateVar| (CONS |i| NIL))) NIL))) #13#))))))))) (SPADLET |margl| (APPEND |argl| (CONS (QUOTE |envArg|) NIL))) (SPADLET |max| (GENSYM)) (SPADLET |tripleCode| (CONS (QUOTE CONS) (CONS |n| (CONS (CONS (QUOTE LIST) |initCode|) NIL)))) (SPADLET |initialSetCode| (PROGN (SPADLET |initialValueCode| (COND (|extraArguments| (CONS (QUOTE MAKE-HASHTABLE) (CONS (QUOTE (QUOTE UEQUAL)) NIL))) ((QUOTE T) |tripleCode|))) (SPADLET |cacheResetCode| (CONS (QUOTE SETQ) (CONS |stateNam| (CONS |initialValueCode| NIL)))) (CONS (QUOTE COND) (CONS (CONS (CONS (QUOTE NULL) (CONS (CONS (QUOTE AND) (CONS (CONS (QUOTE BOUNDP) (CONS (MKQ |stateNam|) NIL)) (CONS (CONS (QUOTE PAIRP) (CONS |stateNam| NIL)) NIL))) NIL)) (CONS (CONS (QUOTE LET) (CONS |stateVar| (CONS |cacheResetCode| NIL))) NIL)) (CONS (CONS (QUOTE (QUOTE T)) (CONS (CONS (QUOTE LET) (CONS |stateVar| (CONS |stateNam| NIL))) NIL)) NIL))))) (SPADLET |initialResetCode| (COND ((NULL |extraArguments|) NIL) ((QUOTE T) (CONS (CONS (QUOTE LET) (CONS |stateVar| (CONS (CONS (QUOTE OR) (CONS (CONS (QUOTE HGET) (CONS |stateVar| (CONS |extraArgumentCode| NIL))) (CONS (CONS (QUOTE HPUT) (CONS |stateVar| (CONS |extraArgumentCode| (CONS |tripleCode| NIL)))) NIL))) NIL))) NIL)))) (SPADLET |mbody| (PROGN (SPADLET |preset| (CONS |initialSetCode| (APPEND |initialResetCode| (CONS (CONS (QUOTE LET) (CONS |max| (CONS (CONS (QUOTE ELT) (CONS |stateVar| (CONS 0 NIL))) NIL))) NIL)))) (SPADLET |phrase1| (CONS (CONS (QUOTE AND) (CONS (CONS (QUOTE LET) (CONS |max| (CONS (CONS (QUOTE ELT) (CONS |stateVar| (CONS 0 NIL))) NIL))) (CONS (CONS (QUOTE GE) (CONS |sharpArg| (CONS |max| NIL))) NIL))) (CONS (CONS |auxfn| (APPEND |argl| (CONS |stateVar| NIL))) NIL))) (SPADLET |phrase2| (CONS (CONS (QUOTE GT) (CONS |sharpArg| (CONS (CONS (QUOTE SETQ) (CONS |max| (CONS (CONS (QUOTE DIFFERENCE) (CONS |max| (CONS |k| NIL))) NIL))) NIL))) (CONS (CONS (QUOTE ELT) (CONS |stateVar| (CONS (CONS (QUOTE QSADD1) (CONS (CONS (QUOTE QSDIFFERENCE) (CONS |k| (CONS (CONS (QUOTE DIFFERENCE) (CONS |sharpArg| (CONS |max| NIL))) NIL))) NIL)) NIL))) NIL))) (SPADLET |phrase3| (CONS (CONS (QUOTE GT) (CONS |sharpArg| (CONS |n| NIL))) (CONS (CONS |auxfn| (APPEND |argl| (CONS (CONS (QUOTE LIST) (CONS |n| |initCode|)) NIL))) NIL))) (SPADLET |phrase4| (CONS (CONS (QUOTE GT) (CONS |sharpArg| (CONS (SPADDIFFERENCE |n| |k|) NIL))) (CONS (CONS (QUOTE ELT) (CONS (CONS (QUOTE LIST) |initCode|) (CONS (CONS (QUOTE QSDIFFERENCE) (CONS |n| (CONS |sharpArg| NIL))) NIL))) NIL))) (SPADLET |phrase5| (CONS (QUOTE (QUOTE T)) (CONS (CONS (QUOTE |recurrenceError|) (CONS (MKQ |op|) (CONS |sharpArg| NIL))) NIL))) (CONS (QUOTE PROGN) (APPEND |preset| (CONS (CONS (QUOTE COND) (CONS |phrase1| (CONS |phrase2| (CONS |phrase3| (CONS |phrase4| (CONS |phrase5| NIL)))))) NIL))))) (SPADLET |mainFunction| (CONS |nam| (CONS (CONS (QUOTE LAM) (CONS |margl| (CONS |mbody| NIL))) NIL))) (|sayKeyedMsg| (QUOTE S2IX0001) (CONS |op| NIL)) (|compileInteractive| |computeFunction|) (|compileInteractive| |mainFunction|) (SPADLET |cacheType| (QUOTE |recurrence|)) (SPADLET |cacheCountCode| (CONS (QUOTE |nodeCount|) (CONS |stateNam| NIL))) (SPADLET |cacheVector| (|mkCacheVec| |op| |stateNam| |cacheType| |cacheResetCode| |cacheCountCode|)) (SPADLET |$e| (|put| |nam| (QUOTE |cacheInfo|) |cacheVector| |$e|)) |nam|))))) -; -;nodeCount x == NUMOFNODES x - -;;; *** |nodeCount| REDEFINED - -(DEFUN |nodeCount| (|x|) (NUMOFNODES |x|)) -; -;recurrenceError(op,arg) == throwKeyedMsg("S2IX0002",[op,arg]) - -;;; *** |recurrenceError| REDEFINED - -(DEFUN |recurrenceError| (|op| |arg|) (|throwKeyedMsg| (QUOTE S2IX0002) (CONS |op| (CONS |arg| NIL)))) -; -;mkCacheVec(op,nam,kind,resetCode,countCode) == -; [op,nam,kind,resetCode,countCode] - -;;; *** |mkCacheVec| REDEFINED - -(DEFUN |mkCacheVec| (|op| |nam| |kind| |resetCode| |countCode|) (CONS |op| (CONS |nam| (CONS |kind| (CONS |resetCode| (CONS |countCode| NIL)))))) -; -;-- reportCacheStore vl == -;-- sayMSG concat(centerString('"Name",22,'" ")," Kind #Cells") -;-- sayMSG concat(centerString('"----",22,'" ")," ---- ------") -;-- for x in vl repeat reportCacheStoreFor x -;-- -;-- op2String op == -;-- u:= linearFormatName op -;-- atom u => PNAME u -;-- "STRCONC"/u -;-- -;-- reportCacheStorePrint(op,kind,count) == -;-- ops:= op2String op -;-- opString:= centerString(ops,22,'" ") -;-- kindString:= centerString(PNAME kind,10,'" ") -;-- countString:= centerString(count,19,'" ") -;-- sayMSG concat(opString,kindString,countString) -;-- -;-- reportCacheStoreFor op == -;-- u:= getI(op,'localModemap) => -;-- for [['local,target,:.],[.,fn],:.] in u repeat -;-- [op1,cacheName,kind,.,countCode]:= getI(fn,'cacheInfo) or -;-- keyedSystemError("S2GE0016",['"reportCacheStoreFor", -;-- '"missing cache information vector"]) -;-- reportCacheStorePrint(op,kind,eval countCode) -;-- true -;-- u:= getI(op,"cache") => -;-- reportCacheStorePrint(op,'variable,nodeCount u) -;-- nil -; -;clearCache x == -; get(x,'localModemap,$e) or get(x,'mapBody,$e) => -; for [map,:sub] in $mapSubNameAlist repeat -; map=x => _/UNTRACE_,2(sub,NIL) -; $e:= putHist(x,'localModemap,nil,$e) -; $e:= putHist(x,'mapBody,nil,$e) -; $e:= putHist(x,'localVars,nil,$e) -; sayKeyedMsg("S2IX0007",[x]) - -;;; *** |clearCache| REDEFINED - -(DEFUN |clearCache| (|x|) (PROG (|map| |sub|) (RETURN (SEQ (COND ((OR (|get| |x| (QUOTE |localModemap|) |$e|) (|get| |x| (QUOTE |mapBody|) |$e|)) (EXIT (SEQ (DO ((#0=#:G2580 |$mapSubNameAlist| (CDR #0#)) (#1=#:G2571 NIL)) ((OR (ATOM #0#) (PROGN (SETQ #1# (CAR #0#)) NIL) (PROGN (PROGN (SPADLET |map| (CAR #1#)) (SPADLET |sub| (CDR #1#)) #1#) NIL)) NIL) (SEQ (EXIT (COND ((BOOT-EQUAL |map| |x|) (EXIT (|/UNTRACE,2| |sub| NIL))))))) (SPADLET |$e| (|putHist| |x| (QUOTE |localModemap|) NIL |$e|)) (SPADLET |$e| (|putHist| |x| (QUOTE |mapBody|) NIL |$e|)) (SPADLET |$e| (|putHist| |x| (QUOTE |localVars|) NIL |$e|)) (|sayKeyedMsg| (QUOTE S2IX0007) (CONS |x| NIL)))))))))) -; -;clearLocalModemaps x == -; u:= get(x,"localModemap",$e) => -; for sub in ASSOCRIGHT $mapSubNameAlist repeat -; _/UNTRACE_,2(sub,NIL) -; $e:= putHist(x,"localModemap",nil,$e) -; for mm in u repeat -; [.,fn,:.] := mm -; if def:= get(fn,'definition,$e) then -; $e:= putHist(x,'value,mkObj(def,$EmptyMode),$e) -; if cacheVec:= get(fn,'cacheInfo,$e) then -; SET(cacheVec.cacheName,NIL) -; -- now clear the property list of the identifier -; $e := addIntSymTabBinding(x,nil,$e) -; sayKeyedMsg("S2IX0007",[x]) - -;;; *** |clearLocalModemaps| REDEFINED - -(DEFUN |clearLocalModemaps| (|x|) (PROG (|u| |fn| |def| |cacheVec|) (RETURN (SEQ (COND ((SPADLET |u| (|get| |x| (QUOTE |localModemap|) |$e|)) (EXIT (PROGN (DO ((#0=#:G2602 (ASSOCRIGHT |$mapSubNameAlist|) (CDR #0#)) (|sub| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |sub| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (|/UNTRACE,2| |sub| NIL)))) (SPADLET |$e| (|putHist| |x| (QUOTE |localModemap|) NIL |$e|)) (DO ((#1=#:G2615 |u| (CDR #1#)) (|mm| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |mm| (CAR #1#)) NIL)) NIL) (SEQ (EXIT (PROGN (SPADLET |fn| (CADR |mm|)) (COND ((SPADLET |def| (|get| |fn| (QUOTE |definition|) |$e|)) (SPADLET |$e| (|putHist| |x| (QUOTE |value|) (|mkObj| |def| |$EmptyMode|) |$e|)))) (COND ((SPADLET |cacheVec| (|get| |fn| (QUOTE |cacheInfo|) |$e|)) (SET (CADR |cacheVec|) NIL))) (SPADLET |$e| (|addIntSymTabBinding| |x| NIL |$e|)))))) (|sayKeyedMsg| (QUOTE S2IX0007) (CONS |x| NIL)))))))))) -; -;compileInteractive fn == -; if $InteractiveMode then startTimingProcess 'compilation -; --following not used for common lisp -; --removeUnnecessaryLastArguments CADR fn -; if $reportCompilation then -; sayBrightlyI bright '"Generated LISP code for function:" -; pp fn -; optfn := -; $InteractiveMode => [timedOptimization fn] -; [fn] -; result := compQuietly optfn -; if $InteractiveMode then stopTimingProcess 'compilation -; result - -;;; *** |compileInteractive| REDEFINED - -(DEFUN |compileInteractive| (|fn|) (PROG (|optfn| |result|) (RETURN (PROGN (COND (|$InteractiveMode| (|startTimingProcess| (QUOTE |compilation|)))) (COND (|$reportCompilation| (|sayBrightlyI| (|bright| (MAKESTRING "Generated LISP code for function:"))) (|pp| |fn|))) (SPADLET |optfn| (COND (|$InteractiveMode| (CONS (|timedOptimization| |fn|) NIL)) ((QUOTE T) (CONS |fn| NIL)))) (SPADLET |result| (|compQuietly| |optfn|)) (COND (|$InteractiveMode| (|stopTimingProcess| (QUOTE |compilation|)))) |result|)))) -; -;clearAllSlams x == -; fn(x,nil) where -; fn(thoseToClear,thoseCleared) == -; for x in thoseToClear | not MEMQ(x,thoseCleared) repeat -; slamListName:= mkCacheName x -; SET(slamListName,nil) -; thoseCleared:= ADJOIN(x,thoseCleared) -; someMoreToClear:= -; setDifference(LASSOC(x,$functorDependencyAlist),[:thoseToClear,: -; thoseCleared]) -; NCONC(thoseToClear,someMoreToClear) - -;;; *** |clearAllSlams,fn| REDEFINED - -(DEFUN |clearAllSlams,fn| (|thoseToClear| |thoseCleared|) (PROG (|slamListName| |someMoreToClear|) (RETURN (SEQ (DO ((#0=#:G2644 |thoseToClear| (CDR #0#)) (|x| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (COND ((NULL (MEMQ |x| |thoseCleared|)) (SEQ (SPADLET |slamListName| (|mkCacheName| |x|)) (SET |slamListName| NIL) (SPADLET |thoseCleared| (ADJOIN |x| |thoseCleared|)) (SPADLET |someMoreToClear| (SETDIFFERENCE (LASSOC |x| |$functorDependencyAlist|) (APPEND |thoseToClear| |thoseCleared|))) (EXIT (NCONC |thoseToClear| |someMoreToClear|)))))))))))) - -;;; *** |clearAllSlams| REDEFINED - -(DEFUN |clearAllSlams| (|x|) (|clearAllSlams,fn| |x| NIL)) -; -;clearSlam("functor")== -; id:= mkCacheName functor -; SET(id,nil) - -;;; *** |clearSlam| REDEFINED - -(DEFUN |clearSlam,LAM| (|functor|) (PROG (|id|) (RETURN (PROGN (SPADLET |id| (|mkCacheName| |functor|)) (SET |id| NIL))))) - -(DEFMACRO |clearSlam| (&WHOLE #0=#:G2667 &REST #:G2668 &AUX #1=#:G2666) (DSETQ #1# #0#) (CONS (QUOTE |clearSlam,LAM|) (VMLISP::WRAP (CDR #1#) (QUOTE (QUOTE))))) -;;;Boot translation finished for slam.boot -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/slam.lisp.pamphlet b/src/interp/slam.lisp.pamphlet new file mode 100644 index 0000000..60a88a0 --- /dev/null +++ b/src/interp/slam.lisp.pamphlet @@ -0,0 +1,1283 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp slam.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;reportFunctionCompilation(op,nam,argl,body,isRecursive) == +; -- for an alternate definition of this function which does not allow +; -- dynamic caching, see SLAMOLD BOOT +;--+ +; $compiledOpNameList := [nam] +; minivectorName := makeInternalMapMinivectorName(nam) +; $minivectorNames := [[op,:minivectorName],:$minivectorNames] +; body := SUBST(minivectorName,"$$$",body) +; if $compilingInputFile then +; $minivectorCode := [:$minivectorCode,minivectorName] +; SET(minivectorName,LIST2REFVEC $minivector) +; argl := COPY argl -- play it safe for optimization +; init := +; not(isRecursive and $compileRecurrence and #argl = 1) => nil +; NRTisRecurrenceRelation(nam,body,minivectorName) +; init => compileRecurrenceRelation(op,nam,argl,body,init) +; cacheCount:= getCacheCount op +; cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body) +; cacheCount = 0 or null argl => +; function:= [nam,['LAMBDA,[:argl,'envArg],body]] +; compileInteractive function +; nam +; num := +; FIXP cacheCount => +; cacheCount < 1 => +; keyedSystemError("S2IM0019",[cacheCount,op]) +; cacheCount +; keyedSystemError("S2IM0019",[cacheCount,op]) +; sayKeyedMsg("S2IX0003",[op,num]) +; auxfn := mkAuxiliaryName nam +; g1:= GENSYM() --argument or argument list +; [arg,computeValue] := +; null argl => [nil,[auxfn]] +; argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter +; [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list +; cacheName := mkCacheName nam +; g2:= GENSYM() --length of cache or arg-value pair +; g3:= GENSYM() --value computed by calling function +; secondPredPair:= +; null argl => [cacheName] +; [['SETQ,g3,['assocCircular,g1,cacheName]],['CDR,g3]] +; thirdPredPair:= +; null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] +; ['(QUOTE T), +; ['SETQ,g2,computeValue], +; ['SETQ,g3, +; ['CAR,['SETQ,cacheName,['predCircular,cacheName,cacheCount]]]], +; ['RPLACA,g3,g1], +; ['RPLACD,g3,g2], +; g2] +; codeBody:= +; ['PROG,[g2,g3],['RETURN,['COND,secondPredPair,thirdPredPair]]] +; -- cannot use envArg in next statement without redoing much +; -- of above. +; lamex:= ['LAM,arg,codeBody] +; mainFunction:= [nam,lamex] +; computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] +; compileInteractive mainFunction +; compileInteractive computeFunction +; cacheType:= 'function +; cacheResetCode:= ['SETQ,cacheName,['mkCircularAlist,cacheCount]] +; cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] +; cacheVector:= +; mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) +; $e:= put(nam,'cacheInfo, cacheVector,$e) +; eval cacheResetCode +; SETANDFILE(cacheName,mkCircularAlist cacheCount) +; nam + +;;; *** |reportFunctionCompilation| REDEFINED + +(DEFUN |reportFunctionCompilation| + (|op| |nam| |argl| |body| |isRecursive|) + (PROG (|minivectorName| |init| |cacheCount| |function| |num| |auxfn| + |g1| |LETTMP#1| |arg| |computeValue| |cacheName| |g2| |g3| + |secondPredPair| |thirdPredPair| |codeBody| |lamex| + |mainFunction| |computeFunction| |cacheType| + |cacheResetCode| |cacheCountCode| |cacheVector|) + (RETURN + (PROGN + (SPADLET |$compiledOpNameList| (CONS |nam| NIL)) + (SPADLET |minivectorName| + (|makeInternalMapMinivectorName| |nam|)) + (SPADLET |$minivectorNames| + (CONS (CONS |op| |minivectorName|) |$minivectorNames|)) + (SPADLET |body| (MSUBST |minivectorName| '$$$ |body|)) + (COND + (|$compilingInputFile| + (SPADLET |$minivectorCode| + (APPEND |$minivectorCode| + (CONS |minivectorName| NIL))))) + (SET |minivectorName| (LIST2REFVEC |$minivector|)) + (SPADLET |argl| (COPY |argl|)) + (SPADLET |init| + (COND + ((NULL (AND |isRecursive| |$compileRecurrence| + (EQL (|#| |argl|) 1))) + NIL) + ('T + (|NRTisRecurrenceRelation| |nam| |body| + |minivectorName|)))) + (COND + (|init| (|compileRecurrenceRelation| |op| |nam| |argl| |body| + |init|)) + ('T (SPADLET |cacheCount| (|getCacheCount| |op|)) + (COND + ((BOOT-EQUAL |cacheCount| '|all|) + (|reportFunctionCacheAll| |op| |nam| |argl| |body|)) + ((OR (EQL |cacheCount| 0) (NULL |argl|)) + (SPADLET |function| + (CONS |nam| + (CONS (CONS 'LAMBDA + (CONS + (APPEND |argl| + (CONS '|envArg| NIL)) + (CONS |body| NIL))) + NIL))) + (|compileInteractive| |function|) |nam|) + ('T + (SPADLET |num| + (COND + ((FIXP |cacheCount|) + (COND + ((> 1 |cacheCount|) + (|keyedSystemError| 'S2IM0019 + (CONS |cacheCount| (CONS |op| NIL)))) + ('T |cacheCount|))) + ('T + (|keyedSystemError| 'S2IM0019 + (CONS |cacheCount| (CONS |op| NIL)))))) + (|sayKeyedMsg| 'S2IX0003 (CONS |op| (CONS |num| NIL))) + (SPADLET |auxfn| (|mkAuxiliaryName| |nam|)) + (SPADLET |g1| (GENSYM)) + (SPADLET |LETTMP#1| + (COND + ((NULL |argl|) + (CONS NIL (CONS (CONS |auxfn| NIL) NIL))) + ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) + (CONS (CONS |g1| (CONS '|envArg| NIL)) + (CONS (CONS |auxfn| + (CONS |g1| (CONS '|envArg| NIL))) + NIL))) + ('T + (CONS |g1| + (CONS (CONS 'APPLX + (CONS (MKQ |auxfn|) + (CONS |g1| NIL))) + NIL))))) + (SPADLET |arg| (CAR |LETTMP#1|)) + (SPADLET |computeValue| (CADR |LETTMP#1|)) + (SPADLET |cacheName| (|mkCacheName| |nam|)) + (SPADLET |g2| (GENSYM)) (SPADLET |g3| (GENSYM)) + (SPADLET |secondPredPair| + (COND + ((NULL |argl|) (CONS |cacheName| NIL)) + ('T + (CONS (CONS 'SETQ + (CONS |g3| + (CONS + (CONS '|assocCircular| + (CONS |g1| + (CONS |cacheName| NIL))) + NIL))) + (CONS (CONS 'CDR (CONS |g3| NIL)) NIL))))) + (SPADLET |thirdPredPair| + (COND + ((NULL |argl|) + (CONS ''T + (CONS (CONS 'SETQ + (CONS |cacheName| + (CONS |computeValue| NIL))) + NIL))) + ('T + (CONS ''T + (CONS (CONS 'SETQ + (CONS |g2| + (CONS |computeValue| NIL))) + (CONS + (CONS 'SETQ + (CONS |g3| + (CONS + (CONS 'CAR + (CONS + (CONS 'SETQ + (CONS |cacheName| + (CONS + (CONS '|predCircular| + (CONS |cacheName| + (CONS |cacheCount| + NIL))) + NIL))) + NIL)) + NIL))) + (CONS + (CONS 'RPLACA + (CONS |g3| (CONS |g1| NIL))) + (CONS + (CONS 'RPLACD + (CONS |g3| (CONS |g2| NIL))) + (CONS |g2| NIL))))))))) + (SPADLET |codeBody| + (CONS 'PROG + (CONS (CONS |g2| (CONS |g3| NIL)) + (CONS + (CONS 'RETURN + (CONS + (CONS 'COND + (CONS |secondPredPair| + (CONS |thirdPredPair| NIL))) + NIL)) + NIL)))) + (SPADLET |lamex| + (CONS 'LAM (CONS |arg| (CONS |codeBody| NIL)))) + (SPADLET |mainFunction| (CONS |nam| (CONS |lamex| NIL))) + (SPADLET |computeFunction| + (CONS |auxfn| + (CONS (CONS 'LAMBDA + (CONS + (APPEND |argl| + (CONS '|envArg| NIL)) + (CONS |body| NIL))) + NIL))) + (|compileInteractive| |mainFunction|) + (|compileInteractive| |computeFunction|) + (SPADLET |cacheType| '|function|) + (SPADLET |cacheResetCode| + (CONS 'SETQ + (CONS |cacheName| + (CONS + (CONS '|mkCircularAlist| + (CONS |cacheCount| NIL)) + NIL)))) + (SPADLET |cacheCountCode| + (CONS '|countCircularAlist| + (CONS |cacheName| (CONS |cacheCount| NIL)))) + (SPADLET |cacheVector| + (|mkCacheVec| |op| |cacheName| |cacheType| + |cacheResetCode| |cacheCountCode|)) + (SPADLET |$e| + (|put| |nam| '|cacheInfo| |cacheVector| |$e|)) + (|eval| |cacheResetCode|) + (SETANDFILE |cacheName| (|mkCircularAlist| |cacheCount|)) + |nam|)))))))) + +;getCacheCount fn == +; n:= LASSOC(fn,$cacheAlist) => n +; $cacheCount + +;;; *** |getCacheCount| REDEFINED + +(DEFUN |getCacheCount| (|fn|) + (PROG (|n|) + (RETURN + (COND + ((SPADLET |n| (LASSOC |fn| |$cacheAlist|)) |n|) + ('T |$cacheCount|))))) + +;reportFunctionCacheAll(op,nam,argl,body) == +; sayKeyedMsg("S2IX0004",[op]) +; auxfn:= mkAuxiliaryName nam +; g1:= GENSYM() --argument or argument list +; [arg,computeValue] := +; null argl => [['envArg],[auxfn, 'envArg]] +; argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter +; [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list +; if null argl then g1:=nil +; cacheName:= mkCacheName nam +; g2:= GENSYM() --value computed by calling function +; secondPredPair:= [['SETQ,g2,['HGET,cacheName,g1]],g2] +; thirdPredPair:= ['(QUOTE T),['HPUT,cacheName,g1,computeValue]] +; codeBody:= ['PROG,[g2],['RETURN,['COND,secondPredPair,thirdPredPair]]] +; lamex:= ['LAM,arg,codeBody] +; mainFunction:= [nam,lamex] +; computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] +; compileInteractive mainFunction +; compileInteractive computeFunction +; cacheType:= 'hash_-table +; cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,''UEQUAL]] +; cacheCountCode:= ['hashCount,cacheName] +; cacheVector:= +; mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) +; $e:= put(nam,'cacheInfo, cacheVector,$e) +; eval cacheResetCode +; nam + +;;; *** |reportFunctionCacheAll| REDEFINED + +(DEFUN |reportFunctionCacheAll| (|op| |nam| |argl| |body|) + (PROG (|auxfn| |LETTMP#1| |arg| |computeValue| |g1| |cacheName| |g2| + |secondPredPair| |thirdPredPair| |codeBody| |lamex| + |mainFunction| |computeFunction| |cacheType| + |cacheResetCode| |cacheCountCode| |cacheVector|) + (RETURN + (PROGN + (|sayKeyedMsg| 'S2IX0004 (CONS |op| NIL)) + (SPADLET |auxfn| (|mkAuxiliaryName| |nam|)) + (SPADLET |g1| (GENSYM)) + (SPADLET |LETTMP#1| + (COND + ((NULL |argl|) + (CONS (CONS '|envArg| NIL) + (CONS (CONS |auxfn| (CONS '|envArg| NIL)) + NIL))) + ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL)) + (CONS (CONS |g1| (CONS '|envArg| NIL)) + (CONS (CONS |auxfn| + (CONS |g1| (CONS '|envArg| NIL))) + NIL))) + ('T + (CONS |g1| + (CONS (CONS 'APPLX + (CONS (MKQ |auxfn|) + (CONS |g1| NIL))) + NIL))))) + (SPADLET |arg| (CAR |LETTMP#1|)) + (SPADLET |computeValue| (CADR |LETTMP#1|)) + (COND ((NULL |argl|) (SPADLET |g1| NIL))) + (SPADLET |cacheName| (|mkCacheName| |nam|)) + (SPADLET |g2| (GENSYM)) + (SPADLET |secondPredPair| + (CONS (CONS 'SETQ + (CONS |g2| + (CONS + (CONS 'HGET + (CONS |cacheName| (CONS |g1| NIL))) + NIL))) + (CONS |g2| NIL))) + (SPADLET |thirdPredPair| + (CONS ''T + (CONS (CONS 'HPUT + (CONS |cacheName| + (CONS |g1| + (CONS |computeValue| NIL)))) + NIL))) + (SPADLET |codeBody| + (CONS 'PROG + (CONS (CONS |g2| NIL) + (CONS (CONS 'RETURN + (CONS + (CONS 'COND + (CONS |secondPredPair| + (CONS |thirdPredPair| NIL))) + NIL)) + NIL)))) + (SPADLET |lamex| + (CONS 'LAM (CONS |arg| (CONS |codeBody| NIL)))) + (SPADLET |mainFunction| (CONS |nam| (CONS |lamex| NIL))) + (SPADLET |computeFunction| + (CONS |auxfn| + (CONS (CONS 'LAMBDA + (CONS + (APPEND |argl| + (CONS '|envArg| NIL)) + (CONS |body| NIL))) + NIL))) + (|compileInteractive| |mainFunction|) + (|compileInteractive| |computeFunction|) + (SPADLET |cacheType| '|hash-table|) + (SPADLET |cacheResetCode| + (CONS 'SETQ + (CONS |cacheName| + (CONS (CONS 'MAKE-HASHTABLE + (CONS ''UEQUAL NIL)) + NIL)))) + (SPADLET |cacheCountCode| + (CONS '|hashCount| (CONS |cacheName| NIL))) + (SPADLET |cacheVector| + (|mkCacheVec| |op| |cacheName| |cacheType| + |cacheResetCode| |cacheCountCode|)) + (SPADLET |$e| (|put| |nam| '|cacheInfo| |cacheVector| |$e|)) + (|eval| |cacheResetCode|) + |nam|)))) + +;hashCount table == +; +/[ADD1 nodeCount HGET(table,key) for key in HKEYS table] + +;;; *** |hashCount| REDEFINED + +(DEFUN |hashCount| (|table|) + (PROG () + (RETURN + (SEQ (PROG (G166140) + (SPADLET G166140 0) + (RETURN + (DO ((G166145 (HKEYS |table|) (CDR G166145)) + (|key| NIL)) + ((OR (ATOM G166145) + (PROGN (SETQ |key| (CAR G166145)) NIL)) + G166140) + (SEQ (EXIT (SETQ G166140 + (PLUS G166140 + (ADD1 + (|nodeCount| + (HGET |table| |key|)))))))))))))) + +; +;mkCircularAlist n == +; l:= [[$failed,:$failed] for i in 1..n] +; RPLACD(LASTNODE l,l) + +;;; *** |mkCircularAlist| REDEFINED + +(DEFUN |mkCircularAlist| (|n|) + (PROG (|l|) + (RETURN + (SEQ (PROGN + (SPADLET |l| + (PROG (G166160) + (SPADLET G166160 NIL) + (RETURN + (DO ((|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| |n|) + (NREVERSE0 G166160)) + (SEQ (EXIT (SETQ G166160 + (CONS + (CONS |$failed| |$failed|) + G166160)))))))) + (RPLACD (LASTNODE |l|) |l|)))))) + +;countCircularAlist(cal,n) == +; +/[nodeCount x for x in cal for i in 1..n] + +;;; *** |countCircularAlist| REDEFINED + +(DEFUN |countCircularAlist| (|cal| |n|) + (PROG () + (RETURN + (SEQ (PROG (G166173) + (SPADLET G166173 0) + (RETURN + (DO ((G166179 |cal| (CDR G166179)) (|x| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G166179) + (PROGN (SETQ |x| (CAR G166179)) NIL) + (QSGREATERP |i| |n|)) + G166173) + (SEQ (EXIT (SETQ G166173 + (PLUS G166173 (|nodeCount| |x|)))))))))))) + +;predCircular(al,n) == +; for i in 1..QSSUB1 n repeat al:= QCDR al +; al + +;;; *** |predCircular| REDEFINED + +(DEFUN |predCircular| (|al| |n|) + (SEQ (PROGN + (DO ((G166194 (QSSUB1 |n|)) (|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| G166194) NIL) + (SEQ (EXIT (SPADLET |al| (QCDR |al|))))) + |al|))) + +;assocCircular(x,al) == --like ASSOC except that al is circular +; forwardPointer:= al +; val:= nil +; until EQ(forwardPointer,al) repeat +; EQUAL(CAAR forwardPointer,x) => return (val:= CAR forwardPointer) +; forwardPointer:= CDR forwardPointer +; val + +;;; *** |assocCircular| REDEFINED + +(DEFUN |assocCircular| (|x| |al|) + (PROG (|val| |forwardPointer|) + (RETURN + (SEQ (PROGN + (SPADLET |forwardPointer| |al|) + (SPADLET |val| NIL) + (DO ((G166207 NIL (EQ |forwardPointer| |al|))) + (G166207 NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL (CAAR |forwardPointer|) |x|) + (RETURN + (SPADLET |val| (CAR |forwardPointer|)))) + ('T + (SPADLET |forwardPointer| + (CDR |forwardPointer|))))))) + |val|))))) + +;compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) == +; k:= #initCode +; extraArgumentCode := +; extraArguments := [x for x in argl | x ^= sharpArg] => +; extraArguments is [x] => x +; ['LIST,:extraArguments] +; nil +; g:= GENSYM() +; gIndex:= GENSYM() +; gsList:= [GENSYM() for x in initCode] +; auxfn := mkAuxiliaryName(nam) +; $compiledOpNameList := [:$compiledOpNameList,auxfn] +; stateNam:= GENVAR() +; stateVar:= GENSYM() +; stateVal:= GENSYM() +; lastArg := INTERNL STRCONC('"#",STRINGIMAGE QSADD1 LENGTH argl) +; decomposeCode:= +; [['LET,gIndex,['ELT,lastArg,0]],:[['LET,g,['ELT,lastArg,i]] +; for g in gsList for i in 1..]] +; gsRev:= REVERSE gsList +; rotateCode:= [['LET,p,q] for p in gsRev for q in [:rest gsRev,g]] +; advanceCode:= ['LET,gIndex,['ADD1,gIndex]] +; +; newTripleCode := ['LIST,sharpArg,:gsList] +; newStateCode := +; null extraArguments => ['SETQ,stateNam,newTripleCode] +; ['HPUT,stateNam,extraArgumentCode,newTripleCode] +; +; computeFunction:= [auxfn,['LAM,cargl,cbody]] where +; cargl:= [:argl,lastArg] +; returnValue:= ['PROGN,newStateCode,first gsList] +; cbody:= +; endTest:= +; ['COND, [['EQL,sharpArg,gIndex],['RETURN,returnValue]]] +; newValueCode:= ['LET,g,SUBST(gIndex,sharpArg, +; EQSUBSTLIST(gsList,rest $TriangleVariableList,body))] +; ['PROGN,:decomposeCode, +; ['REPEAT,['WHILE,'T],['PROGN,endTest,advanceCode, +; newValueCode,:rotateCode]]] +; fromScratchInit:= +; [['LET,gIndex,n],:[['LET,g,x] for g in gsList for x in initCode]] +; continueInit:= +; [['LET,gIndex,['ELT,stateVar,0]], +; :[['LET,g,['ELT,stateVar,i]] for g in gsList for i in 1..]] +; mainFunction:= [nam,['LAM,margl,mbody]] where +; margl:= [:argl,'envArg] +; max:= GENSYM() +; tripleCode := ['CONS,n,['LIST,:initCode]] +; +; -- initialSetCode initializes the global variable if necessary and +; -- also binds "stateVar" to its current value +; initialSetCode := +; initialValueCode := +; extraArguments => ['MAKE_-HASHTABLE,''UEQUAL] +; tripleCode +; cacheResetCode := ['SETQ,stateNam,initialValueCode] +; ['COND,[['NULL,['AND,['BOUNDP,MKQ stateNam], _ +; ['PAIRP,stateNam]]], _ +; ['LET,stateVar,cacheResetCode]], _ +; [''T, ['LET,stateVar,stateNam]]] +; +; -- when there are extra arguments, initialResetCode resets "stateVar" +; -- to the hashtable entry for the extra arguments +; initialResetCode := +; null extraArguments => nil +; [['LET,stateVar,['OR, +; ['HGET,stateVar,extraArgumentCode], +; ['HPUT,stateVar,extraArgumentCode,tripleCode]]]] +; +; mbody := +; preset := [initialSetCode,:initialResetCode,['LET,max,['ELT,stateVar,0]]] +; phrase1:= [['AND,['LET,max,['ELT,stateVar,0]],['GE,sharpArg,max]], +; [auxfn,:argl,stateVar]] +; phrase2:= [['GT,sharpArg,['SETQ,max,['DIFFERENCE,max,k]]], +; ['ELT,stateVar,['QSADD1,['QSDIFFERENCE,k,['DIFFERENCE,sharpArg,max]]]]] +; phrase3:= [['GT,sharpArg,n],[auxfn,:argl,['LIST,n,:initCode]]] +; phrase4:= [['GT,sharpArg,n-k], +; ['ELT,['LIST,:initCode],['QSDIFFERENCE,n,sharpArg]]] +; phrase5:= ['(QUOTE T),['recurrenceError,MKQ op,sharpArg]] +; ['PROGN,:preset,['COND,phrase1,phrase2,phrase3,phrase4,phrase5]] +; sayKeyedMsg("S2IX0001",[op]) +; compileInteractive computeFunction +; compileInteractive mainFunction +; cacheType:= 'recurrence +; cacheCountCode:= ['nodeCount,stateNam] +; cacheVector:= mkCacheVec(op,stateNam,cacheType,cacheResetCode,cacheCountCode) +; $e:= put(nam,'cacheInfo, cacheVector,$e) +; nam + +;;; *** |compileRecurrenceRelation| REDEFINED + +(DEFUN |compileRecurrenceRelation| (|op| |nam| |argl| |junk| G166238) + (PROG (|body| |sharpArg| |n| |initCode| |k| |extraArguments| |x| + |extraArgumentCode| |g| |gIndex| |gsList| |auxfn| + |stateNam| |stateVar| |stateVal| |lastArg| + |decomposeCode| |gsRev| |rotateCode| |advanceCode| + |newTripleCode| |newStateCode| |cargl| |returnValue| + |endTest| |newValueCode| |cbody| |computeFunction| + |fromScratchInit| |continueInit| |margl| |max| + |tripleCode| |initialValueCode| |cacheResetCode| + |initialSetCode| |initialResetCode| |preset| |phrase1| + |phrase2| |phrase3| |phrase4| |phrase5| |mbody| + |mainFunction| |cacheType| |cacheCountCode| + |cacheVector|) + (RETURN + (SEQ (PROGN + (SPADLET |body| (CAR G166238)) + (SPADLET |sharpArg| (CADR G166238)) + (SPADLET |n| (CADDR G166238)) + (SPADLET |initCode| (CDDDR G166238)) + (SPADLET |k| (|#| |initCode|)) + (SPADLET |extraArgumentCode| + (COND + ((SPADLET |extraArguments| + (PROG (G166269) + (SPADLET G166269 NIL) + (RETURN + (DO + ((G166275 |argl| + (CDR G166275)) + (|x| NIL)) + ((OR (ATOM G166275) + (PROGN + (SETQ |x| (CAR G166275)) + NIL)) + (NREVERSE0 G166269)) + (SEQ + (EXIT + (COND + ((NEQUAL |x| |sharpArg|) + (SETQ G166269 + (CONS |x| G166269)))))))))) + (COND + ((AND (PAIRP |extraArguments|) + (EQ (QCDR |extraArguments|) NIL) + (PROGN + (SPADLET |x| + (QCAR |extraArguments|)) + 'T)) + |x|) + ('T (CONS 'LIST |extraArguments|)))) + ('T NIL))) + (SPADLET |g| (GENSYM)) + (SPADLET |gIndex| (GENSYM)) + (SPADLET |gsList| + (PROG (G166285) + (SPADLET G166285 NIL) + (RETURN + (DO ((G166290 |initCode| (CDR G166290)) + (|x| NIL)) + ((OR (ATOM G166290) + (PROGN + (SETQ |x| (CAR G166290)) + NIL)) + (NREVERSE0 G166285)) + (SEQ (EXIT (SETQ G166285 + (CONS (GENSYM) G166285)))))))) + (SPADLET |auxfn| (|mkAuxiliaryName| |nam|)) + (SPADLET |$compiledOpNameList| + (APPEND |$compiledOpNameList| (CONS |auxfn| NIL))) + (SPADLET |stateNam| (GENVAR)) + (SPADLET |stateVar| (GENSYM)) + (SPADLET |stateVal| (GENSYM)) + (SPADLET |lastArg| + (INTERNL (STRCONC (MAKESTRING "#") + (STRINGIMAGE + (QSADD1 (LENGTH |argl|)))))) + (SPADLET |decomposeCode| + (CONS (CONS 'LET + (CONS |gIndex| + (CONS + (CONS 'ELT + (CONS |lastArg| (CONS 0 NIL))) + NIL))) + (PROG (G166301) + (SPADLET G166301 NIL) + (RETURN + (DO ((G166307 |gsList| + (CDR G166307)) + (|g| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G166307) + (PROGN + (SETQ |g| (CAR G166307)) + NIL)) + (NREVERSE0 G166301)) + (SEQ (EXIT + (SETQ G166301 + (CONS + (CONS 'LET + (CONS |g| + (CONS + (CONS 'ELT + (CONS |lastArg| + (CONS |i| NIL))) + NIL))) + G166301))))))))) + (SPADLET |gsRev| (REVERSE |gsList|)) + (SPADLET |rotateCode| + (PROG (G166318) + (SPADLET G166318 NIL) + (RETURN + (DO ((G166324 |gsRev| (CDR G166324)) + (|p| NIL) + (G166325 + (APPEND (CDR |gsRev|) + (CONS |g| NIL)) + (CDR G166325)) + (|q| NIL)) + ((OR (ATOM G166324) + (PROGN + (SETQ |p| (CAR G166324)) + NIL) + (ATOM G166325) + (PROGN + (SETQ |q| (CAR G166325)) + NIL)) + (NREVERSE0 G166318)) + (SEQ (EXIT (SETQ G166318 + (CONS + (CONS 'LET + (CONS |p| (CONS |q| NIL))) + G166318)))))))) + (SPADLET |advanceCode| + (CONS 'LET + (CONS |gIndex| + (CONS (CONS 'ADD1 + (CONS |gIndex| NIL)) + NIL)))) + (SPADLET |newTripleCode| + (CONS 'LIST (CONS |sharpArg| |gsList|))) + (SPADLET |newStateCode| + (COND + ((NULL |extraArguments|) + (CONS 'SETQ + (CONS |stateNam| + (CONS |newTripleCode| NIL)))) + ('T + (CONS 'HPUT + (CONS |stateNam| + (CONS |extraArgumentCode| + (CONS |newTripleCode| NIL))))))) + (SPADLET |cargl| (APPEND |argl| (CONS |lastArg| NIL))) + (SPADLET |returnValue| + (CONS 'PROGN + (CONS |newStateCode| + (CONS (CAR |gsList|) NIL)))) + (SPADLET |cbody| + (PROGN + (SPADLET |endTest| + (CONS 'COND + (CONS + (CONS + (CONS 'EQL + (CONS |sharpArg| + (CONS |gIndex| NIL))) + (CONS + (CONS 'RETURN + (CONS |returnValue| NIL)) + NIL)) + NIL))) + (SPADLET |newValueCode| + (CONS 'LET + (CONS |g| + (CONS + (MSUBST |gIndex| |sharpArg| + (EQSUBSTLIST |gsList| + (CDR + |$TriangleVariableList|) + |body|)) + NIL)))) + (CONS 'PROGN + (APPEND |decomposeCode| + (CONS + (CONS 'REPEAT + (CONS + (CONS 'WHILE (CONS 'T NIL)) + (CONS + (CONS 'PROGN + (CONS |endTest| + (CONS |advanceCode| + (CONS |newValueCode| + |rotateCode|)))) + NIL))) + NIL))))) + (SPADLET |computeFunction| + (CONS |auxfn| + (CONS (CONS 'LAM + (CONS |cargl| + (CONS |cbody| NIL))) + NIL))) + (SPADLET |fromScratchInit| + (CONS (CONS 'LET (CONS |gIndex| (CONS |n| NIL))) + (PROG (G166339) + (SPADLET G166339 NIL) + (RETURN + (DO ((G166345 |gsList| + (CDR G166345)) + (|g| NIL) + (G166346 |initCode| + (CDR G166346)) + (|x| NIL)) + ((OR (ATOM G166345) + (PROGN + (SETQ |g| (CAR G166345)) + NIL) + (ATOM G166346) + (PROGN + (SETQ |x| (CAR G166346)) + NIL)) + (NREVERSE0 G166339)) + (SEQ (EXIT + (SETQ G166339 + (CONS + (CONS 'LET + (CONS |g| (CONS |x| NIL))) + G166339))))))))) + (SPADLET |continueInit| + (CONS (CONS 'LET + (CONS |gIndex| + (CONS + (CONS 'ELT + (CONS |stateVar| + (CONS 0 NIL))) + NIL))) + (PROG (G166360) + (SPADLET G166360 NIL) + (RETURN + (DO ((G166366 |gsList| + (CDR G166366)) + (|g| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G166366) + (PROGN + (SETQ |g| (CAR G166366)) + NIL)) + (NREVERSE0 G166360)) + (SEQ (EXIT + (SETQ G166360 + (CONS + (CONS 'LET + (CONS |g| + (CONS + (CONS 'ELT + (CONS |stateVar| + (CONS |i| NIL))) + NIL))) + G166360))))))))) + (SPADLET |margl| (APPEND |argl| (CONS '|envArg| NIL))) + (SPADLET |max| (GENSYM)) + (SPADLET |tripleCode| + (CONS 'CONS + (CONS |n| + (CONS (CONS 'LIST |initCode|) NIL)))) + (SPADLET |initialSetCode| + (PROGN + (SPADLET |initialValueCode| + (COND + (|extraArguments| + (CONS 'MAKE-HASHTABLE + (CONS ''UEQUAL NIL))) + ('T |tripleCode|))) + (SPADLET |cacheResetCode| + (CONS 'SETQ + (CONS |stateNam| + (CONS |initialValueCode| NIL)))) + (CONS 'COND + (CONS (CONS + (CONS 'NULL + (CONS + (CONS 'AND + (CONS + (CONS 'BOUNDP + (CONS (MKQ |stateNam|) NIL)) + (CONS + (CONS 'PAIRP + (CONS |stateNam| NIL)) + NIL))) + NIL)) + (CONS + (CONS 'LET + (CONS |stateVar| + (CONS |cacheResetCode| NIL))) + NIL)) + (CONS + (CONS ''T + (CONS + (CONS 'LET + (CONS |stateVar| + (CONS |stateNam| NIL))) + NIL)) + NIL))))) + (SPADLET |initialResetCode| + (COND + ((NULL |extraArguments|) NIL) + ('T + (CONS (CONS 'LET + (CONS |stateVar| + (CONS + (CONS 'OR + (CONS + (CONS 'HGET + (CONS |stateVar| + (CONS |extraArgumentCode| + NIL))) + (CONS + (CONS 'HPUT + (CONS |stateVar| + (CONS |extraArgumentCode| + (CONS |tripleCode| NIL)))) + NIL))) + NIL))) + NIL)))) + (SPADLET |mbody| + (PROGN + (SPADLET |preset| + (CONS |initialSetCode| + (APPEND |initialResetCode| + (CONS + (CONS 'LET + (CONS |max| + (CONS + (CONS 'ELT + (CONS |stateVar| + (CONS 0 NIL))) + NIL))) + NIL)))) + (SPADLET |phrase1| + (CONS (CONS 'AND + (CONS + (CONS 'LET + (CONS |max| + (CONS + (CONS 'ELT + (CONS |stateVar| + (CONS 0 NIL))) + NIL))) + (CONS + (CONS 'GE + (CONS |sharpArg| + (CONS |max| NIL))) + NIL))) + (CONS + (CONS |auxfn| + (APPEND |argl| + (CONS |stateVar| NIL))) + NIL))) + (SPADLET |phrase2| + (CONS (CONS 'GT + (CONS |sharpArg| + (CONS + (CONS 'SETQ + (CONS |max| + (CONS + (CONS 'DIFFERENCE + (CONS |max| + (CONS |k| NIL))) + NIL))) + NIL))) + (CONS + (CONS 'ELT + (CONS |stateVar| + (CONS + (CONS 'QSADD1 + (CONS + (CONS 'QSDIFFERENCE + (CONS |k| + (CONS + (CONS 'DIFFERENCE + (CONS |sharpArg| + (CONS |max| NIL))) + NIL))) + NIL)) + NIL))) + NIL))) + (SPADLET |phrase3| + (CONS (CONS 'GT + (CONS |sharpArg| + (CONS |n| NIL))) + (CONS + (CONS |auxfn| + (APPEND |argl| + (CONS + (CONS 'LIST + (CONS |n| |initCode|)) + NIL))) + NIL))) + (SPADLET |phrase4| + (CONS (CONS 'GT + (CONS |sharpArg| + (CONS (SPADDIFFERENCE |n| |k|) + NIL))) + (CONS + (CONS 'ELT + (CONS (CONS 'LIST |initCode|) + (CONS + (CONS 'QSDIFFERENCE + (CONS |n| + (CONS |sharpArg| NIL))) + NIL))) + NIL))) + (SPADLET |phrase5| + (CONS ''T + (CONS + (CONS '|recurrenceError| + (CONS (MKQ |op|) + (CONS |sharpArg| NIL))) + NIL))) + (CONS 'PROGN + (APPEND |preset| + (CONS + (CONS 'COND + (CONS |phrase1| + (CONS |phrase2| + (CONS |phrase3| + (CONS |phrase4| + (CONS |phrase5| NIL)))))) + NIL))))) + (SPADLET |mainFunction| + (CONS |nam| + (CONS (CONS 'LAM + (CONS |margl| + (CONS |mbody| NIL))) + NIL))) + (|sayKeyedMsg| 'S2IX0001 (CONS |op| NIL)) + (|compileInteractive| |computeFunction|) + (|compileInteractive| |mainFunction|) + (SPADLET |cacheType| '|recurrence|) + (SPADLET |cacheCountCode| + (CONS '|nodeCount| (CONS |stateNam| NIL))) + (SPADLET |cacheVector| + (|mkCacheVec| |op| |stateNam| |cacheType| + |cacheResetCode| |cacheCountCode|)) + (SPADLET |$e| + (|put| |nam| '|cacheInfo| |cacheVector| |$e|)) + |nam|))))) + +;nodeCount x == NUMOFNODES x + +;;; *** |nodeCount| REDEFINED + +(DEFUN |nodeCount| (|x|) (NUMOFNODES |x|)) + +;recurrenceError(op,arg) == throwKeyedMsg("S2IX0002",[op,arg]) + +;;; *** |recurrenceError| REDEFINED + +(DEFUN |recurrenceError| (|op| |arg|) + (|throwKeyedMsg| 'S2IX0002 (CONS |op| (CONS |arg| NIL)))) + +;mkCacheVec(op,nam,kind,resetCode,countCode) == +; [op,nam,kind,resetCode,countCode] + +;;; *** |mkCacheVec| REDEFINED + +(DEFUN |mkCacheVec| (|op| |nam| |kind| |resetCode| |countCode|) + (CONS |op| + (CONS |nam| + (CONS |kind| (CONS |resetCode| (CONS |countCode| NIL)))))) + +;-- reportCacheStore vl == +;-- sayMSG concat(centerString('"Name",22,'" ")," Kind #Cells") +;-- sayMSG concat(centerString('"----",22,'" ")," ---- ------") +;-- for x in vl repeat reportCacheStoreFor x +;-- +;-- op2String op == +;-- u:= linearFormatName op +;-- atom u => PNAME u +;-- "STRCONC"/u +;-- +;-- reportCacheStorePrint(op,kind,count) == +;-- ops:= op2String op +;-- opString:= centerString(ops,22,'" ") +;-- kindString:= centerString(PNAME kind,10,'" ") +;-- countString:= centerString(count,19,'" ") +;-- sayMSG concat(opString,kindString,countString) +;-- +;-- reportCacheStoreFor op == +;-- u:= getI(op,'localModemap) => +;-- for [['local,target,:.],[.,fn],:.] in u repeat +;-- [op1,cacheName,kind,.,countCode]:= getI(fn,'cacheInfo) or +;-- keyedSystemError("S2GE0016",['"reportCacheStoreFor", +;-- '"missing cache information vector"]) +;-- reportCacheStorePrint(op,kind,eval countCode) +;-- true +;-- u:= getI(op,"cache") => +;-- reportCacheStorePrint(op,'variable,nodeCount u) +;-- nil +; +;clearCache x == +; get(x,'localModemap,$e) or get(x,'mapBody,$e) => +; for [map,:sub] in $mapSubNameAlist repeat +; map=x => _/UNTRACE_,2(sub,NIL) +; $e:= putHist(x,'localModemap,nil,$e) +; $e:= putHist(x,'mapBody,nil,$e) +; $e:= putHist(x,'localVars,nil,$e) +; sayKeyedMsg("S2IX0007",[x]) + +;;; *** |clearCache| REDEFINED + +(DEFUN |clearCache| (|x|) + (PROG (|map| |sub|) + (RETURN + (SEQ (COND + ((OR (|get| |x| '|localModemap| |$e|) + (|get| |x| '|mapBody| |$e|)) + (EXIT (SEQ (DO ((G166449 |$mapSubNameAlist| + (CDR G166449)) + (G166440 NIL)) + ((OR (ATOM G166449) + (PROGN + (SETQ G166440 (CAR G166449)) + NIL) + (PROGN + (PROGN + (SPADLET |map| (CAR G166440)) + (SPADLET |sub| (CDR G166440)) + G166440) + NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |map| |x|) + (EXIT + (|/UNTRACE,2| |sub| NIL))))))) + (SPADLET |$e| + (|putHist| |x| '|localModemap| NIL + |$e|)) + (SPADLET |$e| + (|putHist| |x| '|mapBody| NIL |$e|)) + (SPADLET |$e| + (|putHist| |x| '|localVars| NIL |$e|)) + (|sayKeyedMsg| 'S2IX0007 (CONS |x| NIL)))))))))) + +;clearLocalModemaps x == +; u:= get(x,"localModemap",$e) => +; for sub in ASSOCRIGHT $mapSubNameAlist repeat +; _/UNTRACE_,2(sub,NIL) +; $e:= putHist(x,"localModemap",nil,$e) +; for mm in u repeat +; [.,fn,:.] := mm +; if def:= get(fn,'definition,$e) then +; $e:= putHist(x,'value,mkObj(def,$EmptyMode),$e) +; if cacheVec:= get(fn,'cacheInfo,$e) then +; SET(cacheVec.cacheName,NIL) +; -- now clear the property list of the identifier +; $e := addIntSymTabBinding(x,nil,$e) +; sayKeyedMsg("S2IX0007",[x]) + +;;; *** |clearLocalModemaps| REDEFINED + +(DEFUN |clearLocalModemaps| (|x|) + (PROG (|u| |fn| |def| |cacheVec|) + (RETURN + (SEQ (COND + ((SPADLET |u| (|get| |x| '|localModemap| |$e|)) + (EXIT (PROGN + (DO ((G166471 (ASSOCRIGHT |$mapSubNameAlist|) + (CDR G166471)) + (|sub| NIL)) + ((OR (ATOM G166471) + (PROGN + (SETQ |sub| (CAR G166471)) + NIL)) + NIL) + (SEQ (EXIT (|/UNTRACE,2| |sub| NIL)))) + (SPADLET |$e| + (|putHist| |x| '|localModemap| NIL |$e|)) + (DO ((G166484 |u| (CDR G166484)) (|mm| NIL)) + ((OR (ATOM G166484) + (PROGN (SETQ |mm| (CAR G166484)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |fn| (CADR |mm|)) + (COND + ((SPADLET |def| + (|get| |fn| '|definition| + |$e|)) + (SPADLET |$e| + (|putHist| |x| '|value| + (|mkObj| |def| |$EmptyMode|) + |$e|)))) + (COND + ((SPADLET |cacheVec| + (|get| |fn| '|cacheInfo| |$e|)) + (SET (CADR |cacheVec|) NIL))) + (SPADLET |$e| + (|addIntSymTabBinding| |x| NIL + |$e|)))))) + (|sayKeyedMsg| 'S2IX0007 (CONS |x| NIL)))))))))) + +;compileInteractive fn == +; if $InteractiveMode then startTimingProcess 'compilation +; --following not used for common lisp +; --removeUnnecessaryLastArguments CADR fn +; if $reportCompilation then +; sayBrightlyI bright '"Generated LISP code for function:" +; pp fn +; optfn := +; $InteractiveMode => [timedOptimization fn] +; [fn] +; result := compQuietly optfn +; if $InteractiveMode then stopTimingProcess 'compilation +; result + +;;; *** |compileInteractive| REDEFINED + +(DEFUN |compileInteractive| (|fn|) + (PROG (|optfn| |result|) + (RETURN + (PROGN + (COND + (|$InteractiveMode| (|startTimingProcess| '|compilation|))) + (COND + (|$reportCompilation| + (|sayBrightlyI| + (|bright| + (MAKESTRING "Generated LISP code for function:"))) + (|pp| |fn|))) + (SPADLET |optfn| + (COND + (|$InteractiveMode| + (CONS (|timedOptimization| |fn|) NIL)) + ('T (CONS |fn| NIL)))) + (SPADLET |result| (|compQuietly| |optfn|)) + (COND + (|$InteractiveMode| (|stopTimingProcess| '|compilation|))) + |result|)))) + +;clearAllSlams x == +; fn(x,nil) where +; fn(thoseToClear,thoseCleared) == +; for x in thoseToClear | not MEMQ(x,thoseCleared) repeat +; slamListName:= mkCacheName x +; SET(slamListName,nil) +; thoseCleared:= ADJOIN(x,thoseCleared) +; someMoreToClear:= +; setDifference(LASSOC(x,$functorDependencyAlist),[:thoseToClear,: +; thoseCleared]) +; NCONC(thoseToClear,someMoreToClear) + +;;; *** |clearAllSlams,fn| REDEFINED + +(DEFUN |clearAllSlams,fn| (|thoseToClear| |thoseCleared|) + (PROG (|slamListName| |someMoreToClear|) + (RETURN + (SEQ (DO ((G166513 |thoseToClear| (CDR G166513)) (|x| NIL)) + ((OR (ATOM G166513) + (PROGN (SETQ |x| (CAR G166513)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (MEMQ |x| |thoseCleared|)) + (SEQ (SPADLET |slamListName| + (|mkCacheName| |x|)) + (SET |slamListName| NIL) + (SPADLET |thoseCleared| + (ADJOIN |x| |thoseCleared|)) + (SPADLET |someMoreToClear| + (SETDIFFERENCE + (LASSOC |x| + |$functorDependencyAlist|) + (APPEND |thoseToClear| + |thoseCleared|))) + (EXIT (NCONC |thoseToClear| + |someMoreToClear|)))))))))))) + + +;;; *** |clearAllSlams| REDEFINED + +(DEFUN |clearAllSlams| (|x|) (|clearAllSlams,fn| |x| NIL)) + +;clearSlam("functor")== +; id:= mkCacheName functor +; SET(id,nil) + +;;; *** |clearSlam| REDEFINED + +(DEFUN |clearSlam,LAM| (|functor|) + (PROG (|id|) + (RETURN + (PROGN (SPADLET |id| (|mkCacheName| |functor|)) (SET |id| NIL))))) + +(DEFMACRO |clearSlam| (&WHOLE G166536 &REST G166537 &AUX G166535) + (DSETQ G166535 G166536) + (CONS '|clearSlam,LAM| (VMLISP::WRAP (CDR G166535) '(QUOTE)))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}