* Makefile.pamphlet (${DEPSYS}): Depend on g-error.$(FASLEXT),

g-boot.$(FASLEXT), c-util.$(FASLEXT), clam.$(FASLEXT), slam.$(FASLEXT). (slam.$(FASLEXT)): New rule. (clam.$(FASLEXT)): Likewise. (g-boot.$(FASLEXT)): Likewise. (g-error.$(FASLEXT)): Likewise. (c-util.$(FASLEXT)): Likewise. (<<c-util.lisp (OUT from IN)>>): Remove. (<<c-util.clisp>>): Likewise. * c-util.boot.pamphlet: Remove cached Lisp translation. Push into package "BOOT". Fix syntax. Remove unused functions. * clam.boot.pamphlet: Push into package "BOOT". Fix syntax. * g-error.boot.package: Likewise. * g-boot.boot.pamphlet: Push into package "BOOT". * slam.boot.pamphlet: Likewise. * sys-global.boot (CHR): Define. (TOK): Likewise.
author: dos-reis <gdr@axiomatics.org> 2007-10-14 14:31:06 +0000
committer: dos-reis <gdr@axiomatics.org> 2007-10-14 14:31:06 +0000
commit: c74ed936d96536336650b13fe21e79e0db7a2da4 (patch)
tree: bbe9c68519f6ca0d06af7561f114b0ce501b0605 /src/interp
parent: 095703f8cc7439cddda478b12667c5ac8264b6d5 (diff)
download: open-axiom-c74ed936d96536336650b13fe21e79e0db7a2da4.tar.gz
9 files changed, 99 insertions, 1437 deletions
diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog
index 794f83d8..60c5597e 100644
--- a/src/interp/ChangeLog
+++ b/src/interp/ChangeLog
@@ -1,5 +1,26 @@
 2007-10-14  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	* Makefile.pamphlet (${DEPSYS}): Depend on g-error.$(FASLEXT),
+	g-boot.$(FASLEXT), c-util.$(FASLEXT), clam.$(FASLEXT),
+	slam.$(FASLEXT).  
+	(slam.$(FASLEXT)): New rule.
+	(clam.$(FASLEXT)): Likewise.
+	(g-boot.$(FASLEXT)): Likewise.
+	(g-error.$(FASLEXT)): Likewise.
+	(c-util.$(FASLEXT)): Likewise.
+	(<<c-util.lisp (OUT from IN)>>): Remove.
+	(<<c-util.clisp>>): Likewise.
+	* c-util.boot.pamphlet: Remove cached Lisp translation.
+	Push into package "BOOT". Fix syntax. Remove unused functions.
+	* clam.boot.pamphlet: Push into package "BOOT". Fix syntax.
+	* g-error.boot.package: Likewise.
+	* g-boot.boot.pamphlet: Push into package "BOOT".
+	* slam.boot.pamphlet: Likewise.
+	* sys-global.boot (CHR): Define.
+	(TOK): Likewise.
+
+2007-10-14  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
 	* Makefile.pamphlet: Compile Boot code with --boot=old.
 	(bc-solve.$(FASLEXT)): New rule.
 	(bc-matrix.$(FASLEXT)): Likewise.
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 2bc50802..fb5347da 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -314,11 +314,12 @@ ${DEPSYS}:	vmlisp.$(FASLEXT) \
 	        postprop.$(FASLEXT)\
 		def.$(FASLEXT) \
 	        fnewmeta.$(FASLEXT) \
-		g-error.clisp \
-	        g-boot.clisp c-util.${LISP} \
+		g-error.$(FASLEXT) \
+	        g-boot.$(FASLEXT) \
+		c-util.$(FASLEXT) \
 	        g-util.$(FASLEXT) \
-	        clam.clisp \
-	        slam.clisp
+	        clam.$(FASLEXT) \
+	        slam.$(FASLEXT)
 	@ echo 3 making ${DEPSYS} 
 	@ rm -f makedep.lisp
 	@ $(mkinstalldirs) $(axiom_build_bindir)
@@ -347,21 +348,14 @@ ${DEPSYS}:	vmlisp.$(FASLEXT) \
 	@ echo '(|importModule| "bootlex")' >> makedep.lisp
 	@ echo '(|importModule| "postprop")' >> makedep.lisp
 	@ echo '(|importModule| "postpar")' >> makedep.lisp
-	@ echo '(unless (probe-file "clam.$(FASLEXT)") (|compileLispFile| "clam.clisp" "clam.$(FASLEXT)"))' >> makedep.lisp
-	@ echo '(load "clam")' >> makedep.lisp
-	@ echo '(unless (probe-file "slam.$(FASLEXT)") (|compileLispFile| "slam.clisp" "slam.$(FASLEXT)"))' >> makedep.lisp
-	@ echo '(load "slam")' >> makedep.lisp
-	@ echo '(unless (probe-file "g-error.$(FASLEXT)") (|compileLispFile| "g-error.clisp" "g-error.$(FASLEXT)"))' >> makedep.lisp
-	@ echo '(load "g-error")' >> makedep.lisp
-	@ echo '(unless (probe-file "g-boot.$(FASLEXT)") (|compileLispFile| "g-boot.clisp" "g-boot.$(FASLEXT)"))' >> makedep.lisp
-	@ echo '(load "g-boot")' >> makedep.lisp
-	@ echo '(unless (probe-file "c-util.$(FASLEXT)") (|compileLispFile| "c-util.${LISP}" "c-util.$(FASLEXT)"))' >> makedep.lisp
-	@ echo '(load "c-util")' >> makedep.lisp
+	@ echo '(|importModule| "clam")' >> makedep.lisp
+	@ echo '(|importModule| "slam")' >> makedep.lisp
+	@ echo '(|importModule| "g-error")' >> makedep.lisp
+	@ echo '(|importModule| "g-boot")' >> makedep.lisp
+	@ echo '(|importModule| "c-util")' >> makedep.lisp
 	@ echo '(|importModule| "g-util")' >> makedep.lisp
 	../lisp/base-lisp$(EXEEXT) -- --make --output=$@ \
 		--load-directory=. makedep.lisp
-	@rm $(addsuffix .$(FASLEXT), \
-		clam slam g-error g-boot c-util)
 	@ echo 4 ${DEPSYS} created
 
 
@@ -555,12 +549,27 @@ dq.$(FASLEXT): dq.boot boot-pkg.$(FASLEXT)
 
 ## General support and utilities.
 
+slam.$(FASLEXT): slam.boot g-timer.$(FASLEXT)
+	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+clam.$(FASLEXT): clam.boot g-timer.$(FASLEXT)
+	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
 g-opt.$(FASLEXT): g-opt.boot def.$(FASLEXT)
 	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
 
 g-timer.$(FASLEXT): g-timer.boot macros.$(FASLEXT) g-util.$(FASLEXT)
 	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
 
+g-boot.$(FASLEXT): g-boot.boot def.$(FASLEXT) g-util.$(FASLEXT)
+	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+g-error.$(FASLEXT): g-error.boot diagnostics.$(FASLEXT) g-util.$(FASLEXT)
+	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+c-util.$(FASLEXT): c-util.boot g-util.$(FASLEXT)
+	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
 g-util.$(FASLEXT): g-util.boot macros.$(FASLEXT)
 	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
 
@@ -652,16 +661,6 @@ compiler.clisp: compiler.boot
 	@ echo 233 making $@ from $<
 	@ echo '(old-boot::boot "compiler.boot")' | ${DEPSYS}
 
-c-util.${LISP}: $(srcdir)/c-util.boot.pamphlet
-	@ echo 146 making c-util.${LISP} from $(srcdir)/c-util.boot.pamphlet
-	@ rm -f c-util.$(FASLEXT)
-	$(axiom_build_document) --tangle=c-util.clisp --output=$@ $<
-
-c-util.clisp: c-util.boot
-	@ echo 148 making $@ from $<
-	@ echo '(progn (old-boot::boot "c-util.boot"))' | ${DEPSYS}
-
-
 database.clisp: database.boot
 	@ echo 243 making $@ from $<
 	@ echo '(old-boot::boot "database.boot")' | ${DEPSYS}
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index eac7db36..ccc23091 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -940,11 +940,12 @@ ${DEPSYS}:	vmlisp.$(FASLEXT) \
 	        postprop.$(FASLEXT)\
 		def.$(FASLEXT) \
 	        fnewmeta.$(FASLEXT) \
-		g-error.clisp \
-	        g-boot.clisp c-util.${LISP} \
+		g-error.$(FASLEXT) \
+	        g-boot.$(FASLEXT) \
+		c-util.$(FASLEXT) \
 	        g-util.$(FASLEXT) \
-	        clam.clisp \
-	        slam.clisp
+	        clam.$(FASLEXT) \
+	        slam.$(FASLEXT)
 	@ echo 3 making ${DEPSYS} 
 	@ rm -f makedep.lisp
 	@ $(mkinstalldirs) $(axiom_build_bindir)
@@ -973,20 +974,13 @@ ${DEPSYS}:	vmlisp.$(FASLEXT) \
 	@ echo '(|importModule| "bootlex")' >> makedep.lisp
 	@ echo '(|importModule| "postprop")' >> makedep.lisp
 	@ echo '(|importModule| "postpar")' >> makedep.lisp
-	@ echo '(unless (probe-file "clam.$(FASLEXT)") (|compileLispFile| "clam.clisp" "clam.$(FASLEXT)"))' >> makedep.lisp
-	@ echo '(load "clam")' >> makedep.lisp
-	@ echo '(unless (probe-file "slam.$(FASLEXT)") (|compileLispFile| "slam.clisp" "slam.$(FASLEXT)"))' >> makedep.lisp
-	@ echo '(load "slam")' >> makedep.lisp
-	@ echo '(unless (probe-file "g-error.$(FASLEXT)") (|compileLispFile| "g-error.clisp" "g-error.$(FASLEXT)"))' >> makedep.lisp
-	@ echo '(load "g-error")' >> makedep.lisp
-	@ echo '(unless (probe-file "g-boot.$(FASLEXT)") (|compileLispFile| "g-boot.clisp" "g-boot.$(FASLEXT)"))' >> makedep.lisp
-	@ echo '(load "g-boot")' >> makedep.lisp
-	@ echo '(unless (probe-file "c-util.$(FASLEXT)") (|compileLispFile| "c-util.${LISP}" "c-util.$(FASLEXT)"))' >> makedep.lisp
-	@ echo '(load "c-util")' >> makedep.lisp
+	@ echo '(|importModule| "clam")' >> makedep.lisp
+	@ echo '(|importModule| "slam")' >> makedep.lisp
+	@ echo '(|importModule| "g-error")' >> makedep.lisp
+	@ echo '(|importModule| "g-boot")' >> makedep.lisp
+	@ echo '(|importModule| "c-util")' >> makedep.lisp
 	@ echo '(|importModule| "g-util")' >> makedep.lisp
 <<save depsys image>>
-	@rm $(addsuffix .$(FASLEXT), \
-		clam slam g-error g-boot c-util)
 	@ echo 4 ${DEPSYS} created
 
 
@@ -1097,32 +1091,6 @@ fortcall.clisp: fortcall.boot
 
 @
 
-\subsection{c-util.boot \cite{42}}
-
-Note that the {\bf c-util.boot.pamphlet} file contains both the
-original {\bf boot} code and a saved copy of the {\bf c-util.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 WELL: IF YOU CHANGE THE BOOT CODE IN C-UTIL.BOOT.PAMPHLET
-YOU MUST TRANSLATE THIS CODE TO LISP AND STORE THE RESULTING LISP
-CODE BACK INTO THE C-UTIL.BOOT.PAMPHLET FILE. THIS IS NOT AUTOMATED.}
-<<c-util.lisp (OUT from IN)>>=
-c-util.${LISP}: $(srcdir)/c-util.boot.pamphlet
-	@ echo 146 making c-util.${LISP} from $(srcdir)/c-util.boot.pamphlet
-	@ rm -f c-util.$(FASLEXT)
-	$(axiom_build_document) --tangle=c-util.clisp --output=$@ $<
-
-@
-<<c-util.clisp>>=
-c-util.clisp: c-util.boot
-	@ echo 148 making $@ from $<
-	@ echo '(progn (old-boot::boot "c-util.boot"))' | ${DEPSYS}
-
-@
-
-
 \subsection{category.boot \cite{58}}
 
 <<category.clisp>>=
@@ -1765,12 +1733,27 @@ dq.$(FASLEXT): dq.boot boot-pkg.$(FASLEXT)
 
 ## General support and utilities.
 
+slam.$(FASLEXT): slam.boot g-timer.$(FASLEXT)
+	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+clam.$(FASLEXT): clam.boot g-timer.$(FASLEXT)
+	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
 g-opt.$(FASLEXT): g-opt.boot def.$(FASLEXT)
 	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
 
 g-timer.$(FASLEXT): g-timer.boot macros.$(FASLEXT) g-util.$(FASLEXT)
 	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
 
+g-boot.$(FASLEXT): g-boot.boot def.$(FASLEXT) g-util.$(FASLEXT)
+	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+g-error.$(FASLEXT): g-error.boot diagnostics.$(FASLEXT) g-util.$(FASLEXT)
+	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
+c-util.$(FASLEXT): c-util.boot g-util.$(FASLEXT)
+	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
+
 g-util.$(FASLEXT): g-util.boot macros.$(FASLEXT)
 	$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
 
@@ -1836,9 +1819,6 @@ boot-pkg.$(FASLEXT): boot-pkg.lisp
 
 <<compiler.clisp>>
 
-<<c-util.lisp (OUT from IN)>>
-<<c-util.clisp>>
-
 <<database.clisp>>
 
 <<define.clisp>>
diff --git a/src/interp/c-util.boot.pamphlet b/src/interp/c-util.boot.pamphlet
index ceae86d1..63808037 100644
--- a/src/interp/c-util.boot.pamphlet
+++ b/src/interp/c-util.boot.pamphlet
@@ -12,17 +12,6 @@
 \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 c-util.clisp} section below.
 \section{License}
 <<license>>=
 -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
@@ -60,6 +49,9 @@ See the {\bf c-util.clisp} section below.
 <<*>>=
 <<license>>
 
+import '"g-util"
+)package "BOOT"
+
 --% Debugging Functions
  
 CONTINUE() == continue()
@@ -156,7 +148,7 @@ unErrorRef s == unStackWarning ['%b,s,'%d,'"has no value"]
  
 consProplistOf(var,proplist,prop,val) ==
   semchkProplist(var,proplist,prop,val)
-  $InteractiveMode and (u:= ASSOC(prop,proplist)) =>
+  $InteractiveMode and (u:= assoc(prop,proplist)) =>
     RPLACD(u,val)
     proplist
   [[prop,:val],:proplist]
@@ -214,15 +206,15 @@ intersectionContour(c,c') ==
       --3. property="mode" is covered by modeCompare
       prop="mode" => nil
     modeCompare(p,p') ==
-      pair:= ASSOC("mode",p) =>
-        pair':= ASSOC("mode",p') =>
+      pair:= assoc("mode",p) =>
+        pair':= assoc("mode",p') =>
           m'':= unifiable(rest pair,rest pair') => LIST ["mode",:m'']
           stackSemanticError(['%b,$var,'%d,"has two modes: "],nil)
        --stackWarning ("mode for",'%b,$var,'%d,"introduced conditionally")
         LIST ["conditionalmode",:rest pair]
         --LIST pair
        --stackWarning ("mode for",'%b,$var,'%d,"introduced conditionally")
-      pair':= ASSOC("mode",p') => LIST ["conditionalmode",:rest pair']
+      pair':= assoc("mode",p') => LIST ["conditionalmode",:rest pair']
         --LIST pair'
     unifiable(m1,m2) ==
       m1=m2 => m1
@@ -407,7 +399,7 @@ isAlmostSimple x ==
         op="LET" =>
           IDENTP y => (setAssignment LIST x; y)
           true => (setAssignment [["LET",g:= genVariable(),:l],["LET",y,g]]; g)
-        isSideEffectFree op => [op,:mapInto(rest x,"fn")]
+        isSideEffectFree op => [op,:mapInto(rest x, function fn)]
         true => $assignmentList:= "failed"
       setAssignment x ==
         $assignmentList="failed" => nil
@@ -549,7 +541,7 @@ pmatch(s,p) == pmatchWithSl(s,p,"ok")
 pmatchWithSl(s,p,al) ==
   s=$EmptyMode => nil
   s=p => al
-  v:= ASSOC(p,al) => s=rest v or al
+  v:= assoc(p,al) => s=rest v or al
   MEMQ(p,$PatternVariableList) => [[p,:s],:al]
   null atom p and null atom s and (al':= pmatchWithSl(first s,first p,al)) and
     pmatchWithSl(rest s,rest p,al')
@@ -590,12 +582,12 @@ extendsCategoryForm(domain,form,form') ==
     formVec:=(compMakeCategoryObject(form,$e)).expr
             --Must be $e to pick up locally bound domains
     form' is ["SIGNATURE",op,args,:.] =>
-        ASSOC([op,args],formVec.(1)) or
-            ASSOC(SUBSTQ(domain,"$",[op,args]),
+        assoc([op,args],formVec.(1)) or
+            assoc(SUBSTQ(domain,"$",[op,args]),
                   SUBSTQ(domain,"$",formVec.(1)))
     form' is ["ATTRIBUTE",at] =>
-         ASSOC(at,formVec.2) or
-            ASSOC(SUBSTQ(domain,"$",at),SUBSTQ(domain,"$",formVec.2))
+         assoc(at,formVec.2) or
+            assoc(SUBSTQ(domain,"$",at),SUBSTQ(domain,"$",formVec.2))
     form' is ["IF",:.] => true --temporary hack so comp won't fail
     -- Are we dealing with an Aldor category?  If so use the "has" function ...
     # formVec = 1 => newHasTest(form,form')
@@ -736,1349 +728,11 @@ displayModemaps E ==
  
 --% General object traversal functions
  
-GEQSUBSTLIST(old, new, body) ==
-    GEQNSUBSTLIST(old, new, GCOPY body)
- 
-GEQNSUBSTLIST(old, new, body) ==
-    or/[:[EQ(o,n) for o in old] for n in new] =>
-        mid := [GENSYM() for o in old]
-        GEQNSUBSTLIST(old, mid, body)
-        GEQNSUBSTLIST(mid, new, body)
-    alist := [[o,:n] for o in old for n in new]
-    traverse(function GSUBSTinner, alist, body) where
-        GSUBSTinner(alist, ob) ==
-            (pr := ASSQ(ob, alist)) => CDR pr
-            ob
- 
 GCOPY ob == COPY ob  -- for now
  
-traverse(fn, arg, ob) ==
-    $seen:    local := MAKE_-HASHTABLE 'EQ
-    $notseen: local := GENSYM()
- 
-    traverseInner(ob, fn, arg) where
-        traverseInner(ob, fn, arg) ==
-            e := HGET($seen, ob, $notseen)
-            not EQ(e, $notseen) => e
- 
-            nob := FUNCALL(fn, arg, ob)
-            HPUT($seen, ob, nob)
-            not EQ(nob, ob) => nob
-            PAIRP ob =>
-                ne:=traverseInner(QCAR ob, fn, arg)
-                if not EQ(ne,QCAR ob) then QRPLACA(ob, ne)
-                ne:=traverseInner(QCDR ob, fn, arg)
-                if not EQ(ne,QCDR ob) then QRPLACD(ob, ne)
-                ob
-            VECP ob =>
-                n := QVMAXINDEX ob
-                for i in 0..n repeat
-                    e:=QVELT(ob,i)
-                    ne:=traverseInner(e, fn, arg)
-                    if not EQ(ne,e) then QSETVELT(ob,i,ne)
-                ob
-            HASHTABLEP ob =>
-                keys := HKEYS ob
-                for k in keys repeat
-                    e  := HGET(ob, k)
-                    nk := traverseInner(k, fn, arg)
-                    ne := traverseInner(e, fn, arg)
-                    if not EQ(k,nk) or not EQ(e,ne) then
-                        HREM(ob, k)
-                        HPUT(ob, nk, ne)
-                ob
-            PAPPP ob =>
-                for i in 1..PA_-SPEC_-COUNT ob repeat
-                    s := PA_-SPEC(ob, i)
-                    not PAIRP s =>
-                        ns := traverseInner(s,fn,arg)
-                        if not EQ(s,ns) then
-                            SET_-PA_-SPEC(ob,i,ns)
-                    ns := traverseInner(QCDR s, fn, arg)
-                    if not EQ(ns,QCDR s) then
-                       apply(SET_-PA_-SPEC, [ob,i,QCAR s,:ns])
-                ob
-            ob
 @
-\section{c-util.clisp}
-<<c-util.clisp>>=
-
-(IN-PACKAGE "BOOT" )
-
-;
-;--% Debugging Functions
-;
-;CONTINUE() == continue()
-
-;;;     ***       CONTINUE REDEFINED
-
-(DEFUN CONTINUE NIL (|continue|)) 
-;continue() == FIN comp($x,$m,$f)
-
-;;;     ***       |continue| REDEFINED
-
-(DEFUN |continue| NIL (FIN (|comp| |$x| |$m| |$f|))) 
-;
-;LEVEL(:l) == APPLY('level,l)
-
-;;;     ***       LEVEL REDEFINED
-
-(DEFUN LEVEL (&REST #0=#:G2489 &AUX |l|) (DSETQ |l| #0#) (APPLY (QUOTE |level|) |l|)) 
-;level(:l) ==
-;  null l => same()
-;  l is [n] and INTEGERP n => displayComp ($level:= n)
-;  SAY '"Correct format: (level n) where n is the level you want to go to"
-
-;;;     ***       |level| REDEFINED
-
-(DEFUN |level| (&REST #0=#:G2496 &AUX |l|) (DSETQ |l| #0#) (PROG (|n|) (RETURN (COND ((NULL |l|) (|same|)) ((AND (PAIRP |l|) (EQ (QCDR |l|) NIL) (PROGN (SPADLET |n| (QCAR |l|)) (QUOTE T)) (INTEGERP |n|)) (|displayComp| (SPADLET |$level| |n|))) ((QUOTE T) (SAY (MAKESTRING "Correct format: (level n) where n is the level you want to go to"))))))) 
-;
-;UP() == up()
-
-;;;     ***       UP REDEFINED
-
-(DEFUN UP NIL (|up|)) 
-;up() == displayComp ($level:= $level-1)
-
-;;;     ***       |up| REDEFINED
-
-(DEFUN |up| NIL (|displayComp| (SPADLET |$level| (SPADDIFFERENCE |$level| 1)))) 
-;
-;SAME() == same()
-
-;;;     ***       SAME REDEFINED
-
-(DEFUN SAME NIL (|same|)) 
-;same() == displayComp $level
-
-;;;     ***       |same| REDEFINED
-
-(DEFUN |same| NIL (|displayComp| |$level|)) 
-;
-;DOWN() == down()
-
-;;;     ***       DOWN REDEFINED
-
-(DEFUN DOWN NIL (|down|)) 
-;down() == displayComp ($level:= $level+1)
-
-;;;     ***       |down| REDEFINED
-
-(DEFUN |down| NIL (|displayComp| (SPADLET |$level| (PLUS |$level| 1)))) 
-;
-;displaySemanticErrors() ==
-;  n:= #($semanticErrorStack:= REMDUP $semanticErrorStack)
-;  n=0 => nil
-;  l:= NREVERSE $semanticErrorStack
-;  $semanticErrorStack:= nil
-;  sayBrightly bright '"  Semantic Errors:"
-;  displaySemanticError(l,CUROUTSTREAM)
-;  sayBrightly '" "
-;  displayWarnings()
-
-;;;     ***       |displaySemanticErrors| REDEFINED
-
-(DEFUN |displaySemanticErrors| NIL (PROG (|n| |l|) (RETURN (PROGN (SPADLET |n| (|#| (SPADLET |$semanticErrorStack| (REMDUP |$semanticErrorStack|)))) (COND ((EQL |n| 0) NIL) ((QUOTE T) (SPADLET |l| (NREVERSE |$semanticErrorStack|)) (SPADLET |$semanticErrorStack| NIL) (|sayBrightly| (|bright| (MAKESTRING "  Semantic Errors:"))) (|displaySemanticError| |l| CUROUTSTREAM) (|sayBrightly| (MAKESTRING " ")) (|displayWarnings|))))))) 
-;
-;displaySemanticError(l,stream) ==
-;  for x in l for i in 1.. repeat
-;    sayBrightly(['"      [",i,'"] ",:first x],stream)
-
-;;;     ***       |displaySemanticError| REDEFINED
-
-(DEFUN |displaySemanticError| (|l| |stream|) (SEQ (DO ((#0=#:G2529 |l| (CDR #0#)) (|x| NIL) (|i| 1 (QSADD1 |i|))) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (|sayBrightly| (CONS (MAKESTRING "      [") (CONS |i| (CONS (MAKESTRING "] ") (CAR |x|)))) |stream|)))))) 
-;
-;displayWarnings() ==
-;  n:= #($warningStack:= REMDUP $warningStack)
-;  n=0 => nil
-;  sayBrightly bright '"  Warnings:"
-;  l := NREVERSE $warningStack
-;  displayWarning(l,CUROUTSTREAM)
-;  $warningStack:= nil
-;  sayBrightly '" "
-
-;;;     ***       |displayWarnings| REDEFINED
-
-(DEFUN |displayWarnings| NIL (PROG (|n| |l|) (RETURN (PROGN (SPADLET |n| (|#| (SPADLET |$warningStack| (REMDUP |$warningStack|)))) (COND ((EQL |n| 0) NIL) ((QUOTE T) (|sayBrightly| (|bright| (MAKESTRING "  Warnings:"))) (SPADLET |l| (NREVERSE |$warningStack|)) (|displayWarning| |l| CUROUTSTREAM) (SPADLET |$warningStack| NIL) (|sayBrightly| (MAKESTRING " ")))))))) 
-;
-;displayWarning(l,stream) ==
-;  for x in l for i in 1.. repeat
-;    sayBrightly(['"      [",i,'"] ",:x],stream)
-
-;;;     ***       |displayWarning| REDEFINED
-
-(DEFUN |displayWarning| (|l| |stream|) (SEQ (DO ((#0=#:G2550 |l| (CDR #0#)) (|x| NIL) (|i| 1 (QSADD1 |i|))) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (|sayBrightly| (CONS (MAKESTRING "      [") (CONS |i| (CONS (MAKESTRING "] ") |x|))) |stream|)))))) 
-;
-;displayComp level ==
-;  $bright:= " << "
-;  $dim:= " >> "
-;  if $insideCapsuleFunctionIfTrue=true then
-;    sayBrightly ['"error in function",'%b,$op,'%d,'%l]
-;  --mathprint removeZeroOne mkErrorExpr level
-;  pp removeZeroOne mkErrorExpr level
-;  sayBrightly ['"****** level",'%b,level,'%d,'" ******"]
-;  [$x,$m,$f,$exitModeStack]:= ELEM($s,level)
-;  ($X:=$x;$M:=$m;$F:=$f)
-;  SAY("$x:= ",$x)
-;  SAY("$m:= ",$m)
-;  SAY "$f:="
-;  F_,PRINT_-ONE $f
-;  nil
-
-;;;     ***       |displayComp| REDEFINED
-
-(DEFUN |displayComp| (|level|) (PROG (|LETTMP#1|) (RETURN (PROGN (SPADLET |$bright| (QUOTE | << |)) 
-(SPADLET |$dim| (QUOTE | >> |)) (COND ((BOOT-EQUAL |$insideCapsuleFunctionIfTrue| (QUOTE T)) (|sayBrightly| (CONS (MAKESTRING "error in function") (CONS (QUOTE |%b|) (CONS |$op| (CONS (QUOTE |%d|) (CONS (QUOTE |%l|) NIL)))))))) (|pp| (|removeZeroOne| (|mkErrorExpr| |level|))) (|sayBrightly| (CONS (MAKESTRING "****** level") (CONS (QUOTE |%b|) (CONS |level| (CONS (QUOTE |%d|) (CONS (MAKESTRING " ******") NIL)))))) (SPADLET |LETTMP#1| (ELEM |$s| |level|)) (SPADLET |$x| (CAR |LETTMP#1|)) (SPADLET |$m| (CADR |LETTMP#1|)) (SPADLET |$f| (CADDR |LETTMP#1|)) (SPADLET |$exitModeStack| (CADDDR |LETTMP#1|)) (SPADLET $X |$x|) (SPADLET $M |$m|) (SPADLET $F |$f|) (SAY (MAKESTRING "$x:= ") |$x|) (SAY (MAKESTRING "$m:= ") |$m|) (SAY (MAKESTRING "$f:=")) (|F,PRINT-ONE| |$f|) NIL)))) 
-;
-;mkErrorExpr level ==
-;  bracket ASSOCLEFT DROP(level-#$s,$s) where
-;    bracket l ==
-;      #l<2 => l
-;      l is [a,b] =>
-;        highlight(b,a) where
-;          highlight(b,a) ==
-;            atom b =>
-;              substitute(var,b,a) where
-;                var:= INTERN STRCONC(STRINGIMAGE $bright,STRINGIMAGE b,STRINGIMAGE $dim)
-;            highlight1(b,a) where
-;              highlight1(b,a) ==
-;                atom a => a
-;                a is [ =b,:c] => [$bright,b,$dim,:c]
-;                [highlight1(b,first a),:highlight1(b,rest a)]
-;      substitute(bracket rest l,first rest l,first l)
-
-;;;     ***       |mkErrorExpr,highlight1| REDEFINED
-
-(DEFUN |mkErrorExpr,highlight1| (|b| |a|) (PROG (|c|) (RETURN (SEQ (IF (ATOM |a|) (EXIT |a|)) (IF (AND (PAIRP |a|) (EQUAL (QCAR |a|) |b|) (PROGN (SPADLET |c| (QCDR |a|)) (QUOTE T))) (EXIT (CONS |$bright| (CONS |b| (CONS |$dim| |c|))))) (EXIT (CONS (|mkErrorExpr,highlight1| |b| (CAR |a|)) (|mkErrorExpr,highlight1| |b| (CDR |a|)))))))) 
-
-;;;     ***       |mkErrorExpr,highlight| REDEFINED
-
-(DEFUN |mkErrorExpr,highlight| (|b| |a|) (PROG (|var|) (RETURN (SEQ (IF (ATOM |b|) (EXIT (PROGN (SPADLET |var| (INTERN (STRCONC (STRINGIMAGE |$bright|) (STRINGIMAGE |b|) (STRINGIMAGE |$dim|)))) (MSUBST |var| |b| |a|)))) (EXIT (|mkErrorExpr,highlight1| |b| |a|)))))) 
-
-;;;     ***       |mkErrorExpr,bracket| REDEFINED
-
-(DEFUN |mkErrorExpr,bracket| (|l|) (PROG (|a| |ISTMP#1| |b|) (RETURN (SEQ (IF (QSLESSP (|#| |l|) 2) (EXIT |l|)) (IF (AND (PAIRP |l|) (PROGN (SPADLET |a| (QCAR |l|)) (SPADLET |ISTMP#1| (QCDR |l|)) (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) (PROGN (SPADLET |b| (QCAR |ISTMP#1|)) (QUOTE T))))) (EXIT (|mkErrorExpr,highlight| |b| |a|))) (EXIT (MSUBST (|mkErrorExpr,bracket| (CDR |l|)) (CAR (CDR |l|)) (CAR |l|))))))) 
-
-;;;     ***       |mkErrorExpr| REDEFINED
-
-(DEFUN |mkErrorExpr| (|level|) (|mkErrorExpr,bracket| (ASSOCLEFT (DROP (SPADDIFFERENCE |level| (|#| |$s|)) |$s|)))) 
-;
-;compAndTrace [x,m,e] ==
-;  SAY("tracing comp, compFormWithModemap of: ",x)
-;  TRACE_,1(["comp","compFormWithModemap"],nil)
-;  T:= comp(x,m,e)
-;  UNTRACE_,1 "comp"
-;  UNTRACE_,1 "compFormWithModemap"
-;  T
-
-;;;     ***       |compAndTrace| REDEFINED
-
-(DEFUN |compAndTrace| (#0=#:G2621) (PROG (|x| |m| |e| T$) (RETURN (PROGN (SPADLET |x| (CAR #0#)) (SPADLET |m| (CADR #0#)) (SPADLET |e| (CADDR #0#)) (SAY (MAKESTRING "tracing comp, compFormWithModemap of: ") |x|) (|TRACE,1| (CONS (QUOTE |comp|) (CONS (QUOTE |compFormWithModemap|) NIL)) NIL) (SPADLET T$ (|comp| |x| |m| |e|)) (|UNTRACE,1| (QUOTE |comp|)) (|UNTRACE,1| (QUOTE |compFormWithModemap|)) T$)))) 
-;
-;errorRef s == stackWarning ['%b,s,'%d,'"has no value"]
-
-;;;     ***       |errorRef| REDEFINED
-
-(DEFUN |errorRef| (|s|) (|stackWarning| (CONS (QUOTE |%b|) (CONS |s| (CONS (QUOTE |%d|) (CONS (MAKESTRING "has no value") NIL)))))) 
-;
-;unErrorRef s == unStackWarning ['%b,s,'%d,'"has no value"]
-
-;;;     ***       |unErrorRef| REDEFINED
-
-(DEFUN |unErrorRef| (|s|) (|unStackWarning| (CONS (QUOTE |%b|) (CONS |s| (CONS (QUOTE |%d|) (CONS (MAKESTRING "has no value") NIL)))))) 
-;
-;--% ENVIRONMENT FUNCTIONS
-;
-;consProplistOf(var,proplist,prop,val) ==
-;  semchkProplist(var,proplist,prop,val)
-;  $InteractiveMode and (u:= ASSOC(prop,proplist)) =>
-;    RPLACD(u,val)
-;    proplist
-;  [[prop,:val],:proplist]
-
-;;;     ***       |consProplistOf| REDEFINED
-
-(DEFUN |consProplistOf| (|var| |proplist| |prop| |val|) (PROG (|u|) (RETURN (PROGN (|semchkProplist| |var| |proplist| |prop| |val|) (COND ((AND |$InteractiveMode| (SPADLET |u| (|assoc| |prop| |proplist|))) (RPLACD |u| |val|) |proplist|) ((QUOTE T) (CONS (CONS |prop| |val|) |proplist|))))))) 
-;
-;warnLiteral x ==
-;  stackSemanticError(['%b,x,'%d,
-;    '"is BOTH a variable and a literal"],nil)
-
-;;;     ***       |warnLiteral| REDEFINED
-
-(DEFUN |warnLiteral| (|x|) (|stackSemanticError| (CONS (QUOTE |%b|) (CONS |x| (CONS (QUOTE |%d|) (CONS (MAKESTRING "is BOTH a variable and a literal") NIL)))) NIL)) 
-;
-;intersectionEnvironment(e,e') ==
-;  ce:= makeCommonEnvironment(e,e')
-;  ic:= intersectionContour(deltaContour(e,ce),deltaContour(e',ce))
-;  e'':= (ic => addContour(ic,ce); ce)
-
-;;;     ***       |intersectionEnvironment| REDEFINED
-
-(DEFUN |intersectionEnvironment| (|e| |e'|) (PROG (|ce| |ic| |e''|) (RETURN (PROGN (SPADLET |ce| (|makeCommonEnvironment| |e| |e'|)) (SPADLET |ic| (|intersectionContour| (|deltaContour| |e| |ce|) (|deltaContour| |e'| |ce|))) (SPADLET |e''| (COND (|ic| (|addContour| |ic| |ce|)) ((QUOTE T) |ce|))))))) 
-;  --$ie:= e''   this line is for debugging purposes only
-;
-;deltaContour([[c,:cl],:el],[[c',:cl'],:el']) ==
-;  ^el=el' => systemError '"deltaContour" --a cop out for now
-;  eliminateDuplicatePropertyLists contourDifference(c,c') where
-;    contourDifference(c,c') == [first x for x in tails c while (x^=c')]
-;    eliminateDuplicatePropertyLists contour ==
-;      contour is [[x,:.],:contour'] =>
-;        LASSOC(x,contour') =>
-;                               --save some CONSing if possible
-;          [first contour,:DELLASOS(x,eliminateDuplicatePropertyLists contour')]
-;        [first contour,:eliminateDuplicatePropertyLists contour']
-;      nil
-
-;;;     ***       |deltaContour,eliminateDuplicatePropertyLists| REDEFINED
-
-(DEFUN |deltaContour,eliminateDuplicatePropertyLists| (|contour|) (PROG (|ISTMP#1| |x| |contour'|) (RETURN (SEQ (IF (AND (PAIRP |contour|) (PROGN (SPADLET |ISTMP#1| (QCAR |contour|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |x| (QCAR |ISTMP#1|)) (QUOTE T)))) (PROGN (SPADLET |contour'| (QCDR |contour|)) (QUOTE T))) (EXIT (SEQ (IF (LASSOC |x| |contour'|) (EXIT (CONS (CAR |contour|) (DELLASOS |x| (|deltaContour,eliminateDuplicatePropertyLists| |contour'|))))) (EXIT (CONS (CAR |contour|) (|deltaContour,eliminateDuplicatePropertyLists| |contour'|)))))) (EXIT NIL))))) 
-
-;;;     ***       |deltaContour,contourDifference| REDEFINED
-
-(DEFUN |deltaContour,contourDifference| (|c| |c'|) (PROG NIL (RETURN (SEQ (PROG (#0=#:G2679) (SPADLET #0# NIL) (RETURN (DO ((|x| |c| (CDR |x|))) ((OR (ATOM |x|) (NULL (NEQUAL |x| |c'|))) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (CAR |x|) #0#))))))))))) 
-
-;;;     ***       |deltaContour| REDEFINED
-
-(DEFUN |deltaContour| (#0=#:G2695 #1=#:G2706) (PROG (|c'| |cl'| |el'| |c| |cl| |el|) (RETURN (PROGN (SPADLET |c'| (CAAR #1#)) (SPADLET |cl'| (CDAR #1#)) (SPADLET |el'| (CDR #1#)) (SPADLET |c| (CAAR #0#)) (SPADLET |cl| (CDAR #0#)) (SPADLET |el| (CDR #0#)) (COND ((NULL (BOOT-EQUAL |el| |el'|)) (|systemError| (MAKESTRING "deltaContour"))) ((QUOTE T) (|deltaContour,eliminateDuplicatePropertyLists| (|deltaContour,contourDifference| |c| |c'|)))))))) 
-;
-;intersectionContour(c,c') ==
-;  $var: local
-;  computeIntersection(c,c') where
-;    computeIntersection(c,c') ==
-;      varlist:= REMDUP ASSOCLEFT c
-;      varlist':= REMDUP ASSOCLEFT c'
-;      interVars:= setIntersection(varlist,varlist')
-;      unionVars:= setUnion(varlist,varlist')
-;      diffVars:= setDifference(unionVars,interVars)
-;      modeAssoc:= buildModeAssoc(diffVars,c,c')
-;      [:modeAssoc,:
-;        [[x,:proplist]
-;          for [x,:y] in c | MEMBER(x,interVars) and
-;            (proplist:= interProplist(y,LASSOC($var:= x,c')))]]
-;    interProplist(p,p') ==
-;                            --p is new proplist; p' is old one
-;      [:modeCompare(p,p'),:[pair' for pair in p | (pair':= compare(pair,p'))]]
-;    buildModeAssoc(varlist,c,c') ==
-;      [[x,:mp] for x in varlist | (mp:= modeCompare(LASSOC(x,c),LASSOC(x,c')))]
-;    compare(pair is [prop,:val],p') ==
-;      --1. if the property-value pair are identical, accept it immediately
-;      pair=(pair':= ASSOC(prop,p')) => pair
-;      --2. if property="value" and modes are unifiable, give intersection
-;      --       property="value" but value=genSomeVariable)()
-;      (val':= KDR pair') and prop="value" and
-;        (m:= unifiable(val.mode,val'.mode)) => ["value",genSomeVariable(),m,nil]
-;            --this tells us that an undeclared variable received
-;            --two different values but with identical modes
-;      --3. property="mode" is covered by modeCompare
-;      prop="mode" => nil
-;    modeCompare(p,p') ==
-;      pair:= ASSOC("mode",p) =>
-;        pair':= ASSOC("mode",p') =>
-;          m'':= unifiable(rest pair,rest pair') => LIST ["mode",:m'']
-;          stackSemanticError(['%b,$var,'%d,"has two modes: "],nil)
-;       --stackWarning ("mode for",'%b,$var,'%d,"introduced conditionally")
-;        LIST ["conditionalmode",:rest pair]
-;        --LIST pair
-;       --stackWarning ("mode for",'%b,$var,'%d,"introduced conditionally")
-;      pair':= ASSOC("mode",p') => LIST ["conditionalmode",:rest pair']
-;        --LIST pair'
-;    unifiable(m1,m2) ==
-;      m1=m2 => m1
-;        --we may need to add code to coerce up to tagged unions
-;        --but this can not be done here, but should be done by compIf
-;      m:=
-;        m1 is ["Union",:.] =>
-;          m2 is ["Union",:.] => ["Union",:S_+(rest m1,rest m2)]
-;          ["Union",:S_+(rest m1,[m2])]
-;        m2 is ["Union",:.] => ["Union",:S_+(rest m2,[m1])]
-;        ["Union",m1,m2]
-;      for u in getDomainsInScope $e repeat
-;        if u is ["Union",:u'] and (and/[MEMBER(v,u') for v in rest m]) then
-;          return m
-
-;;;     ***       |intersectionContour,unifiable| REDEFINED
-
-(DEFUN |intersectionContour,unifiable| (|m1| |m2|) (PROG (|m| |u'|) (RETURN (SEQ (IF (BOOT-EQUAL |m1| |m2|) (EXIT |m1|)) (SPADLET |m| (SEQ (IF (AND (PAIRP |m1|) (EQ (QCAR |m1|) (QUOTE |Union|))) (EXIT (SEQ (IF (AND (PAIRP |m2|) (EQ (QCAR |m2|) (QUOTE |Union|))) (EXIT (CONS (QUOTE |Union|) (S+ (CDR |m1|) (CDR |m2|))))) (EXIT (CONS (QUOTE |Union|) (S+ (CDR |m1|) (CONS |m2| NIL))))))) (IF (AND (PAIRP |m2|) (EQ (QCAR |m2|) (QUOTE |Union|))) (EXIT (CONS (QUOTE |Union|) (S+ (CDR |m2|) (CONS |m1| NIL))))) (EXIT (CONS (QUOTE |Union|) (CONS |m1| (CONS |m2| NIL)))))) (EXIT (DO ((#0=#:G2748 (|getDomainsInScope| |$e|) (CDR #0#)) (|u| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |u| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (IF (AND (AND (PAIRP |u|) (EQ (QCAR |u|) (QUOTE |Union|)) (PROGN (SPADLET |u'| (QCDR |u|)) (QUOTE T))) (PROG (#1=#:G2754) (SPADLET #1# (QUOTE T)) (RETURN (DO ((#2=#:G2760 NIL (NULL #1#)) (#3=#:G2761 (CDR |m|) (CDR #3#)) (|v| NIL)) ((OR #2# (ATOM #3#) (PROGN (SETQ |v| (CAR #3#)) NIL)) #1#) (SEQ (EXIT (SETQ #1# (AND #1# (|member| |v| |u'|))))))))) (RETURN |m|) NIL))))))))) 
-
-;;;     ***       |intersectionContour,modeCompare| REDEFINED
-
-(DEFUN |intersectionContour,modeCompare| (|p| |p'|) (PROG (|pair| |m''| |pair'|) (RETURN (SEQ (IF (SPADLET |pair| (|assoc| (QUOTE |mode|) |p|)) (EXIT (SEQ (IF (SPADLET |pair'| (|assoc| (QUOTE |mode|) |p'|)) (EXIT (SEQ (IF (SPADLET |m''| (|intersectionContour,unifiable| (CDR |pair|) (CDR |pair'|))) (EXIT (LIST (CONS (QUOTE |mode|) |m''|)))) (EXIT (|stackSemanticError| (CONS (QUOTE |%b|) (CONS |$var| (CONS (QUOTE |%d|) (CONS (QUOTE |has two modes: |) NIL)))) NIL))))) (EXIT (LIST (CONS (QUOTE |conditionalmode|) (CDR |pair|))))))) (EXIT (IF (SPADLET |pair'| (|assoc| (QUOTE |mode|) |p'|)) (EXIT (LIST (CONS (QUOTE |conditionalmode|) (CDR |pair'|)))))))))) 
-
-;;;     ***       |intersectionContour,compare| REDEFINED
-
-(DEFUN |intersectionContour,compare| (|pair| |p'|) (PROG (|prop| |val| |pair'| |val'| |m|) (RETURN (SEQ (PROGN (SPADLET |prop| (CAR |pair|)) (SPADLET |val| (CDR |pair|)) |pair| (SEQ (IF (BOOT-EQUAL |pair| (SPADLET |pair'| (|assoc| |prop| |p'|))) (EXIT |pair|)) (IF (AND (AND (SPADLET |val'| (KDR |pair'|)) (BOOT-EQUAL |prop| (QUOTE |value|))) (SPADLET |m| (|intersectionContour,unifiable| (CADR |val|) (CADR |val'|)))) (EXIT (CONS (QUOTE |value|) (CONS (|genSomeVariable|) (CONS |m| (CONS NIL NIL)))))) (EXIT (IF (BOOT-EQUAL |prop| (QUOTE |mode|)) (EXIT NIL))))))))) 
-
-;;;     ***       |intersectionContour,buildModeAssoc| REDEFINED
-
-(DEFUN |intersectionContour,buildModeAssoc| (|varlist| |c| |c'|) (PROG (|mp|) (RETURN (SEQ (PROG (#0=#:G2802) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G2808 |varlist| (CDR #1#)) (|x| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (COND ((SPADLET |mp| (|intersectionContour,modeCompare| (LASSOC |x| |c|) (LASSOC |x| |c'|))) (SETQ #0# (CONS (CONS |x| |mp|) #0#))))))))))))) 
-
-;;;     ***       |intersectionContour,interProplist| REDEFINED
-
-(DEFUN |intersectionContour,interProplist| (|p| |p'|) (PROG (|pair'|) (RETURN (SEQ (APPEND (|intersectionContour,modeCompare| |p| |p'|) (PROG (#0=#:G2824) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G2830 |p| (CDR #1#)) (|pair| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |pair| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (COND ((SPADLET |pair'| (|intersectionContour,compare| |pair| |p'|)) (SETQ #0# (CONS |pair'| #0#)))))))))))))) 
-
-;;;     ***       |intersectionContour,computeIntersection| REDEFINED
-
-(DEFUN |intersectionContour,computeIntersection| (|c| |c'|) (PROG (|varlist| |varlist'| |interVars| |unionVars| |diffVars| |modeAssoc| |x| |y| |proplist|) (RETURN (SEQ (SPADLET |varlist| (REMDUP (ASSOCLEFT |c|))) (SPADLET |varlist'| (REMDUP (ASSOCLEFT |c'|))) (SPADLET |interVars| (|intersection| |varlist| |varlist'|)) (SPADLET |unionVars| (|union| |varlist| |varlist'|)) (SPADLET |diffVars| (SETDIFFERENCE |unionVars| |interVars|)) (SPADLET |modeAssoc| (|intersectionContour,buildModeAssoc| |diffVars| |c| |c'|)) (EXIT (APPEND |modeAssoc| (PROG (#0=#:G2847) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G2854 |c| (CDR #1#)) (#2=#:G2731 NIL)) ((OR (ATOM #1#) (PROGN (SETQ #2# (CAR #1#)) NIL) (PROGN (PROGN (SPADLET |x| (CAR #2#)) (SPADLET |y| (CDR #2#)) #2#) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (COND ((AND (|member| |x| |interVars|) (SPADLET |proplist| (|intersectionContour,interProplist| |y| (LASSOC (SPADLET |$var| |x|) |c'|)))) (SETQ #0# (CONS (CONS |x| |proplist|) #0#))))))))))))))) 
-
-;;;     ***       |intersectionContour| REDEFINED
-
-(DEFUN |intersectionContour| (|c| |c'|) (PROG (|$var|) (DECLARE (SPECIAL |$var|)) (RETURN (PROGN (SPADLET |$var| NIL) (|intersectionContour,computeIntersection| |c| |c'|))))) 
-;        --this loop will return NIL if not satisfied
-;
-;addContour(c,E is [cur,:tail]) ==
-;  [NCONC(fn(c,E),cur),:tail] where
-;    fn(c,e) ==
-;        for [x,:proplist] in c repeat
-;           fn1(x,proplist,getProplist(x,e)) where
-;              fn1(x,p,ee) ==
-;                for pv in p repeat fn3(x,pv,ee) where
-;                 fn3(x,pv,e) ==
-;                   [p,:v]:=pv;
-;                   if MEMBER(x,$getPutTrace) then
-;                     pp([x,"has",pv]);
-;                   if p="conditionalmode" then
-;                     RPLACA(pv,"mode");
-;                     --check for conflicts with earlier mode
-;                     if vv:=LASSOC("mode",e) then
-;                        if v ^=vv then
-;                          stackWarning ["The conditional modes ",
-;                                     v," and ",vv," conflict"]
-;        LIST c
-
-;;;     ***       |addContour,fn3| REDEFINED
-
-(DEFUN |addContour,fn3| (|x| |pv| |e|) (PROG (|p| |v| |vv|) (RETURN (SEQ (PROGN (SPADLET |p| (CAR |pv|)) (SPADLET |v| (CDR |pv|)) |pv|) (IF (|member| |x| |$getPutTrace|) (|pp| (CONS |x| (CONS (QUOTE |has|) (CONS |pv| NIL)))) NIL) (EXIT (IF (BOOT-EQUAL |p| (QUOTE |conditionalmode|)) (SEQ (RPLACA |pv| (QUOTE |mode|)) (EXIT (IF (SPADLET |vv| (LASSOC (QUOTE |mode|) |e|)) (IF (NEQUAL |v| |vv|) (|stackWarning| (CONS (QUOTE |The conditional modes |) (CONS |v| (CONS (QUOTE | and |) (CONS |vv| (CONS (QUOTE | conflict|) NIL)))))) NIL) NIL))) NIL)))))) 
-
-;;;     ***       |addContour,fn1| REDEFINED
-
-(DEFUN |addContour,fn1| (|x| |p| |ee|) (SEQ (DO ((#0=#:G2898 |p| (CDR #0#)) (|pv| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |pv| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (|addContour,fn3| |x| |pv| |ee|)))))) 
-
-;;;     ***       |addContour,fn| REDEFINED
-
-(DEFUN |addContour,fn| (|c| |e|) (PROG (|x| |proplist|) (RETURN (SEQ (DO ((#0=#:G2917 |c| (CDR #0#)) (#1=#:G2908 NIL)) ((OR (ATOM #0#) (PROGN (SETQ #1# (CAR #0#)) NIL) (PROGN (PROGN (SPADLET |x| (CAR #1#)) (SPADLET |proplist| (CDR #1#)) #1#) NIL)) NIL) (SEQ (EXIT (|addContour,fn1| |x| |proplist| (|getProplist| |x| |e|))))) (EXIT (LIST |c|)))))) 
-
-;;;     ***       |addContour| REDEFINED
-
-(DEFUN |addContour| (|c| E) (PROG (|cur| |tail|) (RETURN (PROGN (SPADLET |cur| (CAR E)) (SPADLET |tail| (CDR E)) (CONS (NCONC (|addContour,fn| |c| E) |cur|) |tail|))))) 
-;
-;makeCommonEnvironment(e,e') ==
-;  interE makeSameLength(e,e') where  --$ie:=
-;    interE [e,e'] ==
-;      rest e=rest e' => [interLocalE makeSameLength(first e,first e'),:rest e]
-;      interE [rest e,rest e']
-;    interLocalE [le,le'] ==
-;      rest le=rest le' =>
-;        [interC makeSameLength(first le,first le'),:rest le]
-;      interLocalE [rest le,rest le']
-;    interC [c,c'] ==
-;      c=c' => c
-;      interC [rest c,rest c']
-;    makeSameLength(x,y) ==
-;      fn(x,y,#x,#y) where
-;        fn(x,y,nx,ny) ==
-;          nx>ny => fn(rest x,y,nx-1,ny)
-;          nx<ny => fn(x,rest y,nx,ny-1)
-;          [x,y]
-
-;;;     ***       |makeCommonEnvironment,fn| REDEFINED
-
-(DEFUN |makeCommonEnvironment,fn| (|x| |y| |nx| |ny|) (SEQ (IF (> |nx| |ny|) (EXIT (|makeCommonEnvironment,fn| (CDR |x|) |y| (SPADDIFFERENCE |nx| 1) |ny|))) (IF (> |ny| |nx|) (EXIT (|makeCommonEnvironment,fn| |x| (CDR |y|) |nx| (SPADDIFFERENCE |ny| 1)))) (EXIT (CONS |x| (CONS |y| NIL))))) 
-
-;;;     ***       |makeCommonEnvironment,makeSameLength| REDEFINED
-
-(DEFUN |makeCommonEnvironment,makeSameLength| (|x| |y|) (|makeCommonEnvironment,fn| |x| |y| (|#| |x|) (|#| |y|))) 
-
-;;;     ***       |makeCommonEnvironment,interC| REDEFINED
-
-(DEFUN |makeCommonEnvironment,interC| (#0=#:G2954) (PROG (|c| |c'|) (RETURN (SEQ (PROGN (SPADLET |c| (CAR #0#)) (SPADLET |c'| (CADR #0#)) #0# (SEQ (IF (BOOT-EQUAL |c| |c'|) (EXIT |c|)) (EXIT (|makeCommonEnvironment,interC| (CONS (CDR |c|) (CONS (CDR |c'|) NIL)))))))))) 
-
-;;;     ***       |makeCommonEnvironment,interLocalE| REDEFINED
-
-(DEFUN |makeCommonEnvironment,interLocalE| (#0=#:G2968) (PROG (|le| |le'|) (RETURN (SEQ (PROGN (SPADLET |le| (CAR #0#)) (SPADLET |le'| (CADR #0#)) #0# (SEQ (IF (BOOT-EQUAL (CDR |le|) (CDR |le'|)) (EXIT (CONS (|makeCommonEnvironment,interC| (|makeCommonEnvironment,makeSameLength| (CAR |le|) (CAR |le'|))) (CDR |le|)))) (EXIT (|makeCommonEnvironment,interLocalE| (CONS (CDR |le|) (CONS (CDR |le'|) NIL)))))))))) 
-
-;;;     ***       |makeCommonEnvironment,interE| REDEFINED
-
-(DEFUN |makeCommonEnvironment,interE| (#0=#:G2982) (PROG (|e| |e'|) (RETURN (SEQ (PROGN (SPADLET |e| (CAR #0#)) (SPADLET |e'| (CADR #0#)) #0# (SEQ (IF (BOOT-EQUAL (CDR |e|) (CDR |e'|)) (EXIT (CONS (|makeCommonEnvironment,interLocalE| (|makeCommonEnvironment,makeSameLength| (CAR |e|) (CAR |e'|))) (CDR |e|)))) (EXIT (|makeCommonEnvironment,interE| (CONS (CDR |e|) (CONS (CDR |e'|) NIL)))))))))) 
-
-;;;     ***       |makeCommonEnvironment| REDEFINED
-
-(DEFUN |makeCommonEnvironment| (|e| |e'|) (|makeCommonEnvironment,interE| (|makeCommonEnvironment,makeSameLength| |e| |e'|))) 
-;
-;printEnv E ==
-;  for x in E for i in 1.. repeat
-;    for y in x for j in 1.. repeat
-;      SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******")
-;      for z in y repeat
-;        TERPRI()
-;        SAY("Properties Of: ",first z)
-;        for u in rest z repeat
-;          PRIN0 first u
-;          printString ": "
-;          PRETTYPRINT tran(rest u,first u) where
-;            tran(val,prop) ==
-;              prop="value" => DROP(-1,val)
-;              val
-
-;;;     ***       |printEnv,tran| REDEFINED
-
-(DEFUN |printEnv,tran| (|val| |prop|) (SEQ (IF (BOOT-EQUAL |prop| (QUOTE |value|)) (EXIT (DROP (SPADDIFFERENCE 1) |val|))) (EXIT |val|))) 
-
-;;;     ***       |printEnv| REDEFINED
-
-(DEFUN |printEnv| (E) (SEQ (DO ((#0=#:G3020 E (CDR #0#)) (|x| NIL) (|i| 1 (QSADD1 |i|))) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (DO ((#1=#:G3038 |x| (CDR #1#)) (|y| NIL) (|j| 1 (QSADD1 |j|))) ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) NIL) (SEQ (EXIT (PROGN (SAY (MAKESTRING "******CONTOUR ") |j| (MAKESTRING ", LEVEL ") |i| (MAKESTRING ":******")) (DO ((#2=#:G3053 |y| (CDR #2#)) (|z| NIL)) ((OR (ATOM #2#) (PROGN (SETQ |z| (CAR #2#)) NIL)) NIL) (SEQ (EXIT (PROGN (TERPRI) (SAY (MAKESTRING "Properties Of: ") (CAR |z|)) (DO ((#3=#:G3065 (CDR |z|) (CDR #3#)) (|u| NIL)) ((OR (ATOM #3#) (PROGN (SETQ |u| (CAR #3#)) NIL)) NIL) (SEQ (EXIT (PROGN (PRIN0 (CAR |u|)) (|printString| (QUOTE |: |)) (PRETTYPRINT (|printEnv,tran| (CDR |u|) (CAR |u|)))))))))))))))))))) 
-;
-;prEnv E ==
-;  for x in E for i in 1.. repeat
-;    for y in x for j in 1.. repeat
-;      SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******")
-;      for z in y | not LASSOC("modemap",rest z) repeat
-;        TERPRI()
-;        SAY("Properties Of: ",first z)
-;        for u in rest z repeat
-;          PRIN0 first u
-;          printString ": "
-;          PRETTYPRINT tran(rest u,first u) where
-;            tran(val,prop) ==
-;              prop="value" => DROP(-1,val)
-;              val
-
-;;;     ***       |prEnv,tran| REDEFINED
-
-(DEFUN |prEnv,tran| (|val| |prop|) (SEQ (IF (BOOT-EQUAL |prop| (QUOTE |value|)) (EXIT (DROP (SPADDIFFERENCE 1) |val|))) (EXIT |val|))) 
-
-;;;     ***       |prEnv| REDEFINED
-
-(DEFUN |prEnv| (E) (SEQ (DO ((#0=#:G3094 E (CDR #0#)) (|x| NIL) (|i| 1 (QSADD1 |i|))) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (DO ((#1=#:G3112 |x| (CDR #1#)) (|y| NIL) (|j| 1 (QSADD1 |j|))) ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) NIL) (SEQ (EXIT (PROGN (SAY (MAKESTRING "******CONTOUR ") |j| (MAKESTRING ", LEVEL ") |i| (MAKESTRING ":******")) (DO ((#2=#:G3128 |y| (CDR #2#)) (|z| NIL)) ((OR (ATOM #2#) (PROGN (SETQ |z| (CAR #2#)) NIL)) NIL) (SEQ (EXIT (COND ((NULL (LASSOC (QUOTE |modemap|) (CDR |z|))) (PROGN (TERPRI) (SAY (MAKESTRING "Properties Of: ") (CAR |z|)) (DO ((#3=#:G3140 (CDR |z|) (CDR #3#)) (|u| NIL)) ((OR (ATOM #3#) (PROGN (SETQ |u| (CAR #3#)) NIL)) NIL) (SEQ (EXIT (PROGN (PRIN0 (CAR |u|)) (|printString| (QUOTE |: |)) (PRETTYPRINT (|prEnv,tran| (CDR |u|) (CAR |u|)))))))))))))))))))))) 
-;
-;prModemaps E ==
-;  listOfOperatorsSeenSoFar:= nil
-;  for x in E for i in 1.. repeat
-;    for y in x for j in 1.. repeat
-;      for z in y | null MEMBER(first z,listOfOperatorsSeenSoFar) and
-;        (modemap:= LASSOC("modemap",rest z)) repeat
-;          listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar]
-;          TERPRI()
-;          PRIN0 first z
-;          printString ": "
-;          PRETTYPRINT modemap
-
-;;;     ***       |prModemaps| REDEFINED
-
-(DEFUN |prModemaps| (E) (PROG (|modemap| |listOfOperatorsSeenSoFar|) (RETURN (SEQ (PROGN (SPADLET |listOfOperatorsSeenSoFar| NIL) (DO ((#0=#:G3160 E (CDR #0#)) (|x| NIL) (|i| 1 (QSADD1 |i|))) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (DO ((#1=#:G3175 |x| (CDR #1#)) (|y| NIL) (|j| 1 (QSADD1 |j|))) ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) NIL) (SEQ (EXIT (DO ((#2=#:G3190 |y| (CDR #2#)) (|z| NIL)) ((OR (ATOM #2#) (PROGN (SETQ |z| (CAR #2#)) NIL)) NIL) (SEQ (EXIT (COND ((AND (NULL (|member| (CAR |z|) |listOfOperatorsSeenSoFar|)) (SPADLET |modemap| (LASSOC (QUOTE |modemap|) (CDR |z|)))) (PROGN (SPADLET |listOfOperatorsSeenSoFar| (CONS (CAR |z|) |listOfOperatorsSeenSoFar|)) (TERPRI) (PRIN0 (CAR |z|)) (|printString| (QUOTE |: |)) (PRETTYPRINT |modemap|)))))))))))))))))) 
-;
-;prTriple T ==
-;   SAY '"Code:"
-;   pp T.0
-;   SAY '"Mode:"
-;   pp T.1
-
-;;;     ***       |prTriple| REDEFINED
-
-(DEFUN |prTriple| (T$) (PROGN (SAY (MAKESTRING "Code:")) (|pp| (ELT T$ 0)) (SAY (MAKESTRING "Mode:")) (|pp| (ELT T$ 1)))) 
-;
-;TrimCF() ==
-;  new:= nil
-;  old:= CAAR $CategoryFrame
-;  for u in old repeat
-;    if not ASSQ(first u,new) then
-;      uold:= rest u
-;      unew:= nil
-;      for v in uold repeat if not ASSQ(first v,unew) then unew:= [v,:unew]
-;      new:= [[first u,:NREVERSE unew],:new]
-;  $CategoryFrame:= [[NREVERSE new]]
-;  nil
-
-;;;     ***       |TrimCF| REDEFINED
-
-(DEFUN |TrimCF| NIL (PROG (|old| |uold| |unew| |new|) (RETURN (SEQ (PROGN (SPADLET |new| NIL) (SPADLET |old| (CAAR |$CategoryFrame|)) (DO ((#0=#:G3211 |old| (CDR #0#)) (|u| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |u| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (COND ((NULL (ASSQ (CAR |u|) |new|)) (SPADLET |uold| (CDR |u|)) (SPADLET |unew| NIL) (DO ((#1=#:G3220 |uold| (CDR #1#)) (|v| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |v| (CAR #1#)) NIL)) NIL) (SEQ (EXIT (COND ((NULL (ASSQ (CAR |v|) |unew|)) (SPADLET |unew| (CONS |v| |unew|))) ((QUOTE T) NIL))))) (SPADLET |new| (CONS (CONS (CAR |u|) (NREVERSE |unew|)) |new|))) ((QUOTE T) NIL))))) (SPADLET |$CategoryFrame| (CONS (CONS (NREVERSE |new|) NIL) NIL)) NIL))))) 
-;
-;
-;--% PREDICATES
-;
-;
-;isConstantId(name,e) ==
-;  IDENTP name =>
-;    pl:= getProplist(name,e) =>
-;      (LASSOC("value",pl) or LASSOC("mode",pl) => false; true)
-;    true
-;  false
-
-;;;     ***       |isConstantId| REDEFINED
-
-(DEFUN |isConstantId| (|name| |e|) (PROG (|pl|) (RETURN (COND ((IDENTP |name|) (COND ((SPADLET |pl| (|getProplist| |name| |e|)) (COND ((OR (LASSOC (QUOTE |value|) |pl|) (LASSOC (QUOTE |mode|) |pl|)) NIL) ((QUOTE T) (QUOTE T)))) ((QUOTE T) (QUOTE T)))) ((QUOTE T) NIL))))) 
-;
-;isFalse() == nil
-
-;;;     ***       |isFalse| REDEFINED
-
-(DEFUN |isFalse| NIL NIL) 
-;
-;isFluid s == atom s and "$"=(PNAME s).(0)
-
-;;;     ***       |isFluid| REDEFINED
-
-(DEFUN |isFluid| (|s|) (AND (ATOM |s|) (BOOT-EQUAL (QUOTE $) (ELT (PNAME |s|) 0)))) 
-;
-;isFunction(x,e) ==
-;  get(x,"modemap",e) or GET(x,"SPECIAL") or x="case" or getmode(x,e) is [
-;    "Mapping",:.]
-
-;;;     ***       |isFunction| REDEFINED
-
-(DEFUN |isFunction| (|x| |e|) (PROG (|ISTMP#1|) (RETURN (OR (|get| |x| (QUOTE |modemap|) |e|) (GETL |x| (QUOTE SPECIAL)) (BOOT-EQUAL |x| (QUOTE |case|)) (PROGN (SPADLET |ISTMP#1| (|getmode| |x| |e|)) (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)))))))) 
-;
-;isLiteral(x,e) == get(x,"isLiteral",e)
-
-;;;     ***       |isLiteral| REDEFINED
-
-(DEFUN |isLiteral| (|x| |e|) (|get| |x| (QUOTE |isLiteral|) |e|)) 
-;
-;makeLiteral(x,e) == put(x,"isLiteral","true",e)
-
-;;;     ***       |makeLiteral| REDEFINED
-
-(DEFUN |makeLiteral| (|x| |e|) (|put| |x| (QUOTE |isLiteral|) (QUOTE |true|) |e|)) 
-;
-;isSomeDomainVariable s ==
-;  IDENTP s and #(x:= PNAME s)>2 and x.(0)="#" and x.(1)="#"
-
-;;;     ***       |isSomeDomainVariable| REDEFINED
-
-(DEFUN |isSomeDomainVariable| (|s|) (PROG (|x|) (RETURN (AND (IDENTP |s|) (> (|#| (SPADLET |x| (PNAME |s|))) 2) (BOOT-EQUAL (ELT |x| 0) (QUOTE |#|)) (BOOT-EQUAL (ELT |x| 1) (QUOTE |#|)))))) 
-;
-;isSubset(x,y,e) ==
-;  x="$" and y="Rep" or x=y or
-;    LASSOC(opOf x,get(opOf y,"Subsets",e) or GET(opOf y,"Subsets")) or
-;      LASSOC(opOf x,get(opOf y,"SubDomain",e)) or
-;        opOf(y)='Type or opOf(y)='Object
-
-;;;     ***       |isSubset| REDEFINED
-
-(DEFUN |isSubset| (|x| |y| |e|) (OR (AND (BOOT-EQUAL |x| (QUOTE $)) (BOOT-EQUAL |y| (QUOTE |Rep|))) (BOOT-EQUAL |x| |y|) (LASSOC (|opOf| |x|) (OR (|get| (|opOf| |y|) (QUOTE |Subsets|) |e|) (GETL (|opOf| |y|) (QUOTE |Subsets|)))) (LASSOC (|opOf| |x|) (|get| (|opOf| |y|) (QUOTE |SubDomain|) |e|)) (BOOT-EQUAL (|opOf| |y|) (QUOTE |Type|)) (BOOT-EQUAL (|opOf| |y|) (QUOTE |Object|)))) 
-;
-;isDomainInScope(domain,e) ==
-;  domainList:= getDomainsInScope e
-;  atom domain =>
-;    MEMQ(domain,domainList) => true
-;    not IDENTP domain or isSomeDomainVariable domain => true
-;    false
-;  (name:= first domain)="Category" => true
-;  ASSQ(name,domainList) => true
-;--   null CDR domain or domainMember(domain,domainList) => true
-;--   false
-;  isFunctor name => false
-;  true --is not a functor
-
-;;;     ***       |isDomainInScope| REDEFINED
-
-(DEFUN |isDomainInScope| (|domain| |e|) (PROG (|domainList| |name|) (RETURN (PROGN (SPADLET |domainList| (|getDomainsInScope| |e|)) (COND ((ATOM |domain|) (COND ((MEMQ |domain| |domainList|) (QUOTE T)) ((OR (NULL (IDENTP |domain|)) (|isSomeDomainVariable| |domain|)) (QUOTE T)) ((QUOTE T) NIL))) ((BOOT-EQUAL (SPADLET |name| (CAR |domain|)) (QUOTE |Category|)) (QUOTE T)) ((ASSQ |name| |domainList|) (QUOTE T)) ((|isFunctor| |name|) NIL) ((QUOTE T) (QUOTE T))))))) 
-;
-;isSymbol x == IDENTP x or x=nil
-
-;;;     ***       |isSymbol| REDEFINED
-
-(DEFUN |isSymbol| (|x|) (OR (IDENTP |x|) (NULL |x|))) 
-;
-;isSimple x ==
-;  atom x or $InteractiveMode => true
-;  x is [op,:argl] and
-;    isSideEffectFree op and (and/[isSimple y for y in argl])
-
-;;;     ***       |isSimple| REDEFINED
-
-(DEFUN |isSimple| (|x|) (PROG (|op| |argl|) (RETURN (SEQ (COND ((OR (ATOM |x|) |$InteractiveMode|) (QUOTE T)) ((QUOTE T) (AND (PAIRP |x|) (PROGN (SPADLET |op| (QCAR |x|)) (SPADLET |argl| (QCDR |x|)) (QUOTE T)) (|isSideEffectFree| |op|) (PROG (#0=#:G3282) (SPADLET #0# (QUOTE T)) (RETURN (DO ((#1=#:G3288 NIL (NULL #0#)) (#2=#:G3289 |argl| (CDR #2#)) (|y| NIL)) ((OR #1# (ATOM #2#) (PROGN (SETQ |y| (CAR #2#)) NIL)) #0#) (SEQ (EXIT (SETQ #0# (AND #0# (|isSimple| |y|))))))))))))))) 
-;
-;isSideEffectFree op ==
-;  MEMBER(op,$SideEffectFreeFunctionList) or op is ["elt",.,op'] and
-;    isSideEffectFree op'
-
-;;;     ***       |isSideEffectFree| REDEFINED
-
-(DEFUN |isSideEffectFree| (|op|) (PROG (|ISTMP#1| |ISTMP#2| |op'|) (RETURN (OR (|member| |op| |$SideEffectFreeFunctionList|) (AND (PAIRP |op|) (EQ (QCAR |op|) (QUOTE |elt|)) (PROGN (SPADLET |ISTMP#1| (QCDR |op|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) (PROGN (SPADLET |op'| (QCAR |ISTMP#2|)) (QUOTE T)))))) (|isSideEffectFree| |op'|)))))) 
-;
-;isAlmostSimple x ==
-;  --returns (<new predicate> . <list of assignments>) or nil
-;  $assignmentList: local --$assigmentList is only used in this function
-;  transform:=
-;    fn x where
-;      fn x ==
-;        atom x or null rest x => x
-;        [op,y,:l]:= x
-;        op="has" => x
-;        op="is" => x
-;        op="LET" =>
-;          IDENTP y => (setAssignment LIST x; y)
-;          true => (setAssignment [["LET",g:= genVariable(),:l],["LET",y,g]]; g)
-;        isSideEffectFree op => [op,:mapInto(rest x,"fn")]
-;        true => $assignmentList:= "failed"
-;      setAssignment x ==
-;        $assignmentList="failed" => nil
-;        $assignmentList:= [:$assignmentList,:x]
-;  $assignmentList="failed" => nil
-;  wrapSEQExit [:$assignmentList,transform]
-
-;;;     ***       |isAlmostSimple,setAssignment| REDEFINED
-
-(DEFUN |isAlmostSimple,setAssignment| (|x|) (SEQ (IF (BOOT-EQUAL |$assignmentList| (QUOTE |failed|)) (EXIT NIL)) (EXIT (SPADLET |$assignmentList| (APPEND |$assignmentList| |x|))))) 
 
-;;;     ***       |isAlmostSimple,fn| REDEFINED
 
-(DEFUN |isAlmostSimple,fn| (|x|) (PROG (|op| |y| |l| |g|) (RETURN (SEQ (IF (OR (ATOM |x|) (NULL (CDR |x|))) (EXIT |x|)) (PROGN (SPADLET |op| (CAR |x|)) (SPADLET |y| (CADR |x|)) (SPADLET |l| (CDDR |x|)) |x|) (IF (BOOT-EQUAL |op| (QUOTE |has|)) (EXIT |x|)) (IF (BOOT-EQUAL |op| (QUOTE |is|)) (EXIT |x|)) (IF (BOOT-EQUAL |op| (QUOTE LET)) (EXIT (SEQ (IF (IDENTP |y|) (EXIT (SEQ (|isAlmostSimple,setAssignment| (LIST |x|)) (EXIT |y|)))) (EXIT (IF (QUOTE T) (EXIT (SEQ (|isAlmostSimple,setAssignment| (CONS (CONS (QUOTE LET) (CONS (SPADLET |g| (|genVariable|)) |l|)) (CONS (CONS (QUOTE LET) (CONS |y| (CONS |g| NIL))) NIL))) (EXIT |g|)))))))) (IF (|isSideEffectFree| |op|) (EXIT (CONS |op| (|mapInto| (CDR |x|) (QUOTE |isAlmostSimple,fn|))))) (EXIT (IF (QUOTE T) (EXIT (SPADLET |$assignmentList| (QUOTE |failed|))))))))) 
-
-;;;     ***       |isAlmostSimple| REDEFINED
-
-(DEFUN |isAlmostSimple| (|x|) (PROG (|$assignmentList| |transform|) (DECLARE (SPECIAL |$assignmentList|)) (RETURN (PROGN (SPADLET |$assignmentList| NIL) (SPADLET |transform| (|isAlmostSimple,fn| |x|)) (COND ((BOOT-EQUAL |$assignmentList| (QUOTE |failed|)) NIL) ((QUOTE T) (|wrapSEQExit| (APPEND |$assignmentList| (CONS |transform| NIL))))))))) 
-;
-;incExitLevel u ==
-;  adjExitLevel(u,1,1)
-;  u
-
-;;;     ***       |incExitLevel| REDEFINED
-
-(DEFUN |incExitLevel| (|u|) (PROGN (|adjExitLevel| |u| 1 1) |u|)) 
-;
-;decExitLevel u ==
-;  (adjExitLevel(u,1,-1); removeExit0 u) where
-;    removeExit0 x ==
-;      atom x => x
-;      x is ["exit",0,u] => removeExit0 u
-;      [removeExit0 first x,:removeExit0 rest x]
-
-;;;     ***       |decExitLevel,removeExit0| REDEFINED
-
-(DEFUN |decExitLevel,removeExit0| (|x|) (PROG (|ISTMP#1| |ISTMP#2| |u|) (RETURN (SEQ (IF (ATOM |x|) (EXIT |x|)) (IF (AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE |exit|)) (PROGN (SPADLET |ISTMP#1| (QCDR |x|)) (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) 0) (PROGN (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) (PROGN (SPADLET |u| (QCAR |ISTMP#2|)) (QUOTE T))))))) (EXIT (|decExitLevel,removeExit0| |u|))) (EXIT (CONS (|decExitLevel,removeExit0| (CAR |x|)) (|decExitLevel,removeExit0| (CDR |x|)))))))) 
-
-;;;     ***       |decExitLevel| REDEFINED
-
-(DEFUN |decExitLevel| (|u|) (PROGN (|adjExitLevel| |u| 1 (SPADDIFFERENCE 1)) (|decExitLevel,removeExit0| |u|))) 
-;
-;adjExitLevel(x,seqnum,inc) ==
-;  atom x => x
-;  x is [op,:l] and MEMQ(op,'(SEQ REPEAT COLLECT)) =>
-;    for u in l repeat adjExitLevel(u,seqnum+1,inc)
-;  x is ["exit",n,u] =>
-;    (adjExitLevel(u,seqnum,inc); seqnum>n => x; rplac(CADR x,n+inc))
-;  x is [op,:l] => for u in l repeat adjExitLevel(u,seqnum,inc)
-
-;;;     ***       |adjExitLevel| REDEFINED
-
-(DEFUN |adjExitLevel| (|x| |seqnum| |inc|) (PROG (|ISTMP#1| |n| |ISTMP#2| |u| |op| |l|) (RETURN (SEQ (COND ((ATOM |x|) |x|) ((AND (PAIRP |x|) (PROGN (SPADLET |op| (QCAR |x|)) (SPADLET |l| (QCDR |x|)) (QUOTE T)) (MEMQ |op| (QUOTE (SEQ REPEAT COLLECT)))) (DO ((#0=#:G3401 |l| (CDR #0#)) (|u| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |u| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (|adjExitLevel| |u| (PLUS |seqnum| 1) |inc|))))) ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE |exit|)) (PROGN (SPADLET |ISTMP#1| (QCDR |x|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |n| (QCAR |ISTMP#1|)) (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) (PROGN (SPADLET |u| (QCAR |ISTMP#2|)) (QUOTE T))))))) (|adjExitLevel| |u| |seqnum| |inc|) (COND ((> |seqnum| |n|) |x|) ((QUOTE T) (|rplac| (CADR |x|) (PLUS |n| |inc|))))) ((AND (PAIRP |x|) (PROGN (SPADLET |op| (QCAR |x|)) (SPADLET |l| (QCDR |x|)) (QUOTE T))) (DO ((#1=#:G3410 |l| (CDR #1#)) (|u| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |u| (CAR #1#)) NIL)) NIL) (SEQ (EXIT (|adjExitLevel| |u| |seqnum| |inc|)))))))))) 
-;
-;wrapSEQExit l ==
-;  null rest l => first l
-;  [:c,x]:= [incExitLevel u for u in l]
-;  ["SEQ",:c,["exit",1,x]]
-
-;;;     ***       |wrapSEQExit| REDEFINED
-
-(DEFUN |wrapSEQExit| (|l|) (PROG (|LETTMP#1| |LETTMP#2| |x| |c|) (RETURN (SEQ (COND ((NULL (CDR |l|)) (CAR |l|)) ((QUOTE T) (SPADLET |LETTMP#1| (PROG (#0=#:G3441) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G3446 |l| (CDR #1#)) (|u| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |u| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (|incExitLevel| |u|) #0#)))))))) (SPADLET |LETTMP#2| (REVERSE |LETTMP#1|)) (SPADLET |x| (CAR |LETTMP#2|)) (SPADLET |c| (NREVERSE (CDR |LETTMP#2|))) (CONS (QUOTE SEQ) (APPEND |c| (CONS (CONS (QUOTE |exit|) (CONS 1 (CONS |x| NIL))) NIL))))))))) 
-;
-;
-;--% UTILITY FUNCTIONS
-;
-;--appendOver x == "append"/x
-;
-;removeEnv t == [t.expr,t.mode,$EmptyEnvironment]  -- t is a triple
-
-;;;     ***       |removeEnv| REDEFINED
-
-(DEFUN |removeEnv| (|t|) (CONS (CAR |t|) (CONS (CADR |t|) (CONS |$EmptyEnvironment| NIL)))) 
-;
-;-- This function seems no longer used
-;--ordinsert(x,l) ==
-;--  null l => [x]
-;--  x=first l => l
-;--  _?ORDER(x,first l) => [x,:l]
-;--  [first l,:ordinsert(x,rest l)]
-;
-;makeNonAtomic x ==
-;  atom x => [x]
-;  x
-
-;;;     ***       |makeNonAtomic| REDEFINED
-
-(DEFUN |makeNonAtomic| (|x|) (COND ((ATOM |x|) (CONS |x| NIL)) ((QUOTE T) |x|))) 
-;
-;flatten(l,key) ==
-;  null l => nil
-;  first l is [k,:r] and k=key => [:r,:flatten(rest l,key)]
-;  [first l,:flatten(rest l,key)]
-
-;;;     ***       |flatten| REDEFINED
-
-(DEFUN |flatten| (|l| |key|) (PROG (|ISTMP#1| |k| |r|) (RETURN (COND ((NULL |l|) NIL) ((AND (PROGN (SPADLET |ISTMP#1| (CAR |l|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |k| (QCAR |ISTMP#1|)) (SPADLET |r| (QCDR |ISTMP#1|)) (QUOTE T)))) (BOOT-EQUAL |k| |key|)) (APPEND |r| (|flatten| (CDR |l|) |key|))) ((QUOTE T) (CONS (CAR |l|) (|flatten| (CDR |l|) |key|))))))) 
-;
-;genDomainVar() ==
-;  $Index:= $Index+1
-;  INTERNL STRCONC("#D",STRINGIMAGE $Index)
-
-;;;     ***       |genDomainVar| REDEFINED
-
-(DEFUN |genDomainVar| NIL (PROGN (SPADLET |$Index| (PLUS |$Index| 1)) (INTERNL (STRCONC (QUOTE |#D|) (STRINGIMAGE |$Index|))))) 
-;
-;genVariable() ==
-;  INTERNL STRCONC("#G",STRINGIMAGE ($genSDVar:= $genSDVar+1))
-
-;;;     ***       |genVariable| REDEFINED
-
-(DEFUN |genVariable| NIL (INTERNL (STRCONC (QUOTE |#G|) (STRINGIMAGE (SPADLET |$genSDVar| (PLUS |$genSDVar| 1)))))) 
-;
-;genSomeVariable() ==
-;  INTERNL STRCONC("##",STRINGIMAGE ($genSDVar:= $genSDVar+1))
-
-;;;     ***       |genSomeVariable| REDEFINED
-
-(DEFUN |genSomeVariable| NIL (INTERNL (STRCONC (QUOTE |##|) (STRINGIMAGE (SPADLET |$genSDVar| (PLUS |$genSDVar| 1)))))) 
-;
-;listOfIdentifiersIn x ==
-;  IDENTP x => [x]
-;  x is [op,:l] => REMDUP ("append"/[listOfIdentifiersIn y for y in l])
-;  nil
-
-;;;     ***       |listOfIdentifiersIn| REDEFINED
-
-(DEFUN |listOfIdentifiersIn| (|x|) (PROG (|op| |l|) (RETURN (SEQ (COND ((IDENTP |x|) (CONS |x| NIL)) ((AND (PAIRP |x|) (PROGN (SPADLET |op| (QCAR |x|)) (SPADLET |l| (QCDR |x|)) (QUOTE T))) (REMDUP (PROG (#0=#:G3499) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G3504 |l| (CDR #1#)) (|y| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) #0#) (SEQ (EXIT (SETQ #0# (APPEND #0# (|listOfIdentifiersIn| |y|)))))))))) ((QUOTE T) NIL)))))) 
-;
-;mapInto(x,fn) == [FUNCALL(fn,y) for y in x]
-
-;;;     ***       |mapInto| REDEFINED
-
-(DEFUN |mapInto| (|x| |fn|) (PROG NIL (RETURN (SEQ (PROG (#0=#:G3520) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G3525 |x| (CDR #1#)) (|y| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (FUNCALL |fn| |y|) #0#))))))))))) 
-;
-;numOfOccurencesOf(x,y) ==
-;  fn(x,y,0) where
-;    fn(x,y,n) ==
-;      null y => 0
-;      x=y => n+1
-;      atom y => n
-;      fn(x,first y,n)+fn(x,rest y,n)
-
-;;;     ***       |numOfOccurencesOf,fn| REDEFINED
-
-(DEFUN |numOfOccurencesOf,fn| (|x| |y| |n|) (SEQ (IF (NULL |y|) (EXIT 0)) (IF (BOOT-EQUAL |x| |y|) (EXIT (PLUS |n| 1))) (IF (ATOM |y|) (EXIT |n|)) (EXIT (PLUS (|numOfOccurencesOf,fn| |x| (CAR |y|) |n|) (|numOfOccurencesOf,fn| |x| (CDR |y|) |n|))))) 
-
-;;;     ***       |numOfOccurencesOf| REDEFINED
-
-(DEFUN |numOfOccurencesOf| (|x| |y|) (|numOfOccurencesOf,fn| |x| |y| 0)) 
-;
-;compilerMessage x ==
-;  $PrintCompilerMessageIfTrue => APPLX("SAY",x)
-
-;;;     ***       |compilerMessage| REDEFINED
-
-(DEFUN |compilerMessage| (|x|) (SEQ (COND (|$PrintCompilerMessageIfTrue| (EXIT (APPLX (QUOTE SAY) |x|)))))) 
-;
-;printDashedLine() ==
-;  SAY
-;   '"--------------------------------------------------------------------------"
-
-;;;     ***       |printDashedLine| REDEFINED
-
-(DEFUN |printDashedLine| NIL (SAY (MAKESTRING "--------------------------------------------------------------------------"))) 
-;
-;stackSemanticError(msg,expr) ==
-;  BUMPERRORCOUNT "semantic"
-;  if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg]
-;  if atom msg then msg:= LIST msg
-;  entry:= [msg,expr]
-;  if not MEMBER(entry,$semanticErrorStack) then $semanticErrorStack:=
-;    [entry,:$semanticErrorStack]
-;  $scanIfTrue and $insideCapsuleFunctionIfTrue=true and #$semanticErrorStack-
-;    $initCapsuleErrorCount>3 => THROW("compCapsuleBody",nil)
-;  nil
-
-;;;     ***       |stackSemanticError| REDEFINED
-
-(DEFUN |stackSemanticError| (|msg| |expr|) (PROG (|entry|) (RETURN (PROGN (BUMPERRORCOUNT (QUOTE |semantic|)) (COND (|$insideCapsuleFunctionIfTrue| (SPADLET |msg| (CONS |$op| (CONS (QUOTE |: |) |msg|))))) (COND ((ATOM |msg|) (SPADLET |msg| (LIST |msg|)))) (SPADLET |entry| (CONS |msg| (CONS |expr| NIL))) (COND ((NULL (|member| |entry| |$semanticErrorStack|)) (SPADLET |$semanticErrorStack| (CONS |entry| |$semanticErrorStack|)))) (COND ((AND |$scanIfTrue| (BOOT-EQUAL |$insideCapsuleFunctionIfTrue| (QUOTE T)) (> (SPADDIFFERENCE (|#| |$semanticErrorStack|) |$initCapsuleErrorCount|) 3)) (THROW (QUOTE |compCapsuleBody|) NIL)) ((QUOTE T) NIL)))))) 
-;
-;stackWarning msg ==
-;  if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg]
-;  if not MEMBER(msg,$warningStack) then $warningStack:= [msg,:$warningStack]
-;  nil
-
-;;;     ***       |stackWarning| REDEFINED
-
-(DEFUN |stackWarning| (|msg|) (PROGN (COND (|$insideCapsuleFunctionIfTrue| (SPADLET |msg| (CONS |$op| (CONS (QUOTE |: |) |msg|))))) (COND ((NULL (|member| |msg| |$warningStack|)) (SPADLET |$warningStack| (CONS |msg| |$warningStack|)))) NIL)) 
-;
-;unStackWarning msg ==
-;  if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg]
-;  $warningStack:= EFFACE(msg,$warningStack)
-;  nil
-
-;;;     ***       |unStackWarning| REDEFINED
-
-(DEFUN |unStackWarning| (|msg|) (PROGN (COND (|$insideCapsuleFunctionIfTrue| (SPADLET |msg| (CONS |$op| (CONS (QUOTE |: |) |msg|))))) (SPADLET |$warningStack| (EFFACE |msg| |$warningStack|)) NIL)) 
-;
-;stackMessage msg ==
-;  $compErrorMessageStack:= [msg,:$compErrorMessageStack]
-;  nil
-
-;;;     ***       |stackMessage| REDEFINED
-
-(DEFUN |stackMessage| (|msg|) (PROGN (SPADLET |$compErrorMessageStack| (CONS |msg| |$compErrorMessageStack|)) NIL)) 
-;
-;stackMessageIfNone msg ==
-;  --used in situations such as compForm where the earliest message is wanted
-;  if null $compErrorMessageStack then $compErrorMessageStack:=
-;    [msg,:$compErrorMessageStack]
-;  nil
-
-;;;     ***       |stackMessageIfNone| REDEFINED
-
-(DEFUN |stackMessageIfNone| (|msg|) (PROGN (COND ((NULL |$compErrorMessageStack|) (SPADLET |$compErrorMessageStack| (CONS |msg| |$compErrorMessageStack|)))) NIL)) 
-;
-;stackAndThrow msg ==
-;  $compErrorMessageStack:= [msg,:$compErrorMessageStack]
-;  THROW("compOrCroak",nil)
-
-;;;     ***       |stackAndThrow| REDEFINED
-
-(DEFUN |stackAndThrow| (|msg|) (PROGN (SPADLET |$compErrorMessageStack| (CONS |msg| |$compErrorMessageStack|)) (THROW (QUOTE |compOrCroak|) NIL))) 
-;
-;printString x == PRINTEXP (STRINGP x => x; PNAME x)
-
-;;;     ***       |printString| REDEFINED
-
-(DEFUN |printString| (|x|) (PRINTEXP (COND ((STRINGP |x|) |x|) ((QUOTE T) (PNAME |x|))))) 
-;
-;printAny x == if atom x then printString x else PRIN0 x
-
-;;;     ***       |printAny| REDEFINED
-
-(DEFUN |printAny| (|x|) (COND ((ATOM |x|) (|printString| |x|)) ((QUOTE T) (PRIN0 |x|)))) 
-;
-;printSignature(before,op,[target,:argSigList]) ==
-;  printString before
-;  printString op
-;  printString ": _("
-;  if argSigList then
-;    printAny first argSigList
-;    for m in rest argSigList repeat (printString ","; printAny m)
-;  printString "_) -> "
-;  printAny target
-;  TERPRI()
-
-;;;     ***       |printSignature| REDEFINED
-
-(DEFUN |printSignature| (|before| |op| #0=#:G3594) (PROG (|target| |argSigList|) (RETURN (SEQ (PROGN (SPADLET |target| (CAR #0#)) (SPADLET |argSigList| (CDR #0#)) (|printString| |before|) (|printString| |op|) (|printString| (QUOTE |: (|)) (COND (|argSigList| (|printAny| (CAR |argSigList|)) (DO ((#1=#:G3608 (CDR |argSigList|) (CDR #1#)) (|m| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |m| (CAR #1#)) NIL)) NIL) (SEQ (EXIT (PROGN (|printString| (QUOTE |,|)) (|printAny| |m|))))))) (|printString| (QUOTE |) -> |)) (|printAny| |target|) (TERPRI)))))) 
-;
-;pmatch(s,p) == pmatchWithSl(s,p,"ok")
-
-;;;     ***       |pmatch| REDEFINED
-
-(DEFUN |pmatch| (|s| |p|) (|pmatchWithSl| |s| |p| (QUOTE |ok|))) 
-;
-;pmatchWithSl(s,p,al) ==
-;  s=$EmptyMode => nil
-;  s=p => al
-;  v:= ASSOC(p,al) => s=rest v or al
-;  MEMQ(p,$PatternVariableList) => [[p,:s],:al]
-;  null atom p and null atom s and (al':= pmatchWithSl(first s,first p,al)) and
-;    pmatchWithSl(rest s,rest p,al')
-
-;;;     ***       |pmatchWithSl| REDEFINED
-
-(DEFUN |pmatchWithSl| (|s| |p| |al|) (PROG (|v| |al'|) (RETURN (COND ((BOOT-EQUAL |s| |$EmptyMode|) NIL) ((BOOT-EQUAL |s| |p|) |al|) ((SPADLET |v| (|assoc| |p| |al|)) (OR (BOOT-EQUAL |s| (CDR |v|)) |al|)) ((MEMQ |p| |$PatternVariableList|) (CONS (CONS |p| |s|) |al|)) ((QUOTE T) (AND (NULL (ATOM |p|)) (NULL (ATOM |s|)) (SPADLET |al'| (|pmatchWithSl| (CAR |s|) (CAR |p|) |al|)) (|pmatchWithSl| (CDR |s|) (CDR |p|) |al'|))))))) 
-;
-;elapsedTime() ==
-;  currentTime:= TEMPUS_-FUGIT()
-;  elapsedSeconds:= (currentTime-$previousTime)*1.0/$timerTicksPerSecond
-;  $previousTime:= currentTime
-;  elapsedSeconds
-
-;;;     ***       |elapsedTime| REDEFINED
-
-(DEFUN |elapsedTime| NIL (PROG (|currentTime| |elapsedSeconds|) (RETURN (PROGN (SPADLET |currentTime| (TEMPUS-FUGIT)) (SPADLET |elapsedSeconds| (QUOTIENT (TIMES (SPADDIFFERENCE |currentTime| |$previousTime|) 1.0) |$timerTicksPerSecond|)) (SPADLET |$previousTime| |currentTime|) |elapsedSeconds|)))) 
-;
-;addStats([a,b],[c,d]) == [a+c,b+d]
-
-;;;     ***       |addStats| REDEFINED
-
-(DEFUN |addStats| (#0=#:G3635 #1=#:G3644) (PROG (|c| |d| |a| |b|) (RETURN (PROGN (SPADLET |c| (CAR #1#)) (SPADLET |d| (CADR #1#)) (SPADLET |a| (CAR #0#)) (SPADLET |b| (CADR #0#)) (CONS (PLUS |a| |c|) (CONS (PLUS |b| |d|) NIL)))))) 
-;
-;printStats [byteCount,elapsedSeconds] ==
-;  timeString := normalizeStatAndStringify elapsedSeconds
-;  if byteCount = 0 then SAY('"Time: ",timeString,'" SEC.") else
-;    SAY('"Size: ",byteCount,'" BYTES     Time: ",timeString,'" SEC.")
-;  TERPRI()
-;  nil
-
-;;;     ***       |printStats| REDEFINED
-
-(DEFUN |printStats| (#0=#:G3665) (PROG (|byteCount| |elapsedSeconds| |timeString|) (RETURN (PROGN (SPADLET |byteCount| (CAR #0#)) (SPADLET |elapsedSeconds| (CADR #0#)) (SPADLET |timeString| (|normalizeStatAndStringify| |elapsedSeconds|)) (COND ((EQL |byteCount| 0) (SAY (MAKESTRING "Time: ") |timeString| (MAKESTRING " SEC."))) ((QUOTE T) (SAY (MAKESTRING "Size: ") |byteCount| (MAKESTRING " BYTES     Time: ") |timeString| (MAKESTRING " SEC.")))) (TERPRI) NIL)))) 
-;
-;extendsCategoryForm(domain,form,form') ==
-;  --is domain of category form also of category form'?
-;  --domain is only used for SubsetCategory resolution.
-;  --and ensuring that X being a Ring means that it
-;  --satisfies (Algebra X)
-;  form=form' => true
-;  form=$Category => nil
-;  form' is ["Join",:l] => and/[extendsCategoryForm(domain,form,x) for x in l]
-;  form' is ["CATEGORY",.,:l] =>
-;    and/[extendsCategoryForm(domain,form,x) for x in l]
-;  form' is ["SubsetCategory",cat,dom] =>
-;    extendsCategoryForm(domain,form,cat) and isSubset(domain,dom,$e)
-;  form is ["Join",:l] => or/[extendsCategoryForm(domain,x,form') for x in l]
-;  form is ["CATEGORY",.,:l] =>
-;    MEMBER(form',l) or
-;      stackWarning ["not known that ",form'," is of mode ",form] or true
-;  isCategoryForm(form,$EmptyEnvironment) =>
-;          --Constructs the associated vector
-;    formVec:=(compMakeCategoryObject(form,$e)).expr
-;            --Must be $e to pick up locally bound domains
-;    form' is ["SIGNATURE",op,args,:.] =>
-;        ASSOC([op,args],formVec.(1)) or
-;            ASSOC(SUBSTQ(domain,"$",[op,args]),
-;                  SUBSTQ(domain,"$",formVec.(1)))
-;    form' is ["ATTRIBUTE",at] =>
-;         ASSOC(at,formVec.2) or
-;            ASSOC(SUBSTQ(domain,"$",at),SUBSTQ(domain,"$",formVec.2))
-;    form' is ["IF",:.] => true --temporary hack so comp won't fail
-;    -- Are we dealing with an Aldor category?  If so use the "has" function ...
-;    # formVec = 1 => newHasTest(form,form')
-;    catvlist:= formVec.4
-;    MEMBER(form',first catvlist) or
-;     MEMBER(form',SUBSTQ(domain,"$",first catvlist)) or
-;      (or/
-;        [extendsCategoryForm(domain,SUBSTQ(domain,"$",cat),form')
-;          for [cat,:.] in CADR catvlist])
-;  nil
-
-;;;     ***       |extendsCategoryForm| REDEFINED
-
-(DEFUN |extendsCategoryForm| (|domain| |form| |form'|) (PROG (|dom| |l| |formVec| |op| |ISTMP#2| |args| |ISTMP#1| |at| |catvlist| |cat|) (RETURN (SEQ (COND ((BOOT-EQUAL |form| |form'|) (QUOTE T)) ((BOOT-EQUAL |form| |$Category|) NIL) ((AND (PAIRP |form'|) (EQ (QCAR |form'|) (QUOTE |Join|)) (PROGN (SPADLET |l| (QCDR |form'|)) (QUOTE T))) (PROG (#0=#:G3729) (SPADLET #0# (QUOTE T)) (RETURN (DO ((#1=#:G3735 NIL (NULL #0#)) (#2=#:G3736 |l| (CDR #2#)) (|x| NIL)) ((OR #1# (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #0#) (SEQ (EXIT (SETQ #0# (AND #0# (|extendsCategoryForm| |domain| |form| |x|))))))))) ((AND (PAIRP |form'|) (EQ (QCAR |form'|) (QUOTE CATEGORY)) (PROGN (SPADLET |ISTMP#1| (QCDR |form'|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) (QUOTE T))))) (PROG (#3=#:G3743) (SPADLET #3# (QUOTE T)) (RETURN (DO ((#4=#:G3749 NIL (NULL #3#)) (#5=#:G3750 |l| (CDR #5#)) (|x| NIL)) ((OR #4# (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) #3#) (SEQ (EXIT (SETQ #3# (AND #3# (|extendsCategoryForm| |domain| |form| |x|))))))))) ((AND (PAIRP |form'|) (EQ (QCAR |form'|) (QUOTE |SubsetCategory|)) (PROGN (SPADLET |ISTMP#1| (QCDR |form'|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |cat| (QCAR |ISTMP#1|)) (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) (PROGN (SPADLET |dom| (QCAR |ISTMP#2|)) (QUOTE T))))))) (AND (|extendsCategoryForm| |domain| |form| |cat|) (|isSubset| |domain| |dom| |$e|))) ((AND (PAIRP |form|) (EQ (QCAR |form|) (QUOTE |Join|)) (PROGN (SPADLET |l| (QCDR |form|)) (QUOTE T))) (PROG (#6=#:G3757) (SPADLET #6# NIL) (RETURN (DO ((#7=#:G3763 NIL #6#) (#8=#:G3764 |l| (CDR #8#)) (|x| NIL)) ((OR #7# (ATOM #8#) (PROGN (SETQ |x| (CAR #8#)) NIL)) #6#) (SEQ (EXIT (SETQ #6# (OR #6# (|extendsCategoryForm| |domain| |x| |form'|))))))))) ((AND (PAIRP |form|) (EQ (QCAR |form|) (QUOTE CATEGORY)) (PROGN (SPADLET |ISTMP#1| (QCDR |form|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) (QUOTE T))))) (OR (|member| |form'| |l|) (|stackWarning| (CONS (QUOTE |not known that |) (CONS |form'| (CONS (QUOTE | is of mode |) (CONS |form| NIL))))) (QUOTE T))) ((|isCategoryForm| |form| |$EmptyEnvironment|) (SPADLET |formVec| (CAR (|compMakeCategoryObject| |form| |$e|))) (COND ((AND (PAIRP |form'|) (EQ (QCAR |form'|) (QUOTE SIGNATURE)) (PROGN (SPADLET |ISTMP#1| (QCDR |form'|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |op| (QCAR |ISTMP#1|)) (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (PROGN (SPADLET |args| (QCAR |ISTMP#2|)) (QUOTE T))))))) (OR (|assoc| (CONS |op| (CONS |args| NIL)) (ELT |formVec| 1)) (|assoc| (SUBSTQ |domain| (QUOTE $) (CONS |op| (CONS |args| NIL))) (SUBSTQ |domain| (QUOTE $) (ELT |formVec| 1))))) ((AND (PAIRP |form'|) (EQ (QCAR |form'|) (QUOTE ATTRIBUTE)) (PROGN (SPADLET |ISTMP#1| (QCDR |form'|)) (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) (PROGN (SPADLET |at| (QCAR |ISTMP#1|)) (QUOTE T))))) (OR (|assoc| |at| (ELT |formVec| 2)) (|assoc| (SUBSTQ |domain| (QUOTE $) |at|) (SUBSTQ |domain| (QUOTE $) (ELT |formVec| 2))))) ((AND (PAIRP |form'|) (EQ (QCAR |form'|) (QUOTE IF))) (QUOTE T)) ((EQL (|#| |formVec|) 1) (|newHasTest| |form| |form'|)) ((QUOTE T) (SPADLET |catvlist| (ELT |formVec| 4)) (OR (|member| |form'| (CAR |catvlist|)) (|member| |form'| (SUBSTQ |domain| (QUOTE $) (CAR |catvlist|))) (PROG (#9=#:G3771) (SPADLET #9# NIL) (RETURN (DO ((#10=#:G3778 NIL #9#) (#11=#:G3779 (CADR |catvlist|) (CDR #11#)) (#12=#:G3724 NIL)) ((OR #10# (ATOM #11#) (PROGN (SETQ #12# (CAR #11#)) NIL) (PROGN (PROGN (SPADLET |cat| (CAR #12#)) #12#) NIL)) #9#) (SEQ (EXIT (SETQ #9# (OR #9# (|extendsCategoryForm| |domain| (SUBSTQ |domain| (QUOTE $) |cat|) |form'|)))))))))))) ((QUOTE T) NIL)))))) 
-;
-;getmode(x,e) ==
-;  prop:=getProplist(x,e)
-;  u:= LASSQ("value",prop) => u.mode
-;  LASSQ("mode",prop)
-
-;;;     ***       |getmode| REDEFINED
-
-(DEFUN |getmode| (|x| |e|) (PROG (|prop| |u|) (RETURN (PROGN (SPADLET |prop| (|getProplist| |x| |e|)) (COND ((SPADLET |u| (LASSQ (QUOTE |value|) |prop|)) (CADR |u|)) ((QUOTE T) (LASSQ (QUOTE |mode|) |prop|))))))) 
-;
-;getmodeOrMapping(x,e) ==
-;  u:= getmode(x,e) => u
-;  (u:= get(x,"modemap",e)) is [[[.,:map],.],:.] => ["Mapping",:map]
-;  nil
-
-;;;     ***       |getmodeOrMapping| REDEFINED
-
-(DEFUN |getmodeOrMapping| (|x| |e|) (PROG (|u| |ISTMP#1| |ISTMP#2| |ISTMP#3| |map| |ISTMP#4|) (RETURN (COND ((SPADLET |u| (|getmode| |x| |e|)) |u|) ((PROGN (SPADLET |ISTMP#1| (SPADLET |u| (|get| |x| (QUOTE |modemap|) |e|))) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (PROGN (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) (AND (PAIRP |ISTMP#3|) (PROGN (SPADLET |map| (QCDR |ISTMP#3|)) (QUOTE T)))) (PROGN (SPADLET |ISTMP#4| (QCDR |ISTMP#2|)) (AND (PAIRP |ISTMP#4|) (EQ (QCDR |ISTMP#4|) NIL))))))) (CONS (QUOTE |Mapping|) |map|)) ((QUOTE T) NIL))))) 
-;
-;outerProduct l ==
-;                --of a list of lists
-;  null l => LIST nil
-;  "append"/[[[x,:y] for y in outerProduct rest l] for x in first l]
-
-;;;     ***       |outerProduct| REDEFINED
-
-(DEFUN |outerProduct| (|l|) (PROG NIL (RETURN (SEQ (COND ((NULL |l|) (LIST NIL)) ((QUOTE T) (PROG (#0=#:G3855) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G3860 (CAR |l|) (CDR #1#)) (|x| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) #0#) (SEQ (EXIT (SETQ #0# (APPEND #0# (PROG (#2=#:G3870) (SPADLET #2# NIL) (RETURN (DO ((#3=#:G3875 (|outerProduct| (CDR |l|)) (CDR #3#)) (|y| NIL)) ((OR (ATOM #3#) (PROGN (SETQ |y| (CAR #3#)) NIL)) (NREVERSE0 #2#)) (SEQ (EXIT (SETQ #2# (CONS (CONS |x| |y|) #2#)))))))))))))))))))) 
-;
-;sublisR(al,u) ==
-;  atom u => u
-;  y:= RASSOC(t:= [sublisR(al,x) for x in u],al) => y
-;  true => t
-
-;;;     ***       |sublisR| REDEFINED
-
-(DEFUN |sublisR| (|al| |u|) (PROG (|t| |y|) (RETURN (SEQ (COND ((ATOM |u|) |u|) ((SPADLET |y| (|rassoc| (SPADLET |t| (PROG (#0=#:G3891) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G3896 |u| (CDR #1#)) (|x| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (|sublisR| |al| |x|) #0#)))))))) |al|)) |y|) ((QUOTE T) |t|)))))) 
-;
-;substituteOp(op',op,x) ==
-;  atom x => x
-;  [(op=(f:= first x) => op'; f),:[substituteOp(op',op,y) for y in rest x]]
-
-;;;     ***       |substituteOp| REDEFINED
-
-(DEFUN |substituteOp| (|op'| |op| |x|) (PROG (|f|) (RETURN (SEQ (COND ((ATOM |x|) |x|) ((QUOTE T) (CONS (COND ((BOOT-EQUAL |op| (SPADLET |f| (CAR |x|))) |op'|) ((QUOTE T) |f|)) (PROG (#0=#:G3914) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G3919 (CDR |x|) (CDR #1#)) (|y| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (|substituteOp| |op'| |op| |y|) #0#)))))))))))))) 
-;
-;--substituteForFormalArguments(argl,expr) ==
-;--  SUBLIS([[v,:a] for a in argl for v in $FormalMapVariableList],expr)
-;
-; -- following is only intended for substituting in domains slots 1 and 4
-; -- signatures and categories
-;sublisV(p,e) ==
-;  (atom p => e; suba(p,e)) where
-;    suba(p,e) ==
-;      STRINGP e => e
-;      -- no need to descend vectors unless they are categories
-;      --REFVECP e => LIST2REFVEC [suba(p,e.i) for i in 0..MAXINDEX e]
-;      isCategory e => LIST2REFVEC [suba(p,e.i) for i in 0..MAXINDEX e]
-;      atom e => (y:= ASSQ(e,p) => rest y; e)
-;      u:= suba(p,QCAR e)
-;      v:= suba(p,QCDR e)
-;      EQ(QCAR e,u) and EQ(QCDR e,v) => e
-;      [u,:v]
-
-;;;     ***       |sublisV,suba| REDEFINED
-
-(DEFUN |sublisV,suba| (|p| |e|) (PROG (|y| |u| |v|) (RETURN (SEQ (IF (STRINGP |e|) (EXIT |e|)) (IF (|isCategory| |e|) (EXIT (LIST2REFVEC (PROG (#0=#:G3936) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G3941 (MAXINDEX |e|)) (|i| 0 (QSADD1 |i|))) ((QSGREATERP |i| #1#) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (|sublisV,suba| |p| (ELT |e| |i|)) #0#)))))))))) (IF (ATOM |e|) (EXIT (SEQ (IF (SPADLET |y| (ASSQ |e| |p|)) (EXIT (CDR |y|))) (EXIT |e|)))) (SPADLET |u| (|sublisV,suba| |p| (QCAR |e|))) (SPADLET |v| (|sublisV,suba| |p| (QCDR |e|))) (IF (AND (EQ (QCAR |e|) |u|) (EQ (QCDR |e|) |v|)) (EXIT |e|)) (EXIT (CONS |u| |v|)))))) 
-
-;;;     ***       |sublisV| REDEFINED
-
-(DEFUN |sublisV| (|p| |e|) (COND ((ATOM |p|) |e|) ((QUOTE T) (|sublisV,suba| |p| |e|)))) 
-;
-;--% DEBUGGING PRINT ROUTINES used in breaks
-;
-;_?MODEMAPS x == _?modemaps x
-
-;;;     ***       ?MODEMAPS REDEFINED
-
-(DEFUN ?MODEMAPS (|x|) (|?modemaps| |x|)) 
-;_?modemaps x ==
-;  env:=
-;    $insideCapsuleFunctionIfTrue=true => $CapsuleModemapFrame
-;    $f
-;  x="all" => displayModemaps env
-;  displayOpModemaps(x,old2NewModemaps get(x,"modemap",env))
-
-;;;     ***       |?modemaps| REDEFINED
-
-(DEFUN |?modemaps| (|x|) (PROG (|env|) (RETURN (PROGN (SPADLET |env| (COND ((BOOT-EQUAL |$insideCapsuleFunctionIfTrue| (QUOTE T)) |$CapsuleModemapFrame|) ((QUOTE T) |$f|))) (COND ((BOOT-EQUAL |x| (QUOTE |all|)) (|displayModemaps| |env|)) ((QUOTE T) (|displayOpModemaps| |x| (|old2NewModemaps| (|get| |x| (QUOTE |modemap|) |env|))))))))) 
-;old2NewModemaps x ==
-;  [[dcSig,pred] for [dcSig,[pred,:.],:.] in x]
-
-;;;     ***       |old2NewModemaps| REDEFINED
-
-(DEFUN |old2NewModemaps| (|x|) (PROG (|dcSig| |pred|) (RETURN (SEQ (PROG (#0=#:G3975) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G3981 |x| (CDR #1#)) (#2=#:G3966 NIL)) ((OR (ATOM #1#) (PROGN (SETQ #2# (CAR #1#)) NIL) (PROGN (PROGN (SPADLET |dcSig| (CAR #2#)) (SPADLET |pred| (CAADR #2#)) #2#) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (CONS |dcSig| (CONS |pred| NIL)) #0#))))))))))) 
-;
-;traceUp() ==
-;  atom $x => sayBrightly "$x is an atom"
-;  for y in rest $x repeat
-;    u:= comp(y,$EmptyMode,$f) =>
-;      sayBrightly [y,'" ==> mode",'%b,u.mode,'%d]
-;    sayBrightly [y,'" does not compile"]
-
-;;;     ***       |traceUp| REDEFINED
-
-(DEFUN |traceUp| NIL (PROG (|u|) (RETURN (SEQ (COND ((ATOM |$x|) (|sayBrightly| (MAKESTRING "$x is an atom"))) ((QUOTE T) (DO ((#0=#:G3999 (CDR |$x|) (CDR #0#)) (|y| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |y| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (COND ((SPADLET |u| (|comp| |y| |$EmptyMode| |$f|)) (|sayBrightly| (CONS |y| (CONS (MAKESTRING " ==> mode") (CONS (QUOTE |%b|) (CONS (CADR |u|) (CONS (QUOTE |%d|) NIL))))))) ((QUOTE T) (|sayBrightly| (CONS |y| (CONS (MAKESTRING " does not compile") NIL)))))))))))))) 
-;
-;_?M x == _?m x
-
-;;;     ***       ?M REDEFINED
-
-(DEFUN ?M (|x|) (|?m| |x|)) 
-;_?m x ==
-;  u:= comp(x,$EmptyMode,$f) => u.mode
-;  nil
-
-;;;     ***       |?m| REDEFINED
-
-(DEFUN |?m| (|x|) (PROG (|u|) (RETURN (COND ((SPADLET |u| (|comp| |x| |$EmptyMode| |$f|)) (CADR |u|)) ((QUOTE T) NIL))))) 
-;
-;traceDown() ==
-;  mmList:= getFormModemaps($x,$f) =>
-;    for mm in mmList repeat if u:= qModemap mm then return u
-;  sayBrightly "no modemaps for $x"
-
-;;;     ***       |traceDown| REDEFINED
-
-(DEFUN |traceDown| NIL (PROG (|mmList| |u|) (RETURN (SEQ (COND ((SPADLET |mmList| (|getFormModemaps| |$x| |$f|)) (DO ((#0=#:G4021 |mmList| (CDR #0#)) (|mm| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (COND ((SPADLET |u| (|qModemap| |mm|)) (RETURN |u|)) ((QUOTE T) NIL)))))) ((QUOTE T) (|sayBrightly| (MAKESTRING "no modemaps for $x")))))))) 
-;
-;qModemap mm ==
-;  sayBrightly ['%b,"modemap",'%d,:formatModemap mm]
-;  [[dc,target,:sl],[pred,:.]]:= mm
-;  and/[qArg(a,m) for a in rest $x for m in sl] => target
-;  sayBrightly ['%b,"fails",'%d,'%l]
-
-;;;     ***       |qModemap| REDEFINED
-
-(DEFUN |qModemap| (|mm|) (PROG (|dc| |target| |sl| |pred|) (RETURN (SEQ (PROGN (|sayBrightly| (CONS (QUOTE |%b|) (CONS (MAKESTRING "modemap") (CONS (QUOTE |%d|) (|formatModemap| |mm|))))) (SPADLET |dc| (CAAR |mm|)) (SPADLET |target| (CADAR |mm|)) (SPADLET |sl| (CDDAR |mm|)) (SPADLET |pred| (CAADR |mm|)) (COND ((PROG (#0=#:G4038) (SPADLET #0# (QUOTE T)) (RETURN (DO ((#1=#:G4045 NIL (NULL #0#)) (#2=#:G4046 (CDR |$x|) (CDR #2#)) (|a| NIL) (#3=#:G4047 |sl| (CDR #3#)) (|m| NIL)) ((OR #1# (ATOM #2#) (PROGN (SETQ |a| (CAR #2#)) NIL) (ATOM #3#) (PROGN (SETQ |m| (CAR #3#)) NIL)) #0#) (SEQ (EXIT (SETQ #0# (AND #0# (|qArg| |a| |m|)))))))) |target|) ((QUOTE T) (|sayBrightly| (CONS (QUOTE |%b|) (CONS (MAKESTRING "fails") (CONS (QUOTE |%d|) (CONS (QUOTE |%l|) NIL)))))))))))) 
-;
-;qArg(a,m) ==
-;  yesOrNo:=
-;    u:= comp(a,m,$f) => "yes"
-;    "no"
-;  sayBrightly [a," --> ",m,'%b,yesOrNo,'%d]
-;  yesOrNo="yes"
-
-;;;     ***       |qArg| REDEFINED
-
-(DEFUN |qArg| (|a| |m|) (PROG (|u| |yesOrNo|) (RETURN (PROGN (SPADLET |yesOrNo| (COND ((SPADLET |u| (|comp| |a| |m| |$f|)) (QUOTE |yes|)) ((QUOTE T) (QUOTE |no|)))) (|sayBrightly| (CONS |a| (CONS (MAKESTRING " --> ") (CONS |m| (CONS (QUOTE |%b|) (CONS |yesOrNo| (CONS (QUOTE |%d|) NIL))))))) (BOOT-EQUAL |yesOrNo| (QUOTE |yes|)))))) 
-;
-;_?COMP x == _?comp x
-
-;;;     ***       ?COMP REDEFINED
-
-(DEFUN ?COMP (|x|) (|?comp| |x|)) 
-;_?comp x ==
-;  msg:=
-;    u:= comp(x,$EmptyMode,$f) =>
-;      [MAKESTRING "compiles to mode",'%b,u.mode,'%d]
-;    nil
-;  sayBrightly msg
-
-;;;     ***       |?comp| REDEFINED
-
-(DEFUN |?comp| (|x|) (PROG (|u| |msg|) (RETURN (PROGN (SPADLET |msg| (COND ((SPADLET |u| (|comp| |x| |$EmptyMode| |$f|)) (CONS (MAKESTRING "compiles to mode") (CONS (QUOTE |%b|) (CONS (CADR |u|) (CONS (QUOTE |%d|) NIL))))) ((QUOTE T) NIL))) (|sayBrightly| |msg|))))) 
-;
-;_?domains() == pp getDomainsInScope $f
-
-;;;     ***       |?domains| REDEFINED
-
-(DEFUN |?domains| NIL (|pp| (|getDomainsInScope| |$f|))) 
-;_?DOMAINS() == ?domains()
-
-;;;     ***       ?DOMAINS REDEFINED
-
-(DEFUN ?DOMAINS NIL (|?domains|)) 
-;
-;_?mode x == displayProplist(x,[["mode",:getmode(x,$f)]])
-
-;;;     ***       |?mode| REDEFINED
-
-(DEFUN |?mode| (|x|) (|displayProplist| |x| (CONS (CONS (QUOTE |mode|) (|getmode| |x| |$f|)) NIL))) 
-;_?MODE x == _?mode x
-
-;;;     ***       ?MODE REDEFINED
-
-(DEFUN ?MODE (|x|) (|?mode| |x|)) 
-;
-;_?properties x == displayProplist(x,getProplist(x,$f))
-
-;;;     ***       |?properties| REDEFINED
-
-(DEFUN |?properties| (|x|) (|displayProplist| |x| (|getProplist| |x| |$f|))) 
-;_?PROPERTIES x == _?properties x
-
-;;;     ***       ?PROPERTIES REDEFINED
-
-(DEFUN ?PROPERTIES (|x|) (|?properties| |x|)) 
-;
-;_?value x == displayProplist(x,[["value",:get(x,"value",$f)]])
-
-;;;     ***       |?value| REDEFINED
-
-(DEFUN |?value| (|x|) (|displayProplist| |x| (CONS (CONS (QUOTE |value|) (|get| |x| (QUOTE |value|) |$f|)) NIL))) 
-;_?VALUE x == _?value x
-
-;;;     ***       ?VALUE REDEFINED
-
-(DEFUN ?VALUE (|x|) (|?value| |x|)) 
-;
-;displayProplist(x,alist) ==
-;  sayBrightly ["properties of",'%b,x,'%d,":"]
-;  fn alist where
-;    fn alist ==
-;      alist is [[prop,:val],:l] =>
-;        if prop="value" then val:= [val.expr,val.mode,'"..."]
-;        sayBrightly ["   ",'%b,prop,'%d,": ",val]
-;        fn deleteAssoc(prop,l)
-
-;;;     ***       |displayProplist,fn| REDEFINED
-
-(DEFUN |displayProplist,fn| (|alist|) (PROG (|ISTMP#1| |prop| |l| |val|) (RETURN (SEQ (IF (AND (PAIRP |alist|) (PROGN (SPADLET |ISTMP#1| (QCAR |alist|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |prop| (QCAR |ISTMP#1|)) (SPADLET |val| (QCDR |ISTMP#1|)) (QUOTE T)))) (PROGN (SPADLET |l| (QCDR |alist|)) (QUOTE T))) (EXIT (SEQ (IF (BOOT-EQUAL |prop| (QUOTE |value|)) (SPADLET |val| (CONS (CAR |val|) (CONS (CADR |val|) (CONS (MAKESTRING "...") NIL)))) NIL) (|sayBrightly| (CONS (MAKESTRING "   ") (CONS (QUOTE |%b|) (CONS |prop| (CONS (QUOTE |%d|) (CONS (MAKESTRING ": ") (CONS |val| NIL))))))) (EXIT (|displayProplist,fn| (|deleteAssoc| |prop| |l|)))))))))) 
-
-;;;     ***       |displayProplist| REDEFINED
-
-(DEFUN |displayProplist| (|x| |alist|) (PROGN (|sayBrightly| (CONS (MAKESTRING "properties of") (CONS (QUOTE |%b|) (CONS |x| (CONS (QUOTE |%d|) (CONS (MAKESTRING ":") NIL)))))) (|displayProplist,fn| |alist|))) 
-;
-;displayModemaps E ==
-;  listOfOperatorsSeenSoFar:= nil
-;  for x in E for i in 1.. repeat
-;    for y in x for j in 1.. repeat
-;      for z in y | null MEMBER(first z,listOfOperatorsSeenSoFar) and
-;        (modemaps:= LASSOC("modemap",rest z)) repeat
-;          listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar]
-;          displayOpModemaps(first z,modemaps)
-
-;;;     ***       |displayModemaps| REDEFINED
-
-(DEFUN |displayModemaps| (E) (PROG (|modemaps| |listOfOperatorsSeenSoFar|) (RETURN (SEQ (PROGN (SPADLET |listOfOperatorsSeenSoFar| NIL) (DO ((#0=#:G4136 E (CDR #0#)) (|x| NIL) (|i| 1 (QSADD1 |i|))) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (DO ((#1=#:G4148 |x| (CDR #1#)) (|y| NIL) (|j| 1 (QSADD1 |j|))) ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) NIL) (SEQ (EXIT (DO ((#2=#:G4160 |y| (CDR #2#)) (|z| NIL)) ((OR (ATOM #2#) (PROGN (SETQ |z| (CAR #2#)) NIL)) NIL) (SEQ (EXIT (COND ((AND (NULL (|member| (CAR |z|) |listOfOperatorsSeenSoFar|)) (SPADLET |modemaps| (LASSOC (QUOTE |modemap|) (CDR |z|)))) (PROGN (SPADLET |listOfOperatorsSeenSoFar| (CONS (CAR |z|) |listOfOperatorsSeenSoFar|)) (|displayOpModemaps| (CAR |z|) |modemaps|)))))))))))))))))) 
-;
-;--% General object traversal functions
-;
-;GEQSUBSTLIST(old, new, body) ==
-;    GEQNSUBSTLIST(old, new, GCOPY body)
-
-;;;     ***       GEQSUBSTLIST REDEFINED
-
-(DEFUN GEQSUBSTLIST (|old| |new| |body|) (GEQNSUBSTLIST |old| |new| (GCOPY |body|))) 
-;
-;GEQNSUBSTLIST(old, new, body) ==
-;    or/[:[EQ(o,n) for o in old] for n in new] =>
-;        mid := [GENSYM() for o in old]
-;        GEQNSUBSTLIST(old, mid, body)
-;        GEQNSUBSTLIST(mid, new, body)
-;    alist := [[o,:n] for o in old for n in new]
-;    traverse(function GSUBSTinner, alist, body) where
-;        GSUBSTinner(alist, ob) ==
-;            (pr := ASSQ(ob, alist)) => CDR pr
-;            ob
-
-;;;     ***       |GEQNSUBSTLIST,GSUBSTinner| REDEFINED
-
-(DEFUN |GEQNSUBSTLIST,GSUBSTinner| (|alist| |ob|) (PROG (|pr|) (RETURN (SEQ (IF (SPADLET |pr| (ASSQ |ob| |alist|)) (EXIT (CDR |pr|))) (EXIT |ob|))))) 
-
-;;;     ***       GEQNSUBSTLIST REDEFINED
-
-(DEFUN GEQNSUBSTLIST (|old| |new| |body|) (PROG (|mid| |alist|) (RETURN (SEQ (COND ((REDUCE-N (QUOTE OR2) NIL (PROG (#0=#:G4183) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G4188 |new| (CDR #1#)) (|n| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |n| (CAR #1#)) NIL)) #0#) (SEQ (EXIT (SETQ #0# (APPEND #0# (PROG (#2=#:G4198) (SPADLET #2# NIL) (RETURN (DO ((#3=#:G4203 |old| (CDR #3#)) (|o| NIL)) ((OR (ATOM #3#) (PROGN (SETQ |o| (CAR #3#)) NIL)) (NREVERSE0 #2#)) (SEQ (EXIT (SETQ #2# (CONS (EQ |o| |n|) #2#)))))))))))))) NIL) (SPADLET |mid| (PROG (#4=#:G4213) (SPADLET #4# NIL) (RETURN (DO ((#5=#:G4218 |old| (CDR #5#)) (|o| NIL)) ((OR (ATOM #5#) (PROGN (SETQ |o| (CAR #5#)) NIL)) (NREVERSE0 #4#)) (SEQ (EXIT (SETQ #4# (CONS (GENSYM) #4#)))))))) (GEQNSUBSTLIST |old| |mid| |body|) (GEQNSUBSTLIST |mid| |new| |body|)) ((QUOTE T) (SPADLET |alist| (PROG (#6=#:G4229) (SPADLET #6# NIL) (RETURN (DO ((#7=#:G4235 |old| (CDR #7#)) (|o| NIL) (#8=#:G4236 |new| (CDR #8#)) (|n| NIL)) ((OR (ATOM #7#) (PROGN (SETQ |o| (CAR #7#)) NIL) (ATOM #8#) (PROGN (SETQ |n| (CAR #8#)) NIL)) (NREVERSE0 #6#)) (SEQ (EXIT (SETQ #6# (CONS (CONS |o| |n|) #6#)))))))) (|traverse| (|function| |GEQNSUBSTLIST,GSUBSTinner|) |alist| |body|))))))) 
-;
-;GCOPY ob == COPY ob  -- for now
-
-;;;     ***       GCOPY REDEFINED
-
-(DEFUN GCOPY (|ob|) (COPY |ob|)) 
-;
-;traverse(fn, arg, ob) ==
-;    $seen:    local := MAKE_-HASHTABLE 'EQ
-;    $notseen: local := GENSYM()
-;
-;    traverseInner(ob, fn, arg) where
-;        traverseInner(ob, fn, arg) ==
-;            e := HGET($seen, ob, $notseen)
-;            not EQ(e, $notseen) => e
-;
-;            nob := FUNCALL(fn, arg, ob)
-;            HPUT($seen, ob, nob)
-;            not EQ(nob, ob) => nob
-;            PAIRP ob =>
-;                ne:=traverseInner(QCAR ob, fn, arg)
-;                if not EQ(ne,QCAR ob) then QRPLACA(ob, ne)
-;                ne:=traverseInner(QCDR ob, fn, arg)
-;                if not EQ(ne,QCDR ob) then QRPLACD(ob, ne)
-;                ob
-;            VECP ob =>
-;                n := QVMAXINDEX ob
-;                for i in 0..n repeat
-;                    e:=QVELT(ob,i)
-;                    ne:=traverseInner(e, fn, arg)
-;                    if not EQ(ne,e) then QSETVELT(ob,i,ne)
-;                ob
-;            HASHTABLEP ob =>
-;                keys := HKEYS ob
-;                for k in keys repeat
-;                    e  := HGET(ob, k)
-;                    nk := traverseInner(k, fn, arg)
-;                    ne := traverseInner(e, fn, arg)
-;                    if not EQ(k,nk) or not EQ(e,ne) then
-;                        HREM(ob, k)
-;                        HPUT(ob, nk, ne)
-;                ob
-;            PAPPP ob =>
-;                for i in 1..PA_-SPEC_-COUNT ob repeat
-;                    s := PA_-SPEC(ob, i)
-;                    not PAIRP s =>
-;                        ns := traverseInner(s,fn,arg)
-;                        if not EQ(s,ns) then
-;                            SET_-PA_-SPEC(ob,i,ns)
-;                    ns := traverseInner(QCDR s, fn, arg)
-;                    if not EQ(ns,QCDR s) then
-;                       apply(SET_-PA_-SPEC, [ob,i,QCAR s,:ns])
-;                ob
-;            ob
-
-;;;     ***       |traverse,traverseInner| REDEFINED
-
-(DEFUN |traverse,traverseInner| (|ob| |fn| |arg|) (PROG (|nob| |n| |keys| |e| |nk| |ne| |s| |ns|) (RETURN (SEQ (SPADLET |e| (HGET |$seen| |ob| |$notseen|)) (IF (NULL (EQ |e| |$notseen|)) (EXIT |e|)) (SPADLET |nob| (FUNCALL |fn| |arg| |ob|)) (HPUT |$seen| |ob| |nob|) (IF (NULL (EQ |nob| |ob|)) (EXIT |nob|)) (IF (PAIRP |ob|) (EXIT (SEQ (SPADLET |ne| (|traverse,traverseInner| (QCAR |ob|) |fn| |arg|)) (IF (NULL (EQ |ne| (QCAR |ob|))) (QRPLACA |ob| |ne|) NIL) (SPADLET |ne| (|traverse,traverseInner| (QCDR |ob|) |fn| |arg|)) (IF (NULL (EQ |ne| (QCDR |ob|))) (QRPLACD |ob| |ne|) NIL) (EXIT |ob|)))) (IF (VECP |ob|) (EXIT (SEQ (SPADLET |n| (QVMAXINDEX |ob|)) (DO ((|i| 0 (QSADD1 |i|))) ((QSGREATERP |i| |n|) NIL) (SEQ (SPADLET |e| (QVELT |ob| |i|)) (SPADLET |ne| (|traverse,traverseInner| |e| |fn| |arg|)) (EXIT (IF (NULL (EQ |ne| |e|)) (QSETVELT |ob| |i| |ne|) NIL)))) (EXIT |ob|)))) (IF (HASHTABLEP |ob|) (EXIT (SEQ (SPADLET |keys| (HKEYS |ob|)) (DO ((#0=#:G4276 |keys| (CDR #0#)) (|k| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |k| (CAR #0#)) NIL)) NIL) (SEQ (SPADLET |e| (HGET |ob| |k|)) (SPADLET |nk| (|traverse,traverseInner| |k| |fn| |arg|)) (SPADLET |ne| (|traverse,traverseInner| |e| |fn| |arg|)) (EXIT (IF (OR (NULL (EQ |k| |nk|)) (NULL (EQ |e| |ne|))) (SEQ (HREM |ob| |k|) (EXIT (HPUT |ob| |nk| |ne|))) NIL)))) (EXIT |ob|)))) (IF (PAPPP |ob|) (EXIT (SEQ (DO ((#1=#:G4285 (PA-SPEC-COUNT |ob|)) (|i| 1 (QSADD1 |i|))) ((QSGREATERP |i| #1#) NIL) (SEQ (SPADLET |s| (PA-SPEC |ob| |i|)) (IF (NULL (PAIRP |s|)) (EXIT (SEQ (SPADLET |ns| (|traverse,traverseInner| |s| |fn| |arg|)) (EXIT (IF (NULL (EQ |s| |ns|)) (SET-PA-SPEC |ob| |i| |ns|) NIL))))) (SPADLET |ns| (|traverse,traverseInner| (QCDR |s|) |fn| |arg|)) (EXIT (IF (NULL (EQ |ns| (QCDR |s|))) (APPLY SET-PA-SPEC (CONS |ob| (CONS |i| (CONS (QCAR |s|) |ns|)))) NIL)))) (EXIT |ob|)))) (EXIT |ob|))))) 
-
-;;;     ***       |traverse| REDEFINED
-
-(DEFUN |traverse| (|fn| |arg| |ob|) (PROG (|$seen| |$notseen|) (DECLARE (SPECIAL |$seen| |$notseen|)) (RETURN (PROGN (SPADLET |$seen| (MAKE-HASHTABLE (QUOTE EQ))) (SPADLET |$notseen| (GENSYM)) (|traverse,traverseInner| |ob| |fn| |arg|))))) 
-;;;Boot translation finished for c-util.boot
-@
 \eject
 \begin{thebibliography}{99}
 \bibitem{1} nothing
diff --git a/src/interp/clam.boot.pamphlet b/src/interp/clam.boot.pamphlet
index ea1679d2..985bb006 100644
--- a/src/interp/clam.boot.pamphlet
+++ b/src/interp/clam.boot.pamphlet
@@ -49,6 +49,7 @@
 <<*>>=
 <<license>>
 
+import '"g-timer"
 )package "BOOT"
 
 --% Cache Lambda Facility
@@ -405,7 +406,7 @@ displayCacheFrequency al ==
  
 mkCircularCountAlist(cl,len) ==
   for [x,count,:.] in cl for i in 1..len while x ^= '_$failed repeat
-    u:= ASSOC(count,al) => RPLACD(u,1 + CDR u)
+    u:= assoc(count,al) => RPLACD(u,1 + CDR u)
     if INTEGERP $reportFavoritesIfNumber and count >= $reportFavoritesIfNumber then
       sayBrightlyNT ["   ",count,"  "]
       pp x
@@ -422,7 +423,7 @@ reportHashCacheStats fn ==
  
 mkHashCountAlist vl ==
   for [count,:.] in vl repeat
-    u:= ASSOC(count,al) => RPLACD(u,1 + CDR u)
+    u:= assoc(count,al) => RPLACD(u,1 + CDR u)
     al:= [[count,:1],:al]
   al
  
@@ -540,7 +541,7 @@ haddProp(ht,op,prop,val) ==
     recordInstantiation(op,prop,false)
     stopTimingProcess 'debug
   u:= HGET(ht,op) =>     --hope that one exists most of the time
-    ASSOC(prop,u) => val     --value is already there--must = val; exit now
+    assoc(prop,u) => val     --value is already there--must = val; exit now
     RPLACD(u,[CAR u,:CDR u])
     RPLACA(u,[prop,:val])
     $op: local := op
diff --git a/src/interp/g-boot.boot.pamphlet b/src/interp/g-boot.boot.pamphlet
index 63a7c00a..a754a951 100644
--- a/src/interp/g-boot.boot.pamphlet
+++ b/src/interp/g-boot.boot.pamphlet
@@ -49,6 +49,8 @@
 <<*>>=
 <<license>>
 
+import '"def"
+import '"g-util"
 )package "BOOT"
 
 -- @(#)g-boot.boot	2.2      89/11/02  14:44:09
diff --git a/src/interp/g-error.boot.pamphlet b/src/interp/g-error.boot.pamphlet
index 103b8b0a..08ecc434 100644
--- a/src/interp/g-error.boot.pamphlet
+++ b/src/interp/g-error.boot.pamphlet
@@ -50,6 +50,7 @@
 <<license>>
 
 import '"diagnostics"
+import '"g-util"
 )package "BOOT"
 
 -- This file contains the error printing code used in BOOT and SPAD.
@@ -63,9 +64,9 @@ import '"diagnostics"
 --   nobreak  -- do not enter lisp break mode
 --   query    -- ask the user if break mode should be entered
 
-SETANDFILEQ($SystemError,'SystemError)
-SETANDFILEQ($UserError,'UserError)
-SETANDFILEQ($AlgebraError,'AlgebraError)
+$SystemError == 'SystemError
+$UserError == 'UserError
+$AlgebraError =='AlgebraError
 
 -- REDERR is used in BFLOAT LISP, should be a macro
 -- REDERR msg == error msg
@@ -178,7 +179,7 @@ sayErrorly(errorLabel, msg) ==
   sayErrorly1(errorLabel, msg)
 
 saturnSayErrorly(errorLabel, msg) ==
-  _*STANDARD_-OUTPUT_* : fluid := $texOutputStream
+  SETQ(_*STANDARD_-OUTPUT_*, $texOutputStream)
   old := pushSatOutput("line")
   sayString '"\bgroup\color{red}"
   sayString '"\begin{verbatim}"
diff --git a/src/interp/slam.boot.pamphlet b/src/interp/slam.boot.pamphlet
index 4b080f02..fe4f4c1c 100644
--- a/src/interp/slam.boot.pamphlet
+++ b/src/interp/slam.boot.pamphlet
@@ -47,6 +47,7 @@
 <<*>>=
 <<license>>
 
+import '"g-timer"
 )package "BOOT"
 
 reportFunctionCompilation(op,nam,argl,body,isRecursive) ==
diff --git a/src/interp/sys-globals.boot b/src/interp/sys-globals.boot
index 071059fb..e01aca54 100644
--- a/src/interp/sys-globals.boot
+++ b/src/interp/sys-globals.boot
@@ -403,3 +403,6 @@ SPADERRORSTREAM := _*ERROR_-OUTPUT_*
 _/VERSION := 0
 _/WSNAME := "NOBOOT"
 
+++
+CHR := nil
+TOK := nil
author	dos-reis <gdr@axiomatics.org>	2007-10-14 14:31:06 +0000
committer	dos-reis <gdr@axiomatics.org>	2007-10-14 14:31:06 +0000
commit	c74ed936d96536336650b13fe21e79e0db7a2da4 (patch)
tree	bbe9c68519f6ca0d06af7561f114b0ce501b0605 /src/interp
parent	095703f8cc7439cddda478b12667c5ac8264b6d5 (diff)
download	open-axiom-c74ed936d96536336650b13fe21e79e0db7a2da4.tar.gz