diff --git a/changelog b/changelog index 694be24..f37d3de 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,8 @@ +20090813 tpd src/axiom-website/patches.html 20090813.02.tpd.patch +20090813 tpd src/interp/Makefile move clammed.boot to clammed.lisp +20090813 tpd src/interp/debugsys.lisp change astr.clisp to clammed.lisp +20090813 tpd src/interp/clammed.lisp added, rewritten from clammed.boot +20090813 tpd src/interp/clammed.boot removed, rewritten to clammed.lisp 20090813 tpd src/axiom-website/patches.html 20090813.01.tpd.patch 20090813 tpd src/interp/Makefile move clam.boot to clam.lisp 20090813 tpd src/interp/debugsys.lisp change astr.clisp to clam.lisp diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 2b1549f..7d3c9a8 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1780,6 +1780,8 @@ cattable.lisp rewrite from boot to lisp
cformat.lisp rewrite from boot to lisp
20090813.01.tpd.patch clam.lisp rewrite from boot to lisp
+20090813.02.tpd.patch +clammed.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index adce7d1..daccb8f 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -417,7 +417,7 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/category.boot.dvi \ ${DOC}/c-doc.boot.dvi \ ${DOC}/cfuns.lisp.dvi \ - ${DOC}/clammed.boot.dvi ${DOC}/compat.boot.dvi \ + ${DOC}/compat.boot.dvi \ ${DOC}/compiler.boot.dvi \ ${DOC}/compress.boot.dvi \ ${DOC}/cparse.boot.dvi ${DOC}/cstream.boot.dvi \ @@ -2566,46 +2566,26 @@ ${OUT}/clam.lisp: ${IN}/clam.lisp.pamphlet @ -\subsection{clammed.boot \cite{62}} +\subsection{clammed.lisp} <>= -${OUT}/clammed.${O}: ${MID}/clammed.clisp - @ echo 225 making ${OUT}/clammed.${O} from ${MID}/clammed.clisp - @ (cd ${MID} ; \ +${OUT}/clammed.${O}: ${MID}/clammed.lisp + @ echo 136 making ${OUT}/clammed.${O} from ${MID}/clammed.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/clammed.clisp"' \ + echo '(progn (compile-file "${MID}/clammed.lisp"' \ ':output-file "${OUT}/clammed.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/clammed.clisp"' \ + echo '(progn (compile-file "${MID}/clammed.lisp"' \ ':output-file "${OUT}/clammed.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/clammed.clisp: ${IN}/clammed.boot.pamphlet - @ echo 226 making ${MID}/clammed.clisp from ${IN}/clammed.boot.pamphlet +<>= +${MID}/clammed.lisp: ${IN}/clammed.lisp.pamphlet + @ echo 137 making ${MID}/clammed.lisp from ${IN}/clammed.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/clammed.boot.pamphlet >clammed.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "clammed.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "clammed.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm clammed.boot) - -@ -<>= -${DOC}/clammed.boot.dvi: ${IN}/clammed.boot.pamphlet - @echo 227 making ${DOC}/clammed.boot.dvi \ - from ${IN}/clammed.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/clammed.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} clammed.boot ; \ - rm -f ${DOC}/clammed.boot.pamphlet ; \ - rm -f ${DOC}/clammed.boot.tex ; \ - rm -f ${DOC}/clammed.boot ) + ${TANGLE} ${IN}/clammed.lisp.pamphlet >clammed.lisp ) @ @@ -6816,8 +6796,7 @@ clean: <> <> -<> -<> +<> <> <> @@ -7390,7 +7369,6 @@ pp \bibitem{57} {\bf \$SPAD/src/interp/nag-s.boot.pamphlet} \bibitem{58} {\bf \$SPAD/src/interp/category.boot.pamphlet} \bibitem{60} {\bf \$SPAD/src/interp/c-doc.boot.pamphlet} -\bibitem{62} {\bf \$SPAD/src/interp/clammed.boot.pamphlet} \bibitem{63} {\bf \$SPAD/src/interp/compat.boot.pamphlet} \bibitem{64} {\bf \$SPAD/src/interp/compiler.boot.pamphlet} \bibitem{65} {\bf \$SPAD/src/interp/profile.boot.pamphlet} diff --git a/src/interp/clammed.boot.pamphlet b/src/interp/clammed.boot.pamphlet deleted file mode 100644 index a1eacde..0000000 --- a/src/interp/clammed.boot.pamphlet +++ /dev/null @@ -1,228 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp clammed.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. - -@ -<<*>>= -<> - ---% Functions on $clamList - --- These files are read in by the system so that they can be cached --- properly. Otherwise, must read in compiled versions and then --- recompile these, resulting in wasted BPI space. - -canCoerceFrom(mr,m) == - -- bind flag for recording/reporting instantiations - -- (see recordInstantiation) - $insideCanCoerceFrom: local := [mr,m] - canCoerceFrom0(mr,m) - -canCoerce(t1, t2) == - val := canCoerce1(t1, t2) => val - t1 is ['Variable, :.] => - newMode := getMinimalVarMode(t1, nil) - canCoerce1(t1, newMode) and canCoerce1(newMode, t2) - nil - -coerceConvertMmSelection(funName,m1,m2) == - -- calls selectMms with $Coerce=NIL and tests for required - -- target type. funName is either 'coerce or 'convert. - $declaredMode : local:= NIL - $reportBottomUpFlag : local:= NIL - l := selectMms1(funName,m2,[m1],[m1],NIL) - mmS := [x for x in l | x is [sig,:.] and hasCorrectTarget(m2,sig) and - sig is [dc,targ,oarg] and isEqualOrSubDomain(m1,oarg)] - mmS and CAR mmS - -hasFileProperty(p,id,abbrev) == hasFilePropertyNoCache(p,id,abbrev) - -isValidType form == - -- returns true IFF form is a type whose arguments satisfy the - -- predicate of the type constructor - -- Note that some forms are said to be invalid because they would - -- cause problems with the interpreter. Thus things like P P I - -- are not valid. - STRINGP form => true - IDENTP form => false - form in '((Mode) (Domain) (SubDomain (Domain))) => true - form is ['Record,:selectors] => - and/[isValidType type for [:.,type] in selectors] - form is ['Enumeration,:args] => - null (and/[IDENTP x for x in args]) => false - ((# args) = (# REMDUP args)) => true - false - form is ['Mapping,:mapargs] => - null mapargs => NIL - and/[isValidType type for type in mapargs] - form is ['Union,:args] => - -- check for a tagged union - args and first args is [":",:.] => - and/[isValidType type for [:.,type] in args] - null (and/[isValidType arg for arg in args]) => NIL - ((# args) = (# REMDUP args)) => true - sayKeyedMsg("S2IR0005",[form]) - NIL - - badDoubles := CONS($QuotientField, '(Gaussian Complex Polynomial Expression)) - form is [T1, [T2, :.]] and T1 = T2 and member(T1, badDoubles) => NIL - - form is [=$QuotientField,D] and not isPartialMode(D) and - ofCategory(D,'(Field)) => NIL - form is ['UnivariatePolynomial, x, ['UnivariatePolynomial, y, .]] and x=y => - NIL - form = '(Complex (AlgebraicNumber)) => NIL - form is ['Expression, ['Kernel, . ]] => NIL - form is [op,:argl] => - null constructor? op => nil - cosig := GETDATABASE(op, 'COSIG) - cosig and null rest cosig => -- niladic constructor - null argl => true - false - null (sig := getConstructorSignature form) => nil - [.,:cl] := sig - -- following line is needed to deal with mutable domains - if # cl ^= # argl and GENSYMP last argl then argl:= DROP(-1,argl) - # cl ^= # argl => nil - cl:= replaceSharps(cl,form) - and/[isValid for x in argl for c in cl] where isValid == - categoryForm?(c) => - evalCategory(x,MSUBSTQ(x,'_$,c)) and isValidType x - not GETDATABASE(opOf x,'CONSTRUCTORKIND) = 'domain - -selectMms1(op,tar,args1,args2,$Coerce) == - -- for new compiler/old world compatibility, sometimes have to look - -- for operations given two names. - - -- NEW COMPILER COMPATIBILITY ON - - op = "^" or op = "**" => - APPEND(selectMms2("**",tar,args1,args2,$Coerce), - selectMms2("^",tar,args1,args2,$Coerce)) - - -- NEW COMPILER COMPATIBILITY OFF - - selectMms2(op,tar,args1,args2,$Coerce) - - -resolveTT(t1,t2) == - -- resolves two types - -- this symmetric resolve looks for a type t to which both t1 and t2 - -- can be coerced - -- if resolveTT fails, the result will be NIL - startTimingProcess 'resolve - t1 := eqType t1 - t2 := eqType t2 - null (t := resolveTT1(t1,t2)) => - stopTimingProcess 'resolve - nil - isValidType (t := eqType t) => - stopTimingProcess 'resolve - t - stopTimingProcess 'resolve - nil - -isLegitimateMode(t,hasPolyMode,polyVarList) == - -- returns true IFF t is a valid type. i.e. if t has no repeated - -- variables, or two levels of Polynomial - null t => true -- a terminating condition with underDomainOf - t = $EmptyMode => true - STRINGP t => true - ATOM t => false - - badDoubles := CONS($QuotientField, '(Gaussian Complex Polynomial Expression)) - t is [T1, [T2, :.]] and T1 = T2 and member(T1, badDoubles) => NIL - - t is [=$QuotientField,D] and not isPartialMode(D) and - ofCategory(D,'(Field)) => NIL - t = '(Complex (AlgebraicNumber)) => NIL - - t := equiType t - vl := isPolynomialMode t => - if vl^='all then - var:= or/[(x in polyVarList => x;nil) for x in vl] => return false - listOfDuplicates vl => return false - polyVarList:= union(vl,polyVarList) - hasPolyMode => false - con := CAR t - poly? := (con = 'Polynomial or con = 'Expression) - isLegitimateMode(underDomainOf t,poly?,polyVarList) - - constructor? first t => - isLegitimateMode(underDomainOf t,hasPolyMode,polyVarList) => t - t is ['Mapping,:ml] => - null ml => NIL - -- first arg is target, which can be Void - null isLegitimateMode(first ml,nil,nil) => NIL - for m in rest ml repeat - m = $Void => - return NIL - null isLegitimateMode(m,nil,nil) => return NIL - true - t is ['Union,:ml] => - -- check for tagged union - ml and first ml is [":",:.] => isLegitimateRecordOrTaggedUnion ml - null (and/[isLegitimateMode(m,nil,nil) for m in ml]) => NIL - ((# ml) = (# REMDUP ml)) => true - NIL - t is ['Record,:r] => isLegitimateRecordOrTaggedUnion r - t is ['Enumeration,:r] => - null (and/[IDENTP x for x in r]) => false - ((# r) = (# REMDUP r)) => true - false - false - -underDomainOf t == - t = $RationalNumber => $Integer - not PAIRP t => NIL - d := deconstructT t - 1 = #d => NIL - u := getUnderModeOf(t) => u - last d - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/clammed.lisp.pamphlet b/src/interp/clammed.lisp.pamphlet new file mode 100644 index 0000000..edd0f0e --- /dev/null +++ b/src/interp/clammed.lisp.pamphlet @@ -0,0 +1,851 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp clammed.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(in-package "BOOT") + +;--% Functions on $clamList +;-- These files are read in by the system so that they can be cached +;-- properly. Otherwise, must read in compiled versions and then +;-- recompile these, resulting in wasted BPI space. +;canCoerceFrom(mr,m) == +; -- bind flag for recording/reporting instantiations +; -- (see recordInstantiation) +; $insideCanCoerceFrom: local := [mr,m] +; canCoerceFrom0(mr,m) + +(DEFUN |canCoerceFrom| (&REST #0=#:G166069 &AUX #1=#:G166064) + (DSETQ #1# #0#) + (PROG () + (RETURN + (PROG (#2=#:G166065) + (RETURN + (COND + ((SETQ #2# (HGET |canCoerceFrom;AL| #1#)) (|CDRwithIncrement| #2#)) + ((QUOTE T) + (CDR (HPUT |canCoerceFrom;AL| #1# + (CONS 1 (APPLY (|function| |canCoerceFrom;|) #1#))))))))))) + +(DEFUN |canCoerceFrom;| (|mr| |m|) + (PROG (|$insideCanCoerceFrom|) + (DECLARE (SPECIAL |$insideCanCoerceFrom|)) + (RETURN + (PROGN + (SPADLET |$insideCanCoerceFrom| (CONS |mr| (CONS |m| NIL))) + (|canCoerceFrom0| |mr| |m|))))) + +(PUT + (QUOTE |canCoerceFrom|) + (QUOTE |cacheInfo|) + (QUOTE (|canCoerceFrom| |canCoerceFrom;AL| |hash-tableWithCounts| + (SETQ |canCoerceFrom;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + (|hashCount| |canCoerceFrom;AL|)))) + +(SETQ |canCoerceFrom;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + +;canCoerce(t1, t2) == +; val := canCoerce1(t1, t2) => val +; t1 is ['Variable, :.] => +; newMode := getMinimalVarMode(t1, nil) +; canCoerce1(t1, newMode) and canCoerce1(newMode, t2) +; nil + +(DEFUN |canCoerce| (&REST #0=#:G166082 &AUX #1=#:G166077) + (DSETQ #1# #0#) + (PROG () + (RETURN + (PROG (#2=#:G166078) + (RETURN + (COND + ((SETQ #2# (HGET |canCoerce;AL| #1#)) (|CDRwithIncrement| #2#)) + ((QUOTE T) + (CDR (HPUT |canCoerce;AL| #1# + (CONS 1 (APPLY (|function| |canCoerce;|) #1#))))))))))) + +(DEFUN |canCoerce;| (|t1| |t2|) + (PROG (|val| |newMode|) + (RETURN + (COND + ((SPADLET |val| (|canCoerce1| |t1| |t2|)) |val|) + ((AND (PAIRP |t1|) (EQ (QCAR |t1|) (QUOTE |Variable|))) + (SPADLET |newMode| (|getMinimalVarMode| |t1| NIL)) + (AND (|canCoerce1| |t1| |newMode|) (|canCoerce1| |newMode| |t2|))) + ((QUOTE T) NIL))))) + +(PUT + (QUOTE |canCoerce|) + (QUOTE |cacheInfo|) + (QUOTE (|canCoerce| |canCoerce;AL| |hash-tableWithCounts| + (SETQ |canCoerce;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + (|hashCount| |canCoerce;AL|)))) + +(SETQ |canCoerce;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + +;coerceConvertMmSelection(funName,m1,m2) == +; -- calls selectMms with $Coerce=NIL and tests for required +; -- target type. funName is either 'coerce or 'convert. +; $declaredMode : local:= NIL +; $reportBottomUpFlag : local:= NIL +; l := selectMms1(funName,m2,[m1],[m1],NIL) +; mmS := [x for x in l | x is [sig,:.] and hasCorrectTarget(m2,sig) and +; sig is [dc,targ,oarg] and isEqualOrSubDomain(m1,oarg)] +; mmS and CAR mmS + +(DEFUN |coerceConvertMmSelection| (&REST #0=#:G166148 &AUX #1=#:G166143) + (DSETQ #1# #0#) + (PROG () + (RETURN + (PROG (#2=#:G166144) + (RETURN + (COND + ((SETQ #2# (HGET |coerceConvertMmSelection;AL| #1#)) + (|CDRwithIncrement| #2#)) + ((QUOTE T) + (CDR (HPUT |coerceConvertMmSelection;AL| #1# + (CONS 1 (APPLY (|function| |coerceConvertMmSelection;|) #1#))))))))))) + +(DEFUN |coerceConvertMmSelection;| (|funName| |m1| |m2|) + (PROG (|$declaredMode| |$reportBottomUpFlag| |l| |sig| |dc| |ISTMP#1| + |targ| |ISTMP#2| |oarg| |mmS|) + (DECLARE (SPECIAL |$declaredMode| |$reportBottomUpFlag|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$declaredMode| NIL) + (SPADLET |$reportBottomUpFlag| NIL) + (SPADLET |l| + (|selectMms1| |funName| |m2| (CONS |m1| NIL) (CONS |m1| NIL) NIL)) + (SPADLET |mmS| + (PROG (#0=#:G166113) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166119 |l| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((AND + (PAIRP |x|) + (PROGN (SPADLET |sig| (QCAR |x|)) (QUOTE T)) + (|hasCorrectTarget| |m2| |sig|) + (PAIRP |sig|) + (PROGN + (SPADLET |dc| (QCAR |sig|)) + (SPADLET |ISTMP#1| (QCDR |sig|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |targ| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |oarg| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (|isEqualOrSubDomain| |m1| |oarg|)) + (SETQ #0# (CONS |x| #0#)))))))))) + (AND |mmS| (CAR |mmS|))))))) + +(PUT + (QUOTE |coerceConvertMmSelection|) + (QUOTE |cacheInfo|) + (QUOTE (|coerceConvertMmSelection| + |coerceConvertMmSelection;AL| + |hash-tableWithCounts| + (SETQ |coerceConvertMmSelection;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + (|hashCount| |coerceConvertMmSelection;AL|)))) + +(SETQ |coerceConvertMmSelection;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + +;hasFileProperty(p,id,abbrev) == hasFilePropertyNoCache(p,id,abbrev) + +(DEFUN |hasFileProperty| (&REST #0=#:G166157 &AUX #1=#:G166152) + (DSETQ #1# #0#) + (PROG () + (RETURN + (PROG (#2=#:G166153) + (RETURN + (COND + ((SETQ #2# (HGET |hasFileProperty;AL| #1#)) (|CDRwithIncrement| #2#)) + ((QUOTE T) + (CDR (HPUT |hasFileProperty;AL| #1# + (CONS 1 (APPLY (|function| |hasFileProperty;|) #1#))))))))))) + +(DEFUN |hasFileProperty;| (|p| |id| |abbrev|) + (|hasFilePropertyNoCache| |p| |id| |abbrev|)) + +(PUT + (QUOTE |hasFileProperty|) + (QUOTE |cacheInfo|) + (QUOTE (|hasFileProperty| + |hasFileProperty;AL| + |hash-tableWithCounts| + (SETQ |hasFileProperty;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + (|hashCount| |hasFileProperty;AL|)))) + +(SETQ |hasFileProperty;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + +;isValidType form == +; -- returns true IFF form is a type whose arguments satisfy the +; -- predicate of the type constructor +; -- Note that some forms are said to be invalid because they would +; -- cause problems with the interpreter. Thus things like P P I +; -- are not valid. +; STRINGP form => true +; IDENTP form => false +; form in '((Mode) (Domain) (SubDomain (Domain))) => true +; form is ['Record,:selectors] => +; and/[isValidType type for [:.,type] in selectors] +; form is ['Enumeration,:args] => +; null (and/[IDENTP x for x in args]) => false +; ((# args) = (# REMDUP args)) => true +; false +; form is ['Mapping,:mapargs] => +; null mapargs => NIL +; and/[isValidType type for type in mapargs] +; form is ['Union,:args] => +; -- check for a tagged union +; args and first args is [":",:.] => +; and/[isValidType type for [:.,type] in args] +; null (and/[isValidType arg for arg in args]) => NIL +; ((# args) = (# REMDUP args)) => true +; sayKeyedMsg("S2IR0005",[form]) +; NIL +; badDoubles := CONS($QuotientField, '(Gaussian Complex Polynomial Expression)) +; form is [T1, [T2, :.]] and T1 = T2 and member(T1, badDoubles) => NIL +; form is [=$QuotientField,D] and not isPartialMode(D) and +; ofCategory(D,'(Field)) => NIL +; form is ['UnivariatePolynomial, x, ['UnivariatePolynomial, y, .]] and x=y => +; NIL +; form = '(Complex (AlgebraicNumber)) => NIL +; form is ['Expression, ['Kernel, . ]] => NIL +; form is [op,:argl] => +; null constructor? op => nil +; cosig := GETDATABASE(op, 'COSIG) +; cosig and null rest cosig => -- niladic constructor +; null argl => true +; false +; null (sig := getConstructorSignature form) => nil +; [.,:cl] := sig +; -- following line is needed to deal with mutable domains +; if # cl ^= # argl and GENSYMP last argl then argl:= DROP(-1,argl) +; # cl ^= # argl => nil +; cl:= replaceSharps(cl,form) +; and/[isValid for x in argl for c in cl] where isValid == +; categoryForm?(c) => +; evalCategory(x,MSUBSTQ(x,'_$,c)) and isValidType x +; not GETDATABASE(opOf x,'CONSTRUCTORKIND) = 'domain + +(DEFUN |isValidType| (#0=#:G166397) + (PROG () + (RETURN + (PROG (#1=#:G166398) + (RETURN + (COND + ((SETQ #1# (HGET |isValidType;AL| #0#)) (|CDRwithIncrement| #1#)) + ((QUOTE T) + (CDR (HPUT |isValidType;AL| #0# (CONS 1 (|isValidType;| #0#))))))))))) + +(DEFUN |isValidType;| (|form|) + (PROG (|selectors| |mapargs| |args| |LETTMP#1| |type| |badDoubles| T1 T2 D + |x| |ISTMP#4| |y| |ISTMP#5| |ISTMP#1| |ISTMP#2| |ISTMP#3| |op| + |cosig| |sig| |argl| |cl|) + (RETURN + (SEQ + (COND + ((STRINGP |form|) (QUOTE T)) + ((IDENTP |form|) NIL) + ((|member| |form| (QUOTE ((|Mode|) (|Domain|) (|SubDomain| (|Domain|))))) + (QUOTE T)) + ((AND (PAIRP |form|) + (EQ (QCAR |form|) (QUOTE |Record|)) + (PROGN (SPADLET |selectors| (QCDR |form|)) (QUOTE T))) + (PROG (#0=#:G166262) + (SPADLET #0# #1=(QUOTE T)) + (RETURN + (DO ((#2=#:G166269 NIL (NULL #0#)) + (#3=#:G166270 |selectors| (CDR #3#)) + (#4=#:G166158 NIL)) + ((OR #2# + (ATOM #3#) + (PROGN (SETQ #4# (CAR #3#)) NIL) + (PROGN + (PROGN + (SPADLET |LETTMP#1| (REVERSE #4#)) + (SPADLET |type| (CAR |LETTMP#1|)) #4#) + NIL)) + #0#) + (SEQ (EXIT (SETQ #0# (AND #0# (|isValidType| |type|))))))))) + ((AND (PAIRP |form|) + (EQ (QCAR |form|) (QUOTE |Enumeration|)) + (PROGN (SPADLET |args| (QCDR |form|)) (QUOTE T))) + (COND + ((NULL + (PROG (#5=#:G166278) + (SPADLET #5# #1#) + (RETURN + (DO ((#6=#:G166284 NIL (NULL #5#)) + (#7=#:G166285 |args| (CDR #7#)) + (|x| NIL)) + ((OR #6# (ATOM #7#) (PROGN (SETQ |x| (CAR #7#)) NIL)) #5#) + (SEQ (EXIT (SETQ #5# (AND #5# (IDENTP |x|))))))))) + NIL) + ((BOOT-EQUAL (|#| |args|) (|#| (REMDUP |args|))) (QUOTE T)) + ((QUOTE T) NIL))) + ((AND (PAIRP |form|) + (EQ (QCAR |form|) (QUOTE |Mapping|)) + (PROGN (SPADLET |mapargs| (QCDR |form|)) (QUOTE T))) + (COND + ((NULL |mapargs|) NIL) + ((QUOTE T) + (PROG (#8=#:G166292) + (SPADLET #8# #1#) + (RETURN + (DO ((#9=#:G166298 NIL (NULL #8#)) + (#10=#:G166299 |mapargs| (CDR #10#)) + (|type| NIL)) + ((OR #9# (ATOM #10#) (PROGN (SETQ |type| (CAR #10#)) NIL)) #8#) + (SEQ (EXIT (SETQ #8# (AND #8# (|isValidType| |type|))))))))))) + ((AND (PAIRP |form|) + (EQ (QCAR |form|) (QUOTE |Union|)) + (PROGN (SPADLET |args| (QCDR |form|)) (QUOTE T))) + (COND + ((AND |args| + (PROGN + (SPADLET |ISTMP#1| (CAR |args|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE |:|))))) + (PROG (#11=#:G166306) + (SPADLET #11# #1#) + (RETURN + (DO ((#12=#:G166313 NIL (NULL #11#)) + (#13=#:G166314 |args| (CDR #13#)) + (#14=#:G166166 NIL)) + ((OR #12# + (ATOM #13#) + (PROGN (SETQ #14# (CAR #13#)) NIL) + (PROGN + (PROGN + (SPADLET |LETTMP#1| (REVERSE #14#)) + (SPADLET |type| (CAR |LETTMP#1|)) + #14#) + NIL)) + #11#) + (SEQ (EXIT (SETQ #11# (AND #11# (|isValidType| |type|))))))))) + ((NULL + (PROG (#15=#:G166322) + (SPADLET #15# #1#) + (RETURN + (DO ((#16=#:G166328 NIL (NULL #15#)) + (#17=#:G166329 |args| (CDR #17#)) + (|arg| NIL)) + ((OR #16# + (ATOM #17#) + (PROGN (SETQ |arg| (CAR #17#)) NIL)) + #15#) + (SEQ (EXIT (SETQ #15# (AND #15# (|isValidType| |arg|))))))))) + NIL) + ((BOOT-EQUAL (|#| |args|) (|#| (REMDUP |args|))) (QUOTE T)) + ((QUOTE T) (|sayKeyedMsg| (QUOTE S2IR0005) (CONS |form| NIL)) NIL))) + ((QUOTE T) + (SPADLET |badDoubles| + (CONS |$QuotientField| + (QUOTE (|Gaussian| |Complex| |Polynomial| |Expression|)))) + (COND + ((AND (PAIRP |form|) + (PROGN + (SPADLET T1 (QCAR |form|)) + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET T2 (QCAR |ISTMP#2|)) + (QUOTE T)))))) + (BOOT-EQUAL T1 T2) + (|member| T1 |badDoubles|)) + NIL) + ((AND (PAIRP |form|) + (EQUAL (QCAR |form|) |$QuotientField|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T)))) + (NULL (|isPartialMode| D)) (|ofCategory| D (QUOTE (|Field|)))) + NIL) + ((AND (PAIRP |form|) + (EQ (QCAR |form|) (QUOTE |UnivariatePolynomial|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) + (QUOTE |UnivariatePolynomial|)) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#4|)) + (SPADLET |ISTMP#5| (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL))))))))))) + (BOOT-EQUAL |x| |y|)) + NIL) + ((BOOT-EQUAL |form| (QUOTE (|Complex| (|AlgebraicNumber|)))) + NIL) + ((AND (PAIRP |form|) + (EQ (QCAR |form|) (QUOTE |Expression|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE |Kernel|)) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) (EQ (QCDR |ISTMP#3|) NIL)))))))) + NIL) + ((AND (PAIRP |form|) + (PROGN + (SPADLET |op| (QCAR |form|)) + (SPADLET |argl| (QCDR |form|)) + (QUOTE T))) + (COND + ((NULL (|constructor?| |op|)) NIL) + ((QUOTE T) + (SPADLET |cosig| (GETDATABASE |op| (QUOTE COSIG))) + (COND + ((AND |cosig| (NULL (CDR |cosig|))) + (COND ((NULL |argl|) (QUOTE T)) ((QUOTE T) NIL))) + ((NULL (SPADLET |sig| (|getConstructorSignature| |form|))) NIL) + ((QUOTE T) + (SPADLET |cl| (CDR |sig|)) + (COND + ((AND (NEQUAL (|#| |cl|) (|#| |argl|)) (GENSYMP (|last| |argl|))) + (SPADLET |argl| (DROP (SPADDIFFERENCE 1) |argl|)))) + (COND + ((NEQUAL (|#| |cl|) (|#| |argl|)) NIL) + ((QUOTE T) + (SPADLET |cl| (|replaceSharps| |cl| |form|)) + (PROG (#18=#:G166336) + (SPADLET #18# #1#) + (RETURN + (DO ((#19=#:G166343 NIL (NULL #18#)) + (#20=#:G166344 |argl| (CDR #20#)) + (|x| NIL) + (#21=#:G166345 |cl| (CDR #21#)) (|c| NIL)) + ((OR #19# + (ATOM #20#) + (PROGN (SETQ |x| (CAR #20#)) NIL) + (ATOM #21#) + (PROGN (SETQ |c| (CAR #21#)) NIL)) + #18#) + (SEQ + (EXIT + (SETQ #18# + (AND #18# + (COND + ((|categoryForm?| |c|) + (AND + (|evalCategory| |x| (MSUBSTQ |x| (QUOTE $) |c|)) + (|isValidType| |x|))) + ((QUOTE T) + (NULL + (BOOT-EQUAL + (GETDATABASE (|opOf| |x|) 'CONSTRUCTORKIND) + (QUOTE |domain|)))))))))))))))))))))))))) + +(PUT + (QUOTE |isValidType|) + (QUOTE |cacheInfo|) + (QUOTE (|isValidType| |isValidType;AL| |hash-tableWithCounts| + (SETQ |isValidType;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + (|hashCount| |isValidType;AL|)))) + +(SETQ |isValidType;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + +;selectMms1(op,tar,args1,args2,$Coerce) == +; -- for new compiler/old world compatibility, sometimes have to look +; -- for operations given two names. +; -- NEW COMPILER COMPATIBILITY ON +; op = "^" or op = "**" => +; APPEND(selectMms2("**",tar,args1,args2,$Coerce), +; selectMms2("^",tar,args1,args2,$Coerce)) +; -- NEW COMPILER COMPATIBILITY OFF +; selectMms2(op,tar,args1,args2,$Coerce) + +(DEFUN |selectMms1| (&REST #0=#:G166411 &AUX #1=#:G166406) + (DSETQ #1# #0#) + (PROG NIL + (RETURN + (PROG (#2=#:G166407) + (RETURN + (COND + ((SETQ #2# (HGET |selectMms1;AL| #1#)) (|CDRwithIncrement| #2#)) + ((QUOTE T) + (CDR (HPUT |selectMms1;AL| #1# + (CONS 1 (APPLY (|function| |selectMms1;|) #1#))))))))))) + +(DEFUN |selectMms1;| (|op| |tar| |args1| |args2| |$Coerce|) + (DECLARE (SPECIAL |$Coerce|)) + (COND + ((OR (BOOT-EQUAL |op| (QUOTE ^)) (BOOT-EQUAL |op| (QUOTE **))) + (APPEND + (|selectMms2| (QUOTE **) |tar| |args1| |args2| |$Coerce|) + (|selectMms2| (QUOTE ^) |tar| |args1| |args2| |$Coerce|))) + ((QUOTE T) + (|selectMms2| |op| |tar| |args1| |args2| |$Coerce|)))) + +(PUT + (QUOTE |selectMms1|) + (QUOTE |cacheInfo|) + (QUOTE (|selectMms1| |selectMms1;AL| |hash-tableWithCounts| + (SETQ |selectMms1;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + (|hashCount| |selectMms1;AL|)))) + +(SETQ |selectMms1;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + +;resolveTT(t1,t2) == +; -- resolves two types +; -- this symmetric resolve looks for a type t to which both t1 and t2 +; -- can be coerced +; -- if resolveTT fails, the result will be NIL +; startTimingProcess 'resolve +; t1 := eqType t1 +; t2 := eqType t2 +; null (t := resolveTT1(t1,t2)) => +; stopTimingProcess 'resolve +; nil +; isValidType (t := eqType t) => +; stopTimingProcess 'resolve +; t +; stopTimingProcess 'resolve +; nil + +(DEFUN |resolveTT| (&REST #0=#:G166428 &AUX #1=#:G166423) + (DSETQ #1# #0#) + (PROG NIL + (RETURN + (PROG (#2=#:G166424) + (RETURN + (COND + ((SETQ #2# (HGET |resolveTT;AL| #1#)) (|CDRwithIncrement| #2#)) + ((QUOTE T) + (CDR (HPUT |resolveTT;AL| #1# + (CONS 1 (APPLY (|function| |resolveTT;|) #1#))))))))))) + +(DEFUN |resolveTT;| (|t1| |t2|) + (PROG (|t|) + (RETURN + (PROGN + (|startTimingProcess| (QUOTE |resolve|)) + (SPADLET |t1| (|eqType| |t1|)) + (SPADLET |t2| (|eqType| |t2|)) + (COND + ((NULL (SPADLET |t| (|resolveTT1| |t1| |t2|))) + (|stopTimingProcess| (QUOTE |resolve|)) NIL) + ((|isValidType| (SPADLET |t| (|eqType| |t|))) + (|stopTimingProcess| (QUOTE |resolve|)) |t|) + ((QUOTE T) + (|stopTimingProcess| (QUOTE |resolve|)) NIL)))))) + +(PUT + (QUOTE |resolveTT|) + (QUOTE |cacheInfo|) + (QUOTE (|resolveTT| |resolveTT;AL| |hash-tableWithCounts| + (SETQ |resolveTT;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + (|hashCount| |resolveTT;AL|)))) + +(SETQ |resolveTT;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + +;isLegitimateMode(t,hasPolyMode,polyVarList) == +; -- returns true IFF t is a valid type. i.e. if t has no repeated +; -- variables, or two levels of Polynomial +; null t => true -- a terminating condition with underDomainOf +; t = $EmptyMode => true +; STRINGP t => true +; ATOM t => false +; badDoubles := CONS($QuotientField, '(Gaussian Complex Polynomial Expression)) +; t is [T1, [T2, :.]] and T1 = T2 and member(T1, badDoubles) => NIL +; t is [=$QuotientField,D] and not isPartialMode(D) and +; ofCategory(D,'(Field)) => NIL +; t = '(Complex (AlgebraicNumber)) => NIL +; t := equiType t +; vl := isPolynomialMode t => +; if vl^='all then +; var:= or/[(x in polyVarList => x;nil) for x in vl] => return false +; listOfDuplicates vl => return false +; polyVarList:= union(vl,polyVarList) +; hasPolyMode => false +; con := CAR t +; poly? := (con = 'Polynomial or con = 'Expression) +; isLegitimateMode(underDomainOf t,poly?,polyVarList) +; constructor? first t => +; isLegitimateMode(underDomainOf t,hasPolyMode,polyVarList) => t +; t is ['Mapping,:ml] => +; null ml => NIL +; -- first arg is target, which can be Void +; null isLegitimateMode(first ml,nil,nil) => NIL +; for m in rest ml repeat +; m = $Void => +; return NIL +; null isLegitimateMode(m,nil,nil) => return NIL +; true +; t is ['Union,:ml] => +; -- check for tagged union +; ml and first ml is [":",:.] => isLegitimateRecordOrTaggedUnion ml +; null (and/[isLegitimateMode(m,nil,nil) for m in ml]) => NIL +; ((# ml) = (# REMDUP ml)) => true +; NIL +; t is ['Record,:r] => isLegitimateRecordOrTaggedUnion r +; t is ['Enumeration,:r] => +; null (and/[IDENTP x for x in r]) => false +; ((# r) = (# REMDUP r)) => true +; false +; false + +(DEFUN |isLegitimateMode| (&REST #0=#:G166540 &AUX #1=#:G166535) + (DSETQ #1# #0#) + (PROG NIL + (RETURN + (PROG (#2=#:G166536) + (RETURN + (COND + ((SETQ #2# (HGET |isLegitimateMode;AL| #1#)) (|CDRwithIncrement| #2#)) + ((QUOTE T) + (CDR (HPUT |isLegitimateMode;AL| #1# + (CONS 1 (APPLY (|function| |isLegitimateMode;|) #1#))))))))))) + +(DEFUN |isLegitimateMode;| (|t| |hasPolyMode| |polyVarList|) + (PROG (|badDoubles| T1 |ISTMP#2| T2 D |vl| |var| |con| |poly?| + |ml| |ISTMP#1| |r|) + (RETURN + (SEQ + (COND + ((NULL |t|) (QUOTE T)) + ((BOOT-EQUAL |t| |$EmptyMode|) (QUOTE T)) + ((STRINGP |t|) (QUOTE T)) + ((ATOM |t|) NIL) + ((QUOTE T) + (SPADLET |badDoubles| + (CONS |$QuotientField| + (QUOTE (|Gaussian| |Complex| |Polynomial| |Expression|)))) + (COND + ((AND (PAIRP |t|) + (PROGN + (SPADLET T1 (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN (SPADLET T2 (QCAR |ISTMP#2|)) (QUOTE T)))))) + (BOOT-EQUAL T1 T2) + (|member| T1 |badDoubles|)) + NIL) + ((AND (PAIRP |t|) + (EQUAL (QCAR |t|) |$QuotientField|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T)))) + (NULL (|isPartialMode| D)) + (|ofCategory| D (QUOTE (|Field|)))) + NIL) + ((BOOT-EQUAL |t| (QUOTE (|Complex| (|AlgebraicNumber|)))) + NIL) + ((QUOTE T) + (SPADLET |t| (|equiType| |t|)) + (SEQ + (COND + ((SPADLET |vl| (|isPolynomialMode| |t|)) + (PROGN + (COND + ((NEQUAL |vl| (QUOTE |all|)) + (COND + ((SPADLET |var| + (PROG (#0=#:G166460) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166466 NIL #0#) + (#2=#:G166467 |vl| (CDR #2#)) + (|x| NIL)) + ((OR #1# + (ATOM #2#) + (PROGN (SETQ |x| (CAR #2#)) NIL)) + #0#) + (SEQ + (EXIT + (SETQ #0# + (OR #0# + (COND + ((|member| |x| |polyVarList|) |x|) + ((QUOTE T) NIL)))))))))) + (RETURN NIL)) + ((|listOfDuplicates| |vl|) + (RETURN NIL)) + ((QUOTE T) + (SPADLET |polyVarList| (|union| |vl| |polyVarList|)))))) + (COND + (|hasPolyMode| NIL) + ((QUOTE T) + (SPADLET |con| (CAR |t|)) + (SPADLET |poly?| + (OR + (BOOT-EQUAL |con| (QUOTE |Polynomial|)) + (BOOT-EQUAL |con| (QUOTE |Expression|)))) + (|isLegitimateMode| + (|underDomainOf| |t|) |poly?| |polyVarList|))))) + ((|constructor?| (CAR |t|)) + (COND + ((|isLegitimateMode| + (|underDomainOf| |t|) + |hasPolyMode| + |polyVarList|) + (EXIT |t|)))) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |Mapping|)) + (PROGN (SPADLET |ml| (QCDR |t|)) (QUOTE T))) + (COND + ((NULL |ml|) NIL) + ((NULL (|isLegitimateMode| (CAR |ml|) NIL NIL)) NIL) + ((QUOTE T) + (DO ((#3=#:G166477 (CDR |ml|) (CDR #3#)) (|m| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |m| (CAR #3#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |m| |$Void|) (RETURN NIL)) + ((NULL (|isLegitimateMode| |m| NIL NIL)) (RETURN NIL)))))) + (QUOTE T)))) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |Union|)) + (PROGN (SPADLET |ml| (QCDR |t|)) (QUOTE T))) + (COND + ((AND |ml| + (PROGN + (SPADLET |ISTMP#1| (CAR |ml|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE |:|))))) + (|isLegitimateRecordOrTaggedUnion| |ml|)) + ((NULL + (PROG (#4=#:G166483) + (SPADLET #4# #5=(QUOTE T)) + (RETURN + (DO ((#6=#:G166489 NIL (NULL #4#)) + (#7=#:G166490 |ml| (CDR #7#)) + (|m| NIL)) + ((OR #6# (ATOM #7#) (PROGN (SETQ |m| (CAR #7#)) NIL)) + #4#) + (SEQ + (EXIT + (SETQ #4# (AND #4# (|isLegitimateMode| |m| NIL NIL))))))))) + NIL) + ((BOOT-EQUAL (|#| |ml|) (|#| (REMDUP |ml|))) + (QUOTE T)) + ((QUOTE T) + NIL))) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |Record|)) + (PROGN (SPADLET |r| (QCDR |t|)) (QUOTE T))) + (|isLegitimateRecordOrTaggedUnion| |r|)) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |Enumeration|)) + (PROGN (SPADLET |r| (QCDR |t|)) (QUOTE T))) + (COND + ((NULL + (PROG (#8=#:G166497) + (SPADLET #8# #5#) + (RETURN + (DO ((#9=#:G166503 NIL (NULL #8#)) + (#10=#:G166504 |r| (CDR #10#)) + (|x| NIL)) + ((OR #9# + (ATOM #10#) + (PROGN (SETQ |x| (CAR #10#)) NIL)) + #8#) + (SEQ (EXIT (SETQ #8# (AND #8# (IDENTP |x|))))))))) + NIL) + ((BOOT-EQUAL (|#| |r|) (|#| (REMDUP |r|))) (QUOTE T)) + ((QUOTE T) NIL))) + ((QUOTE T) NIL))))))))))) + +(PUT + (QUOTE |isLegitimateMode|) + (QUOTE |cacheInfo|) + (QUOTE (|isLegitimateMode| + |isLegitimateMode;AL| + |hash-tableWithCounts| + (SETQ |isLegitimateMode;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + (|hashCount| |isLegitimateMode;AL|)))) + +(SETQ |isLegitimateMode;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + +;underDomainOf t == +; t = $RationalNumber => $Integer +; not PAIRP t => NIL +; d := deconstructT t +; 1 = #d => NIL +; u := getUnderModeOf(t) => u +; last d + +(DEFUN |underDomainOf| (#0=#:G166547) + (PROG NIL + (RETURN + (PROG (#1=#:G166548) + (RETURN + (COND + ((SETQ #1# (HGET |underDomainOf;AL| #0#)) (|CDRwithIncrement| #1#)) + ((QUOTE T) + (CDR + (HPUT |underDomainOf;AL| #0# (CONS 1 (|underDomainOf;| #0#))))))))))) + +(DEFUN |underDomainOf;| (|t|) + (PROG (|d| |u|) + (RETURN + (COND + ((BOOT-EQUAL |t| |$RationalNumber|) |$Integer|) + ((NULL (PAIRP |t|)) NIL) + ((QUOTE T) + (SPADLET |d| (|deconstructT| |t|)) + (COND + ((EQL 1 (|#| |d|)) NIL) + ((SPADLET |u| (|getUnderModeOf| |t|)) |u|) + ((QUOTE T) (|last| |d|)))))))) + +(PUT + (QUOTE |underDomainOf|) + (QUOTE |cacheInfo|) + (QUOTE (|underDomainOf| |underDomainOf;AL| |hash-tableWithCounts| + (SETQ |underDomainOf;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + (|hashCount| |underDomainOf;AL|)))) + +(SETQ |underDomainOf;AL| (MAKE-HASHTABLE (QUOTE UEQUAL))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/debugsys.lisp.pamphlet b/src/interp/debugsys.lisp.pamphlet index 83dbcde..af5888b 100644 --- a/src/interp/debugsys.lisp.pamphlet +++ b/src/interp/debugsys.lisp.pamphlet @@ -92,7 +92,7 @@ loaded by hand we need to establish a value. (thesymb "/int/interp/cformat.lisp") (thesymb (concatenate 'string "/obj/" *sys* "/interp/cfuns.o")) (thesymb "/int/interp/clam.lisp") - (thesymb "/int/interp/clammed.clisp") + (thesymb "/int/interp/clammed.lisp") (thesymb "/int/interp/compat.clisp") (thesymb "/int/interp/compress.clisp") (thesymb "/int/interp/cparse.clisp")