diff --git a/changelog b/changelog index 8bf94c1..1a080a5 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,10 @@ +20090810 tpd src/axiom-website/patches.html 20090810.03.tpd.patch +20090810 tpd src/interp/Makefile move astr.boot to buildom.lisp +20090810 tpd src/interp/debugsys.lisp change buildom.clisp to buildom.lisp +20090810 tpd src/interp/buildom.lisp added, rewritten from buildom.boot +20090810 tpd src/interp/buildom.boot removed, rewritten to buildom.lisp +20090810 tpd src/interp/astr.lisp fix pamphlet title +20090810 tpd src/interp/algl.lisp fix pamphlet title 20090810 tpd src/axiom-website/patches.html 20090810.02.tpd.patch 20090810 tpd src/interp/Makefile move astr.boot to astr.lisp 20090810 tpd src/interp/debugsys.lisp change astr.clisp to astr.lisp diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index ce6e17c..08fd6ef 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1770,6 +1770,8 @@ vmlisp.lisp and unlisp.lisp merged
alql.lisp rewrite from boot to lisp
20090810.02.tpd.patch astr.lisp rewrite from boot to lisp
+20090810.03.tpd.patch +buildom.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 2abadc6..5dcf83c 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -414,7 +414,6 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/axext_l.lisp.dvi \ ${DOC}/bc-matrix.boot.dvi \ ${DOC}/br-con.boot.dvi \ - ${DOC}/buildom.boot.dvi \ ${DOC}/category.boot.dvi ${DOC}/cattable.boot.dvi \ ${DOC}/c-doc.boot.dvi ${DOC}/cformat.boot.dvi \ ${DOC}/cfuns.lisp.dvi ${DOC}/clam.boot.dvi \ @@ -1627,48 +1626,26 @@ ${MID}/alql.lisp: ${IN}/alql.lisp.pamphlet ${TANGLE} ${IN}/alql.lisp.pamphlet >alql.lisp ) @ - -\subsection{buildom.boot \cite{41}} +\subsection{buildom.lisp} <>= -${OUT}/buildom.${O}: ${MID}/buildom.clisp - @ echo 142 making ${OUT}/buildom.${O} from ${MID}/buildom.clisp - @ (cd ${MID} ; \ +${OUT}/buildom.${O}: ${MID}/buildom.lisp + @ echo 136 making ${OUT}/buildom.${O} from ${MID}/buildom.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/buildom.clisp"' \ + echo '(progn (compile-file "${MID}/buildom.lisp"' \ ':output-file "${OUT}/buildom.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/buildom.clisp"' \ + echo '(progn (compile-file "${MID}/buildom.lisp"' \ ':output-file "${OUT}/buildom.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/buildom.clisp: ${IN}/buildom.boot.pamphlet - @ echo 143 making ${MID}/buildom.clisp \ - from ${IN}/buildom.boot.pamphlet +<>= +${MID}/buildom.lisp: ${IN}/buildom.lisp.pamphlet + @ echo 137 making ${MID}/buildom.lisp from ${IN}/buildom.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/buildom.boot.pamphlet >buildom.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "buildom.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "buildom.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm buildom.boot ) - -@ -<>= -${DOC}/buildom.boot.dvi: ${IN}/buildom.boot.pamphlet - @echo 144 making ${DOC}/buildom.boot.dvi \ - from ${IN}/buildom.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/buildom.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} buildom.boot ; \ - rm -f ${DOC}/buildom.boot.pamphlet ; \ - rm -f ${DOC}/buildom.boot.tex ; \ - rm -f ${DOC}/buildom.boot ) + ${TANGLE} ${IN}/buildom.lisp.pamphlet >buildom.lisp ) @ @@ -6897,8 +6874,7 @@ clean: <> <> -<> -<> +<> <> <> @@ -7486,7 +7462,6 @@ pp \bibitem{36} {\bf \$SPAD/src/interp/sys-pkg.lisp.pamphlet} \bibitem{38} {\bf \$SPAD/src/interp/util.lisp.pamphlet} \bibitem{39} {\bf \$SPAD/src/interp/vmlisp.lisp.pamphlet} -\bibitem{41} {\bf \$SPAD/src/interp/buildom.boot.pamphlet} \bibitem{42} {\bf \$SPAD/src/interp/c-util.boot.pamphlet} \bibitem{43} {\bf \$SPAD/src/interp/nag-c02.boot.pamphlet} \bibitem{44} {\bf \$SPAD/src/interp/nag-c05.boot.pamphlet} diff --git a/src/interp/alql.lisp.pamphlet b/src/interp/alql.lisp.pamphlet index 08341a8..66d786e 100644 --- a/src/interp/alql.lisp.pamphlet +++ b/src/interp/alql.lisp.pamphlet @@ -1,7 +1,7 @@ \documentclass{article} \usepackage{axiom} \begin{document} -\title{\$SPAD/src/interp alql.boot} +\title{\$SPAD/src/interp alql.lisp} \author{The Axiom Team} \maketitle \begin{abstract} diff --git a/src/interp/astr.lisp.pamphlet b/src/interp/astr.lisp.pamphlet index c90ebf3..2f97fc3 100644 --- a/src/interp/astr.lisp.pamphlet +++ b/src/interp/astr.lisp.pamphlet @@ -1,7 +1,7 @@ \documentclass{article} \usepackage{axiom} \begin{document} -\title{\$SPAD/src/interp astr.boot} +\title{\$SPAD/src/interp astr.lisp} \author{The Axiom Team} \maketitle \begin{abstract} diff --git a/src/interp/buildom.boot.pamphlet b/src/interp/buildom.boot.pamphlet deleted file mode 100644 index 31d4fce..0000000 --- a/src/interp/buildom.boot.pamphlet +++ /dev/null @@ -1,384 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp buildom.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. - -@ -<<*>>= -<> - --- This file contains the constructors for the domains that cannot --- be written in ScratchpadII yet. They are not cached because they --- are very cheap to instantiate. --- SMW and SCM July 86 - -SETANDFILEQ($noCategoryDomains, '(Domain Mode SubDomain)) -SETANDFILEQ($nonLisplibDomains, - APPEND($Primitives,$noCategoryDomains)) - ---% Record --- Want to eventually have the elts and setelts. --- Record is a macro in BUILDOM LISP. It takes out the colons. - -isRecord type == type is ['Record,:.] - -RecordInner args == - -- this is old and should be removed wherever it occurs - if $evalDomain then - sayBrightly '"-->> Whoops! RecordInner called from this code." - Record0 VEC2LIST args - -Record0 args == - dom := GETREFV 10 - -- JHD added an extra slot to cache EQUAL methods - dom.0 := ['Record, :[['_:, CAR a, devaluate CDR a] for a in args]] - dom.1 := - [function lookupInTable,dom, - [['_=,[[['Boolean],'_$,'_$],:12]], - ['coerce,[[$Expression,'_$],:14]]]] - dom.2 := NIL - dom.3 := ['RecordCategory,:QCDR dom.0] - dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] - dom.5 := [CDR a for a in args] - dom.6 := [function RecordEqual, :dom] - dom.7 := [function RecordPrint, :dom] - dom.8 := [function Undef, :dom] - -- following is cache for equality functions - dom.9 := if (n:= LENGTH args) <= 2 - then [NIL,:NIL] - else GETREFV n - dom - -RecordEqual(x,y,dom) == - PAIRP x => - b:= - SPADCALL(CAR x, CAR y, CAR(dom.9) or - CAR RPLACA(dom.9,findEqualFun(dom.5.0))) - NULL rest(dom.5) => b - b and - SPADCALL(CDR x, CDR y, CDR (dom.9) or - CDR RPLACD(dom.9,findEqualFun(dom.5.1))) - VECP x => - equalfuns := dom.9 - and/[SPADCALL(x.i,y.i,equalfuns.i or (equalfuns.i:=findEqualFun(fdom))) - for i in 0.. for fdom in dom.5] - error '"Bug: Silly record representation" - -RecordPrint(x,dom) == coerceRe2E(x,dom.3) - -coerceVal2E(x,m) == - objValUnwrap coerceByFunction(objNewWrap(x,m),$Expression) - -findEqualFun(dom) == - compiledLookup('_=,[$Boolean,'$,'$],dom) - -coerceRe2E(x,source) == - n := # CDR source - n = 1 => - ['construct, - ['_=, source.1.1, coerceVal2E(CAR x,source.1.2)] ] - n = 2 => - ['construct, - ['_=, source.1.1, coerceVal2E(CAR x,source.1.2)], _ - ['_=, source.2.1, coerceVal2E(CDR x,source.2.2)] ] - VECP x => - ['construct, - :[['_=,tag,coerceVal2E(x.i, fdom)] - for i in 0.. for [.,tag,fdom] in rest source]] - error '"Bug: ridiculous record representation" - - ---% Union --- Want to eventually have the coerce to and from branch types. - -Union(:args) == - dom := GETREFV 9 - dom.0 := ['Union, :[(if a is ['_:,tag,domval] then ['_:,tag,devaluate domval] - else devaluate a) for a in args]] - dom.1 := - [function lookupInTable,dom, - [['_=,[[['Boolean],'_$,'_$],:12]], - ['coerce,[[$Expression,'_$],:14]]]] - dom.2 := NIL - dom.3 := - '(SetCategory) - dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] - dom.5 := args - dom.6 := [function UnionEqual, :dom] - dom.7 := [function UnionPrint, :dom] - dom.8 := [function Undef, :dom] - dom - -UnionEqual(x, y, dom) == - ['Union,:branches] := dom.0 - branches := orderUnionEntries branches - predlist := mkPredList branches - same := false - for b in stripUnionTags branches for p in predlist while not same repeat - typeFun := ['LAMBDA, '(_#1), p] - FUNCALL(typeFun,x) and FUNCALL(typeFun,y) => - STRINGP b => same := (x = y) - if p is ['EQCAR, :.] then (x := rest x; y := rest y) - same := SPADCALL(x, y, findEqualFun(evalDomain b)) - same - -UnionPrint(x, dom) == coerceUn2E(x, dom.0) - -coerceUn2E(x,source) == - ['Union,:branches] := source - branches := orderUnionEntries branches - predlist := mkPredList branches - byGeorge := byJane := GENSYM() - for b in stripUnionTags branches for p in predlist repeat - typeFun := ['LAMBDA, '(_#1), p] - if FUNCALL(typeFun,x) then return - if p is ['EQCAR, :.] then x := rest x --- STRINGP b => return x -- to catch "failed" etc. - STRINGP b => byGeorge := x -- to catch "failed" etc. - byGeorge := coerceVal2E(x,b) - byGeorge = byJane => - error '"Union bug: Cannot find appropriate branch for coerce to E" - byGeorge - ---% Mapping --- Want to eventually have elt: ($, args) -> target - -Mapping(:args) == - dom := GETREFV 9 - dom.0 := ['Mapping, :[devaluate a for a in args]] - dom.1 := - [function lookupInTable,dom, - [['_=,[[['Boolean],'_$,'_$],:12]], - ['coerce,[[$Expression,'_$],:14]]]] - dom.2 := NIL - dom.3 := - '(SetCategory) - dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] - dom.5 := args - dom.6 := [function MappingEqual, :dom] - dom.7 := [function MappingPrint, :dom] - dom.8 := [function Undef, :dom] - dom - -MappingEqual(x, y, dom) == EQ(x,y) -MappingPrint(x, dom) == coerceMap2E(x) - -coerceMap2E(x) == - -- nrlib domain - ARRAYP CDR x => ['theMap, BPINAME CAR x, - if $testingSystem then 0 else REMAINDER(HASHEQ CDR x, 1000)] - -- aldor - ['theMap, BPINAME CAR x ] - ---% Enumeration - -Enumeration(:"args") == - dom := GETREFV 9 - -- JHD added an extra slot to cache EQUAL methods - dom.0 := ['Enumeration, :args] - dom.1 := - [function lookupInTable,dom, - [['_=,[[['Boolean],'_$,'_$],:12]], - ['coerce,[[$Expression,'_$],:14], [['_$, $Symbol], :16]] - ]] - dom.2 := NIL - dom.3 := ['EnumerationCategory,:QCDR dom.0] - dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] - dom.5 := args - dom.6 := [function EnumEqual, :dom] - dom.7 := [function EnumPrint, :dom] - dom.8 := [function createEnum, :dom] - dom - -EnumEqual(e1,e2,dom) == e1=e2 -EnumPrint(enum, dom) == dom.5.enum -createEnum(sym, dom) == - args := dom.5 - val := -1 - for v in args for i in 0.. repeat - sym=v => return(val:=i) - val<0 => error ["Cannot coerce",sym,"to",["Enumeration",:args]] - val - ---% INSTANTIATORS - -RecordCategory(:"x") == constructorCategory ['Record,:x] - -EnumerationCategory(:"x") == constructorCategory ["Enumeration",:x] - -UnionCategory(:"x") == constructorCategory ["Union",:x] - ---ListCategory(:"x") == constructorCategory ("List",:x) - ---VectorCategory(:"x") == constructorCategory ("Vector",:x) - --above two now defined in SPAD code. - -constructorCategory (title is [op,:.]) == - constructorFunction:= GET(op,"makeFunctionList") or - systemErrorHere '"constructorCategory" - [funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame) - oplist:= [[[a,b],true,c] for [a,b,c] in funlist] - cat:= - JoinInner([SetCategory(),mkCategory('domain,oplist,nil,nil,nil)], - $EmptyEnvironment) - cat.(0):= title - cat - ---mkMappingFunList(nam,mapForm,e) == [[],e] -mkMappingFunList(nam,mapForm,e) == - dc := GENSYM() - sigFunAlist:= - [['_=,[['Boolean],nam ,nam],['ELT,dc,6]], - ['coerce,[$Expression,nam],['ELT,dc,7]]] - [substitute(nam,dc,substitute("$",'Rep,sigFunAlist)),e] - -mkRecordFunList(nam,['Record,:Alist],e) == - len:= #Alist - --- for (.,a,.) in Alist do --- if getmode(a,e) then MOAN("Symbol: ",a, --- " must not be both a variable and literal") --- e:= put(a,"isLiteral","true",e) - dc := GENSYM() - sigFunAlist:= - --:((a,(A,nam),('XLAM,("$1","$2"),('RECORDELT,"$1",i,len))) - -- for i in 0..,(.,a,A) in Alist), - - [['construct,[nam,:[A for [.,a,A] in Alist]],'mkRecord], - ['_=,[['Boolean],nam ,nam],['ELT,dc,6]], - ['coerce,[$Expression,nam],['ELT,dc,7]],: - [['elt,[A,nam,PNAME a],['XLAM,["$1","$2"],['RECORDELT,"$1",i,len]]] - for i in 0.. for [.,a,A] in Alist],: - [['setelt,[A,nam,PNAME a,A],['XLAM,["$1","$2","$3"], - ['SETRECORDELT,"$1",i, len,"$3"]]] - for i in 0.. for [.,a,A] in Alist],: - [['copy,[nam,nam],['XLAM,["$1"],['RECORDCOPY, - "$1",len]]]]] - [substitute(nam,dc,substitute("$",'Rep,sigFunAlist)),e] - -mkNewUnionFunList(name,form is ['Union,:listOfEntries],e) == - dc := name - if name = 'Rep then name := '$ - --2. create coercions from subtypes to subUnion - cList:= - [['_=,[['Boolean],name ,name],['ELT,dc,6]], - ['coerce,[$Expression,name],['ELT,dc,7]],: - ("append"/ - [[['construct,[name,type],['XLAM,["#1"],['CONS,i,"#1"]]], - ['elt,[type,name,tag],cdownFun], - ['case,['(Boolean),name,tag], - ['XLAM,["#1"],['QEQCAR,"#1",i]]]] - for [.,tag,type] in listOfEntries for i in 0..])] where - cdownFun() == - gg:=GENSYM() - $InteractiveMode => - ['XLAM,["#1"],['PROG1,['QCDR,"#1"], - ['check_-union,['QEQCAR,"#1",i],type,"#1"]]] - ['XLAM,["#1"],['PROG2,['LET,gg,"#1"],['QCDR,gg], - ['check_-union,['QEQCAR,gg,i],type,gg]]] - [cList,e] - -mkEnumerationFunList(nam,['Enumeration,:SL],e) == - len:= #SL - dc := nam - cList := - [nil, - ['_=,[['Boolean],nam ,nam],['ELT,dc,6]], - ['_^_=,[['Boolean],nam ,nam],['ELT,dc,7]], - ['coerce,[nam, ['Symbol]], ['ELT, dc, 8]], - ['coerce,[['OutputForm],nam],['ELT,dc, 9]]] - [substitute(nam, dc, cList),e] - -mkUnionFunList(op,form is ['Union,:listOfEntries],e) == - first listOfEntries is [":",.,.] => mkNewUnionFunList(op,form,e) - -- following call to order is a bug, but needs massive recomp to fix - listOfEntries:= orderUnionEntries listOfEntries - --1. create representations of subtypes - predList:= mkPredList listOfEntries - g:=GENSYM() - --2. create coercions from subtypes to subUnion - cList:= - [['_=,[['Boolean],g ,g],['ELT,op,6]], - ['coerce,[$Expression,g],['ELT,op,7]],: - ("append"/ - [[['autoCoerce,[g,t],upFun], - ['coerce,[t,g],cdownFun], - ['autoCoerce,[t,g],downFun], --this should be removed eventually - ['case,['(Boolean),g,t],typeFun]] - for p in predList for t in listOfEntries])] where - upFun() == - p is ['EQCAR,x,n] => ['XLAM,["#1"],['CONS,n,"#1"]] - ['XLAM,["#1"],"#1"] - cdownFun() == - gg:=GENSYM() - if p is ['EQCAR,x,n] then - ref:=['QCDR,gg] - q:= ['QEQCAR, gg, n] - else - ref:=gg - q:= substitute(gg,"#1",p) - ['XLAM,["#1"],['PROG2,['LET,gg,"#1"],ref, - ['check_-union,q,t,gg]]] - downFun() == - p is ['EQCAR,x,.] => - ['XLAM,["#1"],['QCDR,"#1"]] - ['XLAM,["#1"],"#1"] - typeFun() == - p is ['EQCAR,x,n] => - ['XLAM,["#1"],['QEQCAR,x,n]] - ['XLAM,["#1"],p] - op:= - op='Rep => '$ - op - cList:= substitute(op,g,cList) - [cList,e] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/buildom.lisp.pamphlet b/src/interp/buildom.lisp.pamphlet new file mode 100644 index 0000000..7d94cb2 --- /dev/null +++ b/src/interp/buildom.lisp.pamphlet @@ -0,0 +1,1455 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp buildom.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= +(IN-PACKAGE "BOOT" ) + +;SETANDFILEQ($noCategoryDomains, '(Domain Mode SubDomain)) + +(SETANDFILEQ |$noCategoryDomains| (QUOTE (|Domain| |Mode| |SubDomain|))) + +;SETANDFILEQ($nonLisplibDomains, +; APPEND($Primitives,$noCategoryDomains)) + +(SETANDFILEQ |$nonLisplibDomains| (APPEND |$Primitives| |$noCategoryDomains|)) + +;--% Record +;-- Want to eventually have the elts and setelts. +;-- Record is a macro in BUILDOM LISP. It takes out the colons. + +;isRecord type == type is ['Record,:.] + +(DEFUN |isRecord| (|type|) + (AND (PAIRP |type|) (EQ (QCAR |type|) (QUOTE |Record|)))) + +;RecordInner args == +; -- this is old and should be removed wherever it occurs +; if $evalDomain then +; sayBrightly '"-->> Whoops! RecordInner called from this code." +; Record0 VEC2LIST args + +(DEFUN |RecordInner| (|args|) + (PROGN + (COND + (|$evalDomain| + (|sayBrightly| + (MAKESTRING "-->> Whoops! RecordInner called from this code.")))) + (|Record0| (VEC2LIST |args|)))) + +;Record0 args == +; dom := GETREFV 10 +; -- JHD added an extra slot to cache EQUAL methods +; dom.0 := ['Record, :[['_:, CAR a, devaluate CDR a] for a in args]] +; dom.1 := +; [function lookupInTable,dom, +; [['_=,[[['Boolean],'_$,'_$],:12]], +; ['coerce,[[$Expression,'_$],:14]]]] +; dom.2 := NIL +; dom.3 := ['RecordCategory,:QCDR dom.0] +; dom.4 := +; [[ '(SetCategory) ],[ '(SetCategory) ]] +; dom.5 := [CDR a for a in args] +; dom.6 := [function RecordEqual, :dom] +; dom.7 := [function RecordPrint, :dom] +; dom.8 := [function Undef, :dom] +; -- following is cache for equality functions +; dom.9 := if (n:= LENGTH args) <= 2 +; then [NIL,:NIL] +; else GETREFV n +; dom + +(DEFUN |Record0| (|args|) + (PROG (|dom| |n|) + (RETURN + (SEQ + (PROGN + (SPADLET |dom| (GETREFV 10)) + (SETELT |dom| 0 + (CONS + (QUOTE |Record|) + (PROG (#0=#:G166069) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166074 |args| (CDR #1#)) (|a| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |a| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (CONS + (QUOTE |:|) + (CONS + (CAR |a|) + (CONS + (|devaluate| (CDR |a|)) + NIL))) + #0#))))))))) + (SETELT |dom| 1 + (CONS + (|function| |lookupInTable|) + (CONS + |dom| + (CONS + (CONS + (CONS + (QUOTE =) + (CONS + (CONS + (CONS + (CONS (QUOTE |Boolean|) NIL) + (CONS (QUOTE $) (CONS (QUOTE $) NIL))) + 12) + NIL)) + (CONS + (CONS + (QUOTE |coerce|) + (CONS + (CONS + (CONS + |$Expression| + (CONS (QUOTE $) NIL)) + 14) + NIL)) + NIL)) + NIL)))) + (SETELT |dom| 2 NIL) + (SETELT |dom| 3 (CONS (QUOTE |RecordCategory|) (QCDR (ELT |dom| 0)))) + (SETELT |dom| 4 + (CONS + (CONS (QUOTE (|SetCategory|)) NIL) + (CONS (CONS (QUOTE (|SetCategory|)) NIL) NIL))) + (SETELT |dom| 5 + (PROG (#2=#:G166084) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G166089 |args| (CDR #3#)) (|a| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |a| (CAR #3#)) NIL)) (NREVERSE0 #2#)) + (SEQ (EXIT (SETQ #2# (CONS (CDR |a|) #2#)))))))) + (SETELT |dom| 6 (CONS (|function| |RecordEqual|) |dom|)) + (SETELT |dom| 7 (CONS (|function| |RecordPrint|) |dom|)) + (SETELT |dom| 8 (CONS (|function| |Undef|) |dom|)) + (SETELT |dom| 9 + (COND + ((<= (SPADLET |n| (LENGTH |args|)) 2) (CONS NIL NIL)) + ((QUOTE T) (GETREFV |n|)))) + |dom|))))) + +;RecordEqual(x,y,dom) == +; PAIRP x => +; b:= +; SPADCALL(CAR x, CAR y, CAR(dom.9) or +; CAR RPLACA(dom.9,findEqualFun(dom.5.0))) +; NULL rest(dom.5) => b +; b and +; SPADCALL(CDR x, CDR y, CDR (dom.9) or +; CDR RPLACD(dom.9,findEqualFun(dom.5.1))) +; VECP x => +; equalfuns := dom.9 +; and/[SPADCALL(x.i,y.i,equalfuns.i or (equalfuns.i:=findEqualFun(fdom))) +; for i in 0.. for fdom in dom.5] +; error '"Bug: Silly record representation" + +(DEFUN |RecordEqual| (|x| |y| |dom|) + (PROG (|b| |equalfuns|) + (RETURN + (SEQ + (COND + ((PAIRP |x|) + (SPADLET |b| + (SPADCALL (CAR |x|) (CAR |y|) + (OR (CAR (ELT |dom| 9)) + (CAR + (RPLACA (ELT |dom| 9) (|findEqualFun| (ELT (ELT |dom| 5) 0))))))) + (COND + ((NULL (CDR (ELT |dom| 5))) |b|) + ((QUOTE T) + (AND |b| + (SPADCALL (CDR |x|) (CDR |y|) + (OR + (CDR (ELT |dom| 9)) + (CDR + (RPLACD + (ELT |dom| 9) + (|findEqualFun| (ELT (ELT |dom| 5) 1)))))))))) + ((VECP |x|) + (SPADLET |equalfuns| (ELT |dom| 9)) + (PROG (#0=#:G166105) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G166112 NIL (NULL #0#)) (|i| 0 (QSADD1 |i|)) (#2=#:G166113 (ELT |dom| 5) (CDR #2#)) (|fdom| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |fdom| (CAR #2#)) NIL)) #0#) + (SEQ + (EXIT + (SETQ #0# + (AND + #0# + (SPADCALL (ELT |x| |i|) (ELT |y| |i|) + (OR (ELT |equalfuns| |i|) + (SETELT |equalfuns| |i| (|findEqualFun| |fdom|)))))))))))) + ((QUOTE T) + (|error| (MAKESTRING "Bug: Silly record representation")))))))) + +;RecordPrint(x,dom) == coerceRe2E(x,dom.3) + +(DEFUN |RecordPrint| (|x| |dom|) (|coerceRe2E| |x| (ELT |dom| 3))) + +;coerceVal2E(x,m) == +; objValUnwrap coerceByFunction(objNewWrap(x,m),$Expression) + +(DEFUN |coerceVal2E| (|x| |m|) + (|objValUnwrap| (|coerceByFunction| (|objNewWrap| |x| |m|) |$Expression|))) + +;findEqualFun(dom) == +; compiledLookup('_=,[$Boolean,'$,'$],dom) + +(DEFUN |findEqualFun| (|dom|) + (|compiledLookup| (QUOTE =) + (CONS |$Boolean| (CONS (QUOTE $) (CONS (QUOTE $) NIL))) |dom|)) + +;coerceRe2E(x,source) == +; n := # CDR source +; n = 1 => +; ['construct, +; ['_=, source.1.1, coerceVal2E(CAR x,source.1.2)] ] +; n = 2 => +; ['construct, +; ['_=, source.1.1, coerceVal2E(CAR x,source.1.2)], _ +; ['_=, source.2.1, coerceVal2E(CDR x,source.2.2)] ] +; VECP x => +; ['construct, +; :[['_=,tag,coerceVal2E(x.i, fdom)] +; for i in 0.. for [.,tag,fdom] in rest source]] +; error '"Bug: ridiculous record representation" + +(DEFUN |coerceRe2E| (|x| |source|) + (PROG (|n| |tag| |fdom|) + (RETURN + (SEQ + (PROGN + (SPADLET |n| (|#| (CDR |source|))) + (COND + ((EQL |n| 1) + (CONS + (QUOTE |construct|) + (CONS + (CONS + (QUOTE =) + (CONS + (ELT (ELT |source| 1) 1) + (CONS (|coerceVal2E| (CAR |x|) (ELT (ELT |source| 1) 2)) NIL))) + NIL))) + ((EQL |n| 2) + (CONS + (QUOTE |construct|) + (CONS + (CONS + (QUOTE =) + (CONS + (ELT (ELT |source| 1) 1) + (CONS (|coerceVal2E| (CAR |x|) (ELT (ELT |source| 1) 2)) NIL))) + (CONS + (CONS + (QUOTE =) + (CONS + (ELT (ELT |source| 2) 1) + (CONS (|coerceVal2E| (CDR |x|) (ELT (ELT |source| 2) 2)) NIL))) + NIL)))) + ((VECP |x|) + (CONS + (QUOTE |construct|) + (PROG (#0=#:G166146) + (SPADLET #0# NIL) + (RETURN + (DO ((|i| 0 (QSADD1 |i|)) + (#1=#:G166153 (CDR |source|) (CDR #1#)) + (#2=#:G166135 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |tag| (CADR #2#)) + (SPADLET |fdom| (CADDR #2#)) + #2#) + NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (CONS + (QUOTE =) + (CONS |tag| (CONS (|coerceVal2E| (ELT |x| |i|) |fdom|) NIL))) + #0#))))))))) + ((QUOTE T) + (|error| (MAKESTRING "Bug: ridiculous record representation"))))))))) + +;--% Union +;-- Want to eventually have the coerce to and from branch types. +;Union(:args) == +; dom := GETREFV 9 +; dom.0 := ['Union, :[(if a is ['_:,tag,domval] +; then ['_:,tag,devaluate domval] +; else devaluate a) for a in args]] +; dom.1 := +; [function lookupInTable,dom, +; [['_=,[[['Boolean],'_$,'_$],:12]], +; ['coerce,[[$Expression,'_$],:14]]]] +; dom.2 := NIL +; dom.3 := +; '(SetCategory) +; dom.4 := +; [[ '(SetCategory) ],[ '(SetCategory) ]] +; dom.5 := args +; dom.6 := [function UnionEqual, :dom] +; dom.7 := [function UnionPrint, :dom] +; dom.8 := [function Undef, :dom] +; dom + +(DEFUN |Union| (&REST #0=#:G166222 &AUX |args|) + (DSETQ |args| #0#) + (PROG (|dom| |ISTMP#1| |tag| |ISTMP#2| |domval|) + (RETURN + (SEQ + (PROGN + (SPADLET |dom| (GETREFV 9)) + (SETELT |dom| 0 + (CONS + (QUOTE |Union|) + (PROG (#1=#:G166195) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=#:G166207 |args| (CDR #2#)) (|a| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |a| (CAR #2#)) NIL)) (NREVERSE0 #1#)) + (SEQ + (EXIT + (SETQ #1# + (CONS + (COND + ((AND (PAIRP |a|) + (EQ (QCAR |a|) (QUOTE |:|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |tag| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |domval| (QCAR |ISTMP#2|)) + (QUOTE T))))))) + (CONS + (QUOTE |:|) + (CONS |tag| (CONS (|devaluate| |domval|) NIL)))) + ((QUOTE T) (|devaluate| |a|))) + #1#))))))))) + (SETELT |dom| 1 + (CONS + (|function| |lookupInTable|) + (CONS + |dom| + (CONS + (CONS + (CONS + (QUOTE =) + (CONS + (CONS + (CONS + (CONS (QUOTE |Boolean|) NIL) + (CONS (QUOTE $) (CONS (QUOTE $) NIL))) + 12) + NIL)) + (CONS + (CONS + (QUOTE |coerce|) + (CONS (CONS (CONS |$Expression| (CONS (QUOTE $) NIL)) 14) NIL)) + NIL)) + NIL)))) + (SETELT |dom| 2 NIL) + (SETELT |dom| 3 (QUOTE (|SetCategory|))) + (SETELT |dom| 4 + (CONS + (CONS (QUOTE (|SetCategory|)) NIL) + (CONS (CONS (QUOTE (|SetCategory|)) NIL) NIL))) + (SETELT |dom| 5 |args|) + (SETELT |dom| 6 (CONS (|function| |UnionEqual|) |dom|)) + (SETELT |dom| 7 (CONS (|function| |UnionPrint|) |dom|)) + (SETELT |dom| 8 (CONS (|function| |Undef|) |dom|)) + |dom|))))) + +;UnionEqual(x, y, dom) == +; ['Union,:branches] := dom.0 +; branches := orderUnionEntries branches +; predlist := mkPredList branches +; same := false +; for b in stripUnionTags branches for p in predlist while not same repeat +; typeFun := ['LAMBDA, '(_#1), p] +; FUNCALL(typeFun,x) and FUNCALL(typeFun,y) => +; STRINGP b => same := (x = y) +; if p is ['EQCAR, :.] then (x := rest x; y := rest y) +; same := SPADCALL(x, y, findEqualFun(evalDomain b)) +; same + +(DEFUN |UnionEqual| (|x| |y| |dom|) + (PROG (|LETTMP#1| |branches| |predlist| |typeFun| |same|) + (RETURN + (SEQ + (PROGN + (SPADLET |LETTMP#1| (ELT |dom| 0)) + (SPADLET |branches| (CDR |LETTMP#1|)) + (SPADLET |branches| (|orderUnionEntries| |branches|)) + (SPADLET |predlist| (|mkPredList| |branches|)) + (SPADLET |same| NIL) + (DO ((#0=#:G166239 (|stripUnionTags| |branches|) (CDR #0#)) + (|b| NIL) + (#1=#:G166240 |predlist| (CDR #1#)) + (|p| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |b| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |p| (CAR #1#)) NIL) + (NULL (NULL |same|))) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |typeFun| + (CONS (QUOTE LAMBDA) (CONS (QUOTE (|#1|)) (CONS |p| NIL)))) + (COND + ((AND (FUNCALL |typeFun| |x|) (FUNCALL |typeFun| |y|)) + (COND + ((STRINGP |b|) (SPADLET |same| (BOOT-EQUAL |x| |y|))) + ((QUOTE T) + (COND + ((AND (PAIRP |p|) (EQ (QCAR |p|) (QUOTE EQCAR))) + (SPADLET |x| (CDR |x|)) + (SPADLET |y| (CDR |y|)))) + (SPADLET |same| + (SPADCALL |x| |y| (|findEqualFun| (|evalDomain| |b|)))))))))))) + |same|))))) + +;UnionPrint(x, dom) == coerceUn2E(x, dom.0) + +(DEFUN |UnionPrint| (|x| |dom|) (|coerceUn2E| |x| (ELT |dom| 0))) +;coerceUn2E(x,source) == +; ['Union,:branches] := source +; branches := orderUnionEntries branches +; predlist := mkPredList branches +; byGeorge := byJane := GENSYM() +; for b in stripUnionTags branches for p in predlist repeat +; typeFun := ['LAMBDA, '(_#1), p] +; if FUNCALL(typeFun,x) then return +; if p is ['EQCAR, :.] then x := rest x +;-- STRINGP b => return x -- to catch "failed" etc. +; STRINGP b => byGeorge := x -- to catch "failed" etc. +; byGeorge := coerceVal2E(x,b) +; byGeorge = byJane => +; error '"Union bug: Cannot find appropriate branch for coerce to E" +; byGeorge + +(DEFUN |coerceUn2E| (|x| |source|) + (PROG (|branches| |predlist| |byJane| |typeFun| |byGeorge|) + (RETURN + (SEQ + (PROGN + (SPADLET |branches| (CDR |source|)) + (SPADLET |branches| (|orderUnionEntries| |branches|)) + (SPADLET |predlist| (|mkPredList| |branches|)) + (SPADLET |byGeorge| (SPADLET |byJane| (GENSYM))) + (DO ((#0=#:G166279 (|stripUnionTags| |branches|) (CDR #0#)) + (|b| NIL) + (#1=#:G166280 |predlist| (CDR #1#)) + (|p| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |b| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |p| (CAR #1#)) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |typeFun| + (CONS (QUOTE LAMBDA) (CONS (QUOTE (|#1|)) (CONS |p| NIL)))) + (COND + ((FUNCALL |typeFun| |x|) + (RETURN + (PROGN + (COND + ((AND (PAIRP |p|) (EQ (QCAR |p|) (QUOTE EQCAR))) + (SPADLET |x| (CDR |x|)))) + (COND + ((STRINGP |b|) (SPADLET |byGeorge| |x|)) + ((QUOTE T) (SPADLET |byGeorge| (|coerceVal2E| |x| |b|))))))) + ((QUOTE T) NIL)))))) + (COND + ((BOOT-EQUAL |byGeorge| |byJane|) + (|error| "Union bug: Cannot find appropriate branch for coerce to E")) + ((QUOTE T) |byGeorge|))))))) + +;--% Mapping +;-- Want to eventually have elt: ($, args) -> target +;Mapping(:args) == +; dom := GETREFV 9 +; dom.0 := ['Mapping, :[devaluate a for a in args]] +; dom.1 := +; [function lookupInTable,dom, +; [['_=,[[['Boolean],'_$,'_$],:12]], +; ['coerce,[[$Expression,'_$],:14]]]] +; dom.2 := NIL +; dom.3 := +; '(SetCategory) +; dom.4 := +; [[ '(SetCategory) ],[ '(SetCategory) ]] +; dom.5 := args +; dom.6 := [function MappingEqual, :dom] +; dom.7 := [function MappingPrint, :dom] +; dom.8 := [function Undef, :dom] +; dom + +(DEFUN |Mapping| (&REST #0=#:G166322 &AUX |args|) + (DSETQ |args| #0#) + (PROG (|dom|) + (RETURN + (SEQ + (PROGN + (SPADLET |dom| (GETREFV 9)) + (SETELT |dom| 0 + (CONS + (QUOTE |Mapping|) + (PROG (#1=#:G166306) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=#:G166311 |args| (CDR #2#)) (|a| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |a| (CAR #2#)) NIL)) (NREVERSE0 #1#)) + (SEQ (EXIT (SETQ #1# (CONS (|devaluate| |a|) #1#))))))))) + (SETELT |dom| 1 + (CONS + (|function| |lookupInTable|) + (CONS + |dom| + (CONS + (CONS + (CONS + (QUOTE =) + (CONS + (CONS + (CONS + (CONS (QUOTE |Boolean|) NIL) + (CONS (QUOTE $) (CONS (QUOTE $) NIL))) + 12) + NIL)) + (CONS + (CONS + (QUOTE |coerce|) + (CONS (CONS (CONS |$Expression| (CONS (QUOTE $) NIL)) 14) NIL)) + NIL)) + NIL)))) + (SETELT |dom| 2 NIL) + (SETELT |dom| 3 (QUOTE (|SetCategory|))) + (SETELT |dom| 4 + (CONS + (CONS (QUOTE (|SetCategory|)) NIL) + (CONS (CONS (QUOTE (|SetCategory|)) NIL) NIL))) + (SETELT |dom| 5 |args|) + (SETELT |dom| 6 (CONS (|function| |MappingEqual|) |dom|)) + (SETELT |dom| 7 (CONS (|function| |MappingPrint|) |dom|)) + (SETELT |dom| 8 (CONS (|function| |Undef|) |dom|)) + |dom|))))) + +;MappingEqual(x, y, dom) == EQ(x,y) + +(DEFUN |MappingEqual| (|x| |y| |dom|) (EQ |x| |y|)) + +;MappingPrint(x, dom) == coerceMap2E(x) + +(DEFUN |MappingPrint| (|x| |dom|) (|coerceMap2E| |x|)) + +;coerceMap2E(x) == +; -- nrlib domain +; ARRAYP CDR x => ['theMap, BPINAME CAR x, +; if $testingSystem then 0 else REMAINDER(HASHEQ CDR x, 1000)] +; -- aldor +; ['theMap, BPINAME CAR x ] + +(DEFUN |coerceMap2E| (|x|) + (COND + ((ARRAYP (CDR |x|)) + (CONS + (QUOTE |theMap|) + (CONS + (BPINAME (CAR |x|)) + (CONS + (COND + (|$testingSystem| 0) + ((QUOTE T) (REMAINDER (HASHEQ (CDR |x|)) 1000))) + NIL)))) + ((QUOTE T) (CONS (QUOTE |theMap|) (CONS (BPINAME (CAR |x|)) NIL))))) + +;--% Enumeration +;Enumeration(:"args") == +; dom := GETREFV 9 +; -- JHD added an extra slot to cache EQUAL methods +; dom.0 := ['Enumeration, :args] +; dom.1 := +; [function lookupInTable,dom, +; [['_=,[[['Boolean],'_$,'_$],:12]], +; ['coerce,[[$Expression,'_$],:14], [['_$, $Symbol], :16]] +; ]] +; dom.2 := NIL +; dom.3 := ['EnumerationCategory,:QCDR dom.0] +; dom.4 := +; [[ '(SetCategory) ],[ '(SetCategory) ]] +; dom.5 := args +; dom.6 := [function EnumEqual, :dom] +; dom.7 := [function EnumPrint, :dom] +; dom.8 := [function createEnum, :dom] +; dom + +(DEFUN |Enumeration,LAM| (&REST #0=#:G166339 &AUX |args|) + (DSETQ |args| #0#) + (PROG (|dom|) + (RETURN + (PROGN + (SPADLET |dom| (GETREFV 9)) + (SETELT |dom| 0 (CONS (QUOTE |Enumeration|) |args|)) + (SETELT |dom| 1 + (CONS + (|function| |lookupInTable|) + (CONS + |dom| + (CONS + (CONS + (CONS + (QUOTE =) + (CONS + (CONS + (CONS + (CONS (QUOTE |Boolean|) NIL) + (CONS (QUOTE $) (CONS (QUOTE $) NIL))) + 12) + NIL)) + (CONS + (CONS + (QUOTE |coerce|) + (CONS + (CONS (CONS |$Expression| (CONS (QUOTE $) NIL)) 14) + (CONS (CONS (CONS (QUOTE $) (CONS |$Symbol| NIL)) 16) NIL))) + NIL)) + NIL)))) + (SETELT |dom| 2 NIL) + (SETELT |dom| 3 (CONS (QUOTE |EnumerationCategory|) (QCDR (ELT |dom| 0)))) + (SETELT |dom| 4 + (CONS + (CONS (QUOTE (|SetCategory|)) NIL) + (CONS (CONS (QUOTE (|SetCategory|)) NIL) NIL))) + (SETELT |dom| 5 |args|) + (SETELT |dom| 6 (CONS (|function| |EnumEqual|) |dom|)) + (SETELT |dom| 7 (CONS (|function| |EnumPrint|) |dom|)) + (SETELT |dom| 8 (CONS (|function| |createEnum|) |dom|)) + |dom|)))) + +(DEFMACRO |Enumeration| (&WHOLE #0=#:G166340 &REST #:G166341 &AUX #1=#:G166338) + (DSETQ #1# #0#) + (CONS (QUOTE |Enumeration,LAM|) (VMLISP::WRAP (CDR #1#) (QUOTE QUOTE)))) + +;EnumEqual(e1,e2,dom) == e1=e2 + +(DEFUN |EnumEqual| (|e1| |e2| |dom|) (BOOT-EQUAL |e1| |e2|)) + +;EnumPrint(enum, dom) == dom.5.enum + +(DEFUN |EnumPrint| (|enum| |dom|) (ELT (ELT |dom| 5) |enum|)) + +;createEnum(sym, dom) == +; args := dom.5 +; val := -1 +; for v in args for i in 0.. repeat +; sym=v => return(val:=i) +; val<0 => error ["Cannot coerce",sym,"to",["Enumeration",:args]] +; val + +(DEFUN |createEnum| (|sym| |dom|) + (PROG (|args| |val|) + (RETURN + (SEQ + (PROGN + (SPADLET |args| (ELT |dom| 5)) + (SPADLET |val| (SPADDIFFERENCE 1)) + (SEQ + (DO ((#0=#:G166353 |args| (CDR #0#)) (|v| NIL) (|i| 0 (QSADD1 |i|))) + ((OR (ATOM #0#) (PROGN (SETQ |v| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |sym| |v|) (EXIT (RETURN (SPADLET |val| |i|)))))))) + (COND + ((MINUSP |val|) + (|error| + (CONS + (QUOTE |Cannot coerce|) + (CONS |sym| + (CONS + (QUOTE |to|) + (CONS (CONS (QUOTE |Enumeration|) |args|) NIL)))))) + ((QUOTE T) |val|)))))))) + +;--% INSTANTIATORS + +;RecordCategory(:"x") == constructorCategory ['Record,:x] + +(DEFUN |RecordCategory,LAM| (&REST #0=#:G166369 &AUX |x|) + (DSETQ |x| #0#) + (|constructorCategory| (CONS (QUOTE |Record|) |x|))) + +(DEFMACRO |RecordCategory| + (&WHOLE #0=#:G166370 &REST #:G166371 &AUX #1=#:G166368) + (DSETQ #1# #0#) + (CONS (QUOTE |RecordCategory,LAM|) (VMLISP::WRAP (CDR #1#) (QUOTE QUOTE)))) + +;EnumerationCategory(:"x") == constructorCategory ["Enumeration",:x] + +(DEFUN |EnumerationCategory,LAM| (&REST #0=#:G166376 &AUX |x|) + (DSETQ |x| #0#) + (|constructorCategory| (CONS (QUOTE |Enumeration|) |x|))) + +(DEFMACRO |EnumerationCategory| + (&WHOLE #0=#:G166377 &REST #:G166378 &AUX #1=#:G166375) + (DSETQ #1# #0#) + (CONS + (QUOTE |EnumerationCategory,LAM|) + (VMLISP::WRAP (CDR #1#) (QUOTE QUOTE)))) + +;UnionCategory(:"x") == constructorCategory ["Union",:x] + +(DEFUN |UnionCategory,LAM| (&REST #0=#:G166383 &AUX |x|) + (DSETQ |x| #0#) + (|constructorCategory| (CONS (QUOTE |Union|) |x|))) + +(DEFMACRO |UnionCategory| + (&WHOLE #0=#:G166384 &REST #:G166385 &AUX #1=#:G166382) + (DSETQ #1# #0#) + (CONS (QUOTE |UnionCategory,LAM|) (VMLISP::WRAP (CDR #1#) (QUOTE QUOTE)))) + +;--ListCategory(:"x") == constructorCategory ("List",:x) +;--VectorCategory(:"x") == constructorCategory ("Vector",:x) +; --above two now defined in SPAD code. +;constructorCategory (title is [op,:.]) == +; constructorFunction:= GET(op,"makeFunctionList") or +; systemErrorHere '"constructorCategory" +; [funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame) +; oplist:= [[[a,b],true,c] for [a,b,c] in funlist] +; cat:= +; JoinInner([SetCategory(),mkCategory('domain,oplist,nil,nil,nil)], +; $EmptyEnvironment) +; cat.(0):= title +; cat + +(DEFUN |constructorCategory| (|title|) + (PROG (|op| |constructorFunction| |LETTMP#1| |funlist| |a| |b| |c| + |oplist| |cat|) + (RETURN + (SEQ + (PROGN + (SPADLET |op| (CAR |title|)) + (SPADLET |constructorFunction| + (OR + (GETL |op| (QUOTE |makeFunctionList|)) + (|systemErrorHere| (MAKESTRING "constructorCategory")))) + (SPADLET |LETTMP#1| + (FUNCALL |constructorFunction| (QUOTE $) |title| |$CategoryFrame|)) + (SPADLET |funlist| (CAR |LETTMP#1|)) + (SPADLET |oplist| + (PROG (#0=#:G166415) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166421 |funlist| (CDR #1#)) (#2=#:G166391 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR #2#)) + (SPADLET |b| (CADR #2#)) + (SPADLET |c| (CADDR #2#)) + #2#) + NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (CONS (CONS |a| (CONS |b| NIL)) (CONS (QUOTE T) (CONS |c| NIL))) + #0#)))))))) + (SPADLET |cat| + (|JoinInner| + (CONS + (|SetCategory|) + (CONS (|mkCategory| (QUOTE |domain|) |oplist| NIL NIL NIL) NIL)) + |$EmptyEnvironment|)) + (SETELT |cat| 0 |title|) + |cat|))))) + +;--mkMappingFunList(nam,mapForm,e) == [[],e] +;mkMappingFunList(nam,mapForm,e) == +; dc := GENSYM() +; sigFunAlist:= +; [['_=,[['Boolean],nam ,nam],['ELT,dc,6]], +; ['coerce,[$Expression,nam],['ELT,dc,7]]] +; [substitute(nam,dc,substitute("$",'Rep,sigFunAlist)),e] + +(DEFUN |mkMappingFunList| (|nam| |mapForm| |e|) + (PROG (|dc| |sigFunAlist|) + (RETURN + (PROGN + (SPADLET |dc| (GENSYM)) + (SPADLET |sigFunAlist| + (CONS + (CONS + (QUOTE =) + (CONS + (CONS (CONS (QUOTE |Boolean|) NIL) (CONS |nam| (CONS |nam| NIL))) + (CONS (CONS (QUOTE ELT) (CONS |dc| (CONS 6 NIL))) NIL))) + (CONS + (CONS + (QUOTE |coerce|) + (CONS + (CONS |$Expression| (CONS |nam| NIL)) + (CONS (CONS (QUOTE ELT) (CONS |dc| (CONS 7 NIL))) NIL))) + NIL))) + (CONS + (MSUBST |nam| |dc| (MSUBST (QUOTE $) (QUOTE |Rep|) |sigFunAlist|)) + (CONS |e| NIL)))))) + +;mkRecordFunList(nam,['Record,:Alist],e) == +; len:= #Alist +;-- for (.,a,.) in Alist do +;-- if getmode(a,e) then MOAN("Symbol: ",a, +;-- " must not be both a variable and literal") +;-- e:= put(a,"isLiteral","true",e) +; dc := GENSYM() +; sigFunAlist:= +; --:((a,(A,nam),('XLAM,("$1","$2"),('RECORDELT,"$1",i,len))) +; -- for i in 0..,(.,a,A) in Alist), +; [['construct,[nam,:[A for [.,a,A] in Alist]],'mkRecord], +; ['_=,[['Boolean],nam ,nam],['ELT,dc,6]], +; ['coerce,[$Expression,nam],['ELT,dc,7]],: +; [['elt,[A,nam,PNAME a],['XLAM,["$1","$2"],['RECORDELT,"$1",i,len]]] +; for i in 0.. for [.,a,A] in Alist],: +; [['setelt,[A,nam,PNAME a,A],['XLAM,["$1","$2","$3"], +; ['SETRECORDELT,"$1",i, len,"$3"]]] +; for i in 0.. for [.,a,A] in Alist],: +; [['copy,[nam,nam],['XLAM,["$1"],['RECORDCOPY, +; "$1",len]]]]] +; [substitute(nam,dc,substitute("$",'Rep,sigFunAlist)),e] + +(DEFUN |mkRecordFunList| (|nam| #0=#:G166460 |e|) + (PROG (|Alist| |len| |dc| |a| A |sigFunAlist|) + (RETURN + (SEQ + (PROGN + (SPADLET |Alist| (CDR #0#)) + (SPADLET |len| (|#| |Alist|)) + (SPADLET |dc| (GENSYM)) + (SPADLET |sigFunAlist| + (CONS + (CONS + (QUOTE |construct|) + (CONS + (CONS + |nam| + (PROG (#1=#:G166481) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=#:G166487 |Alist| (CDR #2#)) (#3=#:G166447 NIL)) + ((OR (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CADR #3#)) + (SPADLET A (CADDR #3#)) + #3#) + NIL)) + (NREVERSE0 #1#)) + (SEQ (EXIT (SETQ #1# (CONS A #1#)))))))) + (CONS (QUOTE |mkRecord|) NIL))) + (CONS + (CONS + (QUOTE =) + (CONS + (CONS (CONS (QUOTE |Boolean|) NIL) (CONS |nam| (CONS |nam| NIL))) + (CONS (CONS (QUOTE ELT) (CONS |dc| (CONS 6 NIL))) NIL))) + (CONS + (CONS + (QUOTE |coerce|) + (CONS + (CONS |$Expression| (CONS |nam| NIL)) + (CONS (CONS (QUOTE ELT) (CONS |dc| (CONS 7 NIL))) NIL))) + (APPEND + (PROG (#4=#:G166500) + (SPADLET #4# NIL) + (RETURN + (DO ((|i| 0 (QSADD1 |i|)) + (#5=#:G166507 |Alist| (CDR #5#)) + (#6=#:G166451 NIL)) + ((OR (ATOM #5#) + (PROGN (SETQ #6# (CAR #5#)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CADR #6#)) + (SPADLET A (CADDR #6#)) + #6#) + NIL)) + (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS + (CONS + (QUOTE |elt|) + (CONS + (CONS A (CONS |nam| (CONS (PNAME |a|) NIL))) + (CONS + (CONS + (QUOTE XLAM) + (CONS + (CONS (QUOTE $1) (CONS (QUOTE $2) NIL)) + (CONS + (CONS + (QUOTE RECORDELT) + (CONS (QUOTE $1) (CONS |i| (CONS |len| NIL)))) + NIL))) + NIL))) + #4#))))))) + (APPEND + (PROG (#7=#:G166520) + (SPADLET #7# NIL) + (RETURN + (DO ((|i| 0 (QSADD1 |i|)) + (#8=#:G166527 |Alist| (CDR #8#)) + (#9=#:G166455 NIL)) + ((OR (ATOM #8#) + (PROGN (SETQ #9# (CAR #8#)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CADR #9#)) + (SPADLET A (CADDR #9#)) + #9#) + NIL)) + (NREVERSE0 #7#)) + (SEQ + (EXIT + (SETQ #7# + (CONS + (CONS + (QUOTE |setelt|) + (CONS + (CONS A (CONS |nam| (CONS (PNAME |a|) (CONS A NIL)))) + (CONS + (CONS + (QUOTE XLAM) + (CONS + (CONS + (QUOTE $1) + (CONS (QUOTE $2) (CONS (QUOTE $3) NIL))) + (CONS + (CONS + (QUOTE SETRECORDELT) + (CONS + (QUOTE $1) + (CONS |i| (CONS |len| (CONS (QUOTE $3) NIL))))) + NIL))) + NIL))) + #7#))))))) + (CONS + (CONS + (QUOTE |copy|) + (CONS + (CONS |nam| (CONS |nam| NIL)) + (CONS + (CONS + (QUOTE XLAM) + (CONS + (CONS (QUOTE $1) NIL) + (CONS + (CONS (QUOTE RECORDCOPY) (CONS (QUOTE $1) (CONS |len| NIL))) + NIL))) + NIL))) + NIL))))))) + (CONS + (MSUBST |nam| |dc| (MSUBST (QUOTE $) (QUOTE |Rep|) |sigFunAlist|)) + (CONS |e| NIL))))))) + +;mkNewUnionFunList(name,form is ['Union,:listOfEntries],e) == +; dc := name +; if name = 'Rep then name := '$ +; --2. create coercions from subtypes to subUnion +; cList:= +; [['_=,[['Boolean],name ,name],['ELT,dc,6]], +; ['coerce,[$Expression,name],['ELT,dc,7]],: +; ("append"/ +; [[['construct,[name,type],['XLAM,["#1"],['CONS,i,"#1"]]], +; ['elt,[type,name,tag],cdownFun], +; ['case,['(Boolean),name,tag], +; ['XLAM,["#1"],['QEQCAR,"#1",i]]]] +; for [.,tag,type] in listOfEntries for i in 0..])] where +; cdownFun() == +; gg:=GENSYM() +; $InteractiveMode => +; ['XLAM,["#1"],['PROG1,['QCDR,"#1"], +; ['check_-union,['QEQCAR,"#1",i],type,"#1"]]] +; ['XLAM,["#1"],['PROG2,['LET,gg,"#1"],['QCDR,gg], +; ['check_-union,['QEQCAR,gg,i],type,gg]]] +; [cList,e] + +(DEFUN |mkNewUnionFunList| (|name| |form| |e|) + (PROG (|listOfEntries| |dc| |tag| |type| |gg| |cList|) + (RETURN + (SEQ + (PROGN + (SPADLET |listOfEntries| (CDR |form|)) + (SPADLET |dc| |name|) + (COND ((BOOT-EQUAL |name| (QUOTE |Rep|)) (SPADLET |name| (QUOTE $)))) + (SPADLET |cList| + (CONS + (CONS + (QUOTE =) + (CONS + (CONS (CONS (QUOTE |Boolean|) NIL) (CONS |name| (CONS |name| NIL))) + (CONS (CONS (QUOTE ELT) (CONS |dc| (CONS 6 NIL))) NIL))) + (CONS + (CONS + (QUOTE |coerce|) + (CONS + (CONS |$Expression| (CONS |name| NIL)) + (CONS (CONS (QUOTE ELT) (CONS |dc| (CONS 7 NIL))) NIL))) + (PROG (#0=#:G166569) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166578 |listOfEntries| (CDR #1#)) + (#2=#:G166551 NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |tag| (CADR #2#)) + (SPADLET |type| (CADDR #2#)) + #2#) + NIL)) + #0#) + (SEQ + (EXIT + (SETQ #0# + (APPEND #0# + (CONS + (CONS + (QUOTE |construct|) + (CONS + (CONS |name| (CONS |type| NIL)) + (CONS + (CONS + (QUOTE XLAM) + (CONS + (CONS (QUOTE |#1|) NIL) + (CONS + (CONS (QUOTE CONS) (CONS |i| (CONS (QUOTE |#1|) NIL))) + NIL))) + NIL))) + (CONS + (CONS + (QUOTE |elt|) + (CONS + (CONS |type| (CONS |name| (CONS |tag| NIL))) + (CONS + (PROGN + (SPADLET |gg| (GENSYM)) + (COND + (|$InteractiveMode| + (CONS + (QUOTE XLAM) + (CONS + (CONS (QUOTE |#1|) NIL) + (CONS + (CONS + (QUOTE PROG1) + (CONS + (CONS (QUOTE QCDR) (CONS (QUOTE |#1|) NIL)) + (CONS + (CONS + (QUOTE |check-union|) + (CONS + (CONS + (QUOTE QEQCAR) + (CONS (QUOTE |#1|) (CONS |i| NIL))) + (CONS |type| (CONS (QUOTE |#1|) NIL)))) + NIL))) + NIL)))) + ((QUOTE T) + (CONS + (QUOTE XLAM) + (CONS + (CONS (QUOTE |#1|) NIL) + (CONS + (CONS + (QUOTE PROG2) + (CONS + (CONS + (QUOTE LET) + (CONS |gg| (CONS (QUOTE |#1|) NIL))) + (CONS + (CONS (QUOTE QCDR) (CONS |gg| NIL)) + (CONS + (CONS + (QUOTE |check-union|) + (CONS + (CONS + (QUOTE QEQCAR) + (CONS |gg| (CONS |i| NIL))) + (CONS |type| (CONS |gg| NIL)))) + NIL)))) + NIL)))))) + NIL))) + (CONS + (CONS + (QUOTE |case|) + (CONS + (CONS (QUOTE (|Boolean|)) (CONS |name| (CONS |tag| NIL))) + (CONS + (CONS + (QUOTE XLAM) + (CONS + (CONS (QUOTE |#1|) NIL) + (CONS + (CONS + (QUOTE QEQCAR) + (CONS (QUOTE |#1|) (CONS |i| NIL))) + NIL))) + NIL))) + NIL))))))))))))) + (CONS |cList| (CONS |e| NIL))))))) + +;mkEnumerationFunList(nam,['Enumeration,:SL],e) == +; len:= #SL +; dc := nam +; cList := +; [nil, +; ['_=,[['Boolean],nam ,nam],['ELT,dc,6]], +; ['_^_=,[['Boolean],nam ,nam],['ELT,dc,7]], +; ['coerce,[nam, ['Symbol]], ['ELT, dc, 8]], +; ['coerce,[['OutputForm],nam],['ELT,dc, 9]]] +; [substitute(nam, dc, cList),e] + +(DEFUN |mkEnumerationFunList| (|nam| #0=#:G166597 |e|) + (PROG (SL |len| |dc| |cList|) + (RETURN + (PROGN + (SPADLET SL (CDR #0#)) + (SPADLET |len| (|#| SL)) + (SPADLET |dc| |nam|) + (SPADLET |cList| + (CONS + NIL + (CONS + (CONS + (QUOTE =) + (CONS + (CONS (CONS (QUOTE |Boolean|) NIL) (CONS |nam| (CONS |nam| NIL))) + (CONS (CONS (QUOTE ELT) (CONS |dc| (CONS 6 NIL))) NIL))) + (CONS + (CONS + (QUOTE ^=) + (CONS + (CONS (CONS (QUOTE |Boolean|) NIL) (CONS |nam| (CONS |nam| NIL))) + (CONS (CONS (QUOTE ELT) (CONS |dc| (CONS 7 NIL))) NIL))) + (CONS + (CONS + (QUOTE |coerce|) + (CONS + (CONS |nam| (CONS (CONS (QUOTE |Symbol|) NIL) NIL)) + (CONS (CONS (QUOTE ELT) (CONS |dc| (CONS 8 NIL))) NIL))) + (CONS + (CONS + (QUOTE |coerce|) + (CONS + (CONS (CONS (QUOTE |OutputForm|) NIL) (CONS |nam| NIL)) + (CONS (CONS (QUOTE ELT) (CONS |dc| (CONS 9 NIL))) NIL))) + NIL)))))) + (CONS (MSUBST |nam| |dc| |cList|) (CONS |e| NIL)))))) + +;mkUnionFunList(op,form is ['Union,:listOfEntries],e) == +; first listOfEntries is [":",.,.] => mkNewUnionFunList(op,form,e) +; -- following call to order is a bug, but needs massive recomp to fix +; listOfEntries:= orderUnionEntries listOfEntries +; --1. create representations of subtypes +; predList:= mkPredList listOfEntries +; g:=GENSYM() +; --2. create coercions from subtypes to subUnion +; cList:= +; [['_=,[['Boolean],g ,g],['ELT,op,6]], +; ['coerce,[$Expression,g],['ELT,op,7]],: +; ("append"/ +; [[['autoCoerce,[g,t],upFun], +; ['coerce,[t,g],cdownFun], +; ['autoCoerce,[t,g],downFun], --this should be removed eventually +; ['case,['(Boolean),g,t],typeFun]] +; for p in predList for t in listOfEntries])] where +; upFun() == +; p is ['EQCAR,x,n] => ['XLAM,["#1"],['CONS,n,"#1"]] +; ['XLAM,["#1"],"#1"] +; cdownFun() == +; gg:=GENSYM() +; if p is ['EQCAR,x,n] then +; ref:=['QCDR,gg] +; q:= ['QEQCAR, gg, n] +; else +; ref:=gg +; q:= substitute(gg,"#1",p) +; ['XLAM,["#1"],['PROG2,['LET,gg,"#1"],ref, +; ['check_-union,q,t,gg]]] +; downFun() == +; p is ['EQCAR,x,.] => +; ['XLAM,["#1"],['QCDR,"#1"]] +; ['XLAM,["#1"],"#1"] +; typeFun() == +; p is ['EQCAR,x,n] => +; ['XLAM,["#1"],['QEQCAR,x,n]] +; ['XLAM,["#1"],p] +; op:= +; op='Rep => '$ +; op +; cList:= substitute(op,g,cList) +; [cList,e] + +(DEFUN |mkUnionFunList| (|op| |form| |e|) + (PROG (|ISTMP#3| |listOfEntries| |predList| |g| |gg| |ref| |q| + |ISTMP#1| |x| |ISTMP#2| |n| |cList|) + (RETURN + (SEQ + (PROGN + (SPADLET |listOfEntries| (CDR |form|)) + (COND + ((PROGN (SPADLET |ISTMP#1| (CAR |listOfEntries|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |:|)) + (PROGN (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL))))))) + (|mkNewUnionFunList| |op| |form| |e|)) + ((QUOTE T) + (SPADLET |listOfEntries| (|orderUnionEntries| |listOfEntries|)) + (SPADLET |predList| (|mkPredList| |listOfEntries|)) + (SPADLET |g| (GENSYM)) + (SPADLET |cList| + (CONS + (CONS + (QUOTE =) + (CONS + (CONS (CONS (QUOTE |Boolean|) NIL) (CONS |g| (CONS |g| NIL))) + (CONS (CONS (QUOTE ELT) (CONS |op| (CONS 6 NIL))) NIL))) + (CONS + (CONS + (QUOTE |coerce|) + (CONS + (CONS |$Expression| (CONS |g| NIL)) + (CONS (CONS (QUOTE ELT) (CONS |op| (CONS 7 NIL))) NIL))) + (PROG (#0=#:G166754) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166789 |predList| (CDR #1#)) + (|p| NIL) + (#2=#:G166790 |listOfEntries| (CDR #2#)) + (|t| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |p| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |t| (CAR #2#)) NIL)) + #0#) + (SEQ + (EXIT + (SETQ #0# + (APPEND #0# + (CONS + (CONS + (QUOTE |autoCoerce|) + (CONS + (CONS |g| (CONS |t| NIL)) + (CONS + (COND + ((AND + (PAIRP |p|) + (EQ (QCAR |p|) (QUOTE EQCAR)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (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 |n| (QCAR |ISTMP#2|)) + (QUOTE T))))))) + (CONS + (QUOTE XLAM) + (CONS + (CONS (QUOTE |#1|) NIL) + (CONS + (CONS + (QUOTE CONS) + (CONS |n| (CONS (QUOTE |#1|) NIL))) + NIL)))) + ((QUOTE T) + (CONS + (QUOTE XLAM) + (CONS + (CONS (QUOTE |#1|) NIL) + (CONS (QUOTE |#1|) NIL))))) + NIL))) + (CONS + (CONS + (QUOTE |coerce|) + (CONS + (CONS |t| (CONS |g| NIL)) + (CONS + (PROGN + (SPADLET |gg| (GENSYM)) + (COND + ((AND + (PAIRP |p|) + (EQ (QCAR |p|) (QUOTE EQCAR)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (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 |n| (QCAR |ISTMP#2|)) + (QUOTE T))))))) + (SPADLET |ref| (CONS (QUOTE QCDR) (CONS |gg| NIL))) + (SPADLET |q| + (CONS (QUOTE QEQCAR) (CONS |gg| (CONS |n| NIL))))) + ((QUOTE T) + (SPADLET |ref| |gg|) + (SPADLET |q| (MSUBST |gg| (QUOTE |#1|) |p|)))) + (CONS + (QUOTE XLAM) + (CONS + (CONS (QUOTE |#1|) NIL) + (CONS + (CONS + (QUOTE PROG2) + (CONS + (CONS + (QUOTE LET) + (CONS |gg| (CONS (QUOTE |#1|) NIL))) + (CONS + |ref| + (CONS + (CONS + (QUOTE |check-union|) + (CONS |q| (CONS |t| (CONS |gg| NIL)))) + NIL)))) + NIL)))) + NIL))) + (CONS + (CONS + (QUOTE |autoCoerce|) + (CONS + (CONS |t| (CONS |g| NIL)) + (CONS + (COND + ((AND + (PAIRP |p|) + (EQ (QCAR |p|) (QUOTE EQCAR)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (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)))))) + (CONS + (QUOTE XLAM) + (CONS + (CONS (QUOTE |#1|) NIL) + (CONS + (CONS (QUOTE QCDR) (CONS (QUOTE |#1|) NIL)) + NIL)))) + ((QUOTE T) + (CONS + (QUOTE XLAM) + (CONS + (CONS (QUOTE |#1|) NIL) + (CONS (QUOTE |#1|) NIL))))) + NIL))) + (CONS + (CONS + (QUOTE |case|) + (CONS + (CONS (QUOTE (|Boolean|)) (CONS |g| (CONS |t| NIL))) + (CONS + (COND + ((AND + (PAIRP |p|) + (EQ (QCAR |p|) (QUOTE EQCAR)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (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 |n| (QCAR |ISTMP#2|)) + (QUOTE T))))))) + (CONS + (QUOTE XLAM) + (CONS + (CONS (QUOTE |#1|) NIL) + (CONS + (CONS (QUOTE QEQCAR) (CONS |x| (CONS |n| NIL))) + NIL)))) + ((QUOTE T) + (CONS + (QUOTE XLAM) + (CONS (CONS (QUOTE |#1|) NIL) (CONS |p| NIL))))) + NIL))) + NIL)))))))))))))) + (SPADLET |op| + (COND + ((BOOT-EQUAL |op| (QUOTE |Rep|)) (QUOTE $)) + ((QUOTE T) |op|))) + (SPADLET |cList| (MSUBST |op| |g| |cList|)) + (CONS |cList| (CONS |e| NIL))))))))) + +@ +\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 dc016cb..8d91800 100644 --- a/src/interp/debugsys.lisp.pamphlet +++ b/src/interp/debugsys.lisp.pamphlet @@ -87,7 +87,7 @@ loaded by hand we need to establish a value. (thesymb "/int/interp/vmlisp.lisp") (thesymb "/int/interp/astr.lisp") (thesymb "/int/interp/alql.lisp") - (thesymb "/int/interp/buildom.clisp") + (thesymb "/int/interp/buildom.lisp") (thesymb "/int/interp/cattable.clisp") (thesymb "/int/interp/cformat.clisp") (thesymb (concatenate 'string "/obj/" *sys* "/interp/cfuns.o"))