diff --git a/changelog b/changelog index f6b39c0..1bea0f4 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090827 tpd src/axiom-website/patches.html 20090827.04.tpd.patch +20090827 tpd src/interp/Makefile move c-util.boot to c-util.lisp +20090827 tpd src/interp/c-util.lisp added, rewritten from c-util.boot +20090827 tpd src/interp/c-util.boot removed, rewritten to c-util.lisp 20090827 tpd src/axiom-website/patches.html 20090827.03.tpd.patch 20090827 tpd src/interp/Makefile move category.boot to category.lisp 20090827 tpd src/interp/category.lisp added, rewritten from category.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index ed3d76c..cbea030 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1916,5 +1916,7 @@ fortcall.lisp rewrite from boot to lisp
c-doc.lisp rewrite from boot to lisp
20090827.03.tpd.patch category.lisp rewrite from boot to lisp
+20090827.04.tpd.patch +c-util.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 5b869a4..b35b0dc 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -646,7 +646,7 @@ ${DEPSYS}: ${DEP} ${OUT}/sys-pkg.${LISP} ${OUT}/nocompil.${LISP} \ ${OUT}/parsing.${LISP} ${OUT}/fnewmeta.${LISP} \ ${OUT}/newaux.${LISP} \ ${OUT}/postprop.lisp \ - ${OUT}/g-boot.lisp ${OUT}/c-util.${LISP} \ + ${OUT}/g-boot.lisp ${OUT}/c-util.lisp \ ${OUT}/g-util.lisp \ ${OUT}/clam.lisp \ ${OUT}/slam.lisp ${LOADSYS} @@ -689,7 +689,7 @@ ${DEPSYS}: ${DEP} ${OUT}/sys-pkg.${LISP} ${OUT}/nocompil.${LISP} \ ':output-file "${OUT}/g-boot.${O}"))' >> ${OUT}/makedep.lisp @ echo '(load "${OUT}/g-boot")' >> ${OUT}/makedep.lisp @ echo '(unless (probe-file "${OUT}/c-util.${O}")' \ - '(compile-file "${OUT}/c-util.${LISP}"' \ + '(compile-file "${OUT}/c-util.lisp"' \ ':output-file "${OUT}/c-util.${O}"))' >> ${OUT}/makedep.lisp @ echo '(load "${OUT}/c-util")' >> ${OUT}/makedep.lisp @ echo '(unless (probe-file "${OUT}/g-util.${O}")' \ @@ -1506,68 +1506,34 @@ ${MID}/buildom.lisp: ${IN}/buildom.lisp.pamphlet @ -\subsection{c-util.boot \cite{42}} -<>= -${AUTO}/c-util.${O}: ${OUT}/c-util.${O} - @ echo 145 making ${AUTO}/c-util.${O} from ${OUT}/c-util.${O} - @ cp ${OUT}/c-util.${O} ${AUTO} - -@ -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: 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.} -<>= -${OUT}/c-util.${LISP}: ${IN}/c-util.boot.pamphlet - @ echo 146 making ${OUT}/c-util.${LISP} from ${IN}/c-util.boot.pamphlet - @ rm -f ${OUT}/c-util.${O} - @( cd ${OUT} ; \ - ${TANGLE} -Rc-util.clisp ${IN}/c-util.boot.pamphlet >c-util.${LISP} ) - -@ +\subsection{c-util.lisp} <>= -${OUT}/c-util.${O}: ${MID}/c-util.clisp - @ echo 147 making ${OUT}/c-util.${O} from ${MID}/c-util.clisp - @ (cd ${MID} ; \ +${OUT}/c-util.${O}: ${MID}/c-util.lisp + @ echo 136 making ${OUT}/c-util.${O} from ${MID}/c-util.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/c-util.clisp"' \ + echo '(progn (compile-file "${MID}/c-util.lisp"' \ ':output-file "${OUT}/c-util.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/c-util.clisp"' \ + echo '(progn (compile-file "${MID}/c-util.lisp"' \ ':output-file "${OUT}/c-util.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/c-util.clisp: ${IN}/c-util.boot.pamphlet - @ echo 148 making ${MID}/c-util.clisp from ${IN}/c-util.boot.pamphlet +<>= +${MID}/c-util.lisp: ${IN}/c-util.lisp.pamphlet + @ echo 137 making ${MID}/c-util.lisp from ${IN}/c-util.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/c-util.boot.pamphlet >c-util.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "c-util.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "c-util.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm c-util.boot ) + ${TANGLE} ${IN}/c-util.lisp.pamphlet >c-util.lisp ) @ -<>= -${DOC}/c-util.boot.dvi: ${IN}/c-util.boot.pamphlet - @echo 149 making ${DOC}/c-util.boot.dvi from ${IN}/c-util.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/c-util.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} c-util.boot ; \ - rm -f ${DOC}/c-util.boot.pamphlet ; \ - rm -f ${DOC}/c-util.boot.tex ; \ - rm -f ${DOC}/c-util.boot ) +<>= +${OUT}/c-util.lisp: ${IN}/c-util.lisp.pamphlet + @ echo 221 making ${OUT}/c-util.lisp from ${IN}/c-util.boot.pamphlet + @ rm -f ${OUT}/c-util.${O} + @( cd ${OUT} ; \ + ${TANGLE} ${IN}/c-util.lisp.pamphlet >c-util.lisp ) @ @@ -5478,11 +5444,9 @@ clean: <> <> -<> <> <> -<> -<> +<> <> <> diff --git a/src/interp/c-util.boot.pamphlet b/src/interp/c-util.boot.pamphlet deleted file mode 100644 index 02b5213..0000000 --- a/src/interp/c-util.boot.pamphlet +++ /dev/null @@ -1,3706 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp c-util.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -This file contains both the {\bf boot} code and the {\bf Lisp} -code that is the result of the {\bf boot to lisp} translation. -We need to keep the translated code around so we can bootstrap -the system. In other words, we need this boot code translated -so we can build the boot translator. - -{\bf NOTE: AFTER CHANGING 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} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - ---% Debugging Functions - -CONTINUE() == continue() -continue() == FIN comp($x,$m,$f) - -LEVEL(:l) == APPLY('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" - -UP() == up() -up() == displayComp ($level:= $level-1) - -SAME() == same() -same() == displayComp $level - -DOWN() == down() -down() == displayComp ($level:= $level+1) - -displaySemanticErrors() == - n:= #($semanticErrorStack:= REMDUP $semanticErrorStack) - n=0 => nil - l:= NREVERSE $semanticErrorStack - $semanticErrorStack:= nil - sayBrightly bright '" Semantic Errors:" - displaySemanticError(l,CUROUTSTREAM) - sayBrightly '" " - displayWarnings() - -displaySemanticError(l,stream) == - for x in l for i in 1.. repeat - sayBrightly(['" [",i,'"] ",:first x],stream) - -displayWarnings() == - n:= #($warningStack:= REMDUP $warningStack) - n=0 => nil - sayBrightly bright '" Warnings:" - l := NREVERSE $warningStack - displayWarning(l,CUROUTSTREAM) - $warningStack:= nil - sayBrightly '" " - -displayWarning(l,stream) == - for x in l for i in 1.. repeat - sayBrightly(['" [",i,'"] ",:x],stream) - -displayComp level == - $tripleCache:= nil - $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 - -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) - -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 - -errorRef s == stackWarning ['%b,s,'%d,'"has no value"] - -unErrorRef s == unStackWarning ['%b,s,'%d,'"has no value"] - ---% 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] - -warnLiteral x == - stackSemanticError(['%b,x,'%d, - '"is BOTH a variable and a literal"],nil) - -intersectionEnvironment(e,e') == - ce:= makeCommonEnvironment(e,e') - ic:= intersectionContour(deltaContour(e,ce),deltaContour(e',ce)) - e'':= (ic => addContour(ic,ce); 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 - -intersectionContour(c,c') == - $var: local := nil - 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 - --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 - -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 fn(x,rest y,nx,ny-1) - [x,y] - -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 - -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 - -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 - -prTriple T == - SAY '"Code:" - pp T.0 - SAY '"Mode:" - pp 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 - - ---% PREDICATES - - -isConstantId(name,e) == - IDENTP name => - pl:= getProplist(name,e) => - (LASSOC("value",pl) or LASSOC("mode",pl) => false; true) - true - false - -isFalse() == nil - -isFluid s == atom s and "$"=(PNAME s).(0) - -isFunction(x,e) == - get(x,"modemap",e) or GET(x,"SPECIAL") or x="case" or getmode(x,e) is [ - "Mapping",:.] - -isLiteral(x,e) == get(x,"isLiteral",e) - -makeLiteral(x,e) == put(x,"isLiteral","true",e) - -isSomeDomainVariable s == - IDENTP s and #(x:= PNAME s)>2 and x.(0)="#" and x.(1)="#" - -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 - -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 - -isSymbol x == IDENTP x or x=nil - -isSimple x == - atom x or $InteractiveMode => true - x is [op,:argl] and - isSideEffectFree op and (and/[isSimple y for y in argl]) - -isSideEffectFree op == - MEMBER(op,$SideEffectFreeFunctionList) or op is ["elt",.,op'] and - isSideEffectFree op' - -isAlmostSimple x == - --returns ( . ) 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] - -incExitLevel u == - 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] - -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) - -wrapSEQExit l == - null rest l => first l - [:c,x]:= [incExitLevel u for u in l] - ["SEQ",:c,["exit",1,x]] - - ---% UTILITY FUNCTIONS - ---appendOver x == "append"/x - -removeEnv t == [t.expr,t.mode,$EmptyEnvironment] -- t is a triple - --- 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 - -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)] - -genDomainVar() == - $Index:= $Index+1 - INTERNL STRCONC("#D",STRINGIMAGE $Index) - -genVariable() == - INTERNL STRCONC("#G",STRINGIMAGE ($genSDVar:= $genSDVar+1)) - -genSomeVariable() == - INTERNL STRCONC("##",STRINGIMAGE ($genSDVar:= $genSDVar+1)) - -listOfIdentifiersIn x == - IDENTP x => [x] - x is [op,:l] => REMDUP ("append"/[listOfIdentifiersIn y for y in l]) - nil - -mapInto(x,fn) == [FUNCALL(fn,y) for y in x] - -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) - -compilerMessage x == - $PrintCompilerMessageIfTrue => APPLX("SAY",x) - -printDashedLine() == - SAY - '"----------------------------------------------------------------------" - -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 - -stackWarning msg == - if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] - if not MEMBER(msg,$warningStack) then $warningStack:= [msg,:$warningStack] - nil - -unStackWarning msg == - if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] - $warningStack:= EFFACE(msg,$warningStack) - nil - -stackMessage msg == - $compErrorMessageStack:= [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 - -stackAndThrow msg == - $compErrorMessageStack:= [msg,:$compErrorMessageStack] - THROW("compOrCroak",nil) - -printString x == PRINTEXP (STRINGP x => x; PNAME x) - -printAny x == if atom x then printString x else 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() - -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 - 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') - -elapsedTime() == - currentTime:= TEMPUS_-FUGIT() - elapsedSeconds:= (currentTime-$previousTime)*1.0/$timerTicksPerSecond - $previousTime:= currentTime - elapsedSeconds - -addStats([a,b],[c,d]) == [a+c,b+d] - -printStats [byteCount,elapsedSeconds] == - timeString := normalizeStatAndStringify elapsedSeconds - if byteCount = 0 then SAY('"Time: ",timeString,'" SEC.") else - SAY('"Size: ",byteCount,'" BYTES Time: ",timeString,'" 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 - -getmode(x,e) == - prop:=getProplist(x,e) - u:= LASSQ("value",prop) => u.mode - LASSQ("mode",prop) - -getmodeOrMapping(x,e) == - u:= getmode(x,e) => u - (u:= get(x,"modemap",e)) is [[[.,:map],.],:.] => ["Mapping",:map] - 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] - -sublisR(al,u) == - atom u => u - y:= RASSOC(t:= [sublisR(al,x) for x in u],al) => y - true => t - -substituteOp(op',op,x) == - atom x => x - [(op=(f:= first x) => op'; f),:[substituteOp(op',op,y) for y in rest x]] - ---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] - ---% DEBUGGING PRINT ROUTINES used in breaks - -_?MODEMAPS x == _?modemaps x -_?modemaps x == - env:= - $insideCapsuleFunctionIfTrue=true => $CapsuleModemapFrame - $f - x="all" => displayModemaps env - -- displayOpModemaps(x,old2NewModemaps get(x,"modemap",env)) - displayOpModemaps(x,get(x,"modemap",env)) - - -old2NewModemaps x == --- [[dcSig,pred] for [dcSig,[pred,:.],:.] in x] - x is [dcSig,[pred,:.],:.] => [dcSig,pred] - x - -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"] - -_?M x == _?m x -_?m x == - u:= comp(x,$EmptyMode,$f) => u.mode - nil - -traceDown() == - mmList:= getFormModemaps($x,$f) => - for mm in mmList repeat if u:= qModemap mm then return u - sayBrightly "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] - -qArg(a,m) == - yesOrNo:= - u:= comp(a,m,$f) => "yes" - "no" - sayBrightly [a," --> ",m,'%b,yesOrNo,'%d] - yesOrNo="yes" - -_?COMP x == _?comp x -_?comp x == - msg:= - u:= comp(x,$EmptyMode,$f) => - [MAKESTRING "compiles to mode",'%b,u.mode,'%d] - nil - sayBrightly msg - -_?domains() == pp getDomainsInScope $f -_?DOMAINS() == ?domains() - -_?mode x == displayProplist(x,[["mode",:getmode(x,$f)]]) -_?MODE x == _?mode x - -_?properties x == displayProplist(x,getProplist(x,$f)) -_?PROPERTIES x == _?properties x - -_?value x == displayProplist(x,[["value",:get(x,"value",$f)]]) -_?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) - -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) - ---% 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} -<>= - -(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 == -; $tripleCache:= nil -; $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 |$tripleCache| NIL) - (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 := nil -; 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 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 ( . ) 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 -\end{thebibliography} -\end{document} diff --git a/src/interp/c-util.lisp.pamphlet b/src/interp/c-util.lisp.pamphlet new file mode 100644 index 0000000..d7fc4aa --- /dev/null +++ b/src/interp/c-util.lisp.pamphlet @@ -0,0 +1,3110 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp c-util.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +; +;--% Debugging Functions +; +;CONTINUE() == continue() + +;;; *** CONTINUE REDEFINED + +(DEFUN CONTINUE () (|continue|)) + +;continue() == FIN comp($x,$m,$f) + +;;; *** |continue| REDEFINED + +(DEFUN |continue| () (FIN (|comp| |$x| |$m| |$f|))) + +; +;LEVEL(:l) == APPLY('level,l) + +;;; *** LEVEL REDEFINED + +(DEFUN LEVEL (&REST G2489 &AUX |l|) + (DSETQ |l| G2489) + (APPLY '|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 G2496 &AUX |l|) + (DSETQ |l| G2496) + (PROG (|n|) + (RETURN + (COND + ((NULL |l|) (|same|)) + ((AND (PAIRP |l|) (EQ (QCDR |l|) NIL) + (PROGN (SPADLET |n| (QCAR |l|)) 'T) (INTEGERP |n|)) + (|displayComp| (SPADLET |$level| |n|))) + ('T + (SAY (MAKESTRING + "Correct format: (level n) where n is the level you want to go to" + ))))))) + +; +;UP() == up() + +;;; *** UP REDEFINED + +(DEFUN UP () (|up|)) + +;up() == displayComp ($level:= $level-1) + +;;; *** |up| REDEFINED + +(DEFUN |up| () + (|displayComp| (SPADLET |$level| (SPADDIFFERENCE |$level| 1)))) + +; +;SAME() == same() + +;;; *** SAME REDEFINED + +(DEFUN SAME () (|same|)) + +;same() == displayComp $level + +;;; *** |same| REDEFINED + +(DEFUN |same| () (|displayComp| |$level|)) + +; +;DOWN() == down() + +;;; *** DOWN REDEFINED + +(DEFUN DOWN () (|down|)) + +;down() == displayComp ($level:= $level+1) + +;;; *** |down| REDEFINED + +(DEFUN |down| () (|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| () + (PROG (|n| |l|) + (RETURN + (PROGN + (SPADLET |n| + (|#| (SPADLET |$semanticErrorStack| + (REMDUP |$semanticErrorStack|)))) + (COND + ((EQL |n| 0) NIL) + ('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 ((G2529 |l| (CDR G2529)) (|x| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G2529) (PROGN (SETQ |x| (CAR G2529)) 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| () + (PROG (|n| |l|) + (RETURN + (PROGN + (SPADLET |n| + (|#| (SPADLET |$warningStack| + (REMDUP |$warningStack|)))) + (COND + ((EQL |n| 0) NIL) + ('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 ((G2550 |l| (CDR G2550)) (|x| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G2550) (PROGN (SETQ |x| (CAR G2550)) NIL)) + NIL) + (SEQ (EXIT (|sayBrightly| + (CONS (MAKESTRING " [") + (CONS |i| (CONS (MAKESTRING "] ") |x|))) + |stream|)))))) + +; +;displayComp level == +; $tripleCache:= nil +; $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 |$tripleCache| NIL) + (SPADLET |$bright| '| << |) + (SPADLET |$dim| '| >> |) + (COND + ((BOOT-EQUAL |$insideCapsuleFunctionIfTrue| 'T) + (|sayBrightly| + (CONS (MAKESTRING "error in function") + (CONS '|%b| + (CONS |$op| (CONS '|%d| (CONS '|%l| NIL)))))))) + (|pp| (|removeZeroOne| (|mkErrorExpr| |level|))) + (|sayBrightly| + (CONS (MAKESTRING "****** level") + (CONS '|%b| + (CONS |level| + (CONS '|%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|)) '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|)) '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| (G2621) + (PROG (|x| |m| |e| T$) + (RETURN + (PROGN + (SPADLET |x| (CAR G2621)) + (SPADLET |m| (CADR G2621)) + (SPADLET |e| (CADDR G2621)) + (SAY (MAKESTRING "tracing comp, compFormWithModemap of: ") |x|) + (|TRACE,1| (CONS '|comp| (CONS '|compFormWithModemap| NIL)) + NIL) + (SPADLET T$ (|comp| |x| |m| |e|)) + (|UNTRACE,1| '|comp|) + (|UNTRACE,1| '|compFormWithModemap|) + T$)))) + +; +;errorRef s == stackWarning ['%b,s,'%d,'"has no value"] + +;;; *** |errorRef| REDEFINED + +(DEFUN |errorRef| (|s|) + (|stackWarning| + (CONS '|%b| + (CONS |s| + (CONS '|%d| (CONS (MAKESTRING "has no value") NIL)))))) + +; +;unErrorRef s == unStackWarning ['%b,s,'%d,'"has no value"] + +;;; *** |unErrorRef| REDEFINED + +(DEFUN |unErrorRef| (|s|) + (|unStackWarning| + (CONS '|%b| + (CONS |s| + (CONS '|%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|) + ('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 '|%b| + (CONS |x| + (CONS '|%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|)) ('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|)) 'T))) + (PROGN (SPADLET |contour'| (QCDR |contour|)) '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 () + (RETURN + (SEQ (PROG (G2679) + (SPADLET G2679 NIL) + (RETURN + (DO ((|x| |c| (CDR |x|))) + ((OR (ATOM |x|) (NULL (NEQUAL |x| |c'|))) + (NREVERSE0 G2679)) + (SEQ (EXIT (SETQ G2679 (CONS (CAR |x|) G2679))))))))))) + +;;; *** |deltaContour| REDEFINED + +(DEFUN |deltaContour| (G2695 G2706) + (PROG (|c'| |cl'| |el'| |c| |cl| |el|) + (RETURN + (PROGN + (SPADLET |c'| (CAAR G2706)) + (SPADLET |cl'| (CDAR G2706)) + (SPADLET |el'| (CDR G2706)) + (SPADLET |c| (CAAR G2695)) + (SPADLET |cl| (CDAR G2695)) + (SPADLET |el| (CDR G2695)) + (COND + ((NULL (BOOT-EQUAL |el| |el'|)) + (|systemError| (MAKESTRING "deltaContour"))) + ('T + (|deltaContour,eliminateDuplicatePropertyLists| + (|deltaContour,contourDifference| |c| |c'|)))))))) + +; +;intersectionContour(c,c') == +; $var: local := nil +; 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|) '|Union|)) + (EXIT (SEQ + (IF + (AND (PAIRP |m2|) + (EQ (QCAR |m2|) '|Union|)) + (EXIT + (CONS '|Union| + (S+ (CDR |m1|) (CDR |m2|))))) + (EXIT + (CONS '|Union| + (S+ (CDR |m1|) (CONS |m2| NIL))))))) + (IF (AND (PAIRP |m2|) + (EQ (QCAR |m2|) '|Union|)) + (EXIT (CONS '|Union| + (S+ (CDR |m2|) (CONS |m1| NIL))))) + (EXIT (CONS '|Union| + (CONS |m1| (CONS |m2| NIL)))))) + (EXIT (DO ((G2748 (|getDomainsInScope| |$e|) + (CDR G2748)) + (|u| NIL)) + ((OR (ATOM G2748) + (PROGN (SETQ |u| (CAR G2748)) NIL)) + NIL) + (SEQ (EXIT (IF (AND (AND (PAIRP |u|) + (EQ (QCAR |u|) '|Union|) + (PROGN + (SPADLET |u'| (QCDR |u|)) + 'T)) + (PROG (G2754) + (SPADLET G2754 'T) + (RETURN + (DO + ((G2760 NIL + (NULL G2754)) + (G2761 (CDR |m|) + (CDR G2761)) + (|v| NIL)) + ((OR G2760 (ATOM G2761) + (PROGN + (SETQ |v| + (CAR G2761)) + NIL)) + G2754) + (SEQ + (EXIT + (SETQ G2754 + (AND G2754 + (|member| |v| |u'|))))))))) + (RETURN |m|) NIL))))))))) + +;;; *** |intersectionContour,modeCompare| REDEFINED + +(DEFUN |intersectionContour,modeCompare| (|p| |p'|) + (PROG (|pair| |m''| |pair'|) + (RETURN + (SEQ (IF (SPADLET |pair| (|assoc| '|mode| |p|)) + (EXIT (SEQ (IF (SPADLET |pair'| (|assoc| '|mode| |p'|)) + (EXIT (SEQ + (IF + (SPADLET |m''| + (|intersectionContour,unifiable| + (CDR |pair|) (CDR |pair'|))) + (EXIT + (LIST (CONS '|mode| |m''|)))) + (EXIT + (|stackSemanticError| + (CONS '|%b| + (CONS |$var| + (CONS '|%d| + (CONS '|has two modes: | NIL)))) + NIL))))) + (EXIT (LIST (CONS '|conditionalmode| + (CDR |pair|))))))) + (EXIT (IF (SPADLET |pair'| (|assoc| '|mode| |p'|)) + (EXIT (LIST (CONS '|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| '|value|)) + (SPADLET |m| + (|intersectionContour,unifiable| + (CADR |val|) (CADR |val'|)))) + (EXIT (CONS '|value| + (CONS (|genSomeVariable|) + (CONS |m| (CONS NIL NIL)))))) + (EXIT (IF (BOOT-EQUAL |prop| '|mode|) (EXIT NIL))))))))) + +;;; *** |intersectionContour,buildModeAssoc| REDEFINED + +(DEFUN |intersectionContour,buildModeAssoc| (|varlist| |c| |c'|) + (PROG (|mp|) + (RETURN + (SEQ (PROG (G2802) + (SPADLET G2802 NIL) + (RETURN + (DO ((G2808 |varlist| (CDR G2808)) (|x| NIL)) + ((OR (ATOM G2808) + (PROGN (SETQ |x| (CAR G2808)) NIL)) + (NREVERSE0 G2802)) + (SEQ (EXIT (COND + ((SPADLET |mp| + (|intersectionContour,modeCompare| + (LASSOC |x| |c|) + (LASSOC |x| |c'|))) + (SETQ G2802 + (CONS (CONS |x| |mp|) G2802))))))))))))) + +;;; *** |intersectionContour,interProplist| REDEFINED + +(DEFUN |intersectionContour,interProplist| (|p| |p'|) + (PROG (|pair'|) + (RETURN + (SEQ (APPEND (|intersectionContour,modeCompare| |p| |p'|) + (PROG (G2824) + (SPADLET G2824 NIL) + (RETURN + (DO ((G2830 |p| (CDR G2830)) (|pair| NIL)) + ((OR (ATOM G2830) + (PROGN + (SETQ |pair| (CAR G2830)) + NIL)) + (NREVERSE0 G2824)) + (SEQ (EXIT (COND + ((SPADLET |pair'| + (|intersectionContour,compare| + |pair| |p'|)) + (SETQ G2824 + (CONS |pair'| G2824)))))))))))))) + +;;; *** |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 (G2847) + (SPADLET G2847 NIL) + (RETURN + (DO ((G2854 |c| (CDR G2854)) + (G2731 NIL)) + ((OR (ATOM G2854) + (PROGN + (SETQ G2731 (CAR G2854)) + NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G2731)) + (SPADLET |y| (CDR G2731)) + G2731) + NIL)) + (NREVERSE0 G2847)) + (SEQ (EXIT + (COND + ((AND (|member| |x| |interVars|) + (SPADLET |proplist| + (|intersectionContour,interProplist| + |y| + (LASSOC (SPADLET |$var| |x|) + |c'|)))) + (SETQ G2847 + (CONS (CONS |x| |proplist|) + G2847))))))))))))))) + +;;; *** |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 '|has| (CONS |pv| NIL)))) NIL) + (EXIT (IF (BOOT-EQUAL |p| '|conditionalmode|) + (SEQ (RPLACA |pv| '|mode|) + (EXIT (IF (SPADLET |vv| (LASSOC '|mode| |e|)) + (IF (NEQUAL |v| |vv|) + (|stackWarning| + (CONS '|The conditional modes | + (CONS |v| + (CONS '| and | + (CONS |vv| + (CONS '| conflict| NIL)))))) + NIL) + NIL))) + NIL)))))) + +;;; *** |addContour,fn1| REDEFINED + +(DEFUN |addContour,fn1| (|x| |p| |ee|) + (SEQ (DO ((G2898 |p| (CDR G2898)) (|pv| NIL)) + ((OR (ATOM G2898) (PROGN (SETQ |pv| (CAR G2898)) NIL)) + NIL) + (SEQ (EXIT (|addContour,fn3| |x| |pv| |ee|)))))) + +;;; *** |addContour,fn| REDEFINED + +(DEFUN |addContour,fn| (|c| |e|) + (PROG (|x| |proplist|) + (RETURN + (SEQ (DO ((G2917 |c| (CDR G2917)) (G2908 NIL)) + ((OR (ATOM G2917) + (PROGN (SETQ G2908 (CAR G2917)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G2908)) + (SPADLET |proplist| (CDR G2908)) + G2908) + 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 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| (G2954) + (PROG (|c| |c'|) + (RETURN + (SEQ (PROGN + (SPADLET |c| (CAR G2954)) + (SPADLET |c'| (CADR G2954)) + G2954 + (SEQ (IF (BOOT-EQUAL |c| |c'|) (EXIT |c|)) + (EXIT (|makeCommonEnvironment,interC| + (CONS (CDR |c|) (CONS (CDR |c'|) NIL)))))))))) + +;;; *** |makeCommonEnvironment,interLocalE| REDEFINED + +(DEFUN |makeCommonEnvironment,interLocalE| (G2968) + (PROG (|le| |le'|) + (RETURN + (SEQ (PROGN + (SPADLET |le| (CAR G2968)) + (SPADLET |le'| (CADR G2968)) + G2968 + (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| (G2982) + (PROG (|e| |e'|) + (RETURN + (SEQ (PROGN + (SPADLET |e| (CAR G2982)) + (SPADLET |e'| (CADR G2982)) + G2982 + (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| '|value|) + (EXIT (DROP (SPADDIFFERENCE 1) |val|))) + (EXIT |val|))) + +;;; *** |printEnv| REDEFINED + +(DEFUN |printEnv| (E) + (SEQ (DO ((G3020 E (CDR G3020)) (|x| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G3020) (PROGN (SETQ |x| (CAR G3020)) NIL)) + NIL) + (SEQ (EXIT (DO ((G3038 |x| (CDR G3038)) (|y| NIL) + (|j| 1 (QSADD1 |j|))) + ((OR (ATOM G3038) + (PROGN (SETQ |y| (CAR G3038)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SAY (MAKESTRING "******CONTOUR ") + |j| (MAKESTRING ", LEVEL ") |i| + (MAKESTRING ":******")) + (DO + ((G3053 |y| (CDR G3053)) + (|z| NIL)) + ((OR (ATOM G3053) + (PROGN + (SETQ |z| (CAR G3053)) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (TERPRI) + (SAY + (MAKESTRING + "Properties Of: ") + (CAR |z|)) + (DO + ((G3065 (CDR |z|) + (CDR G3065)) + (|u| NIL)) + ((OR (ATOM G3065) + (PROGN + (SETQ |u| (CAR G3065)) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (PRIN0 (CAR |u|)) + (|printString| '|: |) + (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| '|value|) + (EXIT (DROP (SPADDIFFERENCE 1) |val|))) + (EXIT |val|))) + +;;; *** |prEnv| REDEFINED + +(DEFUN |prEnv| (E) + (SEQ (DO ((G3094 E (CDR G3094)) (|x| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G3094) (PROGN (SETQ |x| (CAR G3094)) NIL)) + NIL) + (SEQ (EXIT (DO ((G3112 |x| (CDR G3112)) (|y| NIL) + (|j| 1 (QSADD1 |j|))) + ((OR (ATOM G3112) + (PROGN (SETQ |y| (CAR G3112)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SAY (MAKESTRING "******CONTOUR ") + |j| (MAKESTRING ", LEVEL ") |i| + (MAKESTRING ":******")) + (DO + ((G3128 |y| (CDR G3128)) + (|z| NIL)) + ((OR (ATOM G3128) + (PROGN + (SETQ |z| (CAR G3128)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL + (LASSOC '|modemap| + (CDR |z|))) + (PROGN + (TERPRI) + (SAY + (MAKESTRING + "Properties Of: ") + (CAR |z|)) + (DO + ((G3140 (CDR |z|) + (CDR G3140)) + (|u| NIL)) + ((OR (ATOM G3140) + (PROGN + (SETQ |u| + (CAR G3140)) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (PRIN0 (CAR |u|)) + (|printString| '|: |) + (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 ((G3160 E (CDR G3160)) (|x| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G3160) + (PROGN (SETQ |x| (CAR G3160)) NIL)) + NIL) + (SEQ (EXIT (DO ((G3175 |x| (CDR G3175)) (|y| NIL) + (|j| 1 (QSADD1 |j|))) + ((OR (ATOM G3175) + (PROGN + (SETQ |y| (CAR G3175)) + NIL)) + NIL) + (SEQ (EXIT (DO + ((G3190 |y| (CDR G3190)) + (|z| NIL)) + ((OR (ATOM G3190) + (PROGN + (SETQ |z| (CAR G3190)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((AND + (NULL + (|member| (CAR |z|) + |listOfOperatorsSeenSoFar|)) + (SPADLET |modemap| + (LASSOC '|modemap| + (CDR |z|)))) + (PROGN + (SPADLET + |listOfOperatorsSeenSoFar| + (CONS (CAR |z|) + |listOfOperatorsSeenSoFar|)) + (TERPRI) + (PRIN0 (CAR |z|)) + (|printString| '|: |) + (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| () + (PROG (|old| |uold| |unew| |new|) + (RETURN + (SEQ (PROGN + (SPADLET |new| NIL) + (SPADLET |old| (CAAR |$CategoryFrame|)) + (DO ((G3211 |old| (CDR G3211)) (|u| NIL)) + ((OR (ATOM G3211) + (PROGN (SETQ |u| (CAR G3211)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (ASSQ (CAR |u|) |new|)) + (SPADLET |uold| (CDR |u|)) + (SPADLET |unew| NIL) + (DO ((G3220 |uold| (CDR G3220)) + (|v| NIL)) + ((OR (ATOM G3220) + (PROGN + (SETQ |v| (CAR G3220)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((NULL (ASSQ (CAR |v|) |unew|)) + (SPADLET |unew| + (CONS |v| |unew|))) + ('T NIL))))) + (SPADLET |new| + (CONS + (CONS (CAR |u|) + (NREVERSE |unew|)) + |new|))) + ('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 '|value| |pl|) (LASSOC '|mode| |pl|)) NIL) + ('T 'T))) + ('T 'T))) + ('T NIL))))) + +; +;isFalse() == nil + +;;; *** |isFalse| REDEFINED + +(DEFUN |isFalse| () NIL) + +; +;isFluid s == atom s and "$"=(PNAME s).(0) + +;;; *** |isFluid| REDEFINED + +(DEFUN |isFluid| (|s|) + (AND (ATOM |s|) (BOOT-EQUAL '$ (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| '|modemap| |e|) (GETL |x| 'SPECIAL) + (BOOT-EQUAL |x| '|case|) + (PROGN + (SPADLET |ISTMP#1| (|getmode| |x| |e|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|Mapping|))))))) + +; +;isLiteral(x,e) == get(x,"isLiteral",e) + +;;; *** |isLiteral| REDEFINED + +(DEFUN |isLiteral| (|x| |e|) (|get| |x| '|isLiteral| |e|)) + +; +;makeLiteral(x,e) == put(x,"isLiteral","true",e) + +;;; *** |makeLiteral| REDEFINED + +(DEFUN |makeLiteral| (|x| |e|) (|put| |x| '|isLiteral| '|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) '|#|) (BOOT-EQUAL (ELT |x| 1) '|#|))))) + +; +;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| '$) (BOOT-EQUAL |y| '|Rep|)) + (BOOT-EQUAL |x| |y|) + (LASSOC (|opOf| |x|) + (OR (|get| (|opOf| |y|) '|Subsets| |e|) + (GETL (|opOf| |y|) '|Subsets|))) + (LASSOC (|opOf| |x|) (|get| (|opOf| |y|) '|SubDomain| |e|)) + (BOOT-EQUAL (|opOf| |y|) '|Type|) + (BOOT-EQUAL (|opOf| |y|) '|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|) 'T) + ((OR (NULL (IDENTP |domain|)) + (|isSomeDomainVariable| |domain|)) + 'T) + ('T NIL))) + ((BOOT-EQUAL (SPADLET |name| (CAR |domain|)) '|Category|) 'T) + ((ASSQ |name| |domainList|) 'T) + ((|isFunctor| |name|) NIL) + ('T '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|) 'T) + ('T + (AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + 'T) + (|isSideEffectFree| |op|) + (PROG (G3282) + (SPADLET G3282 'T) + (RETURN + (DO ((G3288 NIL (NULL G3282)) + (G3289 |argl| (CDR G3289)) (|y| NIL)) + ((OR G3288 (ATOM G3289) + (PROGN (SETQ |y| (CAR G3289)) NIL)) + G3282) + (SEQ (EXIT (SETQ G3282 + (AND G3282 (|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|) '|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|)) + 'T))))) + (|isSideEffectFree| |op'|)))))) + +; +;isAlmostSimple x == +; --returns ( . ) 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| '|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| '|has|) (EXIT |x|)) + (IF (BOOT-EQUAL |op| '|is|) (EXIT |x|)) + (IF (BOOT-EQUAL |op| 'LET) + (EXIT (SEQ (IF (IDENTP |y|) + (EXIT (SEQ + (|isAlmostSimple,setAssignment| + (LIST |x|)) + (EXIT |y|)))) + (EXIT (IF 'T + (EXIT + (SEQ + (|isAlmostSimple,setAssignment| + (CONS + (CONS 'LET + (CONS + (SPADLET |g| (|genVariable|)) + |l|)) + (CONS + (CONS 'LET + (CONS |y| (CONS |g| NIL))) + NIL))) + (EXIT |g|)))))))) + (IF (|isSideEffectFree| |op|) + (EXIT (CONS |op| + (|mapInto| (CDR |x|) '|isAlmostSimple,fn|)))) + (EXIT (IF 'T (EXIT (SPADLET |$assignmentList| '|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| '|failed|) NIL) + ('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|) '|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|)) + '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|)) + 'T) + (MEMQ |op| '(SEQ REPEAT COLLECT))) + (DO ((G3401 |l| (CDR G3401)) (|u| NIL)) + ((OR (ATOM G3401) + (PROGN (SETQ |u| (CAR G3401)) NIL)) + NIL) + (SEQ (EXIT (|adjExitLevel| |u| (PLUS |seqnum| 1) |inc|))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|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|)) + 'T)))))) + (|adjExitLevel| |u| |seqnum| |inc|) + (COND + ((> |seqnum| |n|) |x|) + ('T (|rplac| (CADR |x|) (PLUS |n| |inc|))))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |l| (QCDR |x|)) + 'T)) + (DO ((G3410 |l| (CDR G3410)) (|u| NIL)) + ((OR (ATOM G3410) + (PROGN (SETQ |u| (CAR G3410)) 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|)) + ('T + (SPADLET |LETTMP#1| + (PROG (G3441) + (SPADLET G3441 NIL) + (RETURN + (DO ((G3446 |l| (CDR G3446)) (|u| NIL)) + ((OR (ATOM G3446) + (PROGN + (SETQ |u| (CAR G3446)) + NIL)) + (NREVERSE0 G3441)) + (SEQ (EXIT (SETQ G3441 + (CONS (|incExitLevel| |u|) + G3441)))))))) + (SPADLET |LETTMP#2| (REVERSE |LETTMP#1|)) + (SPADLET |x| (CAR |LETTMP#2|)) + (SPADLET |c| (NREVERSE (CDR |LETTMP#2|))) + (CONS 'SEQ + (APPEND |c| + (CONS (CONS '|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)) ('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|)) + 'T))) + (BOOT-EQUAL |k| |key|)) + (APPEND |r| (|flatten| (CDR |l|) |key|))) + ('T (CONS (CAR |l|) (|flatten| (CDR |l|) |key|))))))) + +; +;genDomainVar() == +; $Index:= $Index+1 +; INTERNL STRCONC("#D",STRINGIMAGE $Index) + +;;; *** |genDomainVar| REDEFINED + +(DEFUN |genDomainVar| () + (PROGN + (SPADLET |$Index| (PLUS |$Index| 1)) + (INTERNL (STRCONC '|#D| (STRINGIMAGE |$Index|))))) + +; +;genVariable() == +; INTERNL STRCONC("#G",STRINGIMAGE ($genSDVar:= $genSDVar+1)) + +;;; *** |genVariable| REDEFINED + +(DEFUN |genVariable| () + (INTERNL (STRCONC '|#G| + (STRINGIMAGE + (SPADLET |$genSDVar| (PLUS |$genSDVar| 1)))))) + +; +;genSomeVariable() == +; INTERNL STRCONC("##",STRINGIMAGE ($genSDVar:= $genSDVar+1)) + +;;; *** |genSomeVariable| REDEFINED + +(DEFUN |genSomeVariable| () + (INTERNL (STRCONC '|##| + (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|)) + 'T)) + (REMDUP (PROG (G3499) + (SPADLET G3499 NIL) + (RETURN + (DO ((G3504 |l| (CDR G3504)) (|y| NIL)) + ((OR (ATOM G3504) + (PROGN + (SETQ |y| (CAR G3504)) + NIL)) + G3499) + (SEQ (EXIT (SETQ G3499 + (APPEND G3499 + (|listOfIdentifiersIn| |y|)))))))))) + ('T NIL)))))) + +; +;mapInto(x,fn) == [FUNCALL(fn,y) for y in x] + +;;; *** |mapInto| REDEFINED + +(DEFUN |mapInto| (|x| |fn|) + (PROG () + (RETURN + (SEQ (PROG (G3520) + (SPADLET G3520 NIL) + (RETURN + (DO ((G3525 |x| (CDR G3525)) (|y| NIL)) + ((OR (ATOM G3525) + (PROGN (SETQ |y| (CAR G3525)) NIL)) + (NREVERSE0 G3520)) + (SEQ (EXIT (SETQ G3520 + (CONS (FUNCALL |fn| |y|) G3520))))))))))) + +; +;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 'SAY |x|)))))) + +; +;printDashedLine() == +; SAY +; '"----------------------------------------------------------------------" + +;;; *** |printDashedLine| REDEFINED + +(DEFUN |printDashedLine| () + (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 '|semantic|) + (COND + (|$insideCapsuleFunctionIfTrue| + (SPADLET |msg| (CONS |$op| (CONS '|: | |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| 'T) + (> (SPADDIFFERENCE (|#| |$semanticErrorStack|) + |$initCapsuleErrorCount|) + 3)) + (THROW '|compCapsuleBody| NIL)) + ('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 '|: | |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 '|: | |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 '|compOrCroak| NIL))) + +; +;printString x == PRINTEXP (STRINGP x => x; PNAME x) + +;;; *** |printString| REDEFINED + +(DEFUN |printString| (|x|) + (PRINTEXP (COND ((STRINGP |x|) |x|) ('T (PNAME |x|))))) + +; +;printAny x == if atom x then printString x else PRIN0 x + +;;; *** |printAny| REDEFINED + +(DEFUN |printAny| (|x|) + (COND ((ATOM |x|) (|printString| |x|)) ('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| G3594) + (PROG (|target| |argSigList|) + (RETURN + (SEQ (PROGN + (SPADLET |target| (CAR G3594)) + (SPADLET |argSigList| (CDR G3594)) + (|printString| |before|) + (|printString| |op|) + (|printString| '|: (|) + (COND + (|argSigList| (|printAny| (CAR |argSigList|)) + (DO ((G3608 (CDR |argSigList|) (CDR G3608)) + (|m| NIL)) + ((OR (ATOM G3608) + (PROGN (SETQ |m| (CAR G3608)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|printString| '|,|) + (|printAny| |m|))))))) + (|printString| '|) -> |) + (|printAny| |target|) + (TERPRI)))))) + +; +;pmatch(s,p) == pmatchWithSl(s,p,"ok") + +;;; *** |pmatch| REDEFINED + +(DEFUN |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 +; 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|)) + ('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| () + (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| (G3635 G3644) + (PROG (|c| |d| |a| |b|) + (RETURN + (PROGN + (SPADLET |c| (CAR G3644)) + (SPADLET |d| (CADR G3644)) + (SPADLET |a| (CAR G3635)) + (SPADLET |b| (CADR G3635)) + (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| (G3665) + (PROG (|byteCount| |elapsedSeconds| |timeString|) + (RETURN + (PROGN + (SPADLET |byteCount| (CAR G3665)) + (SPADLET |elapsedSeconds| (CADR G3665)) + (SPADLET |timeString| + (|normalizeStatAndStringify| |elapsedSeconds|)) + (COND + ((EQL |byteCount| 0) + (SAY (MAKESTRING "Time: ") |timeString| + (MAKESTRING " SEC."))) + ('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'|) 'T) + ((BOOT-EQUAL |form| |$Category|) NIL) + ((AND (PAIRP |form'|) (EQ (QCAR |form'|) '|Join|) + (PROGN (SPADLET |l| (QCDR |form'|)) 'T)) + (PROG (G3729) + (SPADLET G3729 'T) + (RETURN + (DO ((G3735 NIL (NULL G3729)) + (G3736 |l| (CDR G3736)) (|x| NIL)) + ((OR G3735 (ATOM G3736) + (PROGN (SETQ |x| (CAR G3736)) NIL)) + G3729) + (SEQ (EXIT (SETQ G3729 + (AND G3729 + (|extendsCategoryForm| |domain| + |form| |x|))))))))) + ((AND (PAIRP |form'|) (EQ (QCAR |form'|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form'|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T)))) + (PROG (G3743) + (SPADLET G3743 'T) + (RETURN + (DO ((G3749 NIL (NULL G3743)) + (G3750 |l| (CDR G3750)) (|x| NIL)) + ((OR G3749 (ATOM G3750) + (PROGN (SETQ |x| (CAR G3750)) NIL)) + G3743) + (SEQ (EXIT (SETQ G3743 + (AND G3743 + (|extendsCategoryForm| |domain| + |form| |x|))))))))) + ((AND (PAIRP |form'|) + (EQ (QCAR |form'|) '|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|)) + 'T)))))) + (AND (|extendsCategoryForm| |domain| |form| |cat|) + (|isSubset| |domain| |dom| |$e|))) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|Join|) + (PROGN (SPADLET |l| (QCDR |form|)) 'T)) + (PROG (G3757) + (SPADLET G3757 NIL) + (RETURN + (DO ((G3763 NIL G3757) + (G3764 |l| (CDR G3764)) (|x| NIL)) + ((OR G3763 (ATOM G3764) + (PROGN (SETQ |x| (CAR G3764)) NIL)) + G3757) + (SEQ (EXIT (SETQ G3757 + (OR G3757 + (|extendsCategoryForm| |domain| + |x| |form'|))))))))) + ((AND (PAIRP |form|) (EQ (QCAR |form|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T)))) + (OR (|member| |form'| |l|) + (|stackWarning| + (CONS '|not known that | + (CONS |form'| + (CONS '| is of mode | + (CONS |form| NIL))))) + 'T)) + ((|isCategoryForm| |form| |$EmptyEnvironment|) + (SPADLET |formVec| + (CAR (|compMakeCategoryObject| |form| |$e|))) + (COND + ((AND (PAIRP |form'|) (EQ (QCAR |form'|) '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|)) + 'T)))))) + (OR (|assoc| (CONS |op| (CONS |args| NIL)) + (ELT |formVec| 1)) + (|assoc| (SUBSTQ |domain| '$ + (CONS |op| (CONS |args| NIL))) + (SUBSTQ |domain| '$ (ELT |formVec| 1))))) + ((AND (PAIRP |form'|) (EQ (QCAR |form'|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form'|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |at| (QCAR |ISTMP#1|)) + 'T)))) + (OR (|assoc| |at| (ELT |formVec| 2)) + (|assoc| (SUBSTQ |domain| '$ |at|) + (SUBSTQ |domain| '$ (ELT |formVec| 2))))) + ((AND (PAIRP |form'|) (EQ (QCAR |form'|) 'IF)) 'T) + ((EQL (|#| |formVec|) 1) (|newHasTest| |form| |form'|)) + ('T (SPADLET |catvlist| (ELT |formVec| 4)) + (OR (|member| |form'| (CAR |catvlist|)) + (|member| |form'| + (SUBSTQ |domain| '$ (CAR |catvlist|))) + (PROG (G3771) + (SPADLET G3771 NIL) + (RETURN + (DO ((G3778 NIL G3771) + (G3779 (CADR |catvlist|) (CDR G3779)) + (G3724 NIL)) + ((OR G3778 (ATOM G3779) + (PROGN + (SETQ G3724 (CAR G3779)) + NIL) + (PROGN + (PROGN + (SPADLET |cat| (CAR G3724)) + G3724) + NIL)) + G3771) + (SEQ (EXIT (SETQ G3771 + (OR G3771 + (|extendsCategoryForm| |domain| + (SUBSTQ |domain| '$ |cat|) + |form'|)))))))))))) + ('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 '|value| |prop|)) (CADR |u|)) + ('T (LASSQ '|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| '|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|)) + 'T))) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL))))))) + (CONS '|Mapping| |map|)) + ('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 () + (RETURN + (SEQ (COND + ((NULL |l|) (LIST NIL)) + ('T + (PROG (G3855) + (SPADLET G3855 NIL) + (RETURN + (DO ((G3860 (CAR |l|) (CDR G3860)) (|x| NIL)) + ((OR (ATOM G3860) + (PROGN (SETQ |x| (CAR G3860)) NIL)) + G3855) + (SEQ (EXIT (SETQ G3855 + (APPEND G3855 + (PROG (G3870) + (SPADLET G3870 NIL) + (RETURN + (DO + ((G3875 + (|outerProduct| (CDR |l|)) + (CDR G3875)) + (|y| NIL)) + ((OR (ATOM G3875) + (PROGN + (SETQ |y| (CAR G3875)) + NIL)) + (NREVERSE0 G3870)) + (SEQ + (EXIT + (SETQ G3870 + (CONS (CONS |x| |y|) + G3870)))))))))))))))))))) + +; +;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 (G3891) + (SPADLET G3891 NIL) + (RETURN + (DO + ((G3896 |u| (CDR G3896)) + (|x| NIL)) + ((OR (ATOM G3896) + (PROGN + (SETQ |x| (CAR G3896)) + NIL)) + (NREVERSE0 G3891)) + (SEQ + (EXIT + (SETQ G3891 + (CONS (|sublisR| |al| |x|) + G3891)))))))) + |al|)) + |y|) + ('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|) + ('T + (CONS (COND + ((BOOT-EQUAL |op| (SPADLET |f| (CAR |x|))) |op'|) + ('T |f|)) + (PROG (G3914) + (SPADLET G3914 NIL) + (RETURN + (DO ((G3919 (CDR |x|) (CDR G3919)) + (|y| NIL)) + ((OR (ATOM G3919) + (PROGN (SETQ |y| (CAR G3919)) NIL)) + (NREVERSE0 G3914)) + (SEQ (EXIT (SETQ G3914 + (CONS + (|substituteOp| |op'| |op| |y|) + G3914)))))))))))))) + +; +;--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 (G3936) + (SPADLET G3936 NIL) + (RETURN + (DO ((G3941 (MAXINDEX |e|)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G3941) + (NREVERSE0 G3936)) + (SEQ (EXIT + (SETQ G3936 + (CONS + (|sublisV,suba| |p| + (ELT |e| |i|)) + G3936)))))))))) + (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|) ('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| 'T) + |$CapsuleModemapFrame|) + ('T |$f|))) + (COND + ((BOOT-EQUAL |x| '|all|) (|displayModemaps| |env|)) + ('T + (|displayOpModemaps| |x| + (|old2NewModemaps| (|get| |x| '|modemap| |env|))))))))) + +;old2NewModemaps x == +; [[dcSig,pred] for [dcSig,[pred,:.],:.] in x] + +;;; *** |old2NewModemaps| REDEFINED + +(DEFUN |old2NewModemaps| (|x|) + (PROG (|dcSig| |pred|) + (RETURN + (SEQ (PROG (G3975) + (SPADLET G3975 NIL) + (RETURN + (DO ((G3981 |x| (CDR G3981)) (G3966 NIL)) + ((OR (ATOM G3981) + (PROGN (SETQ G3966 (CAR G3981)) NIL) + (PROGN + (PROGN + (SPADLET |dcSig| (CAR G3966)) + (SPADLET |pred| (CAADR G3966)) + G3966) + NIL)) + (NREVERSE0 G3975)) + (SEQ (EXIT (SETQ G3975 + (CONS (CONS |dcSig| + (CONS |pred| NIL)) + G3975))))))))))) + +; +;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| () + (PROG (|u|) + (RETURN + (SEQ (COND + ((ATOM |$x|) (|sayBrightly| (MAKESTRING "$x is an atom"))) + ('T + (DO ((G3999 (CDR |$x|) (CDR G3999)) (|y| NIL)) + ((OR (ATOM G3999) + (PROGN (SETQ |y| (CAR G3999)) NIL)) + NIL) + (SEQ (EXIT (COND + ((SPADLET |u| + (|comp| |y| |$EmptyMode| |$f|)) + (|sayBrightly| + (CONS |y| + (CONS (MAKESTRING " ==> mode") + (CONS '|%b| + (CONS (CADR |u|) + (CONS '|%d| NIL))))))) + ('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|)) + ('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| () + (PROG (|mmList| |u|) + (RETURN + (SEQ (COND + ((SPADLET |mmList| (|getFormModemaps| |$x| |$f|)) + (DO ((G4021 |mmList| (CDR G4021)) (|mm| NIL)) + ((OR (ATOM G4021) + (PROGN (SETQ |mm| (CAR G4021)) NIL)) + NIL) + (SEQ (EXIT (COND + ((SPADLET |u| (|qModemap| |mm|)) + (RETURN |u|)) + ('T NIL)))))) + ('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 '|%b| + (CONS (MAKESTRING "modemap") + (CONS '|%d| (|formatModemap| |mm|))))) + (SPADLET |dc| (CAAR |mm|)) + (SPADLET |target| (CADAR |mm|)) + (SPADLET |sl| (CDDAR |mm|)) + (SPADLET |pred| (CAADR |mm|)) + (COND + ((PROG (G4038) + (SPADLET G4038 'T) + (RETURN + (DO ((G4045 NIL (NULL G4038)) + (G4046 (CDR |$x|) (CDR G4046)) (|a| NIL) + (G4047 |sl| (CDR G4047)) (|m| NIL)) + ((OR G4045 (ATOM G4046) + (PROGN (SETQ |a| (CAR G4046)) NIL) + (ATOM G4047) + (PROGN (SETQ |m| (CAR G4047)) NIL)) + G4038) + (SEQ (EXIT (SETQ G4038 + (AND G4038 (|qArg| |a| |m|)))))))) + |target|) + ('T + (|sayBrightly| + (CONS '|%b| + (CONS (MAKESTRING "fails") + (CONS '|%d| (CONS '|%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|)) '|yes|) + ('T '|no|))) + (|sayBrightly| + (CONS |a| + (CONS (MAKESTRING " --> ") + (CONS |m| + (CONS '|%b| + (CONS |yesOrNo| (CONS '|%d| NIL))))))) + (BOOT-EQUAL |yesOrNo| '|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 '|%b| + (CONS (CADR |u|) (CONS '|%d| NIL))))) + ('T NIL))) + (|sayBrightly| |msg|))))) + +; +;_?domains() == pp getDomainsInScope $f + +;;; *** |?domains| REDEFINED + +(DEFUN |?domains| () (|pp| (|getDomainsInScope| |$f|))) + +;_?DOMAINS() == ?domains() + +;;; *** ?DOMAINS REDEFINED + +(DEFUN ?DOMAINS () (|?domains|)) + +; +;_?mode x == displayProplist(x,[["mode",:getmode(x,$f)]]) + +;;; *** |?mode| REDEFINED + +(DEFUN |?mode| (|x|) + (|displayProplist| |x| + (CONS (CONS '|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 '|value| (|get| |x| '|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|)) + 'T))) + (PROGN (SPADLET |l| (QCDR |alist|)) 'T)) + (EXIT (SEQ (IF (BOOT-EQUAL |prop| '|value|) + (SPADLET |val| + (CONS (CAR |val|) + (CONS (CADR |val|) + (CONS (MAKESTRING "...") NIL)))) + NIL) + (|sayBrightly| + (CONS (MAKESTRING " ") + (CONS '|%b| + (CONS |prop| + (CONS '|%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 '|%b| + (CONS |x| (CONS '|%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 ((G4136 E (CDR G4136)) (|x| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G4136) + (PROGN (SETQ |x| (CAR G4136)) NIL)) + NIL) + (SEQ (EXIT (DO ((G4148 |x| (CDR G4148)) (|y| NIL) + (|j| 1 (QSADD1 |j|))) + ((OR (ATOM G4148) + (PROGN + (SETQ |y| (CAR G4148)) + NIL)) + NIL) + (SEQ (EXIT (DO + ((G4160 |y| (CDR G4160)) + (|z| NIL)) + ((OR (ATOM G4160) + (PROGN + (SETQ |z| (CAR G4160)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((AND + (NULL + (|member| (CAR |z|) + |listOfOperatorsSeenSoFar|)) + (SPADLET |modemaps| + (LASSOC '|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 'OR2 NIL + (PROG (G4183) + (SPADLET G4183 NIL) + (RETURN + (DO ((G4188 |new| (CDR G4188)) (|n| NIL)) + ((OR (ATOM G4188) + (PROGN (SETQ |n| (CAR G4188)) NIL)) + G4183) + (SEQ (EXIT (SETQ G4183 + (APPEND G4183 + (PROG (G4198) + (SPADLET G4198 NIL) + (RETURN + (DO + ((G4203 |old| + (CDR G4203)) + (|o| NIL)) + ((OR (ATOM G4203) + (PROGN + (SETQ |o| (CAR G4203)) + NIL)) + (NREVERSE0 G4198)) + (SEQ + (EXIT + (SETQ G4198 + (CONS (EQ |o| |n|) + G4198)))))))))))))) + NIL) + (SPADLET |mid| + (PROG (G4213) + (SPADLET G4213 NIL) + (RETURN + (DO ((G4218 |old| (CDR G4218)) + (|o| NIL)) + ((OR (ATOM G4218) + (PROGN + (SETQ |o| (CAR G4218)) + NIL)) + (NREVERSE0 G4213)) + (SEQ (EXIT (SETQ G4213 + (CONS (GENSYM) G4213)))))))) + (GEQNSUBSTLIST |old| |mid| |body|) + (GEQNSUBSTLIST |mid| |new| |body|)) + ('T + (SPADLET |alist| + (PROG (G4229) + (SPADLET G4229 NIL) + (RETURN + (DO ((G4235 |old| (CDR G4235)) (|o| NIL) + (G4236 |new| (CDR G4236)) + (|n| NIL)) + ((OR (ATOM G4235) + (PROGN + (SETQ |o| (CAR G4235)) + NIL) + (ATOM G4236) + (PROGN + (SETQ |n| (CAR G4236)) + NIL)) + (NREVERSE0 G4229)) + (SEQ (EXIT (SETQ G4229 + (CONS (CONS |o| |n|) G4229)))))))) + (|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 ((G4276 |keys| (CDR G4276)) + (|k| NIL)) + ((OR (ATOM G4276) + (PROGN + (SETQ |k| (CAR G4276)) + 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 ((G4285 (PA-SPEC-COUNT |ob|)) + (|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| G4285) 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 'EQ)) + (SPADLET |$notseen| (GENSYM)) + (|traverse,traverseInner| |ob| |fn| |arg|))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}