diff --git a/changelog b/changelog index dddf97e..de5301a 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090828 tpd src/axiom-website/patches.html 20090828.03.tpd.patch +20090828 tpd src/interp/Makefile move compiler.boot to compiler.lisp +20090828 tpd src/interp/compiler.lisp added, rewritten from compiler.boot +20090828 tpd src/interp/compiler.boot removed, rewritten to compiler.lisp 20090828 tpd src/axiom-website/patches.html 20090828.02.tpd.patch 20090828 tpd src/interp/Makefile move htcheck.boot to htcheck.lisp 20090828 tpd src/interp/htcheck.lisp added, rewritten from htcheck.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index ff338ca..280f14b 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1931,6 +1931,8 @@ modemap.lisp rewrite from boot to lisp
20090828.01.tpd.patch package.lisp rewrite from boot to lisp
20090828.02.tpd.patch +htcheck.lisp rewrite from boot to lisp
+20090828.03.tpd.patch compiler.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 8a6df3b..6b57e43 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -2384,53 +2384,27 @@ ${MID}/compat.lisp: ${IN}/compat.lisp.pamphlet @ -\subsection{compiler.boot \cite{64}} -<>= -${AUTO}/compiler.${O}: ${OUT}/compiler.${O} - @ echo 231 making ${AUTO}/compiler.${O} from ${OUT}/compiler.${O} - @ cp ${OUT}/compiler.${O} ${AUTO} - -@ +\subsection{compiler.lisp} <>= -${OUT}/compiler.${O}: ${MID}/compiler.clisp - @ echo 232 making ${OUT}/compiler.${O} from ${MID}/compiler.clisp - @ (cd ${MID} ; \ +${OUT}/compiler.${O}: ${MID}/compiler.lisp + @ echo 136 making ${OUT}/compiler.${O} from ${MID}/compiler.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/compiler.clisp"' \ + echo '(progn (compile-file "${MID}/compiler.lisp"' \ ':output-file "${OUT}/compiler.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/compiler.clisp"' \ + else \ + echo '(progn (compile-file "${MID}/compiler.lisp"' \ ':output-file "${OUT}/compiler.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/compiler.clisp: ${IN}/compiler.boot.pamphlet - @ echo 233 making ${MID}/compiler.clisp \ - from ${IN}/compiler.boot.pamphlet +<>= +${MID}/compiler.lisp: ${IN}/compiler.lisp.pamphlet + @ echo 137 making ${MID}/compiler.lisp from \ + ${IN}/compiler.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/compiler.boot.pamphlet >compiler.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "compiler.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "compiler.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm compiler.boot ) - -@ -<>= -${DOC}/compiler.boot.dvi: ${IN}/compiler.boot.pamphlet - @echo 234 making ${DOC}/compiler.boot.dvi \ - from ${IN}/compiler.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/compiler.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} compiler.boot ; \ - rm -f ${DOC}/compiler.boot.pamphlet ; \ - rm -f ${DOC}/compiler.boot.tex ; \ - rm -f ${DOC}/compiler.boot ) + ${TANGLE} ${IN}/compiler.lisp.pamphlet >compiler.lisp ) @ @@ -5245,10 +5219,8 @@ clean: <> <> -<> <> -<> -<> +<> <> <> diff --git a/src/interp/compiler.boot.pamphlet b/src/interp/compiler.boot.pamphlet deleted file mode 100644 index e07ad75..0000000 --- a/src/interp/compiler.boot.pamphlet +++ /dev/null @@ -1,1811 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp compiler.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{Compiler Top Level Functions} -\subsection{compTopLevel} -<<*>>= -compTopLevel(x,m,e) == ---+ signals that target is derived from lhs-- see NRTmakeSlot1Info - $NRTderivedTargetIfTrue: local := false - $killOptimizeIfTrue: local:= false - $forceAdd: local:= false - $compTimeSum: local := 0 - $resolveTimeSum: local := 0 - $packagesUsed: local := [] - -- This hashtable is a performance improvement by Waldek Hebisch - $envHashTable: local := MAKE_-HASHTABLE 'EQUAL - for u in CAR(CAR(e)) repeat - for v in CDR(u) repeat - HPUT($envHashTable,[CAR u, CAR v],true) - -- The next line allows the new compiler to be tested interactively. - compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak - x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => - ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e]) - --keep old environment after top level function defs - FUNCALL(compFun,x,m,e) - -@ -\subsection{compUniquely} -<<*>>= -compUniquely(x,m,e) == - $compUniquelyIfTrue: local:= true - CATCH("compUniquely",comp(x,m,e)) - -@ -Given: -\begin{verbatim} -CohenCategory(): Category == SetCategory with - - kind:(CExpr)->Boolean - ++ kind(CExpr) - operand:(CExpr,Integer)->CExpr - ++ operand:(CExpr,Integer) - numberOfOperand:(CExpr)->Integer - ++ numberOfOperand:(CExpr)->Integer - construct:(CExpr,CExpr)->CExpr - ++ construct:(CExpr,CExpr)->CExpr - -\end{verbatim} -the resulting call looks like: -\begin{verbatim} - (|compOrCroak| - (DEF (|CohenCategory|) - ((|Category|)) - (NIL) - (|Join| - (|SetCategory|) - (CATEGORY |package| - (SIGNATURE |kind| ((|Boolean|) |CExpr|)) - (SIGNATURE |operand| (|CExpr| |CExpr| (|Integer|))) - (SIGNATURE |numberOfOperand| ((|Integer|) |CExpr|)) - (SIGNATURE |construct| (|CExpr| |CExpr| |CExpr|))))) - |$EmptyMode| - ((( - (|$DomainsInScope| - (FLUID . |true|) - (|special| |$EmptyMode| |$NoValueMode|)))))) -\end{verbatim} - -This is compiler call expects the first argument {\tt x} -to be a {\tt DEF} form to compile, -The second argument, {\tt m}, is the mode. -The third argument, {\tt e}, is the environment. - -In the call to {\tt compOrCroak1} the fourth argument {\tt comp} -is the function to call. -\subsection{compOrCroak} -<<*>>= -compOrCroak(x,m,e) == compOrCroak1(x,m,e,'comp) - -@ -Which results in the call: -\begin{verbatim} -(|compOrCroak1| - (DEF (|CohenCategory|) - ((|Category|)) - (NIL) - (|Join| - (|SetCategory|) - (CATEGORY |package| - (SIGNATURE |kind| ((|Boolean|) |CExpr|)) - (SIGNATURE |operand| (|CExpr| |CExpr| (|Integer|))) - (SIGNATURE |numberOfOperand| ((|Integer|) |CExpr|)) - (SIGNATURE |construct| (|CExpr| |CExpr| |CExpr|))))) - |$EmptyMode| - (((( - |$DomainsInScope| - (FLUID . |true|) - (|special| |$EmptyMode| |$NoValueMode|))))) - |comp|) -\end{verbatim} -This results into a call to the inner function -\begin{verbatim} -(|compOrCroak1,fn| - (DEF (|CohenCategory|) - ((|Category|)) - (NIL) - (|Join| - (|SetCategory|) - (CATEGORY |package| - (SIGNATURE |kind| ((|Boolean|) |CExpr|)) - (SIGNATURE |operand| (|CExpr| |CExpr| (|Integer|))) - (SIGNATURE |numberOfOperand| ((|Integer|) |CExpr|)) - (SIGNATURE |construct| (|CExpr| |CExpr| |CExpr|))))) - |$EmptyMode| - (((( - |$DomainsInScope| - (FLUID . |true|) - (|special| |$EmptyMode| |$NoValueMode|))))) - NIL - NIL - |comp|) -\end{verbatim} -This is compiler call expects the first argument {\tt x} -to be a {\tt DEF} form to compile, -The second argument, {\tt m}, is the mode. -The third argument, {\tt e}, is the environment. -The fourth argument {\tt comp} is the function to call. - -The inner function augments the environment with information -from the compiler stack {\tt \$compStack} and -{\tt \$compErrorMessageStack}. - -\subsection{compOrCroak1} -<<*>>= -compOrCroak1(x,m,e,compFn) == - fn(x,m,e,nil,nil,compFn) where - fn(x,m,e,$compStack,$compErrorMessageStack,compFn) == - T:= CATCH("compOrCroak",FUNCALL(compFn,x,m,e)) => T - --stackAndThrow here and moan in UT LISP K does the appropriate THROW - $compStack:= [[x,m,e,$exitModeStack],:$compStack] - $s:= - compactify $compStack where - compactify al == - null al => nil - LASSOC(first first al,rest al) => compactify rest al - [first al,:compactify rest al] - $level:= #$s - errorMessage:= - if $compErrorMessageStack - then first $compErrorMessageStack - else "unspecified error" - $scanIfTrue => - stackSemanticError(errorMessage,mkErrorExpr $level) - ["failedCompilation",m,e] - displaySemanticErrors() - SAY("****** comp fails at level ",$level," with expression: ******") - displayComp $level - userError errorMessage - -@ -\subsection{tc} -<<*>>= -tc() == - $tripleCache:= nil - comp($x,$m,$f) - - -@ -\subsection{comp} -<<*>>= -comp(x,m,e) == - T:= compNoStacking(x,m,e) => ($compStack:= nil; T) - $compStack:= [[x,m,e,$exitModeStack],:$compStack] - nil - -@ -\subsection{compNoStacking} -<<*>>= -compNoStacking(x,m,e) == - T:= comp2(x,m,e) => - (m=$EmptyMode and T.mode=$Representation => [T.expr,"$",T.env]; T) - --$Representation is bound in compDefineFunctor, set by doIt - --this hack says that when something is undeclared, $ is - --preferred to the underlying representation -- RDJ 9/12/83 - compNoStacking1(x,m,e,$compStack) - -@ -\subsection{compNoStacking1} -<<*>>= -compNoStacking1(x,m,e,$compStack) == - u:= get(if m="$" then "Rep" else m,"value",e) => - (T:= comp2(x,u.expr,e) => [T.expr,m,T.env]; nil) - nil - -@ -\subsection{comp2} -<<*>>= -comp2(x,m,e) == - [y,m',e]:= comp3(x,m,e) or return nil - if $LISPLIB and isDomainForm(x,e) then - if isFunctor x then - $packagesUsed:= insert([opOf x],$packagesUsed) - --if null atom y and isDomainForm(y,e) then e := addDomain(x,e) - --line commented out to prevent adding derived domain forms - m^=m' and ($bootStrapMode or isDomainForm(m',e))=>[y,m',addDomain(m',e)] - --isDomainForm test needed to prevent error while compiling Ring - --$bootStrapMode-test necessary for compiling Ring in $bootStrapMode - [y,m',e] - -@ -\subsection{comp3} -<<*>>= -comp3(x,m,$e) == - --returns a Triple or %else nil to signalcan't do' - $e:= addDomain(m,$e) - e:= $e --for debugging purposes - m is ["Mapping",:.] => compWithMappingMode(x,m,e) - m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) - STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) - ^x or atom x => compAtom(x,m,e) - op:= first x - getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u - op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) - op=":" => compColon(x,m,e) - op="::" => compCoerce(x,m,e) - not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => - compTypeOf(x,m,e) - t:= compExpression(x,m,e) - t is [x',m',e'] and not MEMBER(m',getDomainsInScope e') => - [x',m',addDomain(m',e')] - t - -@ -\subsection{compTypeOf} -<<*>>= -compTypeOf(x:=[op,:argl],m,e) == - $insideCompTypeOf: local := true - newModemap:= EQSUBSTLIST(argl,$FormalMapVariableList,get(op,'modemap,e)) - e:= put(op,'modemap,newModemap,e) - comp3(x,m,e) - -@ -\subsection{hasFormalMapVariable} -<<*>>= -hasFormalMapVariable(x, vl) == - $formalMapVariables: local := vl - null vl => false - ScanOrPairVec('hasone?,x) where - hasone? x == MEMQ(x,$formalMapVariables) - -@ -\subsection{argsToSig} -<<*>>= -argsToSig(args) == - args is [":",v,t] => [[v],[t]] - sig1:=[] - arg1:=[] - bad:=false - for arg in args repeat - arg is [":",v,t] => - sig1:=[t,:sig1] - arg1:=[v,:arg1] - bad:=true - bad=>[nil,nil] - [REVERSE(arg1),REVERSE(sig1)] - -@ -\subsection{compLambda} -<<*>>= -compLambda(x is ["+->",vl,body],m,e) == - vl is [":",args,target] => - args:= - args is ["Tuple",:a1] => a1 - args - LISTP(args) => - [arg1,sig1]:=argsToSig(args) - sig1 => - ress:=compAtSign(["@",["+->",arg1,body],["Mapping",target,:sig1]],m,e) - ress - stackAndThrow ["compLambda",x] - stackAndThrow ["compLambda",x] - stackAndThrow ["compLambda",x] - -@ -\subsection{compWithMappingMode} -<<*>>= -compWithMappingMode(x,m,oldE) == - compWithMappingMode1(x,m,oldE,$formalArgList) - -@ -\subsection{compWithMappingMode1} -<<*>>= -compWithMappingMode1(x,m is ["Mapping",m',:sl],oldE,$formalArgList) == - $killOptimizeIfTrue: local:= true - e:= oldE - isFunctor x => - if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and - (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] - ) and extendsCategoryForm("$",target,m') then return [x,m,e] - if STRINGP x then x:= INTERN x - ress:=nil - old_style:=true - if x is ["+->",vl,nx] then - old_style:=false - vl is [":",:.] => - ress:=compLambda(x,m,oldE) - ress - vl:= - vl is ["Tuple",:vl1] => vl1 - vl - vl:= - SYMBOLP(vl) => [vl] - LISTP(vl) and (and/[SYMBOLP(v) for v in vl]) => vl - stackAndThrow ["bad +-> arguments:",vl] - $formatArgList:=[:vl,:$formalArgList] - x:=nx - else - vl:=take(#sl,$FormalMapVariableList) - ress => ress - for m in sl for v in vl repeat - [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) - old_style and not null vl and not hasFormalMapVariable(x, vl) => return - [u,.,.] := comp([x,:vl],m',e) or return nil - extractCodeAndConstructTriple(u, m, oldE) - null vl and (t := comp([x], m', e)) => return - [u,.,.] := t - extractCodeAndConstructTriple(u, m, oldE) - [u,.,.]:= comp(x,m',e) or return nil - uu:=optimizeFunctionDef [nil,['LAMBDA,vl,u]] - -- At this point, we have a function that we would like to pass. - -- Unfortunately, it makes various free variable references outside - -- itself. So we build a mini-vector that contains them all, and - -- pass this as the environment to our inner function. - $FUNNAME :local := nil - $FUNNAME__TAIL :local := [nil] - expandedFunction:=COMP_-TRAN CADR uu - frees:=FreeList(expandedFunction,vl,nil,e) - where FreeList(u,bound,free,e) == - atom u => - not IDENTP u => free - MEMQ(u,bound) => free - v:=ASSQ(u,free) => - RPLACD(v,1+CDR v) - free - not getmode(u, e) => free - [[u,:1],:free] - op:=CAR u - MEMQ(op, '(QUOTE GO function)) => free - EQ(op,'LAMBDA) => - bound:=UNIONQ(bound,CADR u) - for v in CDDR u repeat - free:=FreeList(v,bound,free,e) - free - EQ(op,'PROG) => - bound:=UNIONQ(bound,CADR u) - for v in CDDR u | NOT ATOM v repeat - free:=FreeList(v,bound,free,e) - free - EQ(op,'SEQ) => - for v in CDR u | NOT ATOM v repeat - free:=FreeList(v,bound,free,e) - free - EQ(op,'COND) => - for v in CDR u repeat - for vv in v repeat - free:=FreeList(vv,bound,free,e) - free - if ATOM op then u:=CDR u --Atomic functions aren't descended - for v in u repeat - free:=FreeList(v,bound,free,e) - free - expandedFunction := - --One free can go by itself, more than one needs a vector - --An A-list name . number of times used - #frees = 0 => ['LAMBDA,[:vl,"$$"], :CDDR expandedFunction] - #frees = 1 => - vec:=first first frees - ['LAMBDA,[:vl,vec], :CDDR expandedFunction] - scode:=nil - vec:=nil - locals:=nil - i:=-1 - for v in frees repeat - i:=i+1 - vec:=[first v,:vec] - scode:=[['SETQ,first v,[($QuickCode => 'QREFELT;'ELT),"$$",i]],:scode] - locals:=[first v,:locals] - body:=CDDR expandedFunction - if locals then - if body is [['DECLARE,:.],:.] then - body:=[CAR body,['PROG,locals,:scode,['RETURN,['PROGN,:CDR body]]]] - else body:=[['PROG,locals,:scode,['RETURN,['PROGN,:body]]]] - vec:=['VECTOR,:NREVERSE vec] - ['LAMBDA,[:vl,"$$"],:body] - fname:=['CLOSEDFN,expandedFunction] - --Like QUOTE, but gets compiled - uu:= - frees => ['CONS,fname,vec] - ['LIST,fname] - [uu,m,oldE] - -@ -\subsection{extractCodeAndConstructTriple} -<<*>>= -extractCodeAndConstructTriple(u, m, oldE) == - u is ["call",fn,:.] => - if fn is ["applyFun",a] then fn := a - [fn,m,oldE] - [op,:.,env] := u - [["CONS",["function",op],env],m,oldE] - -@ -\subsection{compExpression} -<<*>>= -compExpression(x,m,e) == - $insideExpressionIfTrue: local:= true - atom first x and (fn:= GET(first x,"SPECIAL")) => - FUNCALL(fn,x,m,e) - compForm(x,m,e) - -@ -\subsection{compAtom} -<<*>>= -compAtom(x,m,e) == - T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => T - x="nil" => - T:= - modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) - modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) - T => convert(T,m) - t:= - isSymbol x => - compSymbol(x,m,e) or return nil - m = $Expression and primitiveType x => [x,m,e] - STRINGP x => [x,x,e] - [x,primitiveType x or return nil,e] - convert(t,m) - -@ -\subsection{primitiveType} -<<*>>= -primitiveType x == - x is nil => $EmptyMode - STRINGP x => $String - INTEGERP x => - x=0 => $NonNegativeInteger - x>0 => $PositiveInteger - true => $NegativeInteger - FLOATP x => $DoubleFloat - nil - -@ -\subsection{compSymbol} -<<*>>= -compSymbol(s,m,e) == - s="$NoValue" => ["$NoValue",$NoValueMode,e] - isFluid s => [s,getmode(s,e) or return nil,e] - s="true" => ['(QUOTE T),$Boolean,e] - s="false" => [false,$Boolean,e] - s=m or get(s,"isLiteral",e) => [["QUOTE",s],s,e] - v:= get(s,"value",e) => ---+ - MEMQ(s,$functorLocalParameters) => - NRTgetLocalIndex s - [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile - [s,v.mode,e] --s has been SETQd - m':= getmode(s,e) => - if not MEMBER(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and - not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s - [s,m',e] --s is a declared argument - MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s] - m = $Expression or m = $Symbol => [['QUOTE,s],m,e] - not isFunction(s,e) => errorRef s - -@ -\subsection{convertOrCroak} -<<*>>= -convertOrCroak(T,m) == - u:= convert(T,m) => u - userError ["CANNOT CONVERT: ",T.expr,"%l"," OF MODE: ",T.mode,"%l", - " TO MODE: ",m,"%l"] - -@ -\subsection{convert} -<<*>>= -convert(T,m) == - coerce(T,resolve(T.mode,m) or return nil) - -@ -\subsection{mkUnion} -<<*>>= -mkUnion(a,b) == - b="$" and $Rep is ["Union",:l] => b - a is ["Union",:l] => - b is ["Union",:l'] => ["Union",:setUnion(l,l')] - ["Union",:setUnion([b],l)] - b is ["Union",:l] => ["Union",:setUnion([a],l)] - ["Union",a,b] - -@ -\subsection{maxSuperType} -<<*>>= -maxSuperType(m,e) == - typ:= get(m,"SuperDomain",e) => maxSuperType(typ,e) - m - -@ -\subsection{hasType} -<<*>>= -hasType(x,e) == - fn get(x,"condition",e) where - fn x == - null x => nil - x is [["case",.,y],:.] => y - fn rest x - -@ -\subsection{compForm} -<<*>>= -compForm(form,m,e) == - T:= - compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return - stackMessageIfNone ["cannot compile","%b",form,"%d"] - T - -@ -\subsection{compArgumentsAndTryAgain} -<<*>>= -compArgumentsAndTryAgain(form is [.,:argl],m,e) == - -- used in case: f(g(x)) where f is in domain introduced by - -- comping g, e.g. for (ELT (ELT x a) b), environment can have no - -- modemap with selector b - form is ["elt",a,.] => - ([.,.,e]:= comp(a,$EmptyMode,e) or return nil; compForm1(form,m,e)) - u:= for x in argl repeat [.,.,e]:= comp(x,$EmptyMode,e) or return "failed" - u="failed" => nil - compForm1(form,m,e) - -@ -\subsection{outputComp} -<<*>>= -outputComp(x,e) == - u:=comp(['_:_:,x,$Expression],$Expression,e) => u - x is ['construct,:argl] => - [['LIST,:[([.,.,e]:=outputComp(x,e)).expr for x in argl]],$Expression,e] - (v:= get(x,"value",e)) and (v.mode is ['Union,:l]) => - [['coerceUn2E,x,v.mode],$Expression,e] - [x,$Expression,e] - -@ -\subsection{compForm1} -<<*>>= -compForm1(form is [op,:argl],m,e) == - $NumberOfArgsIfInteger: local:= #argl --see compElt - op="error" => - [[op,:[([.,.,e]:=outputComp(x,e)).expr - for x in argl]],m,e] - op is ["elt",domain,op'] => - domain="Lisp" => - --op'='QUOTE and null rest argl => [first argl,m,e] - [[op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]],m,e] - domain=$Expression and op'="construct" => compExpressionList(argl,m,e) - (op'="COLLECT") and coerceable(domain,m,e) => - (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) - -- Next clause added JHD 8/Feb/94: the clause after doesn't work - -- since addDomain refuses to add modemaps from Mapping - (domain is ['Mapping,:.]) and - (ans := compForm2([op',:argl],m,e:= augModemapsFromDomain1(domain,domain,e), - [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]])) => ans - - ans := compForm2([op',:argl],m,e:= addDomain(domain,e), - [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]]) => ans - (op'="construct") and coerceable(domain,m,e) => - (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) - nil - - e:= addDomain(m,e) --???unneccessary because of comp2's call??? - (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T - compToApply(op,argl,m,e) - -@ -\subsection{compExpressionList} -<<*>>= -compExpressionList(argl,m,e) == - Tl:= [[.,.,e]:= comp(x,$Expression,e) or return "failed" for x in argl] - Tl="failed" => nil - convert([["LIST",:[y.expr for y in Tl]],$Expression,e],m) - -@ -\subsection{compForm2} -<<*>>= -compForm2(form is [op,:argl],m,e,modemapList) == - sargl:= TAKE(# argl, $TriangleVariableList) - aList:= [[sa,:a] for a in argl for sa in sargl] - modemapList:= SUBLIS(aList,modemapList) - deleteList:=[] - newList := [] - -- now delete any modemaps that are subsumed by something else, provided the conditions - -- are right (i.e. subsumer true whenever subsumee true) - for u in modemapList repeat - if u is [[dc,:.],[cond,["Subsumed",.,nsig]]] and - (v:=assoc([dc,:nsig],modemapList)) and v is [.,[ncond,:.]] then - deleteList:=[u,:deleteList] - if not PredImplies(ncond,cond) then - newList := [[CAR u,[cond,['ELT,dc,nil]]],:newList] - if deleteList then modemapList:=[u for u in modemapList | not MEMQ(u,deleteList)] - -- We can use MEMQ since deleteList was built out of members of modemapList - -- its important that subsumed ops (newList) be considered last - if newList then modemapList := append(modemapList,newList) - Tl:= - [[.,.,e]:= T - for x in argl while (isSimple x and (T:= compUniquely(x,$EmptyMode,e)))] - or/[x for x in Tl] => - partialModeList:= [(x => x.mode; nil) for x in Tl] - compFormPartiallyBottomUp(form,m,e,modemapList,partialModeList) or - compForm3(form,m,e,modemapList) - compForm3(form,m,e,modemapList) - -@ -\subsection{compFormPartiallyBottomUp} -<<*>>= -compFormPartiallyBottomUp(form,m,e,modemapList,partialModeList) == - mmList:= [mm for mm in modemapList | compFormMatch(mm,partialModeList)] => - compForm3(form,m,e,mmList) - -@ -\subsection{compFormMatch} -<<*>>= -compFormMatch(mm,partialModeList) == - mm is [[.,.,:argModeList],:.] and match(argModeList,partialModeList) where - match(a,b) == - null b => true - null first b => match(rest a,rest b) - first a=first b and match(rest a,rest b) - -@ -\subsection{compForm3} -<<*>>= -compForm3(form is [op,:argl],m,e,modemapList) == - T:= - or/ - [compFormWithModemap(form,m,e,first (mml:= ml)) - for ml in tails modemapList] - $compUniquelyIfTrue => - or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] => - THROW("compUniquely",nil) - T - T - -@ -\subsection{getFormModemaps} -<<*>>= -getFormModemaps(form is [op,:argl],e) == - op is ["elt",domain,op1] => - [x for x in getFormModemaps([op1,:argl],e) | x is [[ =domain,:.],:.]] - null atom op => nil - modemapList:= get(op,"modemap",e) - if $insideCategoryPackageIfTrue then - modemapList := [x for x in modemapList | x is [[dom,:.],:.] and dom ^= '$] - if op="elt" - then modemapList:= eltModemapFilter(LAST argl,modemapList,e) or return nil - else - if op="setelt" then modemapList:= - seteltModemapFilter(CADR argl,modemapList,e) or return nil - nargs:= #argl - finalModemapList:= [mm for (mm:= [[.,.,:sig],:.]) in modemapList | #sig=nargs] - modemapList and null finalModemapList => - stackMessage ["no modemap for","%b",op,"%d","with ",nargs," arguments"] - finalModemapList - -@ -\subsection{getConstructorFormOfMode} -<<*>>= -getConstructorFormOfMode(m,e) == - isConstructorForm m => m - if m="$" then m:= "Rep" - atom m and get(m,"value",e) is [v,:.] => - isConstructorForm v => v - -@ -\subsection{getConstructorMode} -<<*>>= -getConstructorMode(x,e) == - atom x => (u:= getmode(x,e) or return nil; getConstructorFormOfMode(u,e)) - x is ["elt",y,a] => - u:= getConstructorMode(y,e) - u is ["Vector",R] or u is ["List",R] => - isConstructorForm R => R - u is ["Record",:l] => - (or/[p is [., =a,R] for p in l]) and isConstructorForm R => R - -@ -\subsection{isConstructorForm} -<<*>>= -isConstructorForm u == u is [name,:.] and MEMBER(name,'(Record Vector List)) - -@ -\subsection{eltModemapFilter} -<<*>>= -eltModemapFilter(name,mmList,e) == - isConstantId(name,e) => - l:= [mm for mm in mmList | mm is [[.,.,.,sel,:.],:.] and sel=name] => l - --there are elts with extra parameters - stackMessage ["selector variable: ",name," is undeclared and unbound"] - nil - mmList - -@ -\subsection{seteltModemapFilter} -<<*>>= -seteltModemapFilter(name,mmList,e) == - isConstantId(name,e) => - l:= [mm for (mm:= [[.,.,.,sel,:.],:.]) in mmList | sel=name] => l - --there are setelts with extra parameters - stackMessage ["selector variable: ",name," is undeclared and unbound"] - nil - mmList - -@ -\subsection{substituteIntoFunctorModemap} -<<*>>= -substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) == - #dc^=#sig => - keyedSystemError("S2GE0016",['"substituteIntoFunctorModemap", - '"Incompatible maps"]) - #argl=#rest sig => - --here, we actually have a functor form - sig:= EQSUBSTLIST(argl,rest dc,sig) - --make new modemap, subst. actual for formal parametersinto modemap - Tl:= [[.,.,e]:= compOrCroak(a,m,e) for a in argl for m in rest sig] - substitutionList:= [[x,:T.expr] for x in rest dc for T in Tl] - [SUBLIS(substitutionList,modemap),e] - nil - -@ - -\section{Special evaluation functions} -\subsection{compConstructorCategory} -<<*>>= -compConstructorCategory(x,m,e) == [x,resolve($Category,m),e] - -@ -\subsection{compString} -<<*>>= -compString(x,m,e) == [x,resolve($StringCategory,m),e] - -@ -\subsection{compSubsetCategory} -Compile SubsetCategory -<<*>>= -compSubsetCategory(["SubsetCategory",cat,R],m,e) == - --1. put "Subsets" property on R to allow directly coercion to subset; - -- allow automatic coercion from subset to R but not vice versa - e:= put(R,"Subsets",[[$lhsOfColon,"isFalse"]],e) - --2. give the subset domain modemaps of cat plus 3 new functions - comp(["Join",cat,C'],m,e) where - C'() == - substitute($lhsOfColon,"$",C'') where - C''() == - ["CATEGORY","domain",["SIGNATURE","coerce",[R,"$"]],["SIGNATURE", - "lift",[R,"$"]],["SIGNATURE","reduce",["$",R]]] - -@ -\subsection{compCons} -Compile cons -<<*>>= -compCons(form,m,e) == compCons1(form,m,e) or compForm(form,m,e) - -@ -\subsection{compCons1} -<<*>>= -compCons1(["CONS",x,y],m,e) == - [x,mx,e]:= comp(x,$EmptyMode,e) or return nil - null y => convert([["LIST",x],["List",mx],e],m) - yt:= [y,my,e]:= comp(y,$EmptyMode,e) or return nil - T:= - my is ["List",m',:.] => - mr:= ["List",resolve(m',mx) or return nil] - yt':= convert(yt,mr) or return nil - [x,.,e]:= convert([x,mx,yt'.env],CADR mr) or return nil - yt'.expr is ["LIST",:.] => [["LIST",x,:rest yt'.expr],mr,e] - [["CONS",x,yt'.expr],mr,e] - [["CONS",x,y],["Pair",mx,my],e] - convert(T,m) - -@ -\subsection{compSetq} -Compile setq -<<*>>= -compSetq(["LET",form,val],m,E) == compSetq1(form,val,m,E) - -@ -\subsection{compSetq1} -<<*>>= -compSetq1(form,val,m,E) == - IDENTP form => setqSingle(form,val,m,E) - form is [":",x,y] => - [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E) - compSetq(["LET",x,val],m,E') - form is [op,:l] => - op="CONS" => setqMultiple(uncons form,val,m,E) - op="Tuple" => setqMultiple(l,val,m,E) - setqSetelt(form,val,m,E) - -@ -\subsection{compMakeDeclaration} -<<*>>= -compMakeDeclaration(x,m,e) == - $insideExpressionIfTrue: local - compColon(x,m,e) - -@ -\subsection{setqSetelt} -Compile setelt -<<*>>= -setqSetelt([v,:s],val,m,E) == - comp(["setelt",v,:s,val],m,E) - -@ -\subsection{setqSingle} -<<*>>= -setqSingle(id,val,m,E) == - $insideSetqSingleIfTrue: local:= true - --used for comping domain forms within functions - currentProplist:= getProplist(id,E) - m'':= - get(id,'mode,E) or getmode(id,E) or - (if m=$NoValueMode then $EmptyMode else m) --- m'':= LASSOC("mode",currentProplist) or $EmptyMode - --for above line to work, line 3 of compNoStackingis required - T:= - eval or return nil where - eval() == - T:= comp(val,m'',E) => T - not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and - (T:=comp(val,maxm'',E)) => T - (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => - assignError(val,T.mode,id,m'') - T':= [x,m',e']:= convert(T,m) or return nil - if $profileCompiler = true then - null IDENTP id => nil - key := - MEMQ(id,rest $form) => 'arguments - 'locals - profileRecord(key,id,T.mode) - newProplist:= consProplistOf(id,currentProplist,"value",removeEnv [val,:rest T]) - e':= (PAIRP id => e'; addBinding(id,newProplist,e')) - if isDomainForm(val,e') then - if isDomainInScope(id,e') then - stackWarning ["domain valued variable","%b",id,"%d", - "has been reassigned within its scope"] - e':= augModemapsFromDomain1(id,val,e') - --all we do now is to allocate a slot number for lhs - --e.g. the LET form below will be changed by putInLocalDomainReferences ---+ - if (k:=NRTassocIndex(id)) - then form:=['SETELT,"$",k,x] - else form:= - $QuickLet => ["LET",id,x] - ["LET",id,x, - (isDomainForm(x,e') => ['ELT,id,0];CAR outputComp(id,e'))] - [form,m',e'] - -@ -\subsection{assignError} -<<*>>= -assignError(val,m',form,m) == - message:= - val => - ["CANNOT ASSIGN: ",val,"%l"," OF MODE: ",m',"%l"," TO: ",form,"%l", - " OF MODE: ",m] - ["CANNOT ASSIGN: ",val,"%l"," TO: ",form,"%l"," OF MODE: ",m] - stackMessage message - -@ -\subsection{setqMultiple} -<<*>>= -setqMultiple(nameList,val,m,e) == - val is ["CONS",:.] and m=$NoValueMode => - setqMultipleExplicit(nameList,uncons val,m,e) - val is ["Tuple",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e) - 1 --create a gensym, %add to local environment, compile and assign rhs - g:= genVariable() - e:= addBinding(g,nil,e) - T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil - e:= put(g,"mode",m1,e) - [x,m',e]:= convert(T,m) or return nil - 1.1 --exit if result is a list - m1 is ["List",D] => - for y in nameList repeat e:= put(y,"value",[genSomeVariable(),D,$noEnv],e) - convert([["PROGN",x,["LET",nameList,g],g],m',e],m) - 2 --verify that the #nameList = number of parts of right-hand-side - selectorModePairs:= - --list of modes - decompose(m1,#nameList,e) or return nil where - decompose(t,length,e) == - t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l] - comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] => - [[name,:mode] for [":",name,mode] in l] - stackMessage ["no multiple assigns to mode: ",t] - #nameList^=#selectorModePairs => - stackMessage [val," must decompose into ",#nameList," components"] - 3 --generate code; return - assignList:= - [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr - for x in nameList for [y,:z] in selectorModePairs] - if assignList="failed" then NIL - else [MKPROGN [x,:assignList,g],m',e] - -@ -\subsection{setqMultipleExplicit} -<<*>>= -setqMultipleExplicit(nameList,valList,m,e) == - #nameList^=#valList => - stackMessage ["Multiple assignment error; # of items in: ",nameList, - "must = # in: ",valList] - gensymList:= [genVariable() for name in nameList] - assignList:= - --should be fixed to declare genVar when possible - [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed" - for g in gensymList for val in valList] - assignList="failed" => nil - reAssignList:= - [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed" - for g in gensymList for name in nameList] - reAssignList="failed" => nil - [["PROGN",:[T.expr for T in assignList],:[T.expr for T in reAssignList]], - $NoValueMode, (LAST reAssignList).env] - -@ -\subsection{compWhere} -Compile where -<<*>>= -compWhere([.,form,:exprList],m,eInit) == - $insideExpressionIfTrue: local:= false - $insideWhereIfTrue: local:= true - e:= eInit - u:= - for item in exprList repeat - [.,.,e]:= comp(item,$EmptyMode,e) or return "failed" - u="failed" => return nil - $insideWhereIfTrue:= false - [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil - eFinal:= - del:= deltaContour(eAfter,eBefore) => addContour(del,eInit) - eInit - [x,m,eFinal] - -@ -\subsection{compConstruct} -Compile construct -<<*>>= -compConstruct(form is ["construct",:l],m,e) == - y:= modeIsAggregateOf("List",m,e) => - T:= compList(l,["List",CADR y],e) => convert(T,m) - compForm(form,m,e) - y:= modeIsAggregateOf("Vector",m,e) => - T:= compVector(l,["Vector",CADR y],e) => convert(T,m) - compForm(form,m,e) - T:= compForm(form,m,e) => T - for D in getDomainsInScope e repeat - (y:=modeIsAggregateOf("List",D,e)) and - (T:= compList(l,["List",CADR y],e)) and (T':= convert(T,m)) => - return T' - (y:=modeIsAggregateOf("Vector",D,e)) and - (T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) => - return T' - -@ -\subsection{compQuote} -Compile quote -<<*>>= -compQuote(expr,m,e) == [expr,m,e] - -@ -\subsection{compList} -Compile list -<<*>>= -compList(l,m is ["List",mUnder],e) == - null l => [NIL,m,e] - Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] - Tl="failed" => nil - T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] - -@ -\subsection{compVector} -Compile vector -<<*>>= -compVector(l,m is ["Vector",mUnder],e) == - null l => [$EmptyVector,m,e] - Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] - Tl="failed" => nil - [["VECTOR",:[T.expr for T in Tl]],m,e] - -@ -\subsection{compMacro} -The compMacro function does macro expansion during spad file compiles. -If a macro occurs twice in the same file the macro expands infinitely -causing a stack overflow. The reason for the infinite recursion is that -the left hand side of the macro definition is expanded. Thus defining -a macro: -\begin{verbatim} -name ==> 1 -\end{verbatim} -will expand properly the first time. The second time it turns into: -\begin{verbatim} -1 ==> 1 -\end{verbatim} -The original code read: -\begin{verbatim} -compMacro(form,m,e) == - $macroIfTrue: local:= true - ["MDEF",lhs,signature,specialCases,rhs]:= form - rhs := - rhs is ['CATEGORY,:.] => ['"-- the constructor category"] - rhs is ['Join,:.] => ['"-- the constructor category"] - rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] - rhs is ['add,:.] => ['"-- the constructor capsule"] - formatUnabbreviated rhs - sayBrightly ['" processing macro definition",'%b, - :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] - ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) - m=$EmptyMode or m=$NoValueMode => - ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] - -\end{verbatim} -Juergen Weiss proposed the following fixed code. This does not expand -the left hand side of the macro. -<<*>>= -compMacro(form,m,e) == - $macroIfTrue: local:= true - ["MDEF",lhs,signature,specialCases,rhs]:= form - prhs := - rhs is ['CATEGORY,:.] => ['"-- the constructor category"] - rhs is ['Join,:.] => ['"-- the constructor category"] - rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] - rhs is ['add,:.] => ['"-- the constructor capsule"] - formatUnabbreviated rhs - sayBrightly ['" processing macro definition",'%b, - :formatUnabbreviated lhs,'" ==> ",:prhs,'%d] - m=$EmptyMode or m=$NoValueMode => - ["/throwAway",$NoValueMode,put(first lhs,"macro",macroExpand(rhs,e),e)] - -@ -\subsection{compSeq} -Compile seq -<<*>>= -compSeq(["SEQ",:l],m,e) == compSeq1(l,[m,:$exitModeStack],e) - -@ -\subsection{compSeq1} -<<*>>= -compSeq1(l,$exitModeStack,e) == - $insideExpressionIfTrue: local - $finalEnv: local - --used in replaceExitEtc. - c:= - [([.,.,e]:= - - - --this used to be compOrCroak-- but changed so we can back out - - ($insideExpressionIfTrue:= NIL; compSeqItem(x,$NoValueMode,e) or return - "failed")).expr for x in l] - if c="failed" then return nil - catchTag:= MKQ GENSYM() - form:= ["SEQ",:replaceExitEtc(c,catchTag,"TAGGEDexit",$exitModeStack.(0))] - [["CATCH",catchTag,form],$exitModeStack.(0),$finalEnv] - -@ -\subsection{compSeqItem} -<<*>>= -compSeqItem(x,m,e) == comp(macroExpand(x,e),m,e) - -@ -\subsection{replaceExitEtc} -<<*>>= -replaceExitEtc(x,tag,opFlag,opMode) == - (fn(x,tag,opFlag,opMode); x) where - fn(x,tag,opFlag,opMode) == - atom x => nil - x is ["QUOTE",:.] => nil - x is [ =opFlag,n,t] => - rplac(CAADDR x,replaceExitEtc(CAADDR x,tag,opFlag,opMode)) - n=0 => - $finalEnv:= - --bound in compSeq1 and compDefineCapsuleFunction - $finalEnv => intersectionEnvironment($finalEnv,t.env) - t.env - rplac(first x,"THROW") - rplac(CADR x,tag) - rplac(CADDR x,(convertOrCroak(t,opMode)).expr) - true => rplac(CADR x,CADR x-1) - x is [key,n,t] and MEMQ(key,'(TAGGEDreturn TAGGEDexit)) => - rplac(first t,replaceExitEtc(first t,tag,opFlag,opMode)) - replaceExitEtc(first x,tag,opFlag,opMode) - replaceExitEtc(rest x,tag,opFlag,opMode) - -@ -\subsection{compSuchthat} -Compile suchthat -<<*>>= -compSuchthat([.,x,p],m,e) == - [x',m',e]:= comp(x,m,e) or return nil - [p',.,e]:= comp(p,$Boolean,e) or return nil - e:= put(x',"condition",p',e) - [x',m',e] - -@ -\subsection{compExit} -Compile exit -<<*>>= -compExit(["exit",level,x],m,e) == - index:= level-1 - $exitModeStack = [] => comp(x,m,e) - m1:= $exitModeStack.index - [x',m',e']:= - u:= - comp(x,m1,e) or return - stackMessageIfNone ["cannot compile exit expression",x,"in mode",m1] - modifyModeStack(m',index) - [["TAGGEDexit",index,u],m,e] - -@ -\subsection{modifyModeStack} -<<*>>= -modifyModeStack(m,index) == - $reportExitModeStack => - SAY("exitModeStack: ",COPY $exitModeStack," ====> ", - ($exitModeStack.index:= resolve(m,$exitModeStack.index); $exitModeStack)) - $exitModeStack.index:= resolve(m,$exitModeStack.index) - -@ -\subsection{compLeave} -Compile leave -<<*>>= -compLeave(["leave",level,x],m,e) == - index:= #$exitModeStack-1-$leaveLevelStack.(level-1) - [x',m',e']:= u:= comp(x,$exitModeStack.index,e) or return nil - modifyModeStack(m',index) - [["TAGGEDexit",index,u],m,e] - -@ -\subsection{compReturn} -Compile return -<<*>>= -compReturn(["return",level,x],m,e) == - null $exitModeStack => - stackSemanticError(["the return before","%b",x,"%d","is unneccessary"],nil) - nil - level^=1 => userError '"multi-level returns not supported" - index:= MAX(0,#$exitModeStack-1) - if index>=0 then $returnMode:= resolve($exitModeStack.index,$returnMode) - [x',m',e']:= u:= comp(x,$returnMode,e) or return nil - if index>=0 then - $returnMode:= resolve(m',$returnMode) - modifyModeStack(m',index) - [["TAGGEDreturn",0,u],m,e'] - -@ -\subsection{compElt} -Compile Elt -<<*>>= -compElt(form,m,E) == - form isnt ["elt",aDomain,anOp] => compForm(form,m,E) - aDomain="Lisp" => - [anOp',m,E] where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) - isDomainForm(aDomain,E) => - E:= addDomain(aDomain,E) - mmList:= getModemapListFromDomain(anOp,0,aDomain,E) - modemap:= - n:=#mmList - 1=n => mmList.(0) - 0=n => - return - stackMessage ['"Operation ","%b",anOp,"%d", - '"missing from domain: ", aDomain] - stackWarning ['"more than 1 modemap for: ",anOp, - '" with dc=",aDomain,'" ===>" - ,mmList] - mmList.(0) - [sig,[pred,val]]:= modemap - #sig^=2 and ^val is ["elt",:.] => nil --what does the second clause do ???? ---+ - val := genDeltaEntry [opOf anOp,:modemap] - convert([["call",val],first rest sig,E], m) --implies fn calls used to access constants - compForm(form,m,E) - -@ -\subsection{compHas} -Compile has -<<*>>= -compHas(pred is ["has",a,b],m,$e) == - --b is (":",:.) => (.,.,E):= comp(b,$EmptyMode,E) - $e:= chaseInferences(pred,$e) - --pred':= ("has",a',b') := formatHas(pred) - predCode:= compHasFormat pred - coerce([predCode,$Boolean,$e],m) - - --used in various other places to make the discrimination - -@ -\subsection{compHasFormat} -<<*>>= -compHasFormat (pred is ["has",olda,b]) == - argl := rest $form - formals := TAKE(#argl,$FormalMapVariableList) - a := SUBLISLIS(argl,formals,olda) - [a,:.] := comp(a,$EmptyMode,$e) or return nil - a := SUBLISLIS(formals,argl,a) - b is ["ATTRIBUTE",c] => ["HasAttribute",a,["QUOTE",c]] - b is ["SIGNATURE",op,sig] => - ["HasSignature",a, - mkList [MKQ op,mkList [mkDomainConstructor type for type in sig]]] - isDomainForm(b,$EmptyEnvironment) => ["EQUAL",a,b] - ["HasCategory",a,mkDomainConstructor b] - -@ -\subsection{compIf} -Compile if -<<*>>= -compIf(["IF",a,b,c],m,E) == - [xa,ma,Ea,Einv]:= compBoolean(a,$Boolean,E) or return nil - [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil - [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil - xb':= coerce(Tb,mc) or return nil - x:= ["IF",xa,quotify xb'.expr,quotify xc] - (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where - Env(bEnv,cEnv,b,c,E) == - canReturn(b,0,0,true) => - (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv) - canReturn(c,0,0,true) => cEnv - E - [x,mc,returnEnv] - -@ -\subsection{canReturn} -<<*>>= -canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends - atom expr => ValueFlag and level=exitCount - (op:= first expr)="QUOTE" => ValueFlag and level=exitCount - op="TAGGEDexit" => - expr is [.,count,data] => canReturn(data.expr,level,count,count=level) - level=exitCount and not ValueFlag => nil - op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] - op="TAGGEDreturn" => nil - op="CATCH" => - [.,gs,data]:= expr - (findThrow(gs,data,level,exitCount,ValueFlag) => true) where - findThrow(gs,expr,level,exitCount,ValueFlag) == - atom expr => nil - expr is ["THROW", =gs,data] => true - --this is pessimistic, but I know of no more accurate idea - expr is ["SEQ",:l] => - or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] - or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr] - canReturn(data,level,exitCount,ValueFlag) - op = "COND" => - level = exitCount => - or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr] - or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v] - for v in rest expr] - op="IF" => - expr is [.,a,b,c] - if not canReturn(a,0,0,true) then - SAY "IF statement can not cause consequents to be executed" - pp expr - canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag) - or canReturn(c,level,exitCount,ValueFlag) - --now we have an ordinary form - atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] - op is ["XLAM",args,bods] => - and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] - systemErrorHere '"canReturn" --for the time being - -@ -\subsection{compBoolean} -<<*>>= -compBoolean(p,m,E) == - [p',m,E]:= comp(p,m,E) or return nil - [p',m,getSuccessEnvironment(p,E),getInverseEnvironment(p,E)] - -@ -\subsection{getSuccessEnvironment} -<<*>>= -getSuccessEnvironment(a,e) == - - -- the next four lines try to ensure that explicit special-case tests - -- prevent implicit ones from being generated - a is ["has",x,m] => - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) - e - a is ["is",id,m] => - IDENTP id and isDomainForm(m,$EmptyEnvironment) => - e:=put(id,"specialCase",m,e) - currentProplist:= getProplist(id,e) - [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs - newProplist:= consProplistOf(id,currentProplist,"value",[m,:rest removeEnv T]) - addBinding(id,newProplist,e) - e - a is ["case",x,m] and IDENTP x => - put(x,"condition",[a,:get(x,"condition",e)],e) - e - -@ -\subsection{getInverseEnvironment} -<<*>>= -getInverseEnvironment(a,E) == - atom a => E - [op,:argl]:= a --- the next five lines try to ensure that explicit special-case tests --- prevent implicit ones from being generated - op="has" => - [x,m]:= argl - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) - E - a is ["case",x,m] and IDENTP x => - --the next two lines are necessary to get 3-branched Unions to work - -- old-style unions, that is - (get(x,"condition",E) is [["OR",:oldpred]]) and MEMBER(a,oldpred) => - put(x,"condition",LIST MKPF(DELETE(a,oldpred),"OR"),E) - getUnionMode(x,E) is ["Union",:l] - l':= DELETE(m,l) - for u in l' repeat - if u is ['_:,=m,:.] then l':=DELETE(u,l') - newpred:= MKPF([["case",x,m'] for m' in l'],"OR") - put(x,"condition",[newpred,:get(x,"condition",E)],E) - E - -@ -\subsection{getUnionMode} -<<*>>= -getUnionMode(x,e) == - m:= - atom x => getmode(x,e) - return nil - isUnionMode(m,e) - -@ -\subsection{isUnionMode} -<<*>>= -isUnionMode(m,e) == - m is ["Union",:.] => m - (m':= getmode(m,e)) is ["Mapping",["UnionCategory",:.]] => CADR m' - v:= get(if m="$" then "Rep" else m,"value",e) => - (v.expr is ["Union",:.] => v.expr; nil) - nil - -@ -\subsection{compFromIf} -<<*>>= -compFromIf(a,m,E) == - a="noBranch" => ["noBranch",m,E] - true => comp(a,m,E) - -@ -\subsection{quotify} -<<*>>= -quotify x == x - -@ -\subsection{compImport} -<<*>>= -compImport(["import",:doms],m,e) == - for dom in doms repeat e:=addDomain(dom,e) - ["/throwAway",$NoValueMode,e] - -@ -\subsection{compCase} -Will the jerk who commented out these two functions please NOT do so -again. These functions ARE needed, and case can NOT be done by -modemap alone. The reason is that A case B requires to take A -evaluated, but B unevaluated. Therefore a special function is -required. You may have thought that you had tested this on ``failed'' -etc., but ``failed'' evaluates to it's own mode. Try it on x case \$ -next time. - -An angry JHD - August 15th., 1984 -<<*>>= -compCase(["case",x,m'],m,e) == - e:= addDomain(m',e) - T:= compCase1(x,m',e) => coerce(T,m) - nil - -@ -\subsection{compCase1} -<<*>>= -compCase1(x,m,e) == - [x',m',e']:= comp(x,$EmptyMode,e) or return nil - u:= - [cexpr - for (modemap:= [map,cexpr]) in getModemapList("case",2,e') | map is [.,.,s, - t] and modeEqual(t,m) and modeEqual(s,m')] or return nil - fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil - [["call",fn,x'],$Boolean,e'] - -@ -\subsection{compColon} -<<*>>= -compColon([":",f,t],m,e) == - $insideExpressionIfTrue=true => compColonInside(f,m,e,t) - --if inside an expression, ":" means to convert to m "on faith" - $lhsOfColon: local:= f - t:= - atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' - isDomainForm(t,e) and not $insideCategoryIfTrue => - (if not MEMBER(t,getDomainsInScope e) then e:= addDomain(t,e); t) - isDomainForm(t,e) or isCategoryForm(t,e) => t - t is ["Mapping",m',:r] => t - unknownTypeError t - t - f is ["LISTOF",:l] => - (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) - e:= - f is [op,:argl] and not (t is ["Mapping",:.]) => - --for MPOLY--replace parameters by formal arguments: RDJ 3/83 - newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), - [(x is [":",a,m] => a; x) for x in argl],t) - signature:= - ["Mapping",newTarget,: - [(x is [":",a,m] => m; - getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]] - put(op,"mode",signature,e) - put(f,"mode",t,e) - if not $bootStrapMode and $insideFunctorIfTrue and - makeCategoryForm(t,e) is [catform,e] then - e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) - ["/throwAway",getmode(f,e),e] - -@ -\subsection{unknownTypeError} -<<*>>= -unknownTypeError name == - name:= - name is [op,:.] => op - name - stackSemanticError(["%b",name,"%d","is not a known type"],nil) - -@ -\subsection{compPretend} -<<*>>= -compPretend(["pretend",x,t],m,e) == - e:= addDomain(t,e) - T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil - if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"] - $newCompilerUnionFlag and opOf(T.mode) = 'Union and opOf(m) ^= 'Union => - stackSemanticError(["cannot pretend ",x," of mode ",T.mode," to mode ",m],nil) - T:= [T.expr,t,T.env] - T':= coerce(T,m) => (if warningMessage then stackWarning warningMessage; T') - -@ -\subsection{compColonInside} -<<*>>= -compColonInside(x,m,e,m') == - e:= addDomain(m',e) - T:= comp(x,$EmptyMode,e) or return nil - if (m'':=T.mode)=m' then warningMessage:= [":",m'," -- should replace by @"] - T:= [T.expr,m',T.env] - T':= coerce(T,m) => - if warningMessage - then stackWarning warningMessage - else - $newCompilerUnionFlag and opOf(m'') = 'Union => - return - stackSemanticError(["cannot pretend ",x," of mode ",m''," to mode ",m'],nil) - - stackWarning [":",m'," -- should replace by pretend"] - T' - -@ -\subsection{compIs} -<<*>>= -compIs(["is",a,b],m,e) == - [aval,am,e] := comp(a,$EmptyMode,e) or return nil - [bval,bm,e] := comp(b,$EmptyMode,e) or return nil - T:= [["domainEqual",aval,bval],$Boolean,e] - coerce(T,m) - -@ -\section{Functions for coercion by the compiler} -\subsection{coerce} -The function coerce is used by the old compiler for coercions. -The function coerceInteractive is used by the interpreter. -One should always call the correct function, since the representation -of basic objects may not be the same. -<<*>>= -coerce(T,m) == - $InteractiveMode => - keyedSystemError("S2GE0016",['"coerce", - '"function coerce called from the interpreter."]) - rplac(CADR T,substitute("$",$Rep,CADR T)) - T':= coerceEasy(T,m) => T' - T':= coerceSubset(T,m) => T' - T':= coerceHard(T,m) => T' - T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil - stackMessage fn(T.expr,T.mode,m) where - -- if from from coerceable, this coerce was just a trial coercion - -- from compFormWithModemap to filter through the modemaps - fn(x,m1,m2) == - ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l", - " to mode","%b",m2,"%d"] - -@ -\subsection{coerceEasy} -<<*>>= -coerceEasy(T,m) == - m=$EmptyMode => T - m=$NoValueMode or m=$Void => [T.expr,m,T.env] - T.mode =m => T - T.mode =$NoValueMode => T - T.mode =$Exit => - [["PROGN", T.expr, ["userError", '"Did not really exit."]], - m,T.env] - T.mode=$EmptyMode or modeEqualSubst(T.mode,m,T.env) => - [T.expr,m,T.env] - -@ -\subsection{coerceSubset} -<<*>>= -coerceSubset([x,m,e],m') == - isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] - m is ['SubDomain,=m',:.] => [x,m',e] - (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and - -- obviously this is temporary - eval substitute(x,"#1",pred) => [x,m',e] - (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary - and eval substitute(x,"*",pred) => - [x,m',e] - nil - -@ -\subsection{coerceHard} -<<*>>= -coerceHard(T,m) == - $e: local:= T.env - m':= T.mode - STRINGP m' and modeEqual(m,$String) => [T.expr,m,$e] - modeEqual(m',m) or - (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and - modeEqual(m'',m) or - (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and - modeEqual(m'',m') => [T.expr,m,T.env] - STRINGP T.expr and T.expr=m => [T.expr,m,$e] - isCategoryForm(m,$e) => - $bootStrapMode = true => [T.expr,m,$e] - extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e] - coerceExtraHard(T,m) - coerceExtraHard(T,m) - -@ -\subsection{coerceExtraHard} -<<*>>= -coerceExtraHard(T is [x,m',e],m) == - T':= autoCoerceByModemap(T,m) => T' - isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and - MEMBER(t,l) and (T':= autoCoerceByModemap(T,t)) and - (T'':= coerce(T',m)) => T'' - m' is ['Record,:.] and m = $Expression => - [['coerceRe2E,x,['ELT,COPY m',0]],m,e] - nil - -@ -\subsection{coerceable} -<<*>>= -coerceable(m,m',e) == - m=m' => m - -- must find any free parameters in m - sl:= pmatch(m',m) => SUBLIS(sl,m') - coerce(["$fromCoerceable$",m,e],m') => m' - nil - -@ -\subsection{coerceExit} -<<*>>= -coerceExit([x,m,e],m') == - m':= resolve(m,m') - x':= replaceExitEtc(x,catchTag:= MKQ GENSYM(),"TAGGEDexit",$exitMode) - coerce([["CATCH",catchTag,x'],m,e],m') - -@ -\subsection{compAtSign} -<<*>>= -compAtSign(["@",x,m'],m,e) == - e:= addDomain(m',e) - T:= comp(x,m',e) or return nil - coerce(T,m) - -@ -\subsection{compCoerce} -<<*>>= -compCoerce(["::",x,m'],m,e) == - e:= addDomain(m',e) - T:= compCoerce1(x,m',e) => coerce(T,m) - getmode(m',e) is ["Mapping",["UnionCategory",:l]] => - T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil - coerce([T.expr,m',T.env],m) - -@ -\subsection{compCoerce1} -<<*>>= -compCoerce1(x,m',e) == - T:= comp(x,m',e) or comp(x,$EmptyMode,e) or return nil - m1:= - STRINGP T.mode => $String - T.mode - m':=resolve(m1,m') - T:=[T.expr,m1,T.env] - T':= coerce(T,m') => T' - T':= coerceByModemap(T,m') => T' - pred:=isSubset(m',T.mode,e) => - gg:=GENSYM() - pred:= substitute(gg,"*",pred) - code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] - [code,m',T.env] - -@ -\subsection{coerceByModemap} -<<*>>= -coerceByModemap([x,m,e],m') == ---+ modified 6/27 for new runtime system - u:= - [modemap - for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t, - s] and (modeEqual(t,m') or isSubset(t,m',e)) - and (modeEqual(s,m) or isSubset(m,s,e))] or return nil - - --mm:= (or/[mm for (mm:=[.,[cond,.]]) in u | cond=true]) or return nil - mm:=first u -- patch for non-trival conditons - fn := - genDeltaEntry ['coerce,:mm] - [["call",fn,x],m',e] - -@ -\subsection{autoCoerceByModemap} -<<*>>= -autoCoerceByModemap([x,source,e],target) == - u:= - [cexpr - for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ - .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil - fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil - source is ["Union",:l] and MEMBER(target,l) => - (y:= get(x,"condition",e)) and (or/[u is ["case",., =target] for u in y]) - => [["call",fn,x],target,e] - x="$fromCoerceable$" => nil - stackMessage ["cannot coerce: ",x,"%l"," of mode: ",source,"%l", - " to: ",target," without a case statement"] - [["call",fn,x],target,e] - - -@ -\subsection{resolve} -Very old resolve -should only be used in the old (preWATT) compiler -<<*>>= -resolve(din,dout) == - din=$NoValueMode or dout=$NoValueMode => $NoValueMode - dout=$EmptyMode => din - din^=dout and (STRINGP din or STRINGP dout) => - modeEqual(dout,$String) => dout - modeEqual(din,$String) => nil - mkUnion(din,dout) - dout - -@ -\subsection{modeEqual} -<<*>>= -modeEqual(x,y) == - -- this is the late modeEqual - -- orders Unions - atom x or atom y => x=y - #x ^=#y => nil - x is ['Union,:xl] and y is ['Union,:yl] => - for x1 in xl repeat - for y1 in yl repeat - modeEqual(x1,y1) => - xl := DELETE(x1,xl) - yl := DELETE(y1,yl) - return nil - xl or yl => nil - true - (and/[modeEqual(u,v) for u in x for v in y]) - -@ -\subsection{modeEqualSubst} -<<*>>= -modeEqualSubst(m1,m,e) == - modeEqual(m1, m) => true - atom m1 => get(m1,"value",e) is [m',:.] and modeEqual(m',m) - m1 is [op,:l1] and m is [=op,:l2] and # l1 = # l2 => --- Above length test inserted JHD 4:47 on 15/8/86 --- Otherwise Records can get fouled up - consider expressIdealElt --- in the DEFAULTS package - and/[modeEqualSubst(xm1,xm2,e) for xm1 in l1 for xm2 in l2] - nil - -@ -\subsection{convertSpadToAsFile} -<<*>>= -convertSpadToAsFile path == - -- can assume path has type = .spad - $globalMacroStack : local := nil -- for spad -> as translator - $abbreviationStack: local := nil -- for spad -> as translator - $macrosAlreadyPrinted: local := nil -- for spad -> as translator - SETQ($badStack, nil) --ditto TEMP to check for bad code - $newPaths: local := true --ditto TEMP - $abbreviationsAlreadyPrinted: local := nil -- for spad -> as translator - $convertingSpadFile : local := true - $options: local := '((nolib)) -- translator shouldn't create nrlibs - SETQ(HT,MAKE_-HASHTABLE 'UEQUAL) - - newName := fnameMake(pathnameDirectory path, pathnameName path, '"as") - canDoIt := true - if not fnameWritable? newName then - sayKeyedMsg("S2IZ0086", [NAMESTRING newName]) - newName := fnameMake('".", pathnameName path, '"as") - if not fnameWritable? newName then - sayKeyedMsg("S2IZ0087", [NAMESTRING newName]) - canDoIt := false - not canDoIt => 'failure - - sayKeyedMsg("S2IZ0088", [NAMESTRING newName]) - - $outStream :local := MAKE_-OUTSTREAM newName - markSay('"#include _"axiom.as_"") - markTerpri() - CATCH("SPAD__READER",compiler [path]) - SHUT $outStream - mkCheck() - 'done - -@ -\subsection{compilerDoit} -<<*>>= -compilerDoit(constructor, fun) == - $byConstructors : local := [] - $constructorsSeen : local := [] - fun = ['rf, 'lib] => _/RQ_,LIB() -- Ignore "noquiet". - fun = ['rf, 'nolib] => _/RF() - fun = ['rq, 'lib] => _/RQ_,LIB() - fun = ['rq, 'nolib] => _/RQ() - fun = ['c, 'lib] => - $byConstructors := [opOf x for x in constructor] - _/RQ_,LIB() - for ii in $byConstructors repeat - null MEMBER(ii,$constructorsSeen) => - sayBrightly ['">>> Warning ",'%b,ii,'%d,'" was not found"] - -@ -\subsection{compilerDoitWithScreenedLisplib} -<<*>>= -compilerDoitWithScreenedLisplib(constructor, fun) == - EMBED('RWRITE, - '(LAMBDA (KEY VALUE STREAM) - (COND ((AND (EQ STREAM $libFile) - (NOT (MEMBER KEY $saveableItems))) - VALUE) - ((NOT NIL) - (RWRITE KEY VALUE STREAM)))) ) - UNWIND_-PROTECT(compilerDoit(constructor,fun), - SEQ(UNEMBED 'RWRITE)) - - -@ -\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. - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/compiler.lisp.pamphlet b/src/interp/compiler.lisp.pamphlet new file mode 100644 index 0000000..d36d90d --- /dev/null +++ b/src/interp/compiler.lisp.pamphlet @@ -0,0 +1,6595 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp compiler.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;compTopLevel(x,m,e) == +;--+ signals that target is derived from lhs-- see NRTmakeSlot1Info +; $NRTderivedTargetIfTrue: local := false +; $killOptimizeIfTrue: local:= false +; $forceAdd: local:= false +; $compTimeSum: local := 0 +; $resolveTimeSum: local := 0 +; $packagesUsed: local := [] +; -- This hashtable is a performance improvement by Waldek Hebisch +; $envHashTable: local := MAKE_-HASHTABLE 'EQUAL +; for u in CAR(CAR(e)) repeat +; for v in CDR(u) repeat +; HPUT($envHashTable,[CAR u, CAR v],true) +; -- The next line allows the new compiler to be tested interactively. +; compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak +; x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => +; ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e]) +; --keep old environment after top level function defs +; FUNCALL(compFun,x,m,e) + +(DEFUN |compTopLevel| (|x| |m| |e|) + (PROG (|$NRTderivedTargetIfTrue| |$killOptimizeIfTrue| |$forceAdd| + |$compTimeSum| |$resolveTimeSum| |$packagesUsed| + |$envHashTable| |compFun| |ISTMP#1| |ISTMP#2| |LETTMP#1| + |val| |mode|) + (DECLARE (SPECIAL |$NRTderivedTargetIfTrue| |$killOptimizeIfTrue| + |$forceAdd| |$compTimeSum| |$resolveTimeSum| + |$packagesUsed| |$envHashTable|)) + (RETURN + (SEQ (PROGN + (SPADLET |$NRTderivedTargetIfTrue| NIL) + (SPADLET |$killOptimizeIfTrue| NIL) + (SPADLET |$forceAdd| NIL) + (SPADLET |$compTimeSum| 0) + (SPADLET |$resolveTimeSum| 0) + (SPADLET |$packagesUsed| NIL) + (SPADLET |$envHashTable| (MAKE-HASHTABLE 'EQUAL)) + (DO ((G166075 (CAR (CAR |e|)) (CDR G166075)) + (|u| NIL)) + ((OR (ATOM G166075) + (PROGN (SETQ |u| (CAR G166075)) NIL)) + NIL) + (SEQ (EXIT (DO ((G166084 (CDR |u|) (CDR G166084)) + (|v| NIL)) + ((OR (ATOM G166084) + (PROGN + (SETQ |v| (CAR G166084)) + NIL)) + NIL) + (SEQ (EXIT (HPUT |$envHashTable| + (CONS (CAR |u|) + (CONS (CAR |v|) NIL)) + 'T))))))) + (SPADLET |compFun| + (COND + ((BOOT-EQUAL |$newCompAtTopLevel| 'T) + '|newComp|) + ('T '|compOrCroak|))) + (COND + ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'DEF)) + (AND (PAIRP |x|) (EQ (QCAR |x|) '|where|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) 'DEF))))))) + (SPADLET |LETTMP#1| (FUNCALL |compFun| |x| |m| |e|)) + (SPADLET |val| (CAR |LETTMP#1|)) + (SPADLET |mode| (CADR |LETTMP#1|)) + (CONS |val| (CONS |mode| (CONS |e| NIL)))) + ('T (FUNCALL |compFun| |x| |m| |e|)))))))) + +@ +\subsection{compUniquely} +<<*>>= +;compUniquely(x,m,e) == +; $compUniquelyIfTrue: local:= true +; CATCH("compUniquely",comp(x,m,e)) + +(DEFUN |compUniquely| (|x| |m| |e|) + (PROG (|$compUniquelyIfTrue|) + (DECLARE (SPECIAL |$compUniquelyIfTrue|)) + (RETURN + (PROGN + (SPADLET |$compUniquelyIfTrue| 'T) + (CATCH '|compUniquely| (|comp| |x| |m| |e|)))))) + +@ +Given: +\begin{verbatim} +CohenCategory(): Category == SetCategory with + + kind:(CExpr)->Boolean + ++ kind(CExpr) + operand:(CExpr,Integer)->CExpr + ++ operand:(CExpr,Integer) + numberOfOperand:(CExpr)->Integer + ++ numberOfOperand:(CExpr)->Integer + construct:(CExpr,CExpr)->CExpr + ++ construct:(CExpr,CExpr)->CExpr + +\end{verbatim} +the resulting call looks like: +\begin{verbatim} + (|compOrCroak| + (DEF (|CohenCategory|) + ((|Category|)) + (NIL) + (|Join| + (|SetCategory|) + (CATEGORY |package| + (SIGNATURE |kind| ((|Boolean|) |CExpr|)) + (SIGNATURE |operand| (|CExpr| |CExpr| (|Integer|))) + (SIGNATURE |numberOfOperand| ((|Integer|) |CExpr|)) + (SIGNATURE |construct| (|CExpr| |CExpr| |CExpr|))))) + |$EmptyMode| + ((( + (|$DomainsInScope| + (FLUID . |true|) + (|special| |$EmptyMode| |$NoValueMode|)))))) +\end{verbatim} + +This is compiler call expects the first argument {\tt x} +to be a {\tt DEF} form to compile, +The second argument, {\tt m}, is the mode. +The third argument, {\tt e}, is the environment. + +In the call to {\tt compOrCroak1} the fourth argument {\tt comp} +is the function to call. +\subsection{compOrCroak} +<<*>>= +;compOrCroak(x,m,e) == compOrCroak1(x,m,e,'comp) + +(DEFUN |compOrCroak| (|x| |m| |e|) + (|compOrCroak1| |x| |m| |e| '|comp|)) + +@ +Which results in the call: +\begin{verbatim} +(|compOrCroak1| + (DEF (|CohenCategory|) + ((|Category|)) + (NIL) + (|Join| + (|SetCategory|) + (CATEGORY |package| + (SIGNATURE |kind| ((|Boolean|) |CExpr|)) + (SIGNATURE |operand| (|CExpr| |CExpr| (|Integer|))) + (SIGNATURE |numberOfOperand| ((|Integer|) |CExpr|)) + (SIGNATURE |construct| (|CExpr| |CExpr| |CExpr|))))) + |$EmptyMode| + (((( + |$DomainsInScope| + (FLUID . |true|) + (|special| |$EmptyMode| |$NoValueMode|))))) + |comp|) +\end{verbatim} +This results into a call to the inner function +\begin{verbatim} +(|compOrCroak1,fn| + (DEF (|CohenCategory|) + ((|Category|)) + (NIL) + (|Join| + (|SetCategory|) + (CATEGORY |package| + (SIGNATURE |kind| ((|Boolean|) |CExpr|)) + (SIGNATURE |operand| (|CExpr| |CExpr| (|Integer|))) + (SIGNATURE |numberOfOperand| ((|Integer|) |CExpr|)) + (SIGNATURE |construct| (|CExpr| |CExpr| |CExpr|))))) + |$EmptyMode| + (((( + |$DomainsInScope| + (FLUID . |true|) + (|special| |$EmptyMode| |$NoValueMode|))))) + NIL + NIL + |comp|) +\end{verbatim} +This is compiler call expects the first argument {\tt x} +to be a {\tt DEF} form to compile, +The second argument, {\tt m}, is the mode. +The third argument, {\tt e}, is the environment. +The fourth argument {\tt comp} is the function to call. + +The inner function augments the environment with information +from the compiler stack {\tt \$compStack} and +{\tt \$compErrorMessageStack}. + +\subsection{compOrCroak1} +<<*>>= +;compOrCroak1(x,m,e,compFn) == +; fn(x,m,e,nil,nil,compFn) where +; fn(x,m,e,$compStack,$compErrorMessageStack,compFn) == +; T:= CATCH("compOrCroak",FUNCALL(compFn,x,m,e)) => T +; --stackAndThrow here and moan in UT LISP K does the appropriate THROW +; $compStack:= [[x,m,e,$exitModeStack],:$compStack] +; $s:= +; compactify $compStack where +; compactify al == +; null al => nil +; LASSOC(first first al,rest al) => compactify rest al +; [first al,:compactify rest al] +; $level:= #$s +; errorMessage:= +; if $compErrorMessageStack +; then first $compErrorMessageStack +; else "unspecified error" +; $scanIfTrue => +; stackSemanticError(errorMessage,mkErrorExpr $level) +; ["failedCompilation",m,e] +; displaySemanticErrors() +; SAY("****** comp fails at level ",$level," with expression: ******") +; displayComp $level +; userError errorMessage + +(DEFUN |compOrCroak1,compactify| (|al|) + (SEQ (IF (NULL |al|) (EXIT NIL)) + (IF (LASSOC (CAR (CAR |al|)) (CDR |al|)) + (EXIT (|compOrCroak1,compactify| (CDR |al|)))) + (EXIT (CONS (CAR |al|) (|compOrCroak1,compactify| (CDR |al|)))))) + +(DEFUN |compOrCroak1,fn| + (|x| |m| |e| |$compStack| |$compErrorMessageStack| |compFn|) + (DECLARE (SPECIAL |$compStack| |$compErrorMessageStack|)) + (PROG (T$ |errorMessage|) + (RETURN + (SEQ (IF (SPADLET T$ + (CATCH '|compOrCroak| + (FUNCALL |compFn| |x| |m| |e|))) + (EXIT T$)) + (SPADLET |$compStack| + (CONS (CONS |x| + (CONS |m| + (CONS |e| + (CONS |$exitModeStack| NIL)))) + |$compStack|)) + (SPADLET |$s| (|compOrCroak1,compactify| |$compStack|)) + (SPADLET |$level| (|#| |$s|)) + (SPADLET |errorMessage| + (IF |$compErrorMessageStack| + (CAR |$compErrorMessageStack|) + '|unspecified error|)) + (IF |$scanIfTrue| + (EXIT (SEQ (|stackSemanticError| |errorMessage| + (|mkErrorExpr| |$level|)) + (EXIT (CONS '|failedCompilation| + (CONS |m| (CONS |e| NIL))))))) + (|displaySemanticErrors|) + (SAY (MAKESTRING "****** comp fails at level ") |$level| + (MAKESTRING " with expression: ******")) + (|displayComp| |$level|) + (EXIT (|userError| |errorMessage|)))))) + +(DEFUN |compOrCroak1| (|x| |m| |e| |compFn|) + (|compOrCroak1,fn| |x| |m| |e| NIL NIL |compFn|)) + +@ +\subsection{tc} +<<*>>= +;tc() == +; $tripleCache:= nil +; comp($x,$m,$f) + +(DEFUN |tc| () + (PROGN (SPADLET |$tripleCache| NIL) (|comp| |$x| |$m| |$f|))) + +@ +\subsection{comp} +<<*>>= +;comp(x,m,e) == +; T:= compNoStacking(x,m,e) => ($compStack:= nil; T) +; $compStack:= [[x,m,e,$exitModeStack],:$compStack] +; nil + +(DEFUN |comp| (|x| |m| |e|) + (PROG (T$) + (RETURN + (COND + ((SPADLET T$ (|compNoStacking| |x| |m| |e|)) + (SPADLET |$compStack| NIL) T$) + ('T + (SPADLET |$compStack| + (CONS (CONS |x| + (CONS |m| + (CONS |e| + (CONS |$exitModeStack| NIL)))) + |$compStack|)) + NIL))))) + +@ +\subsection{compNoStacking} +<<*>>= +;compNoStacking(x,m,e) == +; T:= comp2(x,m,e) => +; (m=$EmptyMode and T.mode=$Representation => [T.expr,"$",T.env]; T) +; --$Representation is bound in compDefineFunctor, set by doIt +; --this hack says that when something is undeclared, $ is +; --preferred to the underlying representation -- RDJ 9/12/83 +; compNoStacking1(x,m,e,$compStack) + +(DEFUN |compNoStacking| (|x| |m| |e|) + (PROG (T$) + (RETURN + (COND + ((SPADLET T$ (|comp2| |x| |m| |e|)) + (COND + ((AND (BOOT-EQUAL |m| |$EmptyMode|) + (BOOT-EQUAL (CADR T$) |$Representation|)) + (CONS (CAR T$) (CONS '$ (CONS (CADDR T$) NIL)))) + ('T T$))) + ('T (|compNoStacking1| |x| |m| |e| |$compStack|)))))) + +@ +\subsection{compNoStacking1} +<<*>>= +;compNoStacking1(x,m,e,$compStack) == +; u:= get(if m="$" then "Rep" else m,"value",e) => +; (T:= comp2(x,u.expr,e) => [T.expr,m,T.env]; nil) +; nil + +(DEFUN |compNoStacking1| (|x| |m| |e| |$compStack|) + (DECLARE (SPECIAL |$compStack|)) + (PROG (|u| T$) + (RETURN + (COND + ((SPADLET |u| + (|get| (COND ((BOOT-EQUAL |m| '$) '|Rep|) ('T |m|)) + '|value| |e|)) + (COND + ((SPADLET T$ (|comp2| |x| (CAR |u|) |e|)) + (CONS (CAR T$) (CONS |m| (CONS (CADDR T$) NIL)))) + ('T NIL))) + ('T NIL))))) + +@ +\subsection{comp2} +<<*>>= +;comp2(x,m,e) == +; [y,m',e]:= comp3(x,m,e) or return nil +; if $LISPLIB and isDomainForm(x,e) then +; if isFunctor x then +; $packagesUsed:= insert([opOf x],$packagesUsed) +; --if null atom y and isDomainForm(y,e) then e := addDomain(x,e) +; --line commented out to prevent adding derived domain forms +; m^=m' and ($bootStrapMode or isDomainForm(m',e))=>[y,m',addDomain(m',e)] +; --isDomainForm test needed to prevent error while compiling Ring +; --$bootStrapMode-test necessary for compiling Ring in $bootStrapMode +; [y,m',e] + +(DEFUN |comp2| (|x| |m| |e|) + (PROG (|LETTMP#1| |y| |m'|) + (RETURN + (PROGN + (SPADLET |LETTMP#1| (OR (|comp3| |x| |m| |e|) (RETURN NIL))) + (SPADLET |y| (CAR |LETTMP#1|)) + (SPADLET |m'| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (COND + ((AND $LISPLIB (|isDomainForm| |x| |e|)) + (COND + ((|isFunctor| |x|) + (SPADLET |$packagesUsed| + (|insert| (CONS (|opOf| |x|) NIL) + |$packagesUsed|))) + ('T NIL)))) + (COND + ((AND (NEQUAL |m| |m'|) + (OR |$bootStrapMode| (|isDomainForm| |m'| |e|))) + (CONS |y| (CONS |m'| (CONS (|addDomain| |m'| |e|) NIL)))) + ('T (CONS |y| (CONS |m'| (CONS |e| NIL))))))))) + +@ +\subsection{comp3} +<<*>>= +;comp3(x,m,$e) == +; --returns a Triple or %else nil to signalcan't do' +; $e:= addDomain(m,$e) +; e:= $e --for debugging purposes +; m is ["Mapping",:.] => compWithMappingMode(x,m,e) +; m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) +; STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) +; ^x or atom x => compAtom(x,m,e) +; op:= first x +; getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u +; op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) +; op=":" => compColon(x,m,e) +; op="::" => compCoerce(x,m,e) +; not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => +; compTypeOf(x,m,e) +; t:= compExpression(x,m,e) +; t is [x',m',e'] and not MEMBER(m',getDomainsInScope e') => +; [x',m',addDomain(m',e')] +; t + +(DEFUN |comp3| (|x| |m| |$e|) + (DECLARE (SPECIAL |$e|)) + (PROG (|e| |a| |op| |ml| |u| |sig| |varlist| |ISTMP#3| |body| |t| + |x'| |ISTMP#1| |m'| |ISTMP#2| |e'|) + (RETURN + (PROGN + (SPADLET |$e| (|addDomain| |m| |$e|)) + (SPADLET |e| |$e|) + (COND + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Mapping|)) + (|compWithMappingMode| |x| |m| |e|)) + ((AND (PAIRP |m|) (EQ (QCAR |m|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) + (COND + ((BOOT-EQUAL |x| |a|) + (CONS |x| (CONS |m| (CONS |$e| NIL)))) + ('T NIL))) + ((STRINGP |m|) + (COND + ((ATOM |x|) + (COND + ((OR (BOOT-EQUAL |m| |x|) + (BOOT-EQUAL |m| (STRINGIMAGE |x|))) + (CONS |m| (CONS |m| (CONS |e| NIL)))) + ('T NIL))) + ('T NIL))) + ((OR (NULL |x|) (ATOM |x|)) (|compAtom| |x| |m| |e|)) + ('T (SPADLET |op| (CAR |x|)) + (COND + ((AND (PROGN + (SPADLET |ISTMP#1| (|getmode| |op| |e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN (SPADLET |ml| (QCDR |ISTMP#1|)) 'T))) + (SPADLET |u| (|applyMapping| |x| |m| |e| |ml|))) + |u|) + ((AND (PAIRP |op|) (EQ (QCAR |op|) 'KAPPA) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |sig| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |varlist| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |body| (QCAR |ISTMP#3|)) + 'T)))))))) + (|compApply| |sig| |varlist| |body| (CDR |x|) |m| |e|)) + ((BOOT-EQUAL |op| '|:|) (|compColon| |x| |m| |e|)) + ((BOOT-EQUAL |op| '|::|) (|compCoerce| |x| |m| |e|)) + ((AND (NULL (BOOT-EQUAL |$insideCompTypeOf| 'T)) + (|stringPrefix?| (MAKESTRING "TypeOf") (PNAME |op|))) + (|compTypeOf| |x| |m| |e|)) + ('T (SPADLET |t| (|compExpression| |x| |m| |e|)) + (COND + ((AND (PAIRP |t|) + (PROGN + (SPADLET |x'| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |m'| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |e'| (QCAR |ISTMP#2|)) + 'T))))) + (NULL (|member| |m'| (|getDomainsInScope| |e'|)))) + (CONS |x'| + (CONS |m'| (CONS (|addDomain| |m'| |e'|) NIL)))) + ('T |t|)))))))))) + +@ +\subsection{compTypeOf} +<<*>>= +;compTypeOf(x:=[op,:argl],m,e) == +; $insideCompTypeOf: local := true +; newModemap:= EQSUBSTLIST(argl,$FormalMapVariableList,get(op,'modemap,e)) +; e:= put(op,'modemap,newModemap,e) +; comp3(x,m,e) + +(DEFUN |compTypeOf| (|x| |m| |e|) + (PROG (|$insideCompTypeOf| |op| |argl| |newModemap|) + (DECLARE (SPECIAL |$insideCompTypeOf|)) + (RETURN + (PROGN + (SPADLET |op| (CAR |x|)) + (SPADLET |argl| (CDR |x|)) + (SPADLET |$insideCompTypeOf| 'T) + (SPADLET |newModemap| + (EQSUBSTLIST |argl| |$FormalMapVariableList| + (|get| |op| '|modemap| |e|))) + (SPADLET |e| (|put| |op| '|modemap| |newModemap| |e|)) + (|comp3| |x| |m| |e|))))) + +@ +\subsection{hasFormalMapVariable} +<<*>>= +;hasFormalMapVariable(x, vl) == +; $formalMapVariables: local := vl +; null vl => false +; ScanOrPairVec('hasone?,x) where +; hasone? x == MEMQ(x,$formalMapVariables) + +(DEFUN |hasFormalMapVariable,hasone?| (|x|) + (MEMQ |x| |$formalMapVariables|)) + +(DEFUN |hasFormalMapVariable| (|x| |vl|) + (PROG (|$formalMapVariables|) + (DECLARE (SPECIAL |$formalMapVariables|)) + (RETURN + (PROGN + (SPADLET |$formalMapVariables| |vl|) + (COND + ((NULL |vl|) NIL) + ('T (|ScanOrPairVec| '|hasFormalMapVariable,hasone?| |x|))))))) + +@ +\subsection{argsToSig} +<<*>>= +;argsToSig(args) == +; args is [":",v,t] => [[v],[t]] +; sig1:=[] +; arg1:=[] +; bad:=false +; for arg in args repeat +; arg is [":",v,t] => +; sig1:=[t,:sig1] +; arg1:=[v,:arg1] +; bad:=true +; bad=>[nil,nil] +; [REVERSE(arg1),REVERSE(sig1)] + +(DEFUN |argsToSig| (|args|) + (PROG (|ISTMP#1| |v| |ISTMP#2| |t| |sig1| |arg1| |bad|) + (RETURN + (SEQ (COND + ((AND (PAIRP |args|) (EQ (QCAR |args|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |args|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |t| (QCAR |ISTMP#2|)) + 'T)))))) + (CONS (CONS |v| NIL) (CONS (CONS |t| NIL) NIL))) + ('T (SPADLET |sig1| NIL) (SPADLET |arg1| NIL) + (SPADLET |bad| NIL) + (DO ((G166364 |args| (CDR G166364)) (|arg| NIL)) + ((OR (ATOM G166364) + (PROGN (SETQ |arg| (CAR G166364)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |arg|) (EQ (QCAR |arg|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |arg|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |t| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |sig1| (CONS |t| |sig1|)) + (SPADLET |arg1| (CONS |v| |arg1|))) + ('T (SPADLET |bad| 'T)))))) + (COND + (|bad| (CONS NIL (CONS NIL NIL))) + ('T + (CONS (REVERSE |arg1|) (CONS (REVERSE |sig1|) NIL)))))))))) + +@ +\subsection{compLambda} +<<*>>= +;compLambda(x is ["+->",vl,body],m,e) == +; vl is [":",args,target] => +; args:= +; args is ["Tuple",:a1] => a1 +; args +; LISTP(args) => +; [arg1,sig1]:=argsToSig(args) +; sig1 => +; ress:=compAtSign(["@",["+->",arg1,body],["Mapping",target,:sig1]],m,e) +; ress +; stackAndThrow ["compLambda",x] +; stackAndThrow ["compLambda",x] +; stackAndThrow ["compLambda",x] + +(DEFUN |compLambda| (|x| |m| |e|) + (PROG (|vl| |body| |ISTMP#1| |ISTMP#2| |target| |a1| |args| + |LETTMP#1| |arg1| |sig1| |ress|) + (RETURN + (PROGN + (COND ((EQ (CAR |x|) '+->) (CAR |x|))) + (SPADLET |vl| (CADR |x|)) + (SPADLET |body| (CADDR |x|)) + (COND + ((AND (PAIRP |vl|) (EQ (QCAR |vl|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |vl|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |args| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |target| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |args| + (COND + ((AND (PAIRP |args|) (EQ (QCAR |args|) '|Tuple|) + (PROGN (SPADLET |a1| (QCDR |args|)) 'T)) + |a1|) + ('T |args|))) + (COND + ((LISTP |args|) (SPADLET |LETTMP#1| (|argsToSig| |args|)) + (SPADLET |arg1| (CAR |LETTMP#1|)) + (SPADLET |sig1| (CADR |LETTMP#1|)) + (COND + (|sig1| (SPADLET |ress| + (|compAtSign| + (CONS '@ + (CONS + (CONS '+-> + (CONS |arg1| (CONS |body| NIL))) + (CONS + (CONS '|Mapping| + (CONS |target| |sig1|)) + NIL))) + |m| |e|)) + |ress|) + ('T + (|stackAndThrow| (CONS '|compLambda| (CONS |x| NIL)))))) + ('T (|stackAndThrow| (CONS '|compLambda| (CONS |x| NIL)))))) + ('T (|stackAndThrow| (CONS '|compLambda| (CONS |x| NIL))))))))) + +@ +\subsection{compWithMappingMode} +<<*>>= +;compWithMappingMode(x,m,oldE) == +; compWithMappingMode1(x,m,oldE,$formalArgList) + +(DEFUN |compWithMappingMode| (|x| |m| |oldE|) + (|compWithMappingMode1| |x| |m| |oldE| |$formalArgList|)) + +@ +\subsection{compWithMappingMode1} +<<*>>= +;compWithMappingMode1(x,m is ["Mapping",m',:sl],oldE,$formalArgList) == +; $killOptimizeIfTrue: local:= true +; e:= oldE +; isFunctor x => +; if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and +; (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] +; ) and extendsCategoryForm("$",target,m') then return [x,m,e] +; if STRINGP x then x:= INTERN x +; ress:=nil +; old_style:=true +; if x is ["+->",vl,nx] then +; old_style:=false +; vl is [":",:.] => +; ress:=compLambda(x,m,oldE) +; ress +; vl:= +; vl is ["Tuple",:vl1] => vl1 +; vl +; vl:= +; SYMBOLP(vl) => [vl] +; LISTP(vl) and (and/[SYMBOLP(v) for v in vl]) => vl +; stackAndThrow ["bad +-> arguments:",vl] +; $formatArgList:=[:vl,:$formalArgList] +; x:=nx +; else +; vl:=take(#sl,$FormalMapVariableList) +; ress => ress +; for m in sl for v in vl repeat +; [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) +; old_style and not null vl and not hasFormalMapVariable(x, vl) => return +; [u,.,.] := comp([x,:vl],m',e) or return nil +; extractCodeAndConstructTriple(u, m, oldE) +; null vl and (t := comp([x], m', e)) => return +; [u,.,.] := t +; extractCodeAndConstructTriple(u, m, oldE) +; [u,.,.]:= comp(x,m',e) or return nil +; uu:=optimizeFunctionDef [nil,['LAMBDA,vl,u]] +; -- At this point, we have a function that we would like to pass. +; -- Unfortunately, it makes various free variable references outside +; -- itself. So we build a mini-vector that contains them all, and +; -- pass this as the environment to our inner function. +; $FUNNAME :local := nil +; $FUNNAME__TAIL :local := [nil] +; expandedFunction:=COMP_-TRAN CADR uu +; frees:=FreeList(expandedFunction,vl,nil,e) +; where FreeList(u,bound,free,e) == +; atom u => +; not IDENTP u => free +; MEMQ(u,bound) => free +; v:=ASSQ(u,free) => +; RPLACD(v,1+CDR v) +; free +; not getmode(u, e) => free +; [[u,:1],:free] +; op:=CAR u +; MEMQ(op, '(QUOTE GO function)) => free +; EQ(op,'LAMBDA) => +; bound:=UNIONQ(bound,CADR u) +; for v in CDDR u repeat +; free:=FreeList(v,bound,free,e) +; free +; EQ(op,'PROG) => +; bound:=UNIONQ(bound,CADR u) +; for v in CDDR u | NOT ATOM v repeat +; free:=FreeList(v,bound,free,e) +; free +; EQ(op,'SEQ) => +; for v in CDR u | NOT ATOM v repeat +; free:=FreeList(v,bound,free,e) +; free +; EQ(op,'COND) => +; for v in CDR u repeat +; for vv in v repeat +; free:=FreeList(vv,bound,free,e) +; free +; if ATOM op then u:=CDR u --Atomic functions aren't descended +; for v in u repeat +; free:=FreeList(v,bound,free,e) +; free +; expandedFunction := +; --One free can go by itself, more than one needs a vector +; --An A-list name . number of times used +; #frees = 0 => ['LAMBDA,[:vl,"$$"], :CDDR expandedFunction] +; #frees = 1 => +; vec:=first first frees +; ['LAMBDA,[:vl,vec], :CDDR expandedFunction] +; scode:=nil +; vec:=nil +; locals:=nil +; i:=-1 +; for v in frees repeat +; i:=i+1 +; vec:=[first v,:vec] +; scode:=[['SETQ,first v,[($QuickCode => 'QREFELT;'ELT),"$$",i]],:scode] +; locals:=[first v,:locals] +; body:=CDDR expandedFunction +; if locals then +; if body is [['DECLARE,:.],:.] then +; body:=[CAR body,['PROG,locals,:scode,['RETURN,['PROGN,:CDR body]]]] +; else body:=[['PROG,locals,:scode,['RETURN,['PROGN,:body]]]] +; vec:=['VECTOR,:NREVERSE vec] +; ['LAMBDA,[:vl,"$$"],:body] +; fname:=['CLOSEDFN,expandedFunction] +; --Like QUOTE, but gets compiled +; uu:= +; frees => ['CONS,fname,vec] +; ['LIST,fname] +; [uu,m,oldE] + +(DEFUN |compWithMappingMode1,FreeList| (|u| |bound| |free| |e|) + (PROG (|v| |op|) + (RETURN + (SEQ (IF (ATOM |u|) + (EXIT (SEQ (IF (NULL (IDENTP |u|)) (EXIT |free|)) + (IF (MEMQ |u| |bound|) (EXIT |free|)) + (IF (SPADLET |v| (ASSQ |u| |free|)) + (EXIT (SEQ + (RPLACD |v| (PLUS 1 (CDR |v|))) + (EXIT |free|)))) + (IF (NULL (|getmode| |u| |e|)) (EXIT |free|)) + (EXIT (CONS (CONS |u| 1) |free|))))) + (SPADLET |op| (CAR |u|)) + (IF (MEMQ |op| '(QUOTE GO |function|)) (EXIT |free|)) + (IF (EQ |op| 'LAMBDA) + (EXIT (SEQ (SPADLET |bound| (UNIONQ |bound| (CADR |u|))) + (DO ((G166546 (CDDR |u|) (CDR G166546)) + (|v| NIL)) + ((OR (ATOM G166546) + (PROGN + (SETQ |v| (CAR G166546)) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |free| + (|compWithMappingMode1,FreeList| + |v| |bound| |free| |e|))))) + (EXIT |free|)))) + (IF (EQ |op| 'PROG) + (EXIT (SEQ (SPADLET |bound| (UNIONQ |bound| (CADR |u|))) + (DO ((G166556 (CDDR |u|) (CDR G166556)) + (|v| NIL)) + ((OR (ATOM G166556) + (PROGN + (SETQ |v| (CAR G166556)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (ATOM |v|)) + (SPADLET |free| + (|compWithMappingMode1,FreeList| + |v| |bound| |free| |e|))))))) + (EXIT |free|)))) + (IF (EQ |op| 'SEQ) + (EXIT (SEQ (DO ((G166566 (CDR |u|) (CDR G166566)) + (|v| NIL)) + ((OR (ATOM G166566) + (PROGN + (SETQ |v| (CAR G166566)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (ATOM |v|)) + (SPADLET |free| + (|compWithMappingMode1,FreeList| + |v| |bound| |free| |e|))))))) + (EXIT |free|)))) + (IF (EQ |op| 'COND) + (EXIT (SEQ (DO ((G166575 (CDR |u|) (CDR G166575)) + (|v| NIL)) + ((OR (ATOM G166575) + (PROGN + (SETQ |v| (CAR G166575)) + NIL)) + NIL) + (SEQ (EXIT (DO + ((G166584 |v| + (CDR G166584)) + (|vv| NIL)) + ((OR (ATOM G166584) + (PROGN + (SETQ |vv| (CAR G166584)) + NIL)) + NIL) + (SEQ + (EXIT + (SPADLET |free| + (|compWithMappingMode1,FreeList| + |vv| |bound| |free| |e|)))))))) + (EXIT |free|)))) + (IF (ATOM |op|) (SPADLET |u| (CDR |u|)) NIL) + (DO ((G166593 |u| (CDR G166593)) (|v| NIL)) + ((OR (ATOM G166593) + (PROGN (SETQ |v| (CAR G166593)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |free| + (|compWithMappingMode1,FreeList| |v| + |bound| |free| |e|))))) + (EXIT |free|))))) + +(DEFUN |compWithMappingMode1| (|x| |m| |oldE| |$formalArgList|) + (DECLARE (SPECIAL |$formalArgList|)) + (PROG (|$killOptimizeIfTrue| $FUNNAME $FUNNAME_TAIL |m'| |sl| + |ISTMP#3| |ISTMP#4| |target| |argModeList| |ISTMP#5| + |ISTMP#2| |nx| |oldstyle| |ress| |vl1| |vl| |e| |t| + |LETTMP#1| |u| |frees| |i| |scode| |locals| |ISTMP#1| + |body| |vec| |expandedFunction| |fname| |uu|) + (DECLARE (SPECIAL |$killOptimizeIfTrue| $FUNNAME $FUNNAME_TAIL)) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR |m|) '|Mapping|) (CAR |m|))) + (SPADLET |m'| (CADR |m|)) + (SPADLET |sl| (CDDR |m|)) + (SPADLET |$killOptimizeIfTrue| 'T) + (SPADLET |e| |oldE|) + (COND + ((|isFunctor| |x|) + (COND + ((AND (PROGN + (SPADLET |ISTMP#1| + (|get| |x| '|modemap| + |$CategoryFrame|)) + (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 |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |target| + (QCAR |ISTMP#4|)) + (SPADLET |argModeList| + (QCDR |ISTMP#4|)) + 'T))))) + (PROGN + (SPADLET |ISTMP#5| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL))))))) + (PROG (G166666) + (SPADLET G166666 'T) + (RETURN + (DO ((G166673 NIL (NULL G166666)) + (G166674 |argModeList| + (CDR G166674)) + (|mode| NIL) + (G166675 |sl| (CDR G166675)) + (|s| NIL)) + ((OR G166673 (ATOM G166674) + (PROGN + (SETQ |mode| (CAR G166674)) + NIL) + (ATOM G166675) + (PROGN + (SETQ |s| (CAR G166675)) + NIL)) + G166666) + (SEQ (EXIT + (SETQ G166666 + (AND G166666 + (|extendsCategoryForm| '$ |s| + |mode|)))))))) + (|extendsCategoryForm| '$ |target| |m'|)) + (RETURN (CONS |x| (CONS |m| (CONS |e| NIL))))) + ('T NIL))) + ('T (COND ((STRINGP |x|) (SPADLET |x| (INTERN |x|)))) + (SPADLET |ress| NIL) (SPADLET |oldstyle| 'T) + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '+->) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |vl| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |nx| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |oldstyle| NIL) + (COND + ((AND (PAIRP |vl|) (EQ (QCAR |vl|) '|:|)) + (SPADLET |ress| (|compLambda| |x| |m| |oldE|)) + |ress|) + ('T + (SPADLET |vl| + (COND + ((AND (PAIRP |vl|) + (EQ (QCAR |vl|) '|Tuple|) + (PROGN + (SPADLET |vl1| (QCDR |vl|)) + 'T)) + |vl1|) + ('T |vl|))) + (SPADLET |vl| + (COND + ((SYMBOLP |vl|) (CONS |vl| NIL)) + ((AND (LISTP |vl|) + (PROG (G166685) + (SPADLET G166685 'T) + (RETURN + (DO + ((G166691 NIL + (NULL G166685)) + (G166692 |vl| + (CDR G166692)) + (|v| NIL)) + ((OR G166691 + (ATOM G166692) + (PROGN + (SETQ |v| + (CAR G166692)) + NIL)) + G166685) + (SEQ + (EXIT + (SETQ G166685 + (AND G166685 + (SYMBOLP |v|))))))))) + |vl|) + ('T + (|stackAndThrow| + (CONS '|bad +-> arguments:| + (CONS |vl| NIL)))))) + (SPADLET |$formatArgList| + (APPEND |vl| |$formalArgList|)) + (SPADLET |x| |nx|)))) + ('T + (SPADLET |vl| + (TAKE (|#| |sl|) |$FormalMapVariableList|)))) + (COND + (|ress| |ress|) + ('T + (DO ((G166706 |sl| (CDR G166706)) (|m| NIL) + (G166707 |vl| (CDR G166707)) (|v| NIL)) + ((OR (ATOM G166706) + (PROGN (SETQ |m| (CAR G166706)) NIL) + (ATOM G166707) + (PROGN (SETQ |v| (CAR G166707)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| + (|compMakeDeclaration| + (CONS '|:| + (CONS |v| (CONS |m| NIL))) + |$EmptyMode| |e|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + |LETTMP#1|)))) + (COND + ((AND |oldstyle| (NULL (NULL |vl|)) + (NULL (|hasFormalMapVariable| |x| |vl|))) + (RETURN + (PROGN + (SPADLET |LETTMP#1| + (OR + (|comp| (CONS |x| |vl|) |m'| |e|) + (RETURN NIL))) + (SPADLET |u| (CAR |LETTMP#1|)) + (|extractCodeAndConstructTriple| |u| |m| + |oldE|)))) + ((AND (NULL |vl|) + (SPADLET |t| + (|comp| (CONS |x| NIL) |m'| |e|))) + (RETURN + (PROGN + (SPADLET |u| (CAR |t|)) + (|extractCodeAndConstructTriple| |u| |m| + |oldE|)))) + ('T + (SPADLET |LETTMP#1| + (OR (|comp| |x| |m'| |e|) (RETURN NIL))) + (SPADLET |u| (CAR |LETTMP#1|)) + (SPADLET |uu| + (|optimizeFunctionDef| + (CONS NIL + (CONS + (CONS 'LAMBDA + (CONS |vl| (CONS |u| NIL))) + NIL)))) + (SPADLET $FUNNAME NIL) + (SPADLET $FUNNAME_TAIL (CONS NIL NIL)) + (SPADLET |expandedFunction| + (COMP-TRAN (CADR |uu|))) + (SPADLET |frees| + (|compWithMappingMode1,FreeList| + |expandedFunction| |vl| NIL |e|)) + (SPADLET |expandedFunction| + (COND + ((EQL (|#| |frees|) 0) + (CONS 'LAMBDA + (CONS + (APPEND |vl| (CONS '$$ NIL)) + (CDDR |expandedFunction|)))) + ((EQL (|#| |frees|) 1) + (SPADLET |vec| (CAR (CAR |frees|))) + (CONS 'LAMBDA + (CONS + (APPEND |vl| (CONS |vec| NIL)) + (CDDR |expandedFunction|)))) + ('T (SPADLET |scode| NIL) + (SPADLET |vec| NIL) + (SPADLET |locals| NIL) + (SPADLET |i| (SPADDIFFERENCE 1)) + (DO ((G166723 |frees| + (CDR G166723)) + (|v| NIL)) + ((OR (ATOM G166723) + (PROGN + (SETQ |v| (CAR G166723)) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |i| (PLUS |i| 1)) + (SPADLET |vec| + (CONS (CAR |v|) |vec|)) + (SPADLET |scode| + (CONS + (CONS 'SETQ + (CONS (CAR |v|) + (CONS + (CONS + (COND + (|$QuickCode| 'QREFELT) + ('T 'ELT)) + (CONS '$$ (CONS |i| NIL))) + NIL))) + |scode|)) + (SPADLET |locals| + (CONS (CAR |v|) |locals|)))))) + (SPADLET |body| + (CDDR |expandedFunction|)) + (COND + (|locals| + (COND + ((AND (PAIRP |body|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |body|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + 'DECLARE)))) + (SPADLET |body| + (CONS (CAR |body|) + (CONS + (CONS 'PROG + (CONS |locals| + (APPEND |scode| + (CONS + (CONS 'RETURN + (CONS + (CONS 'PROGN + (CDR |body|)) + NIL)) + NIL)))) + NIL)))) + ('T + (SPADLET |body| + (CONS + (CONS 'PROG + (CONS |locals| + (APPEND |scode| + (CONS + (CONS 'RETURN + (CONS + (CONS 'PROGN |body|) + NIL)) + NIL)))) + NIL)))))) + (SPADLET |vec| + (CONS 'VECTOR + (NREVERSE |vec|))) + (CONS 'LAMBDA + (CONS + (APPEND |vl| (CONS '$$ NIL)) + |body|))))) + (SPADLET |fname| + (CONS 'CLOSEDFN + (CONS |expandedFunction| NIL))) + (SPADLET |uu| + (COND + (|frees| (CONS 'CONS + (CONS |fname| + (CONS |vec| NIL)))) + ('T (CONS 'LIST (CONS |fname| NIL))))) + (CONS |uu| (CONS |m| (CONS |oldE| NIL)))))))))))))) + +@ +\subsection{extractCodeAndConstructTriple} +<<*>>= +;extractCodeAndConstructTriple(u, m, oldE) == +; u is ["call",fn,:.] => +; if fn is ["applyFun",a] then fn := a +; [fn,m,oldE] +; [op,:.,env] := u +; [["CONS",["function",op],env],m,oldE] + +(DEFUN |extractCodeAndConstructTriple| (|u| |m| |oldE|) + (PROG (|ISTMP#1| |a| |fn| |op| |LETTMP#1| |env|) + (RETURN + (COND + ((AND (PAIRP |u|) (EQ (QCAR |u|) '|call|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |fn| (QCAR |ISTMP#1|)) 'T)))) + (COND + ((AND (PAIRP |fn|) (EQ (QCAR |fn|) '|applyFun|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |fn|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) + (SPADLET |fn| |a|))) + (CONS |fn| (CONS |m| (CONS |oldE| NIL)))) + ('T (SPADLET |op| (CAR |u|)) + (SPADLET |LETTMP#1| (REVERSE (CDR |u|))) + (SPADLET |env| (CAR |LETTMP#1|)) + (CONS (CONS 'CONS + (CONS (CONS '|function| (CONS |op| NIL)) + (CONS |env| NIL))) + (CONS |m| (CONS |oldE| NIL)))))))) + +@ +\subsection{compExpression} +<<*>>= +;compExpression(x,m,e) == +; $insideExpressionIfTrue: local:= true +; atom first x and (fn:= GET(first x,"SPECIAL")) => +; FUNCALL(fn,x,m,e) +; compForm(x,m,e) + +(DEFUN |compExpression| (|x| |m| |e|) + (PROG (|$insideExpressionIfTrue| |fn|) + (DECLARE (SPECIAL |$insideExpressionIfTrue|)) + (RETURN + (PROGN + (SPADLET |$insideExpressionIfTrue| 'T) + (COND + ((AND (ATOM (CAR |x|)) + (SPADLET |fn| (GETL (CAR |x|) 'SPECIAL))) + (FUNCALL |fn| |x| |m| |e|)) + ('T (|compForm| |x| |m| |e|))))))) + +@ +\subsection{compAtom} +<<*>>= +;compAtom(x,m,e) == +; T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => T +; x="nil" => +; T:= +; modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) +; modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) +; T => convert(T,m) +; t:= +; isSymbol x => +; compSymbol(x,m,e) or return nil +; m = $Expression and primitiveType x => [x,m,e] +; STRINGP x => [x,x,e] +; [x,primitiveType x or return nil,e] +; convert(t,m) + +(DEFUN |compAtom| (|x| |m| |e|) + (PROG (|ISTMP#1| |ISTMP#2| R T$ |t|) + (RETURN + (COND + ((SPADLET T$ + (|compAtomWithModemap| |x| |m| |e| + (|get| |x| '|modemap| |e|))) + T$) + ((BOOT-EQUAL |x| '|nil|) + (SPADLET T$ + (COND + ((PROGN + (SPADLET |ISTMP#1| + (|modeIsAggregateOf| '|List| |m| |e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET R (QCAR |ISTMP#2|)) + 'T))))) + (|compList| |x| (CONS '|List| (CONS R NIL)) |e|)) + ((PROGN + (SPADLET |ISTMP#1| + (|modeIsAggregateOf| '|Vector| |m| |e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET R (QCAR |ISTMP#2|)) + 'T))))) + (|compVector| |x| (CONS '|Vector| (CONS R NIL)) + |e|)))) + (COND (T$ (|convert| T$ |m|)))) + ('T + (SPADLET |t| + (COND + ((|isSymbol| |x|) + (OR (|compSymbol| |x| |m| |e|) (RETURN NIL))) + ((AND (BOOT-EQUAL |m| |$Expression|) + (|primitiveType| |x|)) + (CONS |x| (CONS |m| (CONS |e| NIL)))) + ((STRINGP |x|) + (CONS |x| (CONS |x| (CONS |e| NIL)))) + ('T + (CONS |x| + (CONS (OR (|primitiveType| |x|) + (RETURN NIL)) + (CONS |e| NIL)))))) + (|convert| |t| |m|)))))) + +@ +\subsection{primitiveType} +<<*>>= +;primitiveType x == +; x is nil => $EmptyMode +; STRINGP x => $String +; INTEGERP x => +; x=0 => $NonNegativeInteger +; x>0 => $PositiveInteger +; true => $NegativeInteger +; FLOATP x => $DoubleFloat +; nil + +(DEFUN |primitiveType| (|x|) + (COND + ((NULL |x|) |$EmptyMode|) + ((STRINGP |x|) |$String|) + ((INTEGERP |x|) + (COND + ((EQL |x| 0) |$NonNegativeInteger|) + ((> |x| 0) |$PositiveInteger|) + ('T |$NegativeInteger|))) + ((FLOATP |x|) |$DoubleFloat|) + ('T NIL))) + +@ +\subsection{compSymbol} +<<*>>= +;compSymbol(s,m,e) == +; s="$NoValue" => ["$NoValue",$NoValueMode,e] +; isFluid s => [s,getmode(s,e) or return nil,e] +; s="true" => ['(QUOTE T),$Boolean,e] +; s="false" => [false,$Boolean,e] +; s=m or get(s,"isLiteral",e) => [["QUOTE",s],s,e] +; v:= get(s,"value",e) => +;--+ +; MEMQ(s,$functorLocalParameters) => +; NRTgetLocalIndex s +; [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile +; [s,v.mode,e] --s has been SETQd +; m':= getmode(s,e) => +; if not MEMBER(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and +; not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s +; [s,m',e] --s is a declared argument +; MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s] +; m = $Expression or m = $Symbol => [['QUOTE,s],m,e] +; not isFunction(s,e) => errorRef s + +(DEFUN |compSymbol| (|s| |m| |e|) + (PROG (|v| |m'|) + (RETURN + (COND + ((BOOT-EQUAL |s| '|$NoValue|) + (CONS '|$NoValue| (CONS |$NoValueMode| (CONS |e| NIL)))) + ((|isFluid| |s|) + (CONS |s| + (CONS (OR (|getmode| |s| |e|) (RETURN NIL)) + (CONS |e| NIL)))) + ((BOOT-EQUAL |s| '|true|) + (CONS ''T (CONS |$Boolean| (CONS |e| NIL)))) + ((BOOT-EQUAL |s| '|false|) + (CONS NIL (CONS |$Boolean| (CONS |e| NIL)))) + ((OR (BOOT-EQUAL |s| |m|) (|get| |s| '|isLiteral| |e|)) + (CONS (CONS 'QUOTE (CONS |s| NIL)) (CONS |s| (CONS |e| NIL)))) + ((SPADLET |v| (|get| |s| '|value| |e|)) + (COND + ((MEMQ |s| |$functorLocalParameters|) + (|NRTgetLocalIndex| |s|) + (CONS |s| (CONS (CADR |v|) (CONS |e| NIL)))) + ('T (CONS |s| (CONS (CADR |v|) (CONS |e| NIL)))))) + ((SPADLET |m'| (|getmode| |s| |e|)) + (COND + ((AND (NULL (|member| |s| |$formalArgList|)) + (NULL (MEMQ |s| |$FormalMapVariableList|)) + (NULL (|isFunction| |s| |e|)) + (NULL (BOOT-EQUAL |$compForModeIfTrue| 'T))) + (|errorRef| |s|))) + (CONS |s| (CONS |m'| (CONS |e| NIL)))) + ((MEMQ |s| |$FormalMapVariableList|) + (|stackMessage| (CONS '|no mode found for| (CONS |s| NIL)))) + ((OR (BOOT-EQUAL |m| |$Expression|) (BOOT-EQUAL |m| |$Symbol|)) + (CONS (CONS 'QUOTE (CONS |s| NIL)) (CONS |m| (CONS |e| NIL)))) + ((NULL (|isFunction| |s| |e|)) (|errorRef| |s|)))))) + +@ +\subsection{convertOrCroak} +<<*>>= +;convertOrCroak(T,m) == +; u:= convert(T,m) => u +; userError ["CANNOT CONVERT: ",T.expr,"%l"," OF MODE: ",T.mode,"%l", +; " TO MODE: ",m,"%l"] + +(DEFUN |convertOrCroak| (T$ |m|) + (PROG (|u|) + (RETURN + (COND + ((SPADLET |u| (|convert| T$ |m|)) |u|) + ('T + (|userError| + (CONS '|CANNOT CONVERT: | + (CONS (CAR T$) + (CONS '|%l| + (CONS '| OF MODE: | + (CONS (CADR T$) + (CONS '|%l| + (CONS '| TO MODE: | + (CONS |m| (CONS '|%l| NIL))))))))))))))) + +@ +\subsection{convert} +<<*>>= +;convert(T,m) == +; coerce(T,resolve(T.mode,m) or return nil) + +(DEFUN |convert| (T$ |m|) + (PROG () + (RETURN (|coerce| T$ (OR (|resolve| (CADR T$) |m|) (RETURN NIL)))))) + +@ +\subsection{mkUnion} +<<*>>= +;mkUnion(a,b) == +; b="$" and $Rep is ["Union",:l] => b +; a is ["Union",:l] => +; b is ["Union",:l'] => ["Union",:setUnion(l,l')] +; ["Union",:setUnion([b],l)] +; b is ["Union",:l] => ["Union",:setUnion([a],l)] +; ["Union",a,b] + +(DEFUN |mkUnion| (|a| |b|) + (PROG (|l'| |l|) + (RETURN + (COND + ((AND (BOOT-EQUAL |b| '$) (PAIRP |$Rep|) + (EQ (QCAR |$Rep|) '|Union|) + (PROGN (SPADLET |l| (QCDR |$Rep|)) 'T)) + |b|) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|Union|) + (PROGN (SPADLET |l| (QCDR |a|)) 'T)) + (COND + ((AND (PAIRP |b|) (EQ (QCAR |b|) '|Union|) + (PROGN (SPADLET |l'| (QCDR |b|)) 'T)) + (CONS '|Union| (|union| |l| |l'|))) + ('T (CONS '|Union| (|union| (CONS |b| NIL) |l|))))) + ((AND (PAIRP |b|) (EQ (QCAR |b|) '|Union|) + (PROGN (SPADLET |l| (QCDR |b|)) 'T)) + (CONS '|Union| (|union| (CONS |a| NIL) |l|))) + ('T (CONS '|Union| (CONS |a| (CONS |b| NIL)))))))) + +@ +\subsection{maxSuperType} +<<*>>= +;maxSuperType(m,e) == +; typ:= get(m,"SuperDomain",e) => maxSuperType(typ,e) +; m + +(DEFUN |maxSuperType| (|m| |e|) + (PROG (|typ|) + (RETURN + (COND + ((SPADLET |typ| (|get| |m| '|SuperDomain| |e|)) + (|maxSuperType| |typ| |e|)) + ('T |m|))))) + +@ +\subsection{hasType} +<<*>>= +;hasType(x,e) == +; fn get(x,"condition",e) where +; fn x == +; null x => nil +; x is [["case",.,y],:.] => y +; fn rest x + +(DEFUN |hasType,fn| (|x|) + (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |y|) + (RETURN + (SEQ (IF (NULL |x|) (EXIT NIL)) + (IF (AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|case|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |y| (QCAR |ISTMP#3|)) + 'T)))))))) + (EXIT |y|)) + (EXIT (|hasType,fn| (CDR |x|))))))) + +(DEFUN |hasType| (|x| |e|) + (|hasType,fn| (|get| |x| '|condition| |e|))) + +@ +\subsection{compForm} +<<*>>= +;compForm(form,m,e) == +; T:= +; compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return +; stackMessageIfNone ["cannot compile","%b",form,"%d"] +; T + +(DEFUN |compForm| (|form| |m| |e|) + (PROG (T$) + (RETURN + (PROGN + (SPADLET T$ + (OR (|compForm1| |form| |m| |e|) + (|compArgumentsAndTryAgain| |form| |m| |e|) + (RETURN + (|stackMessageIfNone| + (CONS '|cannot compile| + (CONS '|%b| + (CONS |form| (CONS '|%d| NIL)))))))) + T$)))) + +@ +\subsection{compArgumentsAndTryAgain} +<<*>>= +;compArgumentsAndTryAgain(form is [.,:argl],m,e) == +; -- used in case: f(g(x)) where f is in domain introduced by +; -- comping g, e.g. for (ELT (ELT x a) b), environment can have no +; -- modemap with selector b +; form is ["elt",a,.] => +; ([.,.,e]:= comp(a,$EmptyMode,e) or return nil; compForm1(form,m,e)) +; u:= for x in argl repeat [.,.,e]:= comp(x,$EmptyMode,e) or return "failed" +; u="failed" => nil +; compForm1(form,m,e) + +(DEFUN |compArgumentsAndTryAgain| (|form| |m| |e|) + (PROG (|argl| |ISTMP#1| |a| |ISTMP#2| |LETTMP#1| |u|) + (RETURN + (SEQ (PROGN + (SPADLET |argl| (CDR |form|)) + (COND + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (SPADLET |LETTMP#1| + (OR (|comp| |a| |$EmptyMode| |e|) + (RETURN NIL))) + (SPADLET |e| (CADDR |LETTMP#1|)) + (|compForm1| |form| |m| |e|)) + ('T + (SPADLET |u| + (DO ((G166982 |argl| (CDR G166982)) + (|x| NIL)) + ((OR (ATOM G166982) + (PROGN + (SETQ |x| (CAR G166982)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| + (OR + (|comp| |x| |$EmptyMode| |e|) + (RETURN '|failed|))) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|))))) + (COND + ((BOOT-EQUAL |u| '|failed|) NIL) + ('T (|compForm1| |form| |m| |e|)))))))))) + +@ +\subsection{outputComp} +<<*>>= +;outputComp(x,e) == +; u:=comp(['_:_:,x,$Expression],$Expression,e) => u +; x is ['construct,:argl] => +; [['LIST,:[([.,.,e]:=outputComp(x,e)).expr for x in argl]],$Expression,e] +; (v:= get(x,"value",e)) and (v.mode is ['Union,:l]) => +; [['coerceUn2E,x,v.mode],$Expression,e] +; [x,$Expression,e] + +(DEFUN |outputComp| (|x| |e|) + (PROG (|u| |argl| |LETTMP#1| |v| |ISTMP#1| |l|) + (RETURN + (SEQ (COND + ((SPADLET |u| + (|comp| (CONS '|::| + (CONS |x| + (CONS |$Expression| NIL))) + |$Expression| |e|)) + |u|) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|construct|) + (PROGN (SPADLET |argl| (QCDR |x|)) 'T)) + (CONS (CONS 'LIST + (PROG (G167017) + (SPADLET G167017 NIL) + (RETURN + (DO ((G167025 |argl| (CDR G167025)) + (|x| NIL)) + ((OR (ATOM G167025) + (PROGN + (SETQ |x| (CAR G167025)) + NIL)) + (NREVERSE0 G167017)) + (SEQ (EXIT + (SETQ G167017 + (CONS + (CAR + (PROGN + (SPADLET |LETTMP#1| + (|outputComp| |x| |e|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|)) + G167017)))))))) + (CONS |$Expression| (CONS |e| NIL)))) + ((AND (SPADLET |v| (|get| |x| '|value| |e|)) + (PROGN + (SPADLET |ISTMP#1| (CADR |v|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Union|) + (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T)))) + (CONS (CONS '|coerceUn2E| + (CONS |x| (CONS (CADR |v|) NIL))) + (CONS |$Expression| (CONS |e| NIL)))) + ('T (CONS |x| (CONS |$Expression| (CONS |e| NIL))))))))) + +@ +\subsection{compForm1} +<<*>>= +;compForm1(form is [op,:argl],m,e) == +; $NumberOfArgsIfInteger: local:= #argl --see compElt +; op="error" => +; [[op,:[([.,.,e]:=outputComp(x,e)).expr +; for x in argl]],m,e] +; op is ["elt",domain,op'] => +; domain="Lisp" => +; --op'='QUOTE and null rest argl => [first argl,m,e] +; [[op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]],m,e] +; domain=$Expression and op'="construct" => compExpressionList(argl,m,e) +; (op'="COLLECT") and coerceable(domain,m,e) => +; (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) +; -- Next clause added JHD 8/Feb/94: the clause after doesn't work +; -- since addDomain refuses to add modemaps from Mapping +; (domain is ['Mapping,:.]) and +; (ans := compForm2([op',:argl],m,e:= augModemapsFromDomain1(domain,domain,e), +; [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]])) => ans +; ans := compForm2([op',:argl],m,e:= addDomain(domain,e), +; [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]]) => ans +; (op'="construct") and coerceable(domain,m,e) => +; (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) +; nil +; e:= addDomain(m,e) --???unneccessary because of comp2's call??? +; (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T +; compToApply(op,argl,m,e) + +(DEFUN |compForm1| (|form| |m| |e|) + (PROG (|$NumberOfArgsIfInteger| |op| |argl| |domain| |ISTMP#2| |op'| + |LETTMP#1| |ISTMP#1| |ans| |mmList| T$) + (DECLARE (SPECIAL |$NumberOfArgsIfInteger|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |$NumberOfArgsIfInteger| (|#| |argl|)) + (COND + ((BOOT-EQUAL |op| '|error|) + (CONS (CONS |op| + (PROG (G167108) + (SPADLET G167108 NIL) + (RETURN + (DO ((G167116 |argl| (CDR G167116)) + (|x| NIL)) + ((OR (ATOM G167116) + (PROGN + (SETQ |x| (CAR G167116)) + NIL)) + (NREVERSE0 G167108)) + (SEQ (EXIT + (SETQ G167108 + (CONS + (CAR + (PROGN + (SPADLET |LETTMP#1| + (|outputComp| |x| |e|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|)) + G167108)))))))) + (CONS |m| (CONS |e| NIL)))) + ((AND (PAIRP |op|) (EQ (QCAR |op|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |domain| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |op'| (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((BOOT-EQUAL |domain| '|Lisp|) + (CONS (CONS |op'| + (PROG (G167129) + (SPADLET G167129 NIL) + (RETURN + (DO + ((G167137 |argl| (CDR G167137)) + (|x| NIL)) + ((OR (ATOM G167137) + (PROGN + (SETQ |x| (CAR G167137)) + NIL)) + (NREVERSE0 G167129)) + (SEQ + (EXIT + (SETQ G167129 + (CONS + (CAR + (PROGN + (SPADLET |LETTMP#1| + (|compOrCroak| |x| + |$EmptyMode| |e|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|)) + G167129)))))))) + (CONS |m| (CONS |e| NIL)))) + ((AND (BOOT-EQUAL |domain| |$Expression|) + (BOOT-EQUAL |op'| '|construct|)) + (|compExpressionList| |argl| |m| |e|)) + ((AND (BOOT-EQUAL |op'| 'COLLECT) + (|coerceable| |domain| |m| |e|)) + (SPADLET T$ + (OR (|comp| (CONS |op'| |argl|) |domain| + |e|) + (RETURN NIL))) + (|coerce| T$ |m|)) + ((AND (PAIRP |domain|) + (EQ (QCAR |domain|) '|Mapping|) + (SPADLET |ans| + (|compForm2| (CONS |op'| |argl|) |m| + (SPADLET |e| + (|augModemapsFromDomain1| + |domain| |domain| |e|)) + (PROG (G167148) + (SPADLET G167148 NIL) + (RETURN + (DO + ((G167154 + (|getFormModemaps| + (CONS |op'| |argl|) |e|) + (CDR G167154)) + (|x| NIL)) + ((OR (ATOM G167154) + (PROGN + (SETQ |x| + (CAR G167154)) + NIL)) + (NREVERSE0 G167148)) + (SEQ + (EXIT + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQUAL + (QCAR |ISTMP#1|) + |domain|)))) + (SETQ G167148 + (CONS |x| G167148)))))))))))) + |ans|) + ((SPADLET |ans| + (|compForm2| (CONS |op'| |argl|) |m| + (SPADLET |e| + (|addDomain| |domain| |e|)) + (PROG (G167165) + (SPADLET G167165 NIL) + (RETURN + (DO + ((G167171 + (|getFormModemaps| + (CONS |op'| |argl|) |e|) + (CDR G167171)) + (|x| NIL)) + ((OR (ATOM G167171) + (PROGN + (SETQ |x| (CAR G167171)) + NIL)) + (NREVERSE0 G167165)) + (SEQ + (EXIT + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + |domain|)))) + (SETQ G167165 + (CONS |x| G167165))))))))))) + |ans|) + ((AND (BOOT-EQUAL |op'| '|construct|) + (|coerceable| |domain| |m| |e|)) + (SPADLET T$ + (OR (|comp| (CONS |op'| |argl|) |domain| + |e|) + (RETURN NIL))) + (|coerce| T$ |m|)) + ('T NIL))) + ('T (SPADLET |e| (|addDomain| |m| |e|)) + (COND + ((AND (SPADLET |mmList| + (|getFormModemaps| |form| |e|)) + (SPADLET T$ + (|compForm2| |form| |m| |e| |mmList|))) + T$) + ('T (|compToApply| |op| |argl| |m| |e|)))))))))) + +@ +\subsection{compExpressionList} +<<*>>= +;compExpressionList(argl,m,e) == +; Tl:= [[.,.,e]:= comp(x,$Expression,e) or return "failed" for x in argl] +; Tl="failed" => nil +; convert([["LIST",:[y.expr for y in Tl]],$Expression,e],m) + +(DEFUN |compExpressionList| (|argl| |m| |e|) + (PROG (|LETTMP#1| |Tl|) + (RETURN + (SEQ (PROGN + (SPADLET |Tl| + (PROG (G167221) + (SPADLET G167221 NIL) + (RETURN + (DO ((G167229 |argl| (CDR G167229)) + (|x| NIL)) + ((OR (ATOM G167229) + (PROGN + (SETQ |x| (CAR G167229)) + NIL)) + (NREVERSE0 G167221)) + (SEQ (EXIT (SETQ G167221 + (CONS + (PROGN + (SPADLET |LETTMP#1| + (OR + (|comp| |x| |$Expression| + |e|) + (RETURN '|failed|))) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|) + G167221)))))))) + (COND + ((BOOT-EQUAL |Tl| '|failed|) NIL) + ('T + (|convert| + (CONS (CONS 'LIST + (PROG (G167239) + (SPADLET G167239 NIL) + (RETURN + (DO + ((G167244 |Tl| (CDR G167244)) + (|y| NIL)) + ((OR (ATOM G167244) + (PROGN + (SETQ |y| (CAR G167244)) + NIL)) + (NREVERSE0 G167239)) + (SEQ + (EXIT + (SETQ G167239 + (CONS (CAR |y|) G167239)))))))) + (CONS |$Expression| (CONS |e| NIL))) + |m|)))))))) + +@ +\subsection{compForm2} +<<*>>= +;compForm2(form is [op,:argl],m,e,modemapList) == +; sargl:= TAKE(# argl, $TriangleVariableList) +; aList:= [[sa,:a] for a in argl for sa in sargl] +; modemapList:= SUBLIS(aList,modemapList) +; deleteList:=[] +; newList := [] +; -- now delete any modemaps that are subsumed by something else, provided the conditions +; -- are right (i.e. subsumer true whenever subsumee true) +; for u in modemapList repeat +; if u is [[dc,:.],[cond,["Subsumed",.,nsig]]] and +; (v:=assoc([dc,:nsig],modemapList)) and v is [.,[ncond,:.]] then +; deleteList:=[u,:deleteList] +; if not PredImplies(ncond,cond) then +; newList := [[CAR u,[cond,['ELT,dc,nil]]],:newList] +; if deleteList then modemapList:=[u for u in modemapList | not MEMQ(u,deleteList)] +; -- We can use MEMQ since deleteList was built out of members of modemapList +; -- its important that subsumed ops (newList) be considered last +; if newList then modemapList := append(modemapList,newList) +; Tl:= +; [[.,.,e]:= T +; for x in argl while (isSimple x and (T:= compUniquely(x,$EmptyMode,e)))] +; or/[x for x in Tl] => +; partialModeList:= [(x => x.mode; nil) for x in Tl] +; compFormPartiallyBottomUp(form,m,e,modemapList,partialModeList) or +; compForm3(form,m,e,modemapList) +; compForm3(form,m,e,modemapList) + +(DEFUN |compForm2| (|form| |m| |e| |modemapList|) + (PROG (|op| |argl| |sargl| |aList| |dc| |ISTMP#3| |cond| |ISTMP#4| + |ISTMP#5| |ISTMP#6| |ISTMP#7| |nsig| |v| |ISTMP#1| + |ISTMP#2| |ncond| |deleteList| |newList| T$ |Tl| + |partialModeList|) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |sargl| + (TAKE (|#| |argl|) |$TriangleVariableList|)) + (SPADLET |aList| + (PROG (G167385) + (SPADLET G167385 NIL) + (RETURN + (DO ((G167391 |argl| (CDR G167391)) + (|a| NIL) + (G167392 |sargl| (CDR G167392)) + (|sa| NIL)) + ((OR (ATOM G167391) + (PROGN + (SETQ |a| (CAR G167391)) + NIL) + (ATOM G167392) + (PROGN + (SETQ |sa| (CAR G167392)) + NIL)) + (NREVERSE0 G167385)) + (SEQ (EXIT (SETQ G167385 + (CONS (CONS |sa| |a|) + G167385)))))))) + (SPADLET |modemapList| (SUBLIS |aList| |modemapList|)) + (SPADLET |deleteList| NIL) + (SPADLET |newList| NIL) + (DO ((G167429 |modemapList| (CDR G167429)) (|u| NIL)) + ((OR (ATOM G167429) + (PROGN (SETQ |u| (CAR G167429)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |dc| (QCAR |ISTMP#1|)) + 'T))) + (PROGN + (SPADLET |ISTMP#2| (QCDR |u|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |cond| + (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |ISTMP#5| + (QCAR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCAR |ISTMP#5|) + '|Subsumed|) + (PROGN + (SPADLET |ISTMP#6| + (QCDR |ISTMP#5|)) + (AND (PAIRP |ISTMP#6|) + (PROGN + (SPADLET |ISTMP#7| + (QCDR |ISTMP#6|)) + (AND + (PAIRP |ISTMP#7|) + (EQ + (QCDR |ISTMP#7|) + NIL) + (PROGN + (SPADLET |nsig| + (QCAR |ISTMP#7|)) + 'T))))))))))))) + (SPADLET |v| + (|assoc| (CONS |dc| |nsig|) + |modemapList|)) + (PAIRP |v|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |v|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ncond| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |deleteList| + (CONS |u| |deleteList|)) + (COND + ((NULL (|PredImplies| |ncond| |cond|)) + (SPADLET |newList| + (CONS + (CONS (CAR |u|) + (CONS + (CONS |cond| + (CONS + (CONS 'ELT + (CONS |dc| + (CONS NIL NIL))) + NIL)) + NIL)) + |newList|))) + ('T NIL))) + ('T NIL))))) + (COND + (|deleteList| + (SPADLET |modemapList| + (PROG (G167440) + (SPADLET G167440 NIL) + (RETURN + (DO ((G167446 |modemapList| + (CDR G167446)) + (|u| NIL)) + ((OR (ATOM G167446) + (PROGN + (SETQ |u| (CAR G167446)) + NIL)) + (NREVERSE0 G167440)) + (SEQ (EXIT + (COND + ((NULL + (MEMQ |u| |deleteList|)) + (SETQ G167440 + (CONS |u| G167440)))))))))))) + (COND + (|newList| + (SPADLET |modemapList| + (APPEND |modemapList| |newList|)))) + (SPADLET |Tl| + (PROG (G167459) + (SPADLET G167459 NIL) + (RETURN + (DO ((G167467 |argl| (CDR G167467)) + (|x| NIL)) + ((OR (ATOM G167467) + (PROGN + (SETQ |x| (CAR G167467)) + NIL) + (NULL + (AND (|isSimple| |x|) + (SPADLET T$ + (|compUniquely| |x| |$EmptyMode| + |e|))))) + (NREVERSE0 G167459)) + (SEQ (EXIT (SETQ G167459 + (CONS + (PROGN + (SPADLET |e| (CADDR T$)) + T$) + G167459)))))))) + (COND + ((PROG (G167474) + (SPADLET G167474 NIL) + (RETURN + (DO ((G167480 NIL G167474) + (G167481 |Tl| (CDR G167481)) (|x| NIL)) + ((OR G167480 (ATOM G167481) + (PROGN (SETQ |x| (CAR G167481)) NIL)) + G167474) + (SEQ (EXIT (SETQ G167474 (OR G167474 |x|))))))) + (SPADLET |partialModeList| + (PROG (G167492) + (SPADLET G167492 NIL) + (RETURN + (DO ((G167497 |Tl| (CDR G167497)) + (|x| NIL)) + ((OR (ATOM G167497) + (PROGN + (SETQ |x| (CAR G167497)) + NIL)) + (NREVERSE0 G167492)) + (SEQ (EXIT + (SETQ G167492 + (CONS + (COND + (|x| (CADR |x|)) + ('T NIL)) + G167492)))))))) + (OR (|compFormPartiallyBottomUp| |form| |m| |e| + |modemapList| |partialModeList|) + (|compForm3| |form| |m| |e| |modemapList|))) + ('T (|compForm3| |form| |m| |e| |modemapList|)))))))) + +@ +\subsection{compFormPartiallyBottomUp} +<<*>>= +;compFormPartiallyBottomUp(form,m,e,modemapList,partialModeList) == +; mmList:= [mm for mm in modemapList | compFormMatch(mm,partialModeList)] => +; compForm3(form,m,e,mmList) + +(DEFUN |compFormPartiallyBottomUp| + (|form| |m| |e| |modemapList| |partialModeList|) + (PROG (|mmList|) + (RETURN + (SEQ (COND + ((SPADLET |mmList| + (PROG (G167545) + (SPADLET G167545 NIL) + (RETURN + (DO ((G167551 |modemapList| + (CDR G167551)) + (|mm| NIL)) + ((OR (ATOM G167551) + (PROGN + (SETQ |mm| (CAR G167551)) + NIL)) + (NREVERSE0 G167545)) + (SEQ (EXIT (COND + ((|compFormMatch| |mm| + |partialModeList|) + (SETQ G167545 + (CONS |mm| G167545)))))))))) + (EXIT (|compForm3| |form| |m| |e| |mmList|)))))))) + +@ +\subsection{compFormMatch} +<<*>>= +;compFormMatch(mm,partialModeList) == +; mm is [[.,.,:argModeList],:.] and match(argModeList,partialModeList) where +; match(a,b) == +; null b => true +; null first b => match(rest a,rest b) +; first a=first b and match(rest a,rest b) + +(DEFUN |compFormMatch,match| (|a| |b|) + (SEQ (IF (NULL |b|) (EXIT 'T)) + (IF (NULL (CAR |b|)) + (EXIT (|compFormMatch,match| (CDR |a|) (CDR |b|)))) + (EXIT (AND (BOOT-EQUAL (CAR |a|) (CAR |b|)) + (|compFormMatch,match| (CDR |a|) (CDR |b|)))))) + +(DEFUN |compFormMatch| (|mm| |partialModeList|) + (PROG (|ISTMP#1| |ISTMP#2| |argModeList|) + (RETURN + (AND (PAIRP |mm|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |mm|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |argModeList| (QCDR |ISTMP#2|)) + 'T))))) + (|compFormMatch,match| |argModeList| |partialModeList|))))) + +@ +\subsection{compForm3} +<<*>>= +;compForm3(form is [op,:argl],m,e,modemapList) == +; T:= +; or/ +; [compFormWithModemap(form,m,e,first (mml:= ml)) +; for ml in tails modemapList] +; $compUniquelyIfTrue => +; or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] => +; THROW("compUniquely",nil) +; T +; T + +(DEFUN |compForm3| (|form| |m| |e| |modemapList|) + (PROG (|op| |argl| |mml| T$) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET T$ + (PROG (G167599) + (SPADLET G167599 NIL) + (RETURN + (DO ((G167605 NIL G167599) + (|ml| |modemapList| (CDR |ml|))) + ((OR G167605 (ATOM |ml|)) G167599) + (SEQ (EXIT (SETQ G167599 + (OR G167599 + (|compFormWithModemap| |form| + |m| |e| + (CAR (SPADLET |mml| |ml|))))))))))) + (COND + (|$compUniquelyIfTrue| + (COND + ((PROG (G167610) + (SPADLET G167610 NIL) + (RETURN + (DO ((G167616 NIL G167610) + (G167617 (CDR |mml|) (CDR G167617)) + (|mm| NIL)) + ((OR G167616 (ATOM G167617) + (PROGN + (SETQ |mm| (CAR G167617)) + NIL)) + G167610) + (SEQ (EXIT (SETQ G167610 + (OR G167610 + (|compFormWithModemap| |form| + |m| |e| |mm|)))))))) + (THROW '|compUniquely| NIL)) + ('T T$))) + ('T T$))))))) + +@ +\subsection{getFormModemaps} +<<*>>= +;getFormModemaps(form is [op,:argl],e) == +; op is ["elt",domain,op1] => +; [x for x in getFormModemaps([op1,:argl],e) | x is [[ =domain,:.],:.]] +; null atom op => nil +; modemapList:= get(op,"modemap",e) +; if $insideCategoryPackageIfTrue then +; modemapList := [x for x in modemapList | x is [[dom,:.],:.] and dom ^= '$] +; if op="elt" +; then modemapList:= eltModemapFilter(LAST argl,modemapList,e) or return nil +; else +; if op="setelt" then modemapList:= +; seteltModemapFilter(CADR argl,modemapList,e) or return nil +; nargs:= #argl +; finalModemapList:= [mm for (mm:= [[.,.,:sig],:.]) in modemapList | #sig=nargs] +; modemapList and null finalModemapList => +; stackMessage ["no modemap for","%b",op,"%d","with ",nargs," arguments"] +; finalModemapList + +(DEFUN |getFormModemaps| (|form| |e|) + (PROG (|op| |argl| |domain| |ISTMP#2| |op1| |ISTMP#1| |dom| + |modemapList| |nargs| |sig| |finalModemapList|) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (COND + ((AND (PAIRP |op|) (EQ (QCAR |op|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |domain| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |op1| (QCAR |ISTMP#2|)) + 'T)))))) + (PROG (G167686) + (SPADLET G167686 NIL) + (RETURN + (DO ((G167692 + (|getFormModemaps| (CONS |op1| |argl|) + |e|) + (CDR G167692)) + (|x| NIL)) + ((OR (ATOM G167692) + (PROGN (SETQ |x| (CAR G167692)) NIL)) + (NREVERSE0 G167686)) + (SEQ (EXIT (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + |domain|)))) + (SETQ G167686 + (CONS |x| G167686)))))))))) + ((NULL (ATOM |op|)) NIL) + ('T (SPADLET |modemapList| (|get| |op| '|modemap| |e|)) + (COND + (|$insideCategoryPackageIfTrue| + (SPADLET |modemapList| + (PROG (G167703) + (SPADLET G167703 NIL) + (RETURN + (DO + ((G167709 |modemapList| + (CDR G167709)) + (|x| NIL)) + ((OR (ATOM G167709) + (PROGN + (SETQ |x| (CAR G167709)) + NIL)) + (NREVERSE0 G167703)) + (SEQ + (EXIT + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |dom| + (QCAR |ISTMP#1|)) + 'T))) + (NEQUAL |dom| '$)) + (SETQ G167703 + (CONS |x| G167703)))))))))))) + (COND + ((BOOT-EQUAL |op| '|elt|) + (SPADLET |modemapList| + (OR (|eltModemapFilter| (|last| |argl|) + |modemapList| |e|) + (RETURN NIL)))) + ((BOOT-EQUAL |op| '|setelt|) + (SPADLET |modemapList| + (OR (|seteltModemapFilter| (CADR |argl|) + |modemapList| |e|) + (RETURN NIL)))) + ('T NIL)) + (SPADLET |nargs| (|#| |argl|)) + (SPADLET |finalModemapList| + (PROG (G167721) + (SPADLET G167721 NIL) + (RETURN + (DO ((G167728 |modemapList| + (CDR G167728)) + (|mm| NIL)) + ((OR (ATOM G167728) + (PROGN + (SETQ |mm| (CAR G167728)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| (CDDAR |mm|)) + |mm|) + NIL)) + (NREVERSE0 G167721)) + (SEQ (EXIT + (COND + ((BOOT-EQUAL (|#| |sig|) + |nargs|) + (SETQ G167721 + (CONS |mm| G167721)))))))))) + (COND + ((AND |modemapList| (NULL |finalModemapList|)) + (|stackMessage| + (CONS '|no modemap for| + (CONS '|%b| + (CONS |op| + (CONS '|%d| + (CONS '|with | + (CONS |nargs| + (CONS '| arguments| NIL))))))))) + ('T |finalModemapList|))))))))) + +@ +\subsection{getConstructorFormOfMode} +<<*>>= +;getConstructorFormOfMode(m,e) == +; isConstructorForm m => m +; if m="$" then m:= "Rep" +; atom m and get(m,"value",e) is [v,:.] => +; isConstructorForm v => v + +(DEFUN |getConstructorFormOfMode| (|m| |e|) + (PROG (|ISTMP#1| |v|) + (RETURN + (SEQ (COND + ((|isConstructorForm| |m|) |m|) + ('T (COND ((BOOT-EQUAL |m| '$) (SPADLET |m| '|Rep|))) + (SEQ (COND + ((AND (ATOM |m|) + (PROGN + (SPADLET |ISTMP#1| + (|get| |m| '|value| |e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + 'T)))) + (COND ((|isConstructorForm| |v|) (EXIT |v|)))))))))))) + +@ +\subsection{getConstructorMode} +<<*>>= +;getConstructorMode(x,e) == +; atom x => (u:= getmode(x,e) or return nil; getConstructorFormOfMode(u,e)) +; x is ["elt",y,a] => +; u:= getConstructorMode(y,e) +; u is ["Vector",R] or u is ["List",R] => +; isConstructorForm R => R +; u is ["Record",:l] => +; (or/[p is [., =a,R] for p in l]) and isConstructorForm R => R + +(DEFUN |getConstructorMode| (|x| |e|) + (PROG (|y| |a| |u| |l| |ISTMP#1| |ISTMP#2| R) + (RETURN + (SEQ (COND + ((ATOM |x|) + (SPADLET |u| (OR (|getmode| |x| |e|) (RETURN NIL))) + (|getConstructorFormOfMode| |u| |e|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |u| (|getConstructorMode| |y| |e|)) + (SEQ (COND + ((OR (AND (PAIRP |u|) (EQ (QCAR |u|) '|Vector|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET R (QCAR |ISTMP#1|)) + 'T)))) + (AND (PAIRP |u|) (EQ (QCAR |u|) '|List|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET R (QCAR |ISTMP#1|)) + 'T))))) + (COND ((|isConstructorForm| R) (EXIT R)))) + ((AND (PAIRP |u|) (EQ (QCAR |u|) '|Record|) + (PROGN (SPADLET |l| (QCDR |u|)) 'T)) + (COND + ((AND (PROG (G167805) + (SPADLET G167805 NIL) + (RETURN + (DO ((G167817 NIL G167805) + (G167818 |l| (CDR G167818)) + (|p| NIL)) + ((OR G167817 (ATOM G167818) + (PROGN + (SETQ |p| (CAR G167818)) + NIL)) + G167805) + (SEQ + (EXIT + (SETQ G167805 + (OR G167805 + (AND (PAIRP |p|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |p|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + |a|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET R + (QCAR |ISTMP#2|)) + 'T))))))))))))) + (|isConstructorForm| R)) + (EXIT R)))))))))))) + +@ +\subsection{isConstructorForm} +<<*>>= +;isConstructorForm u == u is [name,:.] and MEMBER(name,'(Record Vector List)) + +(DEFUN |isConstructorForm| (|u|) + (PROG (|name|) + (RETURN + (AND (PAIRP |u|) (PROGN (SPADLET |name| (QCAR |u|)) 'T) + (|member| |name| '(|Record| |Vector| |List|)))))) + +@ +\subsection{eltModemapFilter} +<<*>>= +;eltModemapFilter(name,mmList,e) == +; isConstantId(name,e) => +; l:= [mm for mm in mmList | mm is [[.,.,.,sel,:.],:.] and sel=name] => l +; --there are elts with extra parameters +; stackMessage ["selector variable: ",name," is undeclared and unbound"] +; nil +; mmList + +(DEFUN |eltModemapFilter| (|name| |mmList| |e|) + (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4| |sel| |l|) + (RETURN + (SEQ (COND + ((|isConstantId| |name| |e|) + (COND + ((SPADLET |l| + (PROG (G167882) + (SPADLET G167882 NIL) + (RETURN + (DO ((G167888 |mmList| (CDR G167888)) + (|mm| NIL)) + ((OR (ATOM G167888) + (PROGN + (SETQ |mm| (CAR G167888)) + NIL)) + (NREVERSE0 G167882)) + (SEQ (EXIT + (COND + ((AND (PAIRP |mm|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |mm|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND + (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |sel| + (QCAR + |ISTMP#4|)) + 'T))))))))) + (BOOT-EQUAL |sel| |name|)) + (SETQ G167882 + (CONS |mm| G167882)))))))))) + |l|) + ('T + (|stackMessage| + (CONS '|selector variable: | + (CONS |name| + (CONS '| is undeclared and unbound| + NIL)))) + NIL))) + ('T |mmList|)))))) + +@ +\subsection{seteltModemapFilter} +<<*>>= +;seteltModemapFilter(name,mmList,e) == +; isConstantId(name,e) => +; l:= [mm for (mm:= [[.,.,.,sel,:.],:.]) in mmList | sel=name] => l +; --there are setelts with extra parameters +; stackMessage ["selector variable: ",name," is undeclared and unbound"] +; nil +; mmList + +(DEFUN |seteltModemapFilter| (|name| |mmList| |e|) + (PROG (|sel| |l|) + (RETURN + (SEQ (COND + ((|isConstantId| |name| |e|) + (COND + ((SPADLET |l| + (PROG (G167914) + (SPADLET G167914 NIL) + (RETURN + (DO ((G167921 |mmList| (CDR G167921)) + (|mm| NIL)) + ((OR (ATOM G167921) + (PROGN + (SETQ |mm| (CAR G167921)) + NIL) + (PROGN + (PROGN + (SPADLET |sel| + (CAR (CDDDAR |mm|))) + |mm|) + NIL)) + (NREVERSE0 G167914)) + (SEQ (EXIT + (COND + ((BOOT-EQUAL |sel| |name|) + (SETQ G167914 + (CONS |mm| G167914)))))))))) + |l|) + ('T + (|stackMessage| + (CONS '|selector variable: | + (CONS |name| + (CONS '| is undeclared and unbound| + NIL)))) + NIL))) + ('T |mmList|)))))) + +@ +\subsection{substituteIntoFunctorModemap} +<<*>>= +;substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) == +; #dc^=#sig => +; keyedSystemError("S2GE0016",['"substituteIntoFunctorModemap", +; '"Incompatible maps"]) +; #argl=#rest sig => +; --here, we actually have a functor form +; sig:= EQSUBSTLIST(argl,rest dc,sig) +; --make new modemap, subst. actual for formal parametersinto modemap +; Tl:= [[.,.,e]:= compOrCroak(a,m,e) for a in argl for m in rest sig] +; substitutionList:= [[x,:T.expr] for x in rest dc for T in Tl] +; [SUBLIS(substitutionList,modemap),e] +; nil + +(DEFUN |substituteIntoFunctorModemap| (|argl| |modemap| |e|) + (PROG (|dc| |sig| |LETTMP#1| |Tl| |substitutionList|) + (RETURN + (SEQ (PROGN + (SPADLET |dc| (CAAR |modemap|)) + (SPADLET |sig| (CDAR |modemap|)) + (COND + ((NEQUAL (|#| |dc|) (|#| |sig|)) + (|keyedSystemError| 'S2GE0016 + (CONS (MAKESTRING "substituteIntoFunctorModemap") + (CONS (MAKESTRING "Incompatible maps") NIL)))) + ((BOOT-EQUAL (|#| |argl|) (|#| (CDR |sig|))) + (SPADLET |sig| (EQSUBSTLIST |argl| (CDR |dc|) |sig|)) + (SPADLET |Tl| + (PROG (G167960) + (SPADLET G167960 NIL) + (RETURN + (DO ((G167969 |argl| (CDR G167969)) + (|a| NIL) + (G167970 (CDR |sig|) + (CDR G167970)) + (|m| NIL)) + ((OR (ATOM G167969) + (PROGN + (SETQ |a| (CAR G167969)) + NIL) + (ATOM G167970) + (PROGN + (SETQ |m| (CAR G167970)) + NIL)) + (NREVERSE0 G167960)) + (SEQ (EXIT + (SETQ G167960 + (CONS + (PROGN + (SPADLET |LETTMP#1| + (|compOrCroak| |a| |m| |e|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|) + G167960)))))))) + (SPADLET |substitutionList| + (PROG (G167984) + (SPADLET G167984 NIL) + (RETURN + (DO ((G167990 (CDR |dc|) + (CDR G167990)) + (|x| NIL) + (G167991 |Tl| (CDR G167991)) + (T$ NIL)) + ((OR (ATOM G167990) + (PROGN + (SETQ |x| (CAR G167990)) + NIL) + (ATOM G167991) + (PROGN + (SETQ T$ (CAR G167991)) + NIL)) + (NREVERSE0 G167984)) + (SEQ (EXIT + (SETQ G167984 + (CONS (CONS |x| (CAR T$)) + G167984)))))))) + (CONS (SUBLIS |substitutionList| |modemap|) + (CONS |e| NIL))) + ('T NIL))))))) + +@ + +\section{Special evaluation functions} +\subsection{compConstructorCategory} +<<*>>= +;compConstructorCategory(x,m,e) == [x,resolve($Category,m),e] + +(DEFUN |compConstructorCategory| (|x| |m| |e|) + (CONS |x| (CONS (|resolve| |$Category| |m|) (CONS |e| NIL)))) + +@ +\subsection{compString} +<<*>>= +;compString(x,m,e) == [x,resolve($StringCategory,m),e] + +(DEFUN |compString| (|x| |m| |e|) + (CONS |x| (CONS (|resolve| |$StringCategory| |m|) (CONS |e| NIL)))) + +@ +\subsection{compSubsetCategory} +Compile SubsetCategory +<<*>>= +;compSubsetCategory(["SubsetCategory",cat,R],m,e) == +; --1. put "Subsets" property on R to allow directly coercion to subset; +; -- allow automatic coercion from subset to R but not vice versa +; e:= put(R,"Subsets",[[$lhsOfColon,"isFalse"]],e) +; --2. give the subset domain modemaps of cat plus 3 new functions +; comp(["Join",cat,C'],m,e) where +; C'() == +; substitute($lhsOfColon,"$",C'') where +; C''() == +; ["CATEGORY","domain",["SIGNATURE","coerce",[R,"$"]],["SIGNATURE", +; "lift",[R,"$"]],["SIGNATURE","reduce",["$",R]]] + +(DEFUN |compSubsetCategory| (G168021 |m| |e|) + (PROG (|cat| R) + (RETURN + (PROGN + (COND + ((EQ (CAR G168021) '|SubsetCategory|) (CAR G168021))) + (SPADLET |cat| (CADR G168021)) + (SPADLET R (CADDR G168021)) + (SPADLET |e| + (|put| R '|Subsets| + (CONS (CONS |$lhsOfColon| + (CONS '|isFalse| NIL)) + NIL) + |e|)) + (|comp| (CONS '|Join| + (CONS |cat| + (CONS (MSUBST |$lhsOfColon| '$ + (CONS 'CATEGORY + (CONS '|domain| + (CONS + (CONS 'SIGNATURE + (CONS '|coerce| + (CONS + (CONS R (CONS '$ NIL)) + NIL))) + (CONS + (CONS 'SIGNATURE + (CONS '|lift| + (CONS + (CONS R (CONS '$ NIL)) + NIL))) + (CONS + (CONS 'SIGNATURE + (CONS '|reduce| + (CONS + (CONS '$ + (CONS R NIL)) + NIL))) + NIL)))))) + NIL))) + |m| |e|))))) + +@ +\subsection{compCons} +Compile cons +<<*>>= +;compCons(form,m,e) == compCons1(form,m,e) or compForm(form,m,e) + +(DEFUN |compCons| (|form| |m| |e|) + (OR (|compCons1| |form| |m| |e|) (|compForm| |form| |m| |e|))) + +@ +\subsection{compCons1} +<<*>>= +;compCons1(["CONS",x,y],m,e) == +; [x,mx,e]:= comp(x,$EmptyMode,e) or return nil +; null y => convert([["LIST",x],["List",mx],e],m) +; yt:= [y,my,e]:= comp(y,$EmptyMode,e) or return nil +; T:= +; my is ["List",m',:.] => +; mr:= ["List",resolve(m',mx) or return nil] +; yt':= convert(yt,mr) or return nil +; [x,.,e]:= convert([x,mx,yt'.env],CADR mr) or return nil +; yt'.expr is ["LIST",:.] => [["LIST",x,:rest yt'.expr],mr,e] +; [["CONS",x,yt'.expr],mr,e] +; [["CONS",x,y],["Pair",mx,my],e] +; convert(T,m) + +(DEFUN |compCons1| (G168075 |m| |e|) + (PROG (|mx| |y| |my| |yt| |m'| |mr| |yt'| |LETTMP#1| |x| |ISTMP#1| + T$) + (RETURN + (PROGN + (COND ((EQ (CAR G168075) 'CONS) (CAR G168075))) + (SPADLET |x| (CADR G168075)) + (SPADLET |y| (CADDR G168075)) + (SPADLET |LETTMP#1| + (OR (|comp| |x| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |mx| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (COND + ((NULL |y|) + (|convert| + (CONS (CONS 'LIST (CONS |x| NIL)) + (CONS (CONS '|List| (CONS |mx| NIL)) + (CONS |e| NIL))) + |m|)) + ('T + (SPADLET |yt| + (PROGN + (SPADLET |LETTMP#1| + (OR (|comp| |y| |$EmptyMode| |e|) + (RETURN NIL))) + (SPADLET |y| (CAR |LETTMP#1|)) + (SPADLET |my| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + |LETTMP#1|)) + (SPADLET T$ + (COND + ((AND (PAIRP |my|) (EQ (QCAR |my|) '|List|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |my|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |m'| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |mr| + (CONS '|List| + (CONS + (OR (|resolve| |m'| |mx|) + (RETURN NIL)) + NIL))) + (SPADLET |yt'| + (OR (|convert| |yt| |mr|) (RETURN NIL))) + (SPADLET |LETTMP#1| + (OR (|convert| + (CONS |x| + (CONS |mx| + (CONS (CADDR |yt'|) NIL))) + (CADR |mr|)) + (RETURN NIL))) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (COND + ((PROGN + (SPADLET |ISTMP#1| (CAR |yt'|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'LIST))) + (CONS (CONS 'LIST + (CONS |x| (CDR (CAR |yt'|)))) + (CONS |mr| (CONS |e| NIL)))) + ('T + (CONS (CONS 'CONS + (CONS |x| (CONS (CAR |yt'|) NIL))) + (CONS |mr| (CONS |e| NIL)))))) + ('T + (CONS (CONS 'CONS (CONS |x| (CONS |y| NIL))) + (CONS (CONS '|Pair| + (CONS |mx| (CONS |my| NIL))) + (CONS |e| NIL)))))) + (|convert| T$ |m|))))))) + +@ +\subsection{compSetq} +Compile setq +<<*>>= +;compSetq(["LET",form,val],m,E) == compSetq1(form,val,m,E) + +(DEFUN |compSetq| (G168129 |m| E) + (PROG (|form| |val|) + (RETURN + (PROGN + (COND ((EQ (CAR G168129) 'LET) (CAR G168129))) + (SPADLET |form| (CADR G168129)) + (SPADLET |val| (CADDR G168129)) + (|compSetq1| |form| |val| |m| E))))) + +@ +\subsection{compSetq1} +<<*>>= +;compSetq1(form,val,m,E) == +; IDENTP form => setqSingle(form,val,m,E) +; form is [":",x,y] => +; [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E) +; compSetq(["LET",x,val],m,E') +; form is [op,:l] => +; op="CONS" => setqMultiple(uncons form,val,m,E) +; op="Tuple" => setqMultiple(l,val,m,E) +; setqSetelt(form,val,m,E) + +(DEFUN |compSetq1| (|form| |val| |m| E) + (PROG (|ISTMP#1| |x| |ISTMP#2| |y| |LETTMP#1| |E'| |op| |l|) + (RETURN + (COND + ((IDENTP |form|) (|setqSingle| |form| |val| |m| E)) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) 'T)))))) + (SPADLET |LETTMP#1| + (|compMakeDeclaration| |form| |$EmptyMode| E)) + (SPADLET |E'| (CADDR |LETTMP#1|)) + (|compSetq| (CONS 'LET (CONS |x| (CONS |val| NIL))) |m| |E'|)) + ((AND (PAIRP |form|) + (PROGN + (SPADLET |op| (QCAR |form|)) + (SPADLET |l| (QCDR |form|)) + 'T)) + (COND + ((BOOT-EQUAL |op| 'CONS) + (|setqMultiple| (|uncons| |form|) |val| |m| E)) + ((BOOT-EQUAL |op| '|Tuple|) + (|setqMultiple| |l| |val| |m| E)) + ('T (|setqSetelt| |form| |val| |m| E)))))))) + +@ +\subsection{compMakeDeclaration} +<<*>>= +;compMakeDeclaration(x,m,e) == +; $insideExpressionIfTrue: local +; compColon(x,m,e) + +(DEFUN |compMakeDeclaration| (|x| |m| |e|) + (PROG (|$insideExpressionIfTrue|) + (DECLARE (SPECIAL |$insideExpressionIfTrue|)) + (RETURN + (PROGN + (SPADLET |$insideExpressionIfTrue| NIL) + (|compColon| |x| |m| |e|))))) + +@ +\subsection{setqSetelt} +Compile setelt +<<*>>= +;setqSetelt([v,:s],val,m,E) == +; comp(["setelt",v,:s,val],m,E) + +(DEFUN |setqSetelt| (G168190 |val| |m| E) + (PROG (|v| |s|) + (RETURN + (PROGN + (SPADLET |v| (CAR G168190)) + (SPADLET |s| (CDR G168190)) + (|comp| (CONS '|setelt| + (CONS |v| (APPEND |s| (CONS |val| NIL)))) + |m| E))))) + +@ +\subsection{setqSingle} +<<*>>= +;setqSingle(id,val,m,E) == +; $insideSetqSingleIfTrue: local:= true +; --used for comping domain forms within functions +; currentProplist:= getProplist(id,E) +; m'':= +; get(id,'mode,E) or getmode(id,E) or +; (if m=$NoValueMode then $EmptyMode else m) +;-- m'':= LASSOC("mode",currentProplist) or $EmptyMode +; --for above line to work, line 3 of compNoStackingis required +; T:= +; eval or return nil where +; eval() == +; T:= comp(val,m'',E) => T +; not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and +; (T:=comp(val,maxm'',E)) => T +; (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => +; assignError(val,T.mode,id,m'') +; T':= [x,m',e']:= convert(T,m) or return nil +; if $profileCompiler = true then +; null IDENTP id => nil +; key := +; MEMQ(id,rest $form) => 'arguments +; 'locals +; profileRecord(key,id,T.mode) +; newProplist:= consProplistOf(id,currentProplist,"value",removeEnv [val,:rest T]) +; e':= (PAIRP id => e'; addBinding(id,newProplist,e')) +; if isDomainForm(val,e') then +; if isDomainInScope(id,e') then +; stackWarning ["domain valued variable","%b",id,"%d", +; "has been reassigned within its scope"] +; e':= augModemapsFromDomain1(id,val,e') +; --all we do now is to allocate a slot number for lhs +; --e.g. the LET form below will be changed by putInLocalDomainReferences +;--+ +; if (k:=NRTassocIndex(id)) +; then form:=['SETELT,"$",k,x] +; else form:= +; $QuickLet => ["LET",id,x] +; ["LET",id,x, +; (isDomainForm(x,e') => ['ELT,id,0];CAR outputComp(id,e'))] +; [form,m',e'] + +(DEFUN |setqSingle| (|id| |val| |m| E) + (PROG (|$insideSetqSingleIfTrue| |currentProplist| |m''| |maxm''| T$ + |LETTMP#1| |x| |m'| |T'| |key| |newProplist| |e'| |k| + |form|) + (DECLARE (SPECIAL |$insideSetqSingleIfTrue|)) + (RETURN + (PROGN + (SPADLET |$insideSetqSingleIfTrue| 'T) + (SPADLET |currentProplist| (|getProplist| |id| E)) + (SPADLET |m''| + (OR (|get| |id| '|mode| E) (|getmode| |id| E) + (COND + ((BOOT-EQUAL |m| |$NoValueMode|) |$EmptyMode|) + ('T |m|)))) + (SPADLET T$ + (OR (COND + ((SPADLET T$ (|comp| |val| |m''| E)) T$) + ((AND (NULL (|get| |id| '|mode| E)) + (NEQUAL |m''| + (SPADLET |maxm''| + (|maxSuperType| |m''| E))) + (SPADLET T$ (|comp| |val| |maxm''| E))) + T$) + ((AND (SPADLET T$ (|comp| |val| |$EmptyMode| E)) + (|getmode| (CADR T$) E)) + (|assignError| |val| (CADR T$) |id| |m''|))) + (RETURN NIL))) + (SPADLET |T'| + (PROGN + (SPADLET |LETTMP#1| + (OR (|convert| T$ |m|) (RETURN NIL))) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |m'| (CADR |LETTMP#1|)) + (SPADLET |e'| (CADDR |LETTMP#1|)) + |LETTMP#1|)) + (COND + ((BOOT-EQUAL |$profileCompiler| 'T) + (COND + ((NULL (IDENTP |id|)) NIL) + ('T + (SPADLET |key| + (COND + ((MEMQ |id| (CDR |$form|)) '|arguments|) + ('T '|locals|))) + (|profileRecord| |key| |id| (CADR T$)))))) + (SPADLET |newProplist| + (|consProplistOf| |id| |currentProplist| '|value| + (|removeEnv| (CONS |val| (CDR T$))))) + (SPADLET |e'| + (COND + ((PAIRP |id|) |e'|) + ('T (|addBinding| |id| |newProplist| |e'|)))) + (COND + ((|isDomainForm| |val| |e'|) + (COND + ((|isDomainInScope| |id| |e'|) + (|stackWarning| + (CONS '|domain valued variable| + (CONS '|%b| + (CONS |id| + (CONS '|%d| + (CONS + '|has been reassigned within its scope| + NIL)))))))) + (SPADLET |e'| (|augModemapsFromDomain1| |id| |val| |e'|)))) + (COND + ((SPADLET |k| (|NRTassocIndex| |id|)) + (SPADLET |form| + (CONS 'SETELT (CONS '$ (CONS |k| (CONS |x| NIL)))))) + ('T + (SPADLET |form| + (COND + (|$QuickLet| + (CONS 'LET (CONS |id| (CONS |x| NIL)))) + ('T + (CONS 'LET + (CONS |id| + (CONS |x| + (CONS + (COND + ((|isDomainForm| |x| |e'|) + (CONS 'ELT + (CONS |id| (CONS 0 NIL)))) + ('T + (CAR (|outputComp| |id| |e'|)))) + NIL))))))))) + (CONS |form| (CONS |m'| (CONS |e'| NIL))))))) + +@ +\subsection{assignError} +<<*>>= +;assignError(val,m',form,m) == +; message:= +; val => +; ["CANNOT ASSIGN: ",val,"%l"," OF MODE: ",m',"%l"," TO: ",form,"%l", +; " OF MODE: ",m] +; ["CANNOT ASSIGN: ",val,"%l"," TO: ",form,"%l"," OF MODE: ",m] +; stackMessage message + +(DEFUN |assignError| (|val| |m'| |form| |m|) + (PROG (|message|) + (RETURN + (PROGN + (SPADLET |message| + (COND + (|val| (CONS '|CANNOT ASSIGN: | + (CONS |val| + (CONS '|%l| + (CONS '| OF MODE: | + (CONS |m'| + (CONS '|%l| + (CONS '| TO: | + (CONS |form| + (CONS '|%l| + (CONS '| OF MODE: | + (CONS |m| NIL)))))))))))) + ('T + (CONS '|CANNOT ASSIGN: | + (CONS |val| + (CONS '|%l| + (CONS '| TO: | + (CONS |form| + (CONS '|%l| + (CONS '| OF MODE: | + (CONS |m| NIL))))))))))) + (|stackMessage| |message|))))) + +@ +\subsection{setqMultiple} +<<*>>= +;setqMultiple(nameList,val,m,e) == +; val is ["CONS",:.] and m=$NoValueMode => +; setqMultipleExplicit(nameList,uncons val,m,e) +; val is ["Tuple",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e) +; 1 --create a gensym, %add to local environment, compile and assign rhs +; g:= genVariable() +; e:= addBinding(g,nil,e) +; T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil +; e:= put(g,"mode",m1,e) +; [x,m',e]:= convert(T,m) or return nil +; 1.1 --exit if result is a list +; m1 is ["List",D] => +; for y in nameList repeat e:= put(y,"value",[genSomeVariable(),D,$noEnv],e) +; convert([["PROGN",x,["LET",nameList,g],g],m',e],m) +; 2 --verify that the #nameList = number of parts of right-hand-side +; selectorModePairs:= +; --list of modes +; decompose(m1,#nameList,e) or return nil where +; decompose(t,length,e) == +; t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l] +; comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] => +; [[name,:mode] for [":",name,mode] in l] +; stackMessage ["no multiple assigns to mode: ",t] +; #nameList^=#selectorModePairs => +; stackMessage [val," must decompose into ",#nameList," components"] +; 3 --generate code; return +; assignList:= +; [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr +; for x in nameList for [y,:z] in selectorModePairs] +; if assignList="failed" then NIL +; else [MKPROGN [x,:assignList,g],m',e] + +(DEFUN |setqMultiple,decompose| (|t| |length| |e|) + (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |l| |ISTMP#4| |name| |mode|) + (RETURN + (SEQ (IF (AND (PAIRP |t|) (EQ (QCAR |t|) '|Record|) + (PROGN (SPADLET |l| (QCDR |t|)) 'T)) + (EXIT (PROG (G168310) + (SPADLET G168310 NIL) + (RETURN + (DO ((G168316 |l| (CDR G168316)) + (G168272 NIL)) + ((OR (ATOM G168316) + (PROGN + (SETQ G168272 (CAR G168316)) + NIL) + (PROGN + (PROGN + (SPADLET |name| (CADR G168272)) + (SPADLET |mode| + (CADDR G168272)) + G168272) + NIL)) + (NREVERSE0 G168310)) + (SEQ (EXIT (SETQ G168310 + (CONS (CONS |name| |mode|) + G168310))))))))) + (IF (PROGN + (SPADLET |ISTMP#1| (|comp| |t| |$EmptyMode| |e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) + '|RecordCategory|) + (PROGN + (SPADLET |l| (QCDR |ISTMP#3|)) + 'T))) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL))))))) + (EXIT (PROG (G168328) + (SPADLET G168328 NIL) + (RETURN + (DO ((G168334 |l| (CDR G168334)) + (G168300 NIL)) + ((OR (ATOM G168334) + (PROGN + (SETQ G168300 (CAR G168334)) + NIL) + (PROGN + (PROGN + (SPADLET |name| (CADR G168300)) + (SPADLET |mode| + (CADDR G168300)) + G168300) + NIL)) + (NREVERSE0 G168328)) + (SEQ (EXIT (SETQ G168328 + (CONS (CONS |name| |mode|) + G168328))))))))) + (EXIT (|stackMessage| + (CONS '|no multiple assigns to mode: | + (CONS |t| NIL)))))))) + + +(DEFUN |setqMultiple| (|nameList| |val| |m| |e|) + (PROG (|l| |g| |m1| T$ |x| |m'| |ISTMP#1| D |selectorModePairs| |y| + |z| |LETTMP#1| |assignList|) + (RETURN + (SEQ (COND + ((AND (PAIRP |val|) (EQ (QCAR |val|) 'CONS) + (BOOT-EQUAL |m| |$NoValueMode|)) + (|setqMultipleExplicit| |nameList| (|uncons| |val|) |m| + |e|)) + ((AND (PAIRP |val|) (EQ (QCAR |val|) '|Tuple|) + (PROGN (SPADLET |l| (QCDR |val|)) 'T) + (BOOT-EQUAL |m| |$NoValueMode|)) + (|setqMultipleExplicit| |nameList| |l| |m| |e|)) + ('T (SPADLET |g| (|genVariable|)) + (SPADLET |e| (|addBinding| |g| NIL |e|)) + (SPADLET T$ + (PROGN + (SPADLET |LETTMP#1| + (OR (|compSetq1| |g| |val| + |$EmptyMode| |e|) + (RETURN NIL))) + (SPADLET |m1| (CADR |LETTMP#1|)) + |LETTMP#1|)) + (SPADLET |e| (|put| |g| '|mode| |m1| |e|)) + (SPADLET |LETTMP#1| (OR (|convert| T$ |m|) (RETURN NIL))) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |m'| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (COND + ((AND (PAIRP |m1|) (EQ (QCAR |m1|) '|List|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) 'T)))) + (DO ((G168370 |nameList| (CDR G168370)) (|y| NIL)) + ((OR (ATOM G168370) + (PROGN (SETQ |y| (CAR G168370)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |e| + (|put| |y| '|value| + (CONS (|genSomeVariable|) + (CONS D (CONS |$noEnv| NIL))) + |e|))))) + (|convert| + (CONS (CONS 'PROGN + (CONS |x| + (CONS + (CONS 'LET + (CONS |nameList| + (CONS |g| NIL))) + (CONS |g| NIL)))) + (CONS |m'| (CONS |e| NIL))) + |m|)) + ('T + (SPADLET |selectorModePairs| + (OR (|setqMultiple,decompose| |m1| + (|#| |nameList|) |e|) + (RETURN NIL))) + (COND + ((NEQUAL (|#| |nameList|) (|#| |selectorModePairs|)) + (|stackMessage| + (CONS |val| + (CONS '| must decompose into | + (CONS (|#| |nameList|) + (CONS '| components| NIL)))))) + ('T + (SPADLET |assignList| + (PROG (G168385) + (SPADLET G168385 NIL) + (RETURN + (DO ((G168395 |nameList| + (CDR G168395)) + (|x| NIL) + (G168396 |selectorModePairs| + (CDR G168396)) + (G168362 NIL)) + ((OR (ATOM G168395) + (PROGN + (SETQ |x| (CAR G168395)) + NIL) + (ATOM G168396) + (PROGN + (SETQ G168362 + (CAR G168396)) + NIL) + (PROGN + (PROGN + (SPADLET |y| + (CAR G168362)) + (SPADLET |z| + (CDR G168362)) + G168362) + NIL)) + (NREVERSE0 G168385)) + (SEQ + (EXIT + (SETQ G168385 + (CONS + (CAR + (PROGN + (SPADLET |LETTMP#1| + (OR + (|compSetq1| |x| + (CONS '|elt| + (CONS |g| (CONS |y| NIL))) + |z| |e|) + (RETURN '|failed|))) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|)) + G168385)))))))) + (COND + ((BOOT-EQUAL |assignList| '|failed|) NIL) + ('T + (CONS (MKPROGN (CONS |x| + (APPEND |assignList| + (CONS |g| NIL)))) + (CONS |m'| (CONS |e| NIL))))))))))))))) + +@ +\subsection{setqMultipleExplicit} +<<*>>= +;setqMultipleExplicit(nameList,valList,m,e) == +; #nameList^=#valList => +; stackMessage ["Multiple assignment error; # of items in: ",nameList, +; "must = # in: ",valList] +; gensymList:= [genVariable() for name in nameList] +; assignList:= +; --should be fixed to declare genVar when possible +; [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed" +; for g in gensymList for val in valList] +; assignList="failed" => nil +; reAssignList:= +; [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed" +; for g in gensymList for name in nameList] +; reAssignList="failed" => nil +; [["PROGN",:[T.expr for T in assignList],:[T.expr for T in reAssignList]], +; $NoValueMode, (LAST reAssignList).env] + +(DEFUN |setqMultipleExplicit| (|nameList| |valList| |m| |e|) + (PROG (|gensymList| |assignList| |LETTMP#1| |reAssignList|) + (RETURN + (SEQ (COND + ((NEQUAL (|#| |nameList|) (|#| |valList|)) + (|stackMessage| + (CONS '|Multiple assignment error; # of items in: | + (CONS |nameList| + (CONS '|must = # in: | + (CONS |valList| NIL)))))) + ('T + (SPADLET |gensymList| + (PROG (G168445) + (SPADLET G168445 NIL) + (RETURN + (DO ((G168450 |nameList| (CDR G168450)) + (|name| NIL)) + ((OR (ATOM G168450) + (PROGN + (SETQ |name| (CAR G168450)) + NIL)) + (NREVERSE0 G168445)) + (SEQ (EXIT (SETQ G168445 + (CONS (|genVariable|) + G168445)))))))) + (SPADLET |assignList| + (PROG (G168464) + (SPADLET G168464 NIL) + (RETURN + (DO ((G168473 |gensymList| + (CDR G168473)) + (|g| NIL) + (G168474 |valList| (CDR G168474)) + (|val| NIL)) + ((OR (ATOM G168473) + (PROGN + (SETQ |g| (CAR G168473)) + NIL) + (ATOM G168474) + (PROGN + (SETQ |val| (CAR G168474)) + NIL)) + (NREVERSE0 G168464)) + (SEQ (EXIT (SETQ G168464 + (CONS + (PROGN + (SPADLET |LETTMP#1| + (OR + (|compSetq1| |g| |val| + |$EmptyMode| |e|) + (RETURN '|failed|))) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|) + G168464)))))))) + (COND + ((BOOT-EQUAL |assignList| '|failed|) NIL) + ('T + (SPADLET |reAssignList| + (PROG (G168491) + (SPADLET G168491 NIL) + (RETURN + (DO ((G168500 |gensymList| + (CDR G168500)) + (|g| NIL) + (G168501 |nameList| + (CDR G168501)) + (|name| NIL)) + ((OR (ATOM G168500) + (PROGN + (SETQ |g| (CAR G168500)) + NIL) + (ATOM G168501) + (PROGN + (SETQ |name| (CAR G168501)) + NIL)) + (NREVERSE0 G168491)) + (SEQ (EXIT + (SETQ G168491 + (CONS + (PROGN + (SPADLET |LETTMP#1| + (OR + (|compSetq1| |name| |g| + |$EmptyMode| |e|) + (RETURN '|failed|))) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|) + G168491)))))))) + (COND + ((BOOT-EQUAL |reAssignList| '|failed|) NIL) + ('T + (CONS (CONS 'PROGN + (APPEND (PROG (G168514) + (SPADLET G168514 NIL) + (RETURN + (DO + ((G168519 |assignList| + (CDR G168519)) + (T$ NIL)) + ((OR (ATOM G168519) + (PROGN + (SETQ T$ + (CAR G168519)) + NIL)) + (NREVERSE0 G168514)) + (SEQ + (EXIT + (SETQ G168514 + (CONS (CAR T$) + G168514))))))) + (PROG (G168529) + (SPADLET G168529 NIL) + (RETURN + (DO + ((G168534 |reAssignList| + (CDR G168534)) + (T$ NIL)) + ((OR (ATOM G168534) + (PROGN + (SETQ T$ + (CAR G168534)) + NIL)) + (NREVERSE0 G168529)) + (SEQ + (EXIT + (SETQ G168529 + (CONS (CAR T$) + G168529))))))))) + (CONS |$NoValueMode| + (CONS (CADDR (|last| |reAssignList|)) + NIL))))))))))))) + +@ +\subsection{compWhere} +Compile where +<<*>>= +;compWhere([.,form,:exprList],m,eInit) == +; $insideExpressionIfTrue: local:= false +; $insideWhereIfTrue: local:= true +; e:= eInit +; u:= +; for item in exprList repeat +; [.,.,e]:= comp(item,$EmptyMode,e) or return "failed" +; u="failed" => return nil +; $insideWhereIfTrue:= false +; [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil +; eFinal:= +; del:= deltaContour(eAfter,eBefore) => addContour(del,eInit) +; eInit +; [x,m,eFinal] + +(DEFUN |compWhere| (G168571 |m| |eInit|) + (PROG (|$insideExpressionIfTrue| |$insideWhereIfTrue| |form| + |exprList| |e| |u| |eBefore| |LETTMP#1| |x| |eAfter| |del| + |eFinal|) + (DECLARE (SPECIAL |$insideExpressionIfTrue| |$insideWhereIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |form| (CADR G168571)) + (SPADLET |exprList| (CDDR G168571)) + (SPADLET |$insideExpressionIfTrue| NIL) + (SPADLET |$insideWhereIfTrue| 'T) + (SPADLET |e| |eInit|) + (SPADLET |u| + (DO ((G168594 |exprList| (CDR G168594)) + (|item| NIL)) + ((OR (ATOM G168594) + (PROGN + (SETQ |item| (CAR G168594)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| + (OR + (|comp| |item| |$EmptyMode| |e|) + (RETURN '|failed|))) + (SPADLET |e| (CADDR |LETTMP#1|)) + |LETTMP#1|))))) + (COND + ((BOOT-EQUAL |u| '|failed|) (RETURN NIL)) + ('T (SPADLET |$insideWhereIfTrue| NIL) + (SPADLET |LETTMP#1| + (OR (|comp| (|macroExpand| |form| + (SPADLET |eBefore| |e|)) + |m| |e|) + (RETURN NIL))) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET |eAfter| (CADDR |LETTMP#1|)) + (SPADLET |eFinal| + (COND + ((SPADLET |del| + (|deltaContour| |eAfter| + |eBefore|)) + (|addContour| |del| |eInit|)) + ('T |eInit|))) + (CONS |x| (CONS |m| (CONS |eFinal| NIL)))))))))) + +@ +\subsection{compConstruct} +Compile construct +<<*>>= +;compConstruct(form is ["construct",:l],m,e) == +; y:= modeIsAggregateOf("List",m,e) => +; T:= compList(l,["List",CADR y],e) => convert(T,m) +; compForm(form,m,e) +; y:= modeIsAggregateOf("Vector",m,e) => +; T:= compVector(l,["Vector",CADR y],e) => convert(T,m) +; compForm(form,m,e) +; T:= compForm(form,m,e) => T +; for D in getDomainsInScope e repeat +; (y:=modeIsAggregateOf("List",D,e)) and +; (T:= compList(l,["List",CADR y],e)) and (T':= convert(T,m)) => +; return T' +; (y:=modeIsAggregateOf("Vector",D,e)) and +; (T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) => +; return T' + +(DEFUN |compConstruct| (|form| |m| |e|) + (PROG (|l| |y| T$ |T'|) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR |form|) '|construct|) (CAR |form|))) + (SPADLET |l| (CDR |form|)) + (COND + ((SPADLET |y| (|modeIsAggregateOf| '|List| |m| |e|)) + (COND + ((SPADLET T$ + (|compList| |l| + (CONS '|List| (CONS (CADR |y|) NIL)) + |e|)) + (|convert| T$ |m|)) + ('T (|compForm| |form| |m| |e|)))) + ((SPADLET |y| (|modeIsAggregateOf| '|Vector| |m| |e|)) + (COND + ((SPADLET T$ + (|compVector| |l| + (CONS '|Vector| (CONS (CADR |y|) NIL)) + |e|)) + (|convert| T$ |m|)) + ('T (|compForm| |form| |m| |e|)))) + ((SPADLET T$ (|compForm| |form| |m| |e|)) T$) + ('T + (DO ((G168638 (|getDomainsInScope| |e|) + (CDR G168638)) + (D NIL)) + ((OR (ATOM G168638) + (PROGN (SETQ D (CAR G168638)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (SPADLET |y| + (|modeIsAggregateOf| '|List| D + |e|)) + (SPADLET T$ + (|compList| |l| + (CONS '|List| + (CONS (CADR |y|) NIL)) + |e|)) + (SPADLET |T'| (|convert| T$ |m|))) + (RETURN |T'|)) + ((AND (SPADLET |y| + (|modeIsAggregateOf| '|Vector| D + |e|)) + (SPADLET T$ + (|compVector| |l| + (CONS '|Vector| + (CONS (CADR |y|) NIL)) + |e|)) + (SPADLET |T'| (|convert| T$ |m|))) + (RETURN |T'|))))))))))))) + +@ +\subsection{compQuote} +Compile quote +<<*>>= +;compQuote(expr,m,e) == [expr,m,e] + +(DEFUN |compQuote| (|expr| |m| |e|) + (CONS |expr| (CONS |m| (CONS |e| NIL)))) + +@ +\subsection{compList} +Compile list +<<*>>= +;compList(l,m is ["List",mUnder],e) == +; null l => [NIL,m,e] +; Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] +; Tl="failed" => nil +; T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] + +(DEFUN |compList| (|l| |m| |e|) + (PROG (|LETTMP#1| |mUnder| |Tl| T$) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR |m|) '|List|) (CAR |m|))) + (SPADLET |mUnder| (CADR |m|)) + (COND + ((NULL |l|) (CONS NIL (CONS |m| (CONS |e| NIL)))) + ('T + (SPADLET |Tl| + (PROG (G168690) + (SPADLET G168690 NIL) + (RETURN + (DO ((G168699 |l| (CDR G168699)) + (|x| NIL)) + ((OR (ATOM G168699) + (PROGN + (SETQ |x| (CAR G168699)) + NIL)) + (NREVERSE0 G168690)) + (SEQ (EXIT + (SETQ G168690 + (CONS + (PROGN + (SPADLET |LETTMP#1| + (OR (|comp| |x| |mUnder| |e|) + (RETURN '|failed|))) + (SPADLET |mUnder| + (CADR |LETTMP#1|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|) + G168690)))))))) + (COND + ((BOOT-EQUAL |Tl| '|failed|) NIL) + ('T + (SPADLET T$ + (CONS (CONS 'LIST + (PROG (G168709) + (SPADLET G168709 NIL) + (RETURN + (DO + ((G168714 |Tl| + (CDR G168714)) + (T$ NIL)) + ((OR (ATOM G168714) + (PROGN + (SETQ T$ + (CAR G168714)) + NIL)) + (NREVERSE0 G168709)) + (SEQ + (EXIT + (SETQ G168709 + (CONS (CAR T$) + G168709)))))))) + (CONS (CONS '|List| + (CONS |mUnder| NIL)) + (CONS |e| NIL))))))))))))) + +@ +\subsection{compVector} +Compile vector +<<*>>= +;compVector(l,m is ["Vector",mUnder],e) == +; null l => [$EmptyVector,m,e] +; Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] +; Tl="failed" => nil +; [["VECTOR",:[T.expr for T in Tl]],m,e] + +(DEFUN |compVector| (|l| |m| |e|) + (PROG (|LETTMP#1| |mUnder| |Tl|) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR |m|) '|Vector|) (CAR |m|))) + (SPADLET |mUnder| (CADR |m|)) + (COND + ((NULL |l|) + (CONS |$EmptyVector| (CONS |m| (CONS |e| NIL)))) + ('T + (SPADLET |Tl| + (PROG (G168759) + (SPADLET G168759 NIL) + (RETURN + (DO ((G168768 |l| (CDR G168768)) + (|x| NIL)) + ((OR (ATOM G168768) + (PROGN + (SETQ |x| (CAR G168768)) + NIL)) + (NREVERSE0 G168759)) + (SEQ (EXIT + (SETQ G168759 + (CONS + (PROGN + (SPADLET |LETTMP#1| + (OR (|comp| |x| |mUnder| |e|) + (RETURN '|failed|))) + (SPADLET |mUnder| + (CADR |LETTMP#1|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|) + G168759)))))))) + (COND + ((BOOT-EQUAL |Tl| '|failed|) NIL) + ('T + (CONS (CONS 'VECTOR + (PROG (G168778) + (SPADLET G168778 NIL) + (RETURN + (DO + ((G168783 |Tl| (CDR G168783)) + (T$ NIL)) + ((OR (ATOM G168783) + (PROGN + (SETQ T$ (CAR G168783)) + NIL)) + (NREVERSE0 G168778)) + (SEQ + (EXIT + (SETQ G168778 + (CONS (CAR T$) G168778)))))))) + (CONS |m| (CONS |e| NIL)))))))))))) + +@ +\subsection{compMacro} +The compMacro function does macro expansion during spad file compiles. +If a macro occurs twice in the same file the macro expands infinitely +causing a stack overflow. The reason for the infinite recursion is that +the left hand side of the macro definition is expanded. Thus defining +a macro: +\begin{verbatim} +name ==> 1 +\end{verbatim} +will expand properly the first time. The second time it turns into: +\begin{verbatim} +1 ==> 1 +\end{verbatim} +The original code read: +\begin{verbatim} +compMacro(form,m,e) == + $macroIfTrue: local:= true + ["MDEF",lhs,signature,specialCases,rhs]:= form + rhs := + rhs is ['CATEGORY,:.] => ['"-- the constructor category"] + rhs is ['Join,:.] => ['"-- the constructor category"] + rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] + rhs is ['add,:.] => ['"-- the constructor capsule"] + formatUnabbreviated rhs + sayBrightly ['" processing macro definition",'%b, + :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] + ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) + m=$EmptyMode or m=$NoValueMode => + ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] + +\end{verbatim} +Juergen Weiss proposed the following fixed code. This does not expand +the left hand side of the macro. +<<*>>= +;compMacro(form,m,e) == +; $macroIfTrue: local:= true +; ["MDEF",lhs,signature,specialCases,rhs]:= form +; prhs := +; rhs is ['CATEGORY,:.] => ['"-- the constructor category"] +; rhs is ['Join,:.] => ['"-- the constructor category"] +; rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] +; rhs is ['add,:.] => ['"-- the constructor capsule"] +; formatUnabbreviated rhs +; sayBrightly ['" processing macro definition",'%b, +; :formatUnabbreviated lhs,'" ==> ",:prhs,'%d] +; m=$EmptyMode or m=$NoValueMode => +; ["/throwAway",$NoValueMode,put(first lhs,"macro",macroExpand(rhs,e),e)] + +(DEFUN |compMacro| (|form| |m| |e|) + (PROG (|$macroIfTrue| |lhs| |signature| |specialCases| |rhs| |prhs|) + (DECLARE (SPECIAL |$macroIfTrue|)) + (RETURN + (PROGN + (SPADLET |$macroIfTrue| 'T) + (COND ((EQ (CAR |form|) 'MDEF) (CAR |form|))) + (SPADLET |lhs| (CADR |form|)) + (SPADLET |signature| (CADDR |form|)) + (SPADLET |specialCases| (CADDDR |form|)) + (SPADLET |rhs| (CAR (CDDDDR |form|))) + (SPADLET |prhs| + (COND + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'CATEGORY)) + (CONS (MAKESTRING "-- the constructor category") + NIL)) + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|Join|)) + (CONS (MAKESTRING "-- the constructor category") + NIL)) + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) 'CAPSULE)) + (CONS (MAKESTRING "-- the constructor capsule") + NIL)) + ((AND (PAIRP |rhs|) (EQ (QCAR |rhs|) '|add|)) + (CONS (MAKESTRING "-- the constructor capsule") + NIL)) + ('T (|formatUnabbreviated| |rhs|)))) + (|sayBrightly| + (CONS (MAKESTRING " processing macro definition") + (CONS '|%b| + (APPEND (|formatUnabbreviated| |lhs|) + (CONS (MAKESTRING " ==> ") + (APPEND |prhs| (CONS '|%d| NIL))))))) + (COND + ((OR (BOOT-EQUAL |m| |$EmptyMode|) + (BOOT-EQUAL |m| |$NoValueMode|)) + (CONS '|/throwAway| + (CONS |$NoValueMode| + (CONS (|put| (CAR |lhs|) '|macro| + (|macroExpand| |rhs| |e|) |e|) + NIL))))))))) + +@ +\subsection{compSeq} +Compile seq +<<*>>= +;compSeq(["SEQ",:l],m,e) == compSeq1(l,[m,:$exitModeStack],e) + +(DEFUN |compSeq| (G168818 |m| |e|) + (PROG (|l|) + (RETURN + (PROGN + (COND ((EQ (CAR G168818) 'SEQ) (CAR G168818))) + (SPADLET |l| (CDR G168818)) + (|compSeq1| |l| (CONS |m| |$exitModeStack|) |e|))))) + +@ +\subsection{compSeq1} +<<*>>= +;compSeq1(l,$exitModeStack,e) == +; $insideExpressionIfTrue: local +; $finalEnv: local +; --used in replaceExitEtc. +; c:= +; [([.,.,e]:= +; --this used to be compOrCroak-- but changed so we can back out +; ($insideExpressionIfTrue:= NIL; compSeqItem(x,$NoValueMode,e) or return +; "failed")).expr for x in l] +; if c="failed" then return nil +; catchTag:= MKQ GENSYM() +; form:= ["SEQ",:replaceExitEtc(c,catchTag,"TAGGEDexit",$exitModeStack.(0))] +; [["CATCH",catchTag,form],$exitModeStack.(0),$finalEnv] + +(DEFUN |compSeq1| (|l| |$exitModeStack| |e|) + (DECLARE (SPECIAL |$exitModeStack|)) + (PROG (|$insideExpressionIfTrue| |$finalEnv| |LETTMP#1| |c| + |catchTag| |form|) + (DECLARE (SPECIAL |$insideExpressionIfTrue| |$finalEnv|)) + (RETURN + (SEQ (PROGN + (SPADLET |$insideExpressionIfTrue| NIL) + (SPADLET |$finalEnv| NIL) + (SPADLET |c| + (PROG (G168847) + (SPADLET G168847 NIL) + (RETURN + (DO ((G168857 |l| (CDR G168857)) + (|x| NIL)) + ((OR (ATOM G168857) + (PROGN + (SETQ |x| (CAR G168857)) + NIL)) + (NREVERSE0 G168847)) + (SEQ (EXIT (SETQ G168847 + (CONS + (CAR + (PROGN + (SPADLET |LETTMP#1| + (PROGN + (SPADLET + |$insideExpressionIfTrue| + NIL) + (OR + (|compSeqItem| |x| + |$NoValueMode| |e|) + (RETURN '|failed|)))) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|)) + G168847)))))))) + (COND ((BOOT-EQUAL |c| '|failed|) (RETURN NIL))) + (SPADLET |catchTag| (MKQ (GENSYM))) + (SPADLET |form| + (CONS 'SEQ + (|replaceExitEtc| |c| |catchTag| + '|TAGGEDexit| (ELT |$exitModeStack| 0)))) + (CONS (CONS 'CATCH (CONS |catchTag| (CONS |form| NIL))) + (CONS (ELT |$exitModeStack| 0) + (CONS |$finalEnv| NIL)))))))) + +@ +\subsection{compSeqItem} +<<*>>= +;compSeqItem(x,m,e) == comp(macroExpand(x,e),m,e) + +(DEFUN |compSeqItem| (|x| |m| |e|) + (|comp| (|macroExpand| |x| |e|) |m| |e|)) + +@ +\subsection{replaceExitEtc} +<<*>>= +;replaceExitEtc(x,tag,opFlag,opMode) == +; (fn(x,tag,opFlag,opMode); x) where +; fn(x,tag,opFlag,opMode) == +; atom x => nil +; x is ["QUOTE",:.] => nil +; x is [ =opFlag,n,t] => +; rplac(CAADDR x,replaceExitEtc(CAADDR x,tag,opFlag,opMode)) +; n=0 => +; $finalEnv:= +; --bound in compSeq1 and compDefineCapsuleFunction +; $finalEnv => intersectionEnvironment($finalEnv,t.env) +; t.env +; rplac(first x,"THROW") +; rplac(CADR x,tag) +; rplac(CADDR x,(convertOrCroak(t,opMode)).expr) +; true => rplac(CADR x,CADR x-1) +; x is [key,n,t] and MEMQ(key,'(TAGGEDreturn TAGGEDexit)) => +; rplac(first t,replaceExitEtc(first t,tag,opFlag,opMode)) +; replaceExitEtc(first x,tag,opFlag,opMode) +; replaceExitEtc(rest x,tag,opFlag,opMode) + +(DEFUN |replaceExitEtc,fn| (|x| |tag| |opFlag| |opMode|) + (PROG (|key| |ISTMP#1| |n| |ISTMP#2| |t|) + (RETURN + (SEQ (IF (ATOM |x|) (EXIT NIL)) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'QUOTE)) (EXIT NIL)) + (IF (AND (PAIRP |x|) (EQUAL (QCAR |x|) |opFlag|) + (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 |t| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT (SEQ (|rplac| (CAADDR |x|) + (|replaceExitEtc| (CAADDR |x|) |tag| + |opFlag| |opMode|)) + (IF (EQL |n| 0) + (EXIT (SEQ + (SPADLET |$finalEnv| + (SEQ + (IF |$finalEnv| + (EXIT + (|intersectionEnvironment| + |$finalEnv| (CADDR |t|)))) + (EXIT (CADDR |t|)))) + (|rplac| (CAR |x|) 'THROW) + (|rplac| (CADR |x|) |tag|) + (EXIT + (|rplac| (CADDR |x|) + (CAR + (|convertOrCroak| |t| |opMode|))))))) + (EXIT (IF 'T + (EXIT + (|rplac| (CADR |x|) + (SPADDIFFERENCE (CADR |x|) 1)))))))) + (IF (AND (AND (PAIRP |x|) + (PROGN + (SPADLET |key| (QCAR |x|)) + (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 |t| (QCAR |ISTMP#2|)) + 'T)))))) + (MEMQ |key| '(|TAGGEDreturn| |TAGGEDexit|))) + (EXIT (|rplac| (CAR |t|) + (|replaceExitEtc| (CAR |t|) |tag| + |opFlag| |opMode|)))) + (|replaceExitEtc| (CAR |x|) |tag| |opFlag| |opMode|) + (EXIT (|replaceExitEtc| (CDR |x|) |tag| |opFlag| |opMode|)))))) + + +(DEFUN |replaceExitEtc| (|x| |tag| |opFlag| |opMode|) + (PROGN (|replaceExitEtc,fn| |x| |tag| |opFlag| |opMode|) |x|)) + +@ +\subsection{compSuchthat} +Compile suchthat +<<*>>= +;compSuchthat([.,x,p],m,e) == +; [x',m',e]:= comp(x,m,e) or return nil +; [p',.,e]:= comp(p,$Boolean,e) or return nil +; e:= put(x',"condition",p',e) +; [x',m',e] + +(DEFUN |compSuchthat| (G168962 |m| |e|) + (PROG (|x| |p| |x'| |m'| |LETTMP#1| |p'|) + (RETURN + (PROGN + (SPADLET |x| (CADR G168962)) + (SPADLET |p| (CADDR G168962)) + (SPADLET |LETTMP#1| (OR (|comp| |x| |m| |e|) (RETURN NIL))) + (SPADLET |x'| (CAR |LETTMP#1|)) + (SPADLET |m'| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (OR (|comp| |p| |$Boolean| |e|) (RETURN NIL))) + (SPADLET |p'| (CAR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |e| (|put| |x'| '|condition| |p'| |e|)) + (CONS |x'| (CONS |m'| (CONS |e| NIL))))))) + +@ +\subsection{compExit} +Compile exit +<<*>>= +;compExit(["exit",level,x],m,e) == +; index:= level-1 +; $exitModeStack = [] => comp(x,m,e) +; m1:= $exitModeStack.index +; [x',m',e']:= +; u:= +; comp(x,m1,e) or return +; stackMessageIfNone ["cannot compile exit expression",x,"in mode",m1] +; modifyModeStack(m',index) +; [["TAGGEDexit",index,u],m,e] + +(DEFUN |compExit| (G169003 |m| |e|) + (PROG (|level| |x| |index| |m1| |u| |x'| |m'| |e'|) + (RETURN + (PROGN + (COND ((EQ (CAR G169003) '|exit|) (CAR G169003))) + (SPADLET |level| (CADR G169003)) + (SPADLET |x| (CADDR G169003)) + (SPADLET |index| (SPADDIFFERENCE |level| 1)) + (COND + ((NULL |$exitModeStack|) (|comp| |x| |m| |e|)) + ('T (SPADLET |m1| (ELT |$exitModeStack| |index|)) + (SPADLET |u| + (OR (|comp| |x| |m1| |e|) + (RETURN + (|stackMessageIfNone| + (CONS '|cannot compile exit expression| + (CONS |x| + (CONS '|in mode| (CONS |m1| NIL)))))))) + (SPADLET |x'| (CAR |u|)) (SPADLET |m'| (CADR |u|)) + (SPADLET |e'| (CADDR |u|)) (|modifyModeStack| |m'| |index|) + (CONS (CONS '|TAGGEDexit| (CONS |index| (CONS |u| NIL))) + (CONS |m| (CONS |e| NIL))))))))) + +@ +\subsection{modifyModeStack} +<<*>>= +;modifyModeStack(m,index) == +; $reportExitModeStack => +; SAY("exitModeStack: ",COPY $exitModeStack," ====> ", +; ($exitModeStack.index:= resolve(m,$exitModeStack.index); $exitModeStack)) +; $exitModeStack.index:= resolve(m,$exitModeStack.index) + +(DEFUN |modifyModeStack| (|m| |index|) + (COND + (|$reportExitModeStack| + (SAY (MAKESTRING "exitModeStack: ") (COPY |$exitModeStack|) + (MAKESTRING " ====> ") + (PROGN + (SETELT |$exitModeStack| |index| + (|resolve| |m| (ELT |$exitModeStack| |index|))) + |$exitModeStack|))) + ('T + (SETELT |$exitModeStack| |index| + (|resolve| |m| (ELT |$exitModeStack| |index|)))))) + +@ +\subsection{compLeave} +Compile leave +<<*>>= +;compLeave(["leave",level,x],m,e) == +; index:= #$exitModeStack-1-$leaveLevelStack.(level-1) +; [x',m',e']:= u:= comp(x,$exitModeStack.index,e) or return nil +; modifyModeStack(m',index) +; [["TAGGEDexit",index,u],m,e] + +(DEFUN |compLeave| (G169045 |m| |e|) + (PROG (|level| |x| |index| |u| |x'| |m'| |e'|) + (RETURN + (PROGN + (COND ((EQ (CAR G169045) '|leave|) (CAR G169045))) + (SPADLET |level| (CADR G169045)) + (SPADLET |x| (CADDR G169045)) + (SPADLET |index| + (SPADDIFFERENCE + (SPADDIFFERENCE (|#| |$exitModeStack|) 1) + (ELT |$leaveLevelStack| + (SPADDIFFERENCE |level| 1)))) + (SPADLET |u| + (OR (|comp| |x| (ELT |$exitModeStack| |index|) |e|) + (RETURN NIL))) + (SPADLET |x'| (CAR |u|)) + (SPADLET |m'| (CADR |u|)) + (SPADLET |e'| (CADDR |u|)) + (|modifyModeStack| |m'| |index|) + (CONS (CONS '|TAGGEDexit| (CONS |index| (CONS |u| NIL))) + (CONS |m| (CONS |e| NIL))))))) + +@ +\subsection{compReturn} +Compile return +<<*>>= +;compReturn(["return",level,x],m,e) == +; null $exitModeStack => +; stackSemanticError(["the return before","%b",x,"%d","is unneccessary"],nil) +; nil +; level^=1 => userError '"multi-level returns not supported" +; index:= MAX(0,#$exitModeStack-1) +; if index>=0 then $returnMode:= resolve($exitModeStack.index,$returnMode) +; [x',m',e']:= u:= comp(x,$returnMode,e) or return nil +; if index>=0 then +; $returnMode:= resolve(m',$returnMode) +; modifyModeStack(m',index) +; [["TAGGEDreturn",0,u],m,e'] + +(DEFUN |compReturn| (G169083 |m| |e|) + (PROG (|level| |x| |index| |u| |x'| |m'| |e'|) + (RETURN + (PROGN + (COND ((EQ (CAR G169083) '|return|) (CAR G169083))) + (SPADLET |level| (CADR G169083)) + (SPADLET |x| (CADDR G169083)) + (COND + ((NULL |$exitModeStack|) + (|stackSemanticError| + (CONS '|the return before| + (CONS '|%b| + (CONS |x| + (CONS '|%d| + (CONS '|is unneccessary| NIL))))) + NIL) + NIL) + ((NEQUAL |level| 1) + (|userError| + (MAKESTRING "multi-level returns not supported"))) + ('T + (SPADLET |index| + (MAX 0 (SPADDIFFERENCE (|#| |$exitModeStack|) 1))) + (COND + ((>= |index| 0) + (SPADLET |$returnMode| + (|resolve| (ELT |$exitModeStack| |index|) + |$returnMode|)))) + (SPADLET |u| + (OR (|comp| |x| |$returnMode| |e|) (RETURN NIL))) + (SPADLET |x'| (CAR |u|)) (SPADLET |m'| (CADR |u|)) + (SPADLET |e'| (CADDR |u|)) + (COND + ((>= |index| 0) + (SPADLET |$returnMode| (|resolve| |m'| |$returnMode|)) + (|modifyModeStack| |m'| |index|))) + (CONS (CONS '|TAGGEDreturn| (CONS 0 (CONS |u| NIL))) + (CONS |m| (CONS |e'| NIL))))))))) + +@ +\subsection{compElt} +Compile Elt +<<*>>= +;compElt(form,m,E) == +; form isnt ["elt",aDomain,anOp] => compForm(form,m,E) +; aDomain="Lisp" => +; [anOp',m,E] where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) +; isDomainForm(aDomain,E) => +; E:= addDomain(aDomain,E) +; mmList:= getModemapListFromDomain(anOp,0,aDomain,E) +; modemap:= +; n:=#mmList +; 1=n => mmList.(0) +; 0=n => +; return +; stackMessage ['"Operation ","%b",anOp,"%d", +; '"missing from domain: ", aDomain] +; stackWarning ['"more than 1 modemap for: ",anOp, +; '" with dc=",aDomain,'" ===>" +; ,mmList] +; mmList.(0) +; [sig,[pred,val]]:= modemap +; #sig^=2 and ^val is ["elt",:.] => nil --what does the second clause do ???? +;--+ +; val := genDeltaEntry [opOf anOp,:modemap] +; convert([["call",val],first rest sig,E], m) --implies fn calls used to access constants +; compForm(form,m,E) + +(DEFUN |compElt| (|form| |m| E) + (PROG (|ISTMP#1| |aDomain| |ISTMP#2| |anOp| |mmList| |n| |modemap| + |sig| |pred| |val|) + (RETURN + (COND + ((NULL (AND (PAIRP |form|) (EQ (QCAR |form|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |aDomain| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |anOp| (QCAR |ISTMP#2|)) + 'T))))))) + (|compForm| |form| |m| E)) + ((BOOT-EQUAL |aDomain| '|Lisp|) + (CONS (COND + ((BOOT-EQUAL |anOp| |$Zero|) 0) + ((BOOT-EQUAL |anOp| |$One|) 1) + ('T |anOp|)) + (CONS |m| (CONS E NIL)))) + ((|isDomainForm| |aDomain| E) + (SPADLET E (|addDomain| |aDomain| E)) + (SPADLET |mmList| + (|getModemapListFromDomain| |anOp| 0 |aDomain| E)) + (SPADLET |modemap| + (PROGN + (SPADLET |n| (|#| |mmList|)) + (COND + ((EQL 1 |n|) (ELT |mmList| 0)) + ((EQL 0 |n|) + (RETURN + (|stackMessage| + (CONS (MAKESTRING "Operation ") + (CONS '|%b| + (CONS |anOp| + (CONS '|%d| + (CONS + (MAKESTRING + "missing from domain: ") + (CONS |aDomain| NIL))))))))) + ('T + (|stackWarning| + (CONS (MAKESTRING + "more than 1 modemap for: ") + (CONS |anOp| + (CONS (MAKESTRING " with dc=") + (CONS |aDomain| + (CONS (MAKESTRING " ===>") + (CONS |mmList| NIL))))))) + (ELT |mmList| 0))))) + (SPADLET |sig| (CAR |modemap|)) + (SPADLET |pred| (CAADR |modemap|)) + (SPADLET |val| (CADADR |modemap|)) + (COND + ((AND (NEQUAL (|#| |sig|) 2) + (NULL (AND (PAIRP |val|) (EQ (QCAR |val|) '|elt|)))) + NIL) + ('T + (SPADLET |val| + (|genDeltaEntry| (CONS (|opOf| |anOp|) |modemap|))) + (|convert| + (CONS (CONS '|call| (CONS |val| NIL)) + (CONS (CAR (CDR |sig|)) (CONS E NIL))) + |m|)))) + ('T (|compForm| |form| |m| E)))))) + +@ +\subsection{compHas} +Compile has +<<*>>= +;compHas(pred is ["has",a,b],m,$e) == +; --b is (":",:.) => (.,.,E):= comp(b,$EmptyMode,E) +; $e:= chaseInferences(pred,$e) +; --pred':= ("has",a',b') := formatHas(pred) +; predCode:= compHasFormat pred +; coerce([predCode,$Boolean,$e],m) + +(DEFUN |compHas| (|pred| |m| |$e|) + (DECLARE (SPECIAL |$e|)) + (PROG (|a| |b| |predCode|) + (RETURN + (PROGN + (COND ((EQ (CAR |pred|) '|has|) (CAR |pred|))) + (SPADLET |a| (CADR |pred|)) + (SPADLET |b| (CADDR |pred|)) + (SPADLET |$e| (|chaseInferences| |pred| |$e|)) + (SPADLET |predCode| (|compHasFormat| |pred|)) + (|coerce| (CONS |predCode| (CONS |$Boolean| (CONS |$e| NIL))) + |m|))))) + +; --used in various other places to make the discrimination +@ +\subsection{compHasFormat} +<<*>>= +;compHasFormat (pred is ["has",olda,b]) == +; argl := rest $form +; formals := TAKE(#argl,$FormalMapVariableList) +; a := SUBLISLIS(argl,formals,olda) +; [a,:.] := comp(a,$EmptyMode,$e) or return nil +; a := SUBLISLIS(formals,argl,a) +; b is ["ATTRIBUTE",c] => ["HasAttribute",a,["QUOTE",c]] +; b is ["SIGNATURE",op,sig] => +; ["HasSignature",a, +; mkList [MKQ op,mkList [mkDomainConstructor type for type in sig]]] +; isDomainForm(b,$EmptyEnvironment) => ["EQUAL",a,b] +; ["HasCategory",a,mkDomainConstructor b] + +(DEFUN |compHasFormat| (|pred|) + (PROG (|olda| |b| |argl| |formals| |LETTMP#1| |a| |c| |ISTMP#1| |op| + |ISTMP#2| |sig|) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR |pred|) '|has|) (CAR |pred|))) + (SPADLET |olda| (CADR |pred|)) + (SPADLET |b| (CADDR |pred|)) + (SPADLET |argl| (CDR |$form|)) + (SPADLET |formals| + (TAKE (|#| |argl|) |$FormalMapVariableList|)) + (SPADLET |a| (SUBLISLIS |argl| |formals| |olda|)) + (SPADLET |LETTMP#1| + (OR (|comp| |a| |$EmptyMode| |$e|) (RETURN NIL))) + (SPADLET |a| (CAR |LETTMP#1|)) + (SPADLET |a| (SUBLISLIS |formals| |argl| |a|)) + (COND + ((AND (PAIRP |b|) (EQ (QCAR |b|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |c| (QCAR |ISTMP#1|)) 'T)))) + (CONS '|HasAttribute| + (CONS |a| + (CONS (CONS 'QUOTE (CONS |c| NIL)) NIL)))) + ((AND (PAIRP |b|) (EQ (QCAR |b|) 'SIGNATURE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |sig| (QCAR |ISTMP#2|)) + 'T)))))) + (CONS '|HasSignature| + (CONS |a| + (CONS (|mkList| + (CONS (MKQ |op|) + (CONS + (|mkList| + (PROG (G169224) + (SPADLET G169224 NIL) + (RETURN + (DO + ((G169229 |sig| + (CDR G169229)) + (|type| NIL)) + ((OR (ATOM G169229) + (PROGN + (SETQ |type| + (CAR G169229)) + NIL)) + (NREVERSE0 G169224)) + (SEQ + (EXIT + (SETQ G169224 + (CONS + (|mkDomainConstructor| + |type|) + G169224)))))))) + NIL))) + NIL)))) + ((|isDomainForm| |b| |$EmptyEnvironment|) + (CONS 'EQUAL (CONS |a| (CONS |b| NIL)))) + ('T + (CONS '|HasCategory| + (CONS |a| (CONS (|mkDomainConstructor| |b|) NIL)))))))))) + +@ +\subsection{compIf} +Compile if +<<*>>= +;compIf(["IF",a,b,c],m,E) == +; [xa,ma,Ea,Einv]:= compBoolean(a,$Boolean,E) or return nil +; [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil +; [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil +; xb':= coerce(Tb,mc) or return nil +; x:= ["IF",xa,quotify xb'.expr,quotify xc] +; (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where +; Env(bEnv,cEnv,b,c,E) == +; canReturn(b,0,0,true) => +; (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv) +; canReturn(c,0,0,true) => cEnv +; E +; [x,mc,returnEnv] + +(DEFUN |compIf,Env| (|bEnv| |cEnv| |b| |c| E) + (SEQ (IF (|canReturn| |b| 0 0 'T) + (EXIT (SEQ (IF (|canReturn| |c| 0 0 'T) + (EXIT (|intersectionEnvironment| |bEnv| + |cEnv|))) + (EXIT |bEnv|)))) + (IF (|canReturn| |c| 0 0 'T) (EXIT |cEnv|)) (EXIT E))) + +(DEFUN |compIf| (G169289 |m| E) + (PROG (|a| |b| |c| |LETTMP#1| |xa| |ma| |Ea| |Einv| |Tb| |xb| |mb| + |Eb| |Tc| |xc| |mc| |Ec| |xb'| |x| |returnEnv|) + (RETURN + (PROGN + (COND ((EQ (CAR G169289) 'IF) (CAR G169289))) + (SPADLET |a| (CADR G169289)) + (SPADLET |b| (CADDR G169289)) + (SPADLET |c| (CADDDR G169289)) + (SPADLET |LETTMP#1| + (OR (|compBoolean| |a| |$Boolean| E) (RETURN NIL))) + (SPADLET |xa| (CAR |LETTMP#1|)) + (SPADLET |ma| (CADR |LETTMP#1|)) + (SPADLET |Ea| (CADDR |LETTMP#1|)) + (SPADLET |Einv| (CADDDR |LETTMP#1|)) + (SPADLET |Tb| (OR (|compFromIf| |b| |m| |Ea|) (RETURN NIL))) + (SPADLET |xb| (CAR |Tb|)) + (SPADLET |mb| (CADR |Tb|)) + (SPADLET |Eb| (CADDR |Tb|)) + (SPADLET |Tc| + (OR (|compFromIf| |c| (|resolve| |mb| |m|) |Einv|) + (RETURN NIL))) + (SPADLET |xc| (CAR |Tc|)) + (SPADLET |mc| (CADR |Tc|)) + (SPADLET |Ec| (CADDR |Tc|)) + (SPADLET |xb'| (OR (|coerce| |Tb| |mc|) (RETURN NIL))) + (SPADLET |x| + (CONS 'IF + (CONS |xa| + (CONS (|quotify| (CAR |xb'|)) + (CONS (|quotify| |xc|) NIL))))) + (SPADLET |returnEnv| + (|compIf,Env| (CADDR |xb'|) |Ec| (CAR |xb'|) |xc| E)) + (CONS |x| (CONS |mc| (CONS |returnEnv| NIL))))))) + +@ +\subsection{canReturn} +<<*>>= +;canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends +; atom expr => ValueFlag and level=exitCount +; (op:= first expr)="QUOTE" => ValueFlag and level=exitCount +; op="TAGGEDexit" => +; expr is [.,count,data] => canReturn(data.expr,level,count,count=level) +; level=exitCount and not ValueFlag => nil +; op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] +; op="TAGGEDreturn" => nil +; op="CATCH" => +; [.,gs,data]:= expr +; (findThrow(gs,data,level,exitCount,ValueFlag) => true) where +; findThrow(gs,expr,level,exitCount,ValueFlag) == +; atom expr => nil +; expr is ["THROW", =gs,data] => true +; --this is pessimistic, but I know of no more accurate idea +; expr is ["SEQ",:l] => +; or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] +; or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr] +; canReturn(data,level,exitCount,ValueFlag) +; op = "COND" => +; level = exitCount => +; or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr] +; or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v] +; for v in rest expr] +; op="IF" => +; expr is [.,a,b,c] +; if not canReturn(a,0,0,true) then +; SAY "IF statement can not cause consequents to be executed" +; pp expr +; canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag) +; or canReturn(c,level,exitCount,ValueFlag) +; --now we have an ordinary form +; atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] +; op is ["XLAM",args,bods] => +; and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] +; systemErrorHere '"canReturn" --for the time being + +(DEFUN |canReturn,findThrow| + (|gs| |expr| |level| |exitCount| |ValueFlag|) + (PROG (|ISTMP#1| |ISTMP#2| |data| |l|) + (RETURN + (SEQ (IF (ATOM |expr|) (EXIT NIL)) + (IF (AND (PAIRP |expr|) (EQ (QCAR |expr|) 'THROW) + (PROGN + (SPADLET |ISTMP#1| (QCDR |expr|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |gs|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |data| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT 'T)) + (IF (AND (PAIRP |expr|) (EQ (QCAR |expr|) 'SEQ) + (PROGN (SPADLET |l| (QCDR |expr|)) 'T)) + (EXIT (PROG (G169370) + (SPADLET G169370 NIL) + (RETURN + (DO ((G169376 NIL G169370) + (G169377 |l| (CDR G169377)) + (|u| NIL)) + ((OR G169376 (ATOM G169377) + (PROGN + (SETQ |u| (CAR G169377)) + NIL)) + G169370) + (SEQ (EXIT (SETQ G169370 + (OR G169370 + (|canReturn,findThrow| |gs| |u| + (PLUS |level| 1) |exitCount| + |ValueFlag|)))))))))) + (EXIT (PROG (G169384) + (SPADLET G169384 NIL) + (RETURN + (DO ((G169390 NIL G169384) + (G169391 (CDR |expr|) (CDR G169391)) + (|u| NIL)) + ((OR G169390 (ATOM G169391) + (PROGN (SETQ |u| (CAR G169391)) NIL)) + G169384) + (SEQ (EXIT (SETQ G169384 + (OR G169384 + (|canReturn,findThrow| |gs| + |u| |level| |exitCount| + |ValueFlag|))))))))))))) + +(DEFUN |canReturn| (|expr| |level| |exitCount| |ValueFlag|) + (PROG (|op| |count| |gs| |data| |a| |b| |ISTMP#3| |c| |ISTMP#1| + |args| |ISTMP#2| |bods|) + (RETURN + (SEQ (COND + ((ATOM |expr|) + (AND |ValueFlag| (BOOT-EQUAL |level| |exitCount|))) + ((BOOT-EQUAL (SPADLET |op| (CAR |expr|)) 'QUOTE) + (AND |ValueFlag| (BOOT-EQUAL |level| |exitCount|))) + ((BOOT-EQUAL |op| '|TAGGEDexit|) + (COND + ((AND (PAIRP |expr|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |expr|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |count| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |data| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT (|canReturn| (CAR |data|) |level| |count| + (BOOT-EQUAL |count| |level|)))))) + ((AND (BOOT-EQUAL |level| |exitCount|) (NULL |ValueFlag|)) + NIL) + ((BOOT-EQUAL |op| 'SEQ) + (PROG (G169463) + (SPADLET G169463 NIL) + (RETURN + (DO ((G169469 NIL G169463) + (G169470 (CDR |expr|) (CDR G169470)) + (|u| NIL)) + ((OR G169469 (ATOM G169470) + (PROGN (SETQ |u| (CAR G169470)) NIL)) + G169463) + (SEQ (EXIT (SETQ G169463 + (OR G169463 + (|canReturn| |u| (PLUS |level| 1) + |exitCount| NIL))))))))) + ((BOOT-EQUAL |op| '|TAGGEDreturn|) NIL) + ((BOOT-EQUAL |op| 'CATCH) + (PROGN + (SPADLET |gs| (CADR |expr|)) + (SPADLET |data| (CADDR |expr|)) + (COND + ((|canReturn,findThrow| |gs| |data| |level| + |exitCount| |ValueFlag|) + 'T) + ('T + (|canReturn| |data| |level| |exitCount| |ValueFlag|))))) + ((BOOT-EQUAL |op| 'COND) + (COND + ((BOOT-EQUAL |level| |exitCount|) + (PROG (G169477) + (SPADLET G169477 NIL) + (RETURN + (DO ((G169483 NIL G169477) + (G169484 (CDR |expr|) (CDR G169484)) + (|u| NIL)) + ((OR G169483 (ATOM G169484) + (PROGN (SETQ |u| (CAR G169484)) NIL)) + G169477) + (SEQ (EXIT (SETQ G169477 + (OR G169477 + (|canReturn| (|last| |u|) + |level| |exitCount| + |ValueFlag|))))))))) + ('T + (PROG (G169491) + (SPADLET G169491 NIL) + (RETURN + (DO ((G169497 NIL G169491) + (G169498 (CDR |expr|) (CDR G169498)) + (|v| NIL)) + ((OR G169497 (ATOM G169498) + (PROGN (SETQ |v| (CAR G169498)) NIL)) + G169491) + (SEQ (EXIT (SETQ G169491 + (OR G169491 + (PROG (G169505) + (SPADLET G169505 NIL) + (RETURN + (DO + ((G169511 NIL + G169505) + (G169512 |v| + (CDR G169512)) + (|u| NIL)) + ((OR G169511 + (ATOM G169512) + (PROGN + (SETQ |u| + (CAR G169512)) + NIL)) + G169505) + (SEQ + (EXIT + (SETQ G169505 + (OR G169505 + (|canReturn| |u| + |level| |exitCount| + |ValueFlag|)))))))))))))))))) + ((BOOT-EQUAL |op| 'IF) + (PROGN + (AND (PAIRP |expr|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |expr|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |c| (QCAR |ISTMP#3|)) + 'T)))))))) + (COND + ((NULL (|canReturn| |a| 0 0 'T)) + (SAY (MAKESTRING + "IF statement can not cause consequents to be executed")) + (|pp| |expr|))) + (OR (|canReturn| |a| |level| |exitCount| NIL) + (|canReturn| |b| |level| |exitCount| |ValueFlag|) + (|canReturn| |c| |level| |exitCount| |ValueFlag|)))) + ((ATOM |op|) + (PROG (G169519) + (SPADLET G169519 'T) + (RETURN + (DO ((G169525 NIL (NULL G169519)) + (G169526 |expr| (CDR G169526)) (|u| NIL)) + ((OR G169525 (ATOM G169526) + (PROGN (SETQ |u| (CAR G169526)) NIL)) + G169519) + (SEQ (EXIT (SETQ G169519 + (AND G169519 + (|canReturn| |u| |level| + |exitCount| |ValueFlag|))))))))) + ((AND (PAIRP |op|) (EQ (QCAR |op|) 'XLAM) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |args| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |bods| (QCAR |ISTMP#2|)) + 'T)))))) + (PROG (G169533) + (SPADLET G169533 'T) + (RETURN + (DO ((G169539 NIL (NULL G169533)) + (G169540 |expr| (CDR G169540)) (|u| NIL)) + ((OR G169539 (ATOM G169540) + (PROGN (SETQ |u| (CAR G169540)) NIL)) + G169533) + (SEQ (EXIT (SETQ G169533 + (AND G169533 + (|canReturn| |u| |level| + |exitCount| |ValueFlag|))))))))) + ('T (|systemErrorHere| (MAKESTRING "canReturn")))))))) + +@ +\subsection{compBoolean} +<<*>>= +;compBoolean(p,m,E) == +; [p',m,E]:= comp(p,m,E) or return nil +; [p',m,getSuccessEnvironment(p,E),getInverseEnvironment(p,E)] + +(DEFUN |compBoolean| (|p| |m| E) + (PROG (|LETTMP#1| |p'|) + (RETURN + (PROGN + (SPADLET |LETTMP#1| (OR (|comp| |p| |m| E) (RETURN NIL))) + (SPADLET |p'| (CAR |LETTMP#1|)) + (SPADLET |m| (CADR |LETTMP#1|)) + (SPADLET E (CADDR |LETTMP#1|)) + (CONS |p'| + (CONS |m| + (CONS (|getSuccessEnvironment| |p| E) + (CONS (|getInverseEnvironment| |p| E) NIL)))))))) + +@ +\subsection{getSuccessEnvironment} +<<*>>= +;getSuccessEnvironment(a,e) == +; -- the next four lines try to ensure that explicit special-case tests +; -- prevent implicit ones from being generated +; a is ["has",x,m] => +; IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) +; e +; a is ["is",id,m] => +; IDENTP id and isDomainForm(m,$EmptyEnvironment) => +; e:=put(id,"specialCase",m,e) +; currentProplist:= getProplist(id,e) +; [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs +; newProplist:= consProplistOf(id,currentProplist,"value",[m,:rest removeEnv T]) +; addBinding(id,newProplist,e) +; e +; a is ["case",x,m] and IDENTP x => +; put(x,"condition",[a,:get(x,"condition",e)],e) +; e + +(DEFUN |getSuccessEnvironment| (|a| |e|) + (PROG (|id| |currentProplist| T$ |newProplist| |ISTMP#1| |x| + |ISTMP#2| |m|) + (RETURN + (COND + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |m| (QCAR |ISTMP#2|)) 'T)))))) + (COND + ((AND (IDENTP |x|) (|isDomainForm| |m| |$EmptyEnvironment|)) + (|put| |x| '|specialCase| |m| |e|)) + ('T |e|))) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|is|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |id| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |m| (QCAR |ISTMP#2|)) 'T)))))) + (COND + ((AND (IDENTP |id|) + (|isDomainForm| |m| |$EmptyEnvironment|)) + (SPADLET |e| (|put| |id| '|specialCase| |m| |e|)) + (SPADLET |currentProplist| (|getProplist| |id| |e|)) + (SPADLET T$ + (OR (|comp| |m| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |e| (CADDR T$)) + (SPADLET |newProplist| + (|consProplistOf| |id| |currentProplist| '|value| + (CONS |m| (CDR (|removeEnv| T$))))) + (|addBinding| |id| |newProplist| |e|)) + ('T |e|))) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|case|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |m| (QCAR |ISTMP#2|)) 'T))))) + (IDENTP |x|)) + (|put| |x| '|condition| + (CONS |a| (|get| |x| '|condition| |e|)) |e|)) + ('T |e|))))) + +@ +\subsection{getInverseEnvironment} +<<*>>= +;getInverseEnvironment(a,E) == +; atom a => E +; [op,:argl]:= a +;-- the next five lines try to ensure that explicit special-case tests +;-- prevent implicit ones from being generated +; op="has" => +; [x,m]:= argl +; IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) +; E +; a is ["case",x,m] and IDENTP x => +; --the next two lines are necessary to get 3-branched Unions to work +; -- old-style unions, that is +; (get(x,"condition",E) is [["OR",:oldpred]]) and MEMBER(a,oldpred) => +; put(x,"condition",LIST MKPF(DELETE(a,oldpred),"OR"),E) +; getUnionMode(x,E) is ["Union",:l] +; l':= DELETE(m,l) +; for u in l' repeat +; if u is ['_:,=m,:.] then l':=DELETE(u,l') +; newpred:= MKPF([["case",x,m'] for m' in l'],"OR") +; put(x,"condition",[newpred,:get(x,"condition",E)],E) +; E + +(DEFUN |getInverseEnvironment| (|a| E) + (PROG (|op| |argl| |x| |m| |ISTMP#2| |oldpred| |l| |ISTMP#1| |l'| + |newpred|) + (RETURN + (SEQ (COND + ((ATOM |a|) E) + ('T (SPADLET |op| (CAR |a|)) (SPADLET |argl| (CDR |a|)) + (COND + ((BOOT-EQUAL |op| '|has|) (SPADLET |x| (CAR |argl|)) + (SPADLET |m| (CADR |argl|)) + (COND + ((AND (IDENTP |x|) + (|isDomainForm| |m| |$EmptyEnvironment|)) + (|put| |x| '|specialCase| |m| E)) + ('T E))) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|case|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |m| (QCAR |ISTMP#2|)) + 'T))))) + (IDENTP |x|)) + (COND + ((AND (PROGN + (SPADLET |ISTMP#1| + (|get| |x| '|condition| E)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) 'OR) + (PROGN + (SPADLET |oldpred| + (QCDR |ISTMP#2|)) + 'T))))) + (|member| |a| |oldpred|)) + (|put| |x| '|condition| + (LIST (MKPF (|delete| |a| |oldpred|) 'OR)) + E)) + ('T (SPADLET |ISTMP#1| (|getUnionMode| |x| E)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Union|) + (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T)) + (SPADLET |l'| (|delete| |m| |l|)) + (DO ((G169713 |l'| (CDR G169713)) (|u| NIL)) + ((OR (ATOM G169713) + (PROGN (SETQ |u| (CAR G169713)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |u|) + (EQ (QCAR |u|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |m|)))) + (SPADLET |l'| (|delete| |u| |l'|))) + ('T NIL))))) + (SPADLET |newpred| + (MKPF (PROG (G169723) + (SPADLET G169723 NIL) + (RETURN + (DO + ((G169728 |l'| + (CDR G169728)) + (|m'| NIL)) + ((OR (ATOM G169728) + (PROGN + (SETQ |m'| (CAR G169728)) + NIL)) + (NREVERSE0 G169723)) + (SEQ + (EXIT + (SETQ G169723 + (CONS + (CONS '|case| + (CONS |x| + (CONS |m'| NIL))) + G169723))))))) + 'OR)) + (|put| |x| '|condition| + (CONS |newpred| (|get| |x| '|condition| E)) + E)))) + ('T E)))))))) + +@ +\subsection{getUnionMode} +<<*>>= +;getUnionMode(x,e) == +; m:= +; atom x => getmode(x,e) +; return nil +; isUnionMode(m,e) + +(DEFUN |getUnionMode| (|x| |e|) + (PROG (|m|) + (RETURN + (PROGN + (SPADLET |m| + (COND + ((ATOM |x|) (|getmode| |x| |e|)) + ('T (RETURN NIL)))) + (|isUnionMode| |m| |e|))))) + +@ +\subsection{isUnionMode} +<<*>>= +;isUnionMode(m,e) == +; m is ["Union",:.] => m +; (m':= getmode(m,e)) is ["Mapping",["UnionCategory",:.]] => CADR m' +; v:= get(if m="$" then "Rep" else m,"value",e) => +; (v.expr is ["Union",:.] => v.expr; nil) +; nil + +(DEFUN |isUnionMode| (|m| |e|) + (PROG (|m'| |ISTMP#2| |ISTMP#3| |v| |ISTMP#1|) + (RETURN + (COND + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Union|)) |m|) + ((PROGN + (SPADLET |ISTMP#1| (SPADLET |m'| (|getmode| |m| |e|))) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) '|UnionCategory|))))))) + (CADR |m'|)) + ((SPADLET |v| + (|get| (COND ((BOOT-EQUAL |m| '$) '|Rep|) ('T |m|)) + '|value| |e|)) + (COND + ((PROGN + (SPADLET |ISTMP#1| (CAR |v|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|Union|))) + (CAR |v|)) + ('T NIL))) + ('T NIL))))) + +@ +\subsection{compFromIf} +<<*>>= +;compFromIf(a,m,E) == +; a="noBranch" => ["noBranch",m,E] +; true => comp(a,m,E) + +(DEFUN |compFromIf| (|a| |m| E) + (COND + ((BOOT-EQUAL |a| '|noBranch|) + (CONS '|noBranch| (CONS |m| (CONS E NIL)))) + ('T (|comp| |a| |m| E)))) + +@ +\subsection{quotify} +<<*>>= +;quotify x == x + +(DEFUN |quotify| (|x|) |x|) + +@ +\subsection{compImport} +<<*>>= +;compImport(["import",:doms],m,e) == +; for dom in doms repeat e:=addDomain(dom,e) +; ["/throwAway",$NoValueMode,e] + +(DEFUN |compImport| (G169794 |m| |e|) + (PROG (|doms|) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR G169794) '|import|) (CAR G169794))) + (SPADLET |doms| (CDR G169794)) + (DO ((G169806 |doms| (CDR G169806)) (|dom| NIL)) + ((OR (ATOM G169806) + (PROGN (SETQ |dom| (CAR G169806)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |e| (|addDomain| |dom| |e|))))) + (CONS '|/throwAway| (CONS |$NoValueMode| (CONS |e| NIL)))))))) + +@ +\subsection{compCase} +Will the jerk who commented out these two functions please NOT do so +again. These functions ARE needed, and case can NOT be done by +modemap alone. The reason is that A case B requires to take A +evaluated, but B unevaluated. Therefore a special function is +required. You may have thought that you had tested this on ``failed'' +etc., but ``failed'' evaluates to it's own mode. Try it on x case \$ +next time. + +An angry JHD - August 15th., 1984 +<<*>>= +;compCase(["case",x,m'],m,e) == +; e:= addDomain(m',e) +; T:= compCase1(x,m',e) => coerce(T,m) +; nil + +(DEFUN |compCase| (G169818 |m| |e|) + (PROG (|x| |m'| T$) + (RETURN + (PROGN + (COND ((EQ (CAR G169818) '|case|) (CAR G169818))) + (SPADLET |x| (CADR G169818)) + (SPADLET |m'| (CADDR G169818)) + (SPADLET |e| (|addDomain| |m'| |e|)) + (COND + ((SPADLET T$ (|compCase1| |x| |m'| |e|)) (|coerce| T$ |m|)) + ('T NIL)))))) + +@ +\subsection{compCase1} +<<*>>= +;compCase1(x,m,e) == +; [x',m',e']:= comp(x,$EmptyMode,e) or return nil +; u:= +; [cexpr +; for (modemap:= [map,cexpr]) in getModemapList("case",2,e') | map is [.,.,s, +; t] and modeEqual(t,m) and modeEqual(s,m')] or return nil +; fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil +; [["call",fn,x'],$Boolean,e'] + +(DEFUN |compCase1| (|x| |m| |e|) + (PROG (|LETTMP#1| |x'| |m'| |e'| |map| |cexpr| |ISTMP#1| |ISTMP#2| + |s| |ISTMP#3| |t| |u| |cond| |selfn| |fn|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| + (OR (|comp| |x| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |x'| (CAR |LETTMP#1|)) + (SPADLET |m'| (CADR |LETTMP#1|)) + (SPADLET |e'| (CADDR |LETTMP#1|)) + (SPADLET |u| + (OR (PROG (G169884) + (SPADLET G169884 NIL) + (RETURN + (DO ((G169891 + (|getModemapList| '|case| 2 |e'|) + (CDR G169891)) + (|modemap| NIL)) + ((OR (ATOM G169891) + (PROGN + (SETQ |modemap| (CAR G169891)) + NIL) + (PROGN + (PROGN + (SPADLET |map| (CAR |modemap|)) + (SPADLET |cexpr| + (CADR |modemap|)) + |modemap|) + NIL)) + (NREVERSE0 G169884)) + (SEQ (EXIT + (COND + ((AND (PAIRP |map|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |map|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |s| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) + NIL) + (PROGN + (SPADLET |t| + (QCAR |ISTMP#3|)) + 'T))))))) + (|modeEqual| |t| |m|) + (|modeEqual| |s| |m'|)) + (SETQ G169884 + (CONS |cexpr| G169884))))))))) + (RETURN NIL))) + (SPADLET |fn| + (OR (PROG (G169898) + (SPADLET G169898 NIL) + (RETURN + (DO ((G169906 NIL G169898) + (G169907 |u| (CDR G169907)) + (G169873 NIL)) + ((OR G169906 (ATOM G169907) + (PROGN + (SETQ G169873 (CAR G169907)) + NIL) + (PROGN + (PROGN + (SPADLET |cond| + (CAR G169873)) + (SPADLET |selfn| + (CADR G169873)) + G169873) + NIL)) + G169898) + (SEQ (EXIT + (COND + ((BOOT-EQUAL |cond| 'T) + (SETQ G169898 + (OR G169898 |selfn|))))))))) + (RETURN NIL))) + (CONS (CONS '|call| (CONS |fn| (CONS |x'| NIL))) + (CONS |$Boolean| (CONS |e'| NIL)))))))) + +@ +\subsection{compColon} +<<*>>= +;compColon([":",f,t],m,e) == +; $insideExpressionIfTrue=true => compColonInside(f,m,e,t) +; --if inside an expression, ":" means to convert to m "on faith" +; $lhsOfColon: local:= f +; t:= +; atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' +; isDomainForm(t,e) and not $insideCategoryIfTrue => +; (if not MEMBER(t,getDomainsInScope e) then e:= addDomain(t,e); t) +; isDomainForm(t,e) or isCategoryForm(t,e) => t +; t is ["Mapping",m',:r] => t +; unknownTypeError t +; t +; f is ["LISTOF",:l] => +; (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) +; e:= +; f is [op,:argl] and not (t is ["Mapping",:.]) => +; --for MPOLY--replace parameters by formal arguments: RDJ 3/83 +; newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), +; [(x is [":",a,m] => a; x) for x in argl],t) +; signature:= +; ["Mapping",newTarget,: +; [(x is [":",a,m] => m; +; getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]] +; put(op,"mode",signature,e) +; put(f,"mode",t,e) +; if not $bootStrapMode and $insideFunctorIfTrue and +; makeCategoryForm(t,e) is [catform,e] then +; e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) +; ["/throwAway",getmode(f,e),e] + +(DEFUN |compColon| (G170007 |m| |e|) + (PROG (|$lhsOfColon| |f| |t'| |m'| |r| |t| |l| |LETTMP#1| T$ |op| + |argl| |newTarget| |a| |signature| |ISTMP#1| |catform| + |ISTMP#2|) + (DECLARE (SPECIAL |$lhsOfColon|)) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR G170007) '|:|) (CAR G170007))) + (SPADLET |f| (CADR G170007)) + (SPADLET |t| (CADDR G170007)) + (COND + ((BOOT-EQUAL |$insideExpressionIfTrue| 'T) + (|compColonInside| |f| |m| |e| |t|)) + ('T (SPADLET |$lhsOfColon| |f|) + (SPADLET |t| + (COND + ((AND (ATOM |t|) + (SPADLET |t'| + (|assoc| |t| + (|getDomainsInScope| |e|)))) + |t'|) + ((AND (|isDomainForm| |t| |e|) + (NULL |$insideCategoryIfTrue|)) + (COND + ((NULL (|member| |t| + (|getDomainsInScope| |e|))) + (SPADLET |e| (|addDomain| |t| |e|)))) + |t|) + ((OR (|isDomainForm| |t| |e|) + (|isCategoryForm| |t| |e|)) + |t|) + ((AND (PAIRP |t|) (EQ (QCAR |t|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |m'| (QCAR |ISTMP#1|)) + (SPADLET |r| (QCDR |ISTMP#1|)) + 'T)))) + |t|) + ('T (|unknownTypeError| |t|) |t|))) + (COND + ((AND (PAIRP |f|) (EQ (QCAR |f|) 'LISTOF) + (PROGN (SPADLET |l| (QCDR |f|)) 'T)) + (DO ((G170058 |l| (CDR G170058)) (|x| NIL)) + ((OR (ATOM G170058) + (PROGN (SETQ |x| (CAR G170058)) NIL)) + NIL) + (SEQ (EXIT (SPADLET T$ + (PROGN + (SPADLET |LETTMP#1| + (|compColon| + (CONS '|:| + (CONS |x| (CONS |t| NIL))) + |m| |e|)) + (SPADLET |e| + (CADDR |LETTMP#1|)) + |LETTMP#1|))))) + T$) + ('T + (SPADLET |e| + (COND + ((AND (PAIRP |f|) + (PROGN + (SPADLET |op| (QCAR |f|)) + (SPADLET |argl| (QCDR |f|)) + 'T) + (NULL + (AND (PAIRP |t|) + (EQ (QCAR |t|) '|Mapping|)))) + (SPADLET |newTarget| + (EQSUBSTLIST + (TAKE (|#| |argl|) + |$FormalMapVariableList|) + (PROG (G170075) + (SPADLET G170075 NIL) + (RETURN + (DO + ((G170087 |argl| + (CDR G170087)) + (|x| NIL)) + ((OR (ATOM G170087) + (PROGN + (SETQ |x| + (CAR G170087)) + NIL)) + (NREVERSE0 G170075)) + (SEQ + (EXIT + (SETQ G170075 + (CONS + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) + '|:|) + (PROGN + (SPADLET + |ISTMP#1| + (QCDR |x|)) + (AND + (PAIRP + |ISTMP#1|) + (PROGN + (SPADLET + |a| + (QCAR + |ISTMP#1|)) + (SPADLET + |ISTMP#2| + (QCDR + |ISTMP#1|)) + (AND + (PAIRP + |ISTMP#2|) + (EQ + (QCDR + |ISTMP#2|) + NIL) + (PROGN + (SPADLET + |m| + (QCAR + |ISTMP#2|)) + 'T)))))) + |a|) + ('T |x|)) + G170075))))))) + |t|)) + (SPADLET |signature| + (CONS '|Mapping| + (CONS |newTarget| + (PROG (G170104) + (SPADLET G170104 NIL) + (RETURN + (DO + ((G170116 |argl| + (CDR G170116)) + (|x| NIL)) + ((OR (ATOM G170116) + (PROGN + (SETQ |x| + (CAR G170116)) + NIL)) + (NREVERSE0 G170104)) + (SEQ + (EXIT + (SETQ G170104 + (CONS + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) + '|:|) + (PROGN + (SPADLET + |ISTMP#1| + (QCDR |x|)) + (AND + (PAIRP + |ISTMP#1|) + (PROGN + (SPADLET + |a| + (QCAR + |ISTMP#1|)) + (SPADLET + |ISTMP#2| + (QCDR + |ISTMP#1|)) + (AND + (PAIRP + |ISTMP#2|) + (EQ + (QCDR + |ISTMP#2|) + NIL) + (PROGN + (SPADLET + |m| + (QCAR + |ISTMP#2|)) + 'T)))))) + |m|) + ('T + (OR + (|getmode| |x| + |e|) + (|systemErrorHere| + (MAKESTRING + "compColonOld"))))) + G170104)))))))))) + (|put| |op| '|mode| |signature| |e|)) + ('T (|put| |f| '|mode| |t| |e|)))) + (COND + ((AND (NULL |$bootStrapMode|) + |$insideFunctorIfTrue| + (PROGN + (SPADLET |ISTMP#1| + (|makeCategoryForm| |t| |e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |catform| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |e| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |e| + (|put| |f| '|value| + (CONS (|genSomeVariable|) + (CONS |t| (CONS |$noEnv| NIL))) + |e|)))) + (CONS '|/throwAway| + (CONS (|getmode| |f| |e|) (CONS |e| NIL)))))))))))) + +@ +\subsection{unknownTypeError} +<<*>>= +;unknownTypeError name == +; name:= +; name is [op,:.] => op +; name +; stackSemanticError(["%b",name,"%d","is not a known type"],nil) + +(DEFUN |unknownTypeError| (|name|) + (PROG (|op|) + (RETURN + (PROGN + (SPADLET |name| + (COND + ((AND (PAIRP |name|) + (PROGN (SPADLET |op| (QCAR |name|)) 'T)) + |op|) + ('T |name|))) + (|stackSemanticError| + (CONS '|%b| + (CONS |name| + (CONS '|%d| (CONS '|is not a known type| NIL)))) + NIL))))) + +@ +\subsection{compPretend} +<<*>>= +;compPretend(["pretend",x,t],m,e) == +; e:= addDomain(t,e) +; T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil +; if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"] +; $newCompilerUnionFlag and opOf(T.mode) = 'Union and opOf(m) ^= 'Union => +; stackSemanticError(["cannot pretend ",x," of mode ",T.mode," to mode ",m],nil) +; T:= [T.expr,t,T.env] +; T':= coerce(T,m) => (if warningMessage then stackWarning warningMessage; T') + +(DEFUN |compPretend| (G170169 |m| |e|) + (PROG (|x| |t| |warningMessage| T$ |T'|) + (RETURN + (PROGN + (COND ((EQ (CAR G170169) '|pretend|) (CAR G170169))) + (SPADLET |x| (CADR G170169)) + (SPADLET |t| (CADDR G170169)) + (SPADLET |e| (|addDomain| |t| |e|)) + (SPADLET T$ + (OR (|comp| |x| |t| |e|) (|comp| |x| |$EmptyMode| |e|) + (RETURN NIL))) + (COND + ((BOOT-EQUAL (CADR T$) |t|) + (SPADLET |warningMessage| + (CONS '|pretend| + (CONS |t| + (CONS '| -- should replace by @| NIL)))))) + (COND + ((AND |$newCompilerUnionFlag| + (BOOT-EQUAL (|opOf| (CADR T$)) '|Union|) + (NEQUAL (|opOf| |m|) '|Union|)) + (|stackSemanticError| + (CONS '|cannot pretend | + (CONS |x| + (CONS '| of mode | + (CONS (CADR T$) + (CONS '| to mode | + (CONS |m| NIL)))))) + NIL)) + ('T + (SPADLET T$ + (CONS (CAR T$) (CONS |t| (CONS (CADDR T$) NIL)))) + (COND + ((SPADLET |T'| (|coerce| T$ |m|)) + (PROGN + (COND + (|warningMessage| (|stackWarning| |warningMessage|))) + |T'|))))))))) + +@ +\subsection{compColonInside} +<<*>>= +;compColonInside(x,m,e,m') == +; e:= addDomain(m',e) +; T:= comp(x,$EmptyMode,e) or return nil +; if (m'':=T.mode)=m' then warningMessage:= [":",m'," -- should replace by @"] +; T:= [T.expr,m',T.env] +; T':= coerce(T,m) => +; if warningMessage +; then stackWarning warningMessage +; else +; $newCompilerUnionFlag and opOf(m'') = 'Union => +; return +; stackSemanticError(["cannot pretend ",x," of mode ",m''," to mode ",m'],nil) +; stackWarning [":",m'," -- should replace by pretend"] +; T' + +(DEFUN |compColonInside| (|x| |m| |e| |m'|) + (PROG (|m''| |warningMessage| T$ |T'|) + (RETURN + (PROGN + (SPADLET |e| (|addDomain| |m'| |e|)) + (SPADLET T$ (OR (|comp| |x| |$EmptyMode| |e|) (RETURN NIL))) + (COND + ((BOOT-EQUAL (SPADLET |m''| (CADR T$)) |m'|) + (SPADLET |warningMessage| + (CONS '|:| + (CONS |m'| + (CONS '| -- should replace by @| NIL)))))) + (SPADLET T$ (CONS (CAR T$) (CONS |m'| (CONS (CADDR T$) NIL)))) + (COND + ((SPADLET |T'| (|coerce| T$ |m|)) + (PROGN + (COND + (|warningMessage| (|stackWarning| |warningMessage|)) + ((AND |$newCompilerUnionFlag| + (BOOT-EQUAL (|opOf| |m''|) '|Union|)) + (RETURN + (|stackSemanticError| + (CONS '|cannot pretend | + (CONS |x| + (CONS '| of mode | + (CONS |m''| + (CONS '| to mode | + (CONS |m'| NIL)))))) + NIL))) + ('T + (|stackWarning| + (CONS '|:| + (CONS |m'| + (CONS '| -- should replace by pretend| + NIL)))))) + |T'|))))))) + +@ +\subsection{compIs} +<<*>>= +;compIs(["is",a,b],m,e) == +; [aval,am,e] := comp(a,$EmptyMode,e) or return nil +; [bval,bm,e] := comp(b,$EmptyMode,e) or return nil +; T:= [["domainEqual",aval,bval],$Boolean,e] +; coerce(T,m) + +(DEFUN |compIs| (G170221 |m| |e|) + (PROG (|a| |b| |aval| |am| |LETTMP#1| |bval| |bm| T$) + (RETURN + (PROGN + (COND ((EQ (CAR G170221) '|is|) (CAR G170221))) + (SPADLET |a| (CADR G170221)) + (SPADLET |b| (CADDR G170221)) + (SPADLET |LETTMP#1| + (OR (|comp| |a| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |aval| (CAR |LETTMP#1|)) + (SPADLET |am| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (OR (|comp| |b| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |bval| (CAR |LETTMP#1|)) + (SPADLET |bm| (CADR |LETTMP#1|)) + (SPADLET |e| (CADDR |LETTMP#1|)) + (SPADLET T$ + (CONS (CONS '|domainEqual| + (CONS |aval| (CONS |bval| NIL))) + (CONS |$Boolean| (CONS |e| NIL)))) + (|coerce| T$ |m|))))) + +@ +\section{Functions for coercion by the compiler} +\subsection{coerce} +The function coerce is used by the old compiler for coercions. +The function coerceInteractive is used by the interpreter. +One should always call the correct function, since the representation +of basic objects may not be the same. +<<*>>= +;coerce(T,m) == +; $InteractiveMode => +; keyedSystemError("S2GE0016",['"coerce", +; '"function coerce called from the interpreter."]) +; rplac(CADR T,substitute("$",$Rep,CADR T)) +; T':= coerceEasy(T,m) => T' +; T':= coerceSubset(T,m) => T' +; T':= coerceHard(T,m) => T' +; T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil +; stackMessage fn(T.expr,T.mode,m) where +; -- if from from coerceable, this coerce was just a trial coercion +; -- from compFormWithModemap to filter through the modemaps +; fn(x,m1,m2) == +; ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l", +; " to mode","%b",m2,"%d"] + +(DEFUN |coerce,fn| (|x| |m1| |m2|) + (CONS '|Cannot coerce| + (CONS '|%b| + (CONS |x| + (CONS '|%d| + (CONS '|%l| + (CONS '| of mode| + (CONS '|%b| + (CONS |m1| + (CONS '|%d| + (CONS '|%l| + (CONS '| to mode| + (CONS '|%b| + (CONS |m2| + (CONS '|%d| NIL))))))))))))))) + + +(DEFUN |coerce| (T$ |m|) + (PROG (|T'|) + (RETURN + (COND + (|$InteractiveMode| + (|keyedSystemError| 'S2GE0016 + (CONS (MAKESTRING "coerce") + (CONS (MAKESTRING + "function coerce called from the interpreter.") + NIL)))) + ('T (|rplac| (CADR T$) (MSUBST '$ |$Rep| (CADR T$))) + (COND + ((SPADLET |T'| (|coerceEasy| T$ |m|)) |T'|) + ((SPADLET |T'| (|coerceSubset| T$ |m|)) |T'|) + ((SPADLET |T'| (|coerceHard| T$ |m|)) |T'|) + ((OR (BOOT-EQUAL (CAR T$) '|$fromCoerceable$|) + (|isSomeDomainVariable| |m|)) + NIL) + ('T (|stackMessage| (|coerce,fn| (CAR T$) (CADR T$) |m|))))))))) + +@ +\subsection{coerceEasy} +<<*>>= +;coerceEasy(T,m) == +; m=$EmptyMode => T +; m=$NoValueMode or m=$Void => [T.expr,m,T.env] +; T.mode =m => T +; T.mode =$NoValueMode => T +; T.mode =$Exit => +; [["PROGN", T.expr, ["userError", '"Did not really exit."]], +; m,T.env] +; T.mode=$EmptyMode or modeEqualSubst(T.mode,m,T.env) => +; [T.expr,m,T.env] + +(DEFUN |coerceEasy| (T$ |m|) + (COND + ((BOOT-EQUAL |m| |$EmptyMode|) T$) + ((OR (BOOT-EQUAL |m| |$NoValueMode|) (BOOT-EQUAL |m| |$Void|)) + (CONS (CAR T$) (CONS |m| (CONS (CADDR T$) NIL)))) + ((BOOT-EQUAL (CADR T$) |m|) T$) + ((BOOT-EQUAL (CADR T$) |$NoValueMode|) T$) + ((BOOT-EQUAL (CADR T$) |$Exit|) + (CONS (CONS 'PROGN + (CONS (CAR T$) + (CONS (CONS '|userError| + (CONS + (MAKESTRING "Did not really exit.") + NIL)) + NIL))) + (CONS |m| (CONS (CADDR T$) NIL)))) + ((OR (BOOT-EQUAL (CADR T$) |$EmptyMode|) + (|modeEqualSubst| (CADR T$) |m| (CADDR T$))) + (CONS (CAR T$) (CONS |m| (CONS (CADDR T$) NIL)))))) + +@ +\subsection{coerceSubset} +<<*>>= +;coerceSubset([x,m,e],m') == +; isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] +; m is ['SubDomain,=m',:.] => [x,m',e] +; (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and +; -- obviously this is temporary +; eval substitute(x,"#1",pred) => [x,m',e] +; (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary +; and eval substitute(x,"*",pred) => +; [x,m',e] +; nil + +(DEFUN |coerceSubset| (G170274 |m'|) + (PROG (|x| |m| |e| |ISTMP#1| |pred|) + (RETURN + (PROGN + (SPADLET |x| (CAR G170274)) + (SPADLET |m| (CADR G170274)) + (SPADLET |e| (CADDR G170274)) + (COND + ((OR (|isSubset| |m| |m'| |e|) + (AND (BOOT-EQUAL |m| '|Rep|) (BOOT-EQUAL |m'| '$))) + (CONS |x| (CONS |m'| (CONS |e| NIL)))) + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|SubDomain|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |m'|)))) + (CONS |x| (CONS |m'| (CONS |e| NIL)))) + ((AND (SPADLET |pred| + (LASSOC (|opOf| |m'|) + (|get| (|opOf| |m|) '|SubDomain| |e|))) + (INTEGERP |x|) (|eval| (MSUBST |x| '|#1| |pred|))) + (CONS |x| (CONS |m'| (CONS |e| NIL)))) + ((AND (SPADLET |pred| + (|isSubset| |m'| (|maxSuperType| |m| |e|) |e|)) + (INTEGERP |x|) (|eval| (MSUBST |x| '* |pred|))) + (CONS |x| (CONS |m'| (CONS |e| NIL)))) + ('T NIL)))))) + +@ +\subsection{coerceHard} +<<*>>= +;coerceHard(T,m) == +; $e: local:= T.env +; m':= T.mode +; STRINGP m' and modeEqual(m,$String) => [T.expr,m,$e] +; modeEqual(m',m) or +; (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and +; modeEqual(m'',m) or +; (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and +; modeEqual(m'',m') => [T.expr,m,T.env] +; STRINGP T.expr and T.expr=m => [T.expr,m,$e] +; isCategoryForm(m,$e) => +; $bootStrapMode = true => [T.expr,m,$e] +; extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e] +; coerceExtraHard(T,m) +; coerceExtraHard(T,m) + +(DEFUN |coerceHard| (T$ |m|) + (PROG (|$e| |m'| |ISTMP#1| |ISTMP#2| |m''|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (PROGN + (SPADLET |$e| (CADDR T$)) + (SPADLET |m'| (CADR T$)) + (COND + ((AND (STRINGP |m'|) (|modeEqual| |m| |$String|)) + (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) + ((OR (|modeEqual| |m'| |m|) + (AND (OR (PROGN + (SPADLET |ISTMP#1| + (|get| |m'| '|value| |$e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |m''| (QCAR |ISTMP#1|)) + 'T))) + (PROGN + (SPADLET |ISTMP#1| (|getmode| |m'| |$e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |m''| + (QCAR |ISTMP#2|)) + 'T)))))) + (|modeEqual| |m''| |m|)) + (AND (OR (PROGN + (SPADLET |ISTMP#1| (|get| |m| '|value| |$e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |m''| (QCAR |ISTMP#1|)) + 'T))) + (PROGN + (SPADLET |ISTMP#1| (|getmode| |m| |$e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |m''| + (QCAR |ISTMP#2|)) + 'T)))))) + (|modeEqual| |m''| |m'|))) + (CONS (CAR T$) (CONS |m| (CONS (CADDR T$) NIL)))) + ((AND (STRINGP (CAR T$)) (BOOT-EQUAL (CAR T$) |m|)) + (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) + ((|isCategoryForm| |m| |$e|) + (COND + ((BOOT-EQUAL |$bootStrapMode| 'T) + (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) + ((|extendsCategoryForm| (CAR T$) (CADR T$) |m|) + (CONS (CAR T$) (CONS |m| (CONS |$e| NIL)))) + ('T (|coerceExtraHard| T$ |m|)))) + ('T (|coerceExtraHard| T$ |m|))))))) + +@ +\subsection{coerceExtraHard} +<<*>>= +;coerceExtraHard(T is [x,m',e],m) == +; T':= autoCoerceByModemap(T,m) => T' +; isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and +; MEMBER(t,l) and (T':= autoCoerceByModemap(T,t)) and +; (T'':= coerce(T',m)) => T'' +; m' is ['Record,:.] and m = $Expression => +; [['coerceRe2E,x,['ELT,COPY m',0]],m,e] +; nil + +(DEFUN |coerceExtraHard| (T$ |m|) + (PROG (|x| |m'| |e| |ISTMP#1| |l| |t| |T'| |T''|) + (RETURN + (PROGN + (SPADLET |x| (CAR T$)) + (SPADLET |m'| (CADR T$)) + (SPADLET |e| (CADDR T$)) + (COND + ((SPADLET |T'| (|autoCoerceByModemap| T$ |m|)) |T'|) + ((AND (PROGN + (SPADLET |ISTMP#1| (|isUnionMode| |m'| |e|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|Union|) + (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T))) + (SPADLET |t| (|hasType| |x| |e|)) (|member| |t| |l|) + (SPADLET |T'| (|autoCoerceByModemap| T$ |t|)) + (SPADLET |T''| (|coerce| |T'| |m|))) + |T''|) + ((AND (PAIRP |m'|) (EQ (QCAR |m'|) '|Record|) + (BOOT-EQUAL |m| |$Expression|)) + (CONS (CONS '|coerceRe2E| + (CONS |x| + (CONS (CONS 'ELT + (CONS (COPY |m'|) (CONS 0 NIL))) + NIL))) + (CONS |m| (CONS |e| NIL)))) + ('T NIL)))))) + +@ +\subsection{coerceable} +<<*>>= +;coerceable(m,m',e) == +; m=m' => m +; -- must find any free parameters in m +; sl:= pmatch(m',m) => SUBLIS(sl,m') +; coerce(["$fromCoerceable$",m,e],m') => m' +; nil + +(DEFUN |coerceable| (|m| |m'| |e|) + (PROG (|sl|) + (RETURN + (COND + ((BOOT-EQUAL |m| |m'|) |m|) + ((SPADLET |sl| (|pmatch| |m'| |m|)) (SUBLIS |sl| |m'|)) + ((|coerce| (CONS '|$fromCoerceable$| (CONS |m| (CONS |e| NIL))) + |m'|) + |m'|) + ('T NIL))))) + +@ +\subsection{coerceExit} +<<*>>= +;coerceExit([x,m,e],m') == +; m':= resolve(m,m') +; x':= replaceExitEtc(x,catchTag:= MKQ GENSYM(),"TAGGEDexit",$exitMode) +; coerce([["CATCH",catchTag,x'],m,e],m') + +(DEFUN |coerceExit| (G170380 |m'|) + (PROG (|x| |m| |e| |catchTag| |x'|) + (RETURN + (PROGN + (SPADLET |x| (CAR G170380)) + (SPADLET |m| (CADR G170380)) + (SPADLET |e| (CADDR G170380)) + (SPADLET |m'| (|resolve| |m| |m'|)) + (SPADLET |x'| + (|replaceExitEtc| |x| + (SPADLET |catchTag| (MKQ (GENSYM))) '|TAGGEDexit| + |$exitMode|)) + (|coerce| + (CONS (CONS 'CATCH (CONS |catchTag| (CONS |x'| NIL))) + (CONS |m| (CONS |e| NIL))) + |m'|))))) + +@ +\subsection{compAtSign} +<<*>>= +;compAtSign(["@",x,m'],m,e) == +; e:= addDomain(m',e) +; T:= comp(x,m',e) or return nil +; coerce(T,m) + +(DEFUN |compAtSign| (G170401 |m| |e|) + (PROG (|x| |m'| T$) + (RETURN + (PROGN + (COND ((EQ (CAR G170401) '@) (CAR G170401))) + (SPADLET |x| (CADR G170401)) + (SPADLET |m'| (CADDR G170401)) + (SPADLET |e| (|addDomain| |m'| |e|)) + (SPADLET T$ (OR (|comp| |x| |m'| |e|) (RETURN NIL))) + (|coerce| T$ |m|))))) + +@ +\subsection{compCoerce} +<<*>>= +;compCoerce(["::",x,m'],m,e) == +; e:= addDomain(m',e) +; T:= compCoerce1(x,m',e) => coerce(T,m) +; getmode(m',e) is ["Mapping",["UnionCategory",:l]] => +; T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil +; coerce([T.expr,m',T.env],m) + +(DEFUN |compCoerce| (G170439 |m| |e|) + (PROG (|x| |m'| |ISTMP#1| |ISTMP#2| |ISTMP#3| |l| T$) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR G170439) '|::|) (CAR G170439))) + (SPADLET |x| (CADR G170439)) + (SPADLET |m'| (CADDR G170439)) + (SPADLET |e| (|addDomain| |m'| |e|)) + (COND + ((SPADLET T$ (|compCoerce1| |x| |m'| |e|)) + (|coerce| T$ |m|)) + ((PROGN + (SPADLET |ISTMP#1| (|getmode| |m'| |e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) + '|UnionCategory|) + (PROGN + (SPADLET |l| (QCDR |ISTMP#3|)) + 'T))))))) + (SPADLET T$ + (OR (PROG (G170458) + (SPADLET G170458 NIL) + (RETURN + (DO ((G170464 NIL G170458) + (G170465 |l| (CDR G170465)) + (|m1| NIL)) + ((OR G170464 (ATOM G170465) + (PROGN + (SETQ |m1| (CAR G170465)) + NIL)) + G170458) + (SEQ + (EXIT + (SETQ G170458 + (OR G170458 + (|compCoerce1| |x| |m1| |e|)))))))) + (RETURN NIL))) + (|coerce| + (CONS (CAR T$) (CONS |m'| (CONS (CADDR T$) NIL))) + |m|)))))))) + +@ +\subsection{compCoerce1} +<<*>>= +;compCoerce1(x,m',e) == +; T:= comp(x,m',e) or comp(x,$EmptyMode,e) or return nil +; m1:= +; STRINGP T.mode => $String +; T.mode +; m':=resolve(m1,m') +; T:=[T.expr,m1,T.env] +; T':= coerce(T,m') => T' +; T':= coerceByModemap(T,m') => T' +; pred:=isSubset(m',T.mode,e) => +; gg:=GENSYM() +; pred:= substitute(gg,"*",pred) +; code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] +; [code,m',T.env] + +(DEFUN |compCoerce1| (|x| |m'| |e|) + (PROG (|m1| T$ |T'| |gg| |pred| |code|) + (RETURN + (PROGN + (SPADLET T$ + (OR (|comp| |x| |m'| |e|) + (|comp| |x| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |m1| + (COND ((STRINGP (CADR T$)) |$String|) ('T (CADR T$)))) + (SPADLET |m'| (|resolve| |m1| |m'|)) + (SPADLET T$ (CONS (CAR T$) (CONS |m1| (CONS (CADDR T$) NIL)))) + (COND + ((SPADLET |T'| (|coerce| T$ |m'|)) |T'|) + ((SPADLET |T'| (|coerceByModemap| T$ |m'|)) |T'|) + ((SPADLET |pred| (|isSubset| |m'| (CADR T$) |e|)) + (PROGN + (SPADLET |gg| (GENSYM)) + (SPADLET |pred| (MSUBST |gg| '* |pred|)) + (SPADLET |code| + (CONS 'PROG1 + (CONS (CONS 'LET + (CONS |gg| (CONS (CAR T$) NIL))) + (CONS (CONS '|check-subtype| + (CONS |pred| + (CONS (MKQ |m'|) + (CONS |gg| NIL)))) + NIL)))) + (CONS |code| (CONS |m'| (CONS (CADDR T$) NIL)))))))))) + +@ +\subsection{coerceByModemap} +<<*>>= +;coerceByModemap([x,m,e],m') == +;--+ modified 6/27 for new runtime system +; u:= +; [modemap +; for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t, +; s] and (modeEqual(t,m') or isSubset(t,m',e)) +; and (modeEqual(s,m) or isSubset(m,s,e))] or return nil +; --mm:= (or/[mm for (mm:=[.,[cond,.]]) in u | cond=true]) or return nil +; mm:=first u -- patch for non-trival conditons +; fn := +; genDeltaEntry ['coerce,:mm] +; [["call",fn,x],m',e] + +(DEFUN |coerceByModemap| (G170521 |m'|) + (PROG (|x| |m| |e| |map| |cexpr| |ISTMP#1| |t| |ISTMP#2| |s| |u| |mm| + |fn|) + (RETURN + (SEQ (PROGN + (SPADLET |x| (CAR G170521)) + (SPADLET |m| (CADR G170521)) + (SPADLET |e| (CADDR G170521)) + (SPADLET |u| + (OR (PROG (G170548) + (SPADLET G170548 NIL) + (RETURN + (DO ((G170555 + (|getModemapList| '|coerce| 1 |e|) + (CDR G170555)) + (|modemap| NIL)) + ((OR (ATOM G170555) + (PROGN + (SETQ |modemap| (CAR G170555)) + NIL) + (PROGN + (PROGN + (SPADLET |map| (CAR |modemap|)) + (SPADLET |cexpr| + (CADR |modemap|)) + |modemap|) + NIL)) + (NREVERSE0 G170548)) + (SEQ (EXIT + (COND + ((AND (PAIRP |map|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |map|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |t| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |s| + (QCAR |ISTMP#2|)) + 'T))))) + (OR (|modeEqual| |t| |m'|) + (|isSubset| |t| |m'| |e|)) + (OR (|modeEqual| |s| |m|) + (|isSubset| |m| |s| |e|))) + (SETQ G170548 + (CONS |modemap| G170548))))))))) + (RETURN NIL))) + (SPADLET |mm| (CAR |u|)) + (SPADLET |fn| (|genDeltaEntry| (CONS '|coerce| |mm|))) + (CONS (CONS '|call| (CONS |fn| (CONS |x| NIL))) + (CONS |m'| (CONS |e| NIL)))))))) + +@ +\subsection{autoCoerceByModemap} +<<*>>= +;autoCoerceByModemap([x,source,e],target) == +; u:= +; [cexpr +; for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ +; .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil +; fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil +; source is ["Union",:l] and MEMBER(target,l) => +; (y:= get(x,"condition",e)) and (or/[u is ["case",., =target] for u in y]) +; => [["call",fn,x],target,e] +; x="$fromCoerceable$" => nil +; stackMessage ["cannot coerce: ",x,"%l"," of mode: ",source,"%l", +; " to: ",target," without a case statement"] +; [["call",fn,x],target,e] + +(DEFUN |autoCoerceByModemap| (G170609 |target|) + (PROG (|x| |source| |e| |map| |cexpr| |t| |s| |u| |cond| |selfn| |fn| + |l| |y| |ISTMP#1| |ISTMP#2|) + (RETURN + (SEQ (PROGN + (SPADLET |x| (CAR G170609)) + (SPADLET |source| (CADR G170609)) + (SPADLET |e| (CADDR G170609)) + (SPADLET |u| + (OR (PROG (G170645) + (SPADLET G170645 NIL) + (RETURN + (DO ((G170652 + (|getModemapList| '|autoCoerce| 1 + |e|) + (CDR G170652)) + (|modemap| NIL)) + ((OR (ATOM G170652) + (PROGN + (SETQ |modemap| (CAR G170652)) + NIL) + (PROGN + (PROGN + (SPADLET |map| (CAR |modemap|)) + (SPADLET |cexpr| + (CADR |modemap|)) + |modemap|) + NIL)) + (NREVERSE0 G170645)) + (SEQ (EXIT + (COND + ((AND (PAIRP |map|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |map|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |t| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |s| + (QCAR |ISTMP#2|)) + 'T))))) + (|modeEqual| |t| |target|) + (|modeEqual| |s| |source|)) + (SETQ G170645 + (CONS |cexpr| G170645))))))))) + (RETURN NIL))) + (SPADLET |fn| + (OR (PROG (G170659) + (SPADLET G170659 NIL) + (RETURN + (DO ((G170667 NIL G170659) + (G170668 |u| (CDR G170668)) + (G170597 NIL)) + ((OR G170667 (ATOM G170668) + (PROGN + (SETQ G170597 (CAR G170668)) + NIL) + (PROGN + (PROGN + (SPADLET |cond| + (CAR G170597)) + (SPADLET |selfn| + (CADR G170597)) + G170597) + NIL)) + G170659) + (SEQ (EXIT + (COND + ((BOOT-EQUAL |cond| 'T) + (SETQ G170659 + (OR G170659 |selfn|))))))))) + (RETURN NIL))) + (COND + ((AND (PAIRP |source|) (EQ (QCAR |source|) '|Union|) + (PROGN (SPADLET |l| (QCDR |source|)) 'T) + (|member| |target| |l|)) + (COND + ((AND (SPADLET |y| (|get| |x| '|condition| |e|)) + (PROG (G170676) + (SPADLET G170676 NIL) + (RETURN + (DO ((G170686 NIL G170676) + (G170687 |y| (CDR G170687)) + (|u| NIL)) + ((OR G170686 (ATOM G170687) + (PROGN + (SETQ |u| (CAR G170687)) + NIL)) + G170676) + (SEQ (EXIT + (SETQ G170676 + (OR G170676 + (AND (PAIRP |u|) + (EQ (QCAR |u|) '|case|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (EQUAL (QCAR |ISTMP#2|) + |target|)))))))))))))) + (CONS (CONS '|call| (CONS |fn| (CONS |x| NIL))) + (CONS |target| (CONS |e| NIL)))) + ((BOOT-EQUAL |x| '|$fromCoerceable$|) NIL) + ('T + (|stackMessage| + (CONS '|cannot coerce: | + (CONS |x| + (CONS '|%l| + (CONS '| of mode: | + (CONS |source| + (CONS '|%l| + (CONS '| to: | + (CONS |target| + (CONS + '| without a case statement| + NIL))))))))))))) + ('T + (CONS (CONS '|call| (CONS |fn| (CONS |x| NIL))) + (CONS |target| (CONS |e| NIL)))))))))) + +@ +\subsection{resolve} +Very old resolve +should only be used in the old (preWATT) compiler +<<*>>= +;resolve(din,dout) == +; din=$NoValueMode or dout=$NoValueMode => $NoValueMode +; dout=$EmptyMode => din +; din^=dout and (STRINGP din or STRINGP dout) => +; modeEqual(dout,$String) => dout +; modeEqual(din,$String) => nil +; mkUnion(din,dout) +; dout + +(DEFUN |resolve| (|din| |dout|) + (COND + ((OR (BOOT-EQUAL |din| |$NoValueMode|) + (BOOT-EQUAL |dout| |$NoValueMode|)) + |$NoValueMode|) + ((BOOT-EQUAL |dout| |$EmptyMode|) |din|) + ((AND (NEQUAL |din| |dout|) (OR (STRINGP |din|) (STRINGP |dout|))) + (COND + ((|modeEqual| |dout| |$String|) |dout|) + ((|modeEqual| |din| |$String|) NIL) + ('T (|mkUnion| |din| |dout|)))) + ('T |dout|))) + +@ +\subsection{modeEqual} +<<*>>= +;modeEqual(x,y) == +; -- this is the late modeEqual +; -- orders Unions +; atom x or atom y => x=y +; #x ^=#y => nil +; x is ['Union,:xl] and y is ['Union,:yl] => +; for x1 in xl repeat +; for y1 in yl repeat +; modeEqual(x1,y1) => +; xl := DELETE(x1,xl) +; yl := DELETE(y1,yl) +; return nil +; xl or yl => nil +; true +; (and/[modeEqual(u,v) for u in x for v in y]) + +(DEFUN |modeEqual| (|x| |y|) + (PROG (|xl| |yl|) + (RETURN + (SEQ (COND + ((OR (ATOM |x|) (ATOM |y|)) (BOOT-EQUAL |x| |y|)) + ((NEQUAL (|#| |x|) (|#| |y|)) NIL) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Union|) + (PROGN (SPADLET |xl| (QCDR |x|)) 'T) (PAIRP |y|) + (EQ (QCAR |y|) '|Union|) + (PROGN (SPADLET |yl| (QCDR |y|)) 'T)) + (SEQ (DO ((G170731 |xl| (CDR G170731)) (|x1| NIL)) + ((OR (ATOM G170731) + (PROGN (SETQ |x1| (CAR G170731)) NIL)) + NIL) + (SEQ (EXIT (DO ((G170743 |yl| (CDR G170743)) + (|y1| NIL)) + ((OR (ATOM G170743) + (PROGN + (SETQ |y1| (CAR G170743)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((|modeEqual| |x1| |y1|) + (EXIT + (PROGN + (SPADLET |xl| + (|delete| |x1| |xl|)) + (SPADLET |yl| + (|delete| |y1| |yl|)) + (RETURN NIL))))))))))) + (COND ((OR |xl| |yl|) NIL) ('T 'T)))) + ('T + (PROG (G170749) + (SPADLET G170749 'T) + (RETURN + (DO ((G170756 NIL (NULL G170749)) + (G170757 |x| (CDR G170757)) (|u| NIL) + (G170758 |y| (CDR G170758)) (|v| NIL)) + ((OR G170756 (ATOM G170757) + (PROGN (SETQ |u| (CAR G170757)) NIL) + (ATOM G170758) + (PROGN (SETQ |v| (CAR G170758)) NIL)) + G170749) + (SEQ (EXIT (SETQ G170749 + (AND G170749 + (|modeEqual| |u| |v|)))))))))))))) + +@ +\subsection{modeEqualSubst} +<<*>>= +;modeEqualSubst(m1,m,e) == +; modeEqual(m1, m) => true +; atom m1 => get(m1,"value",e) is [m',:.] and modeEqual(m',m) +; m1 is [op,:l1] and m is [=op,:l2] and # l1 = # l2 => +;-- Above length test inserted JHD 4:47 on 15/8/86 +;-- Otherwise Records can get fouled up - consider expressIdealElt +;-- in the DEFAULTS package +; and/[modeEqualSubst(xm1,xm2,e) for xm1 in l1 for xm2 in l2] +; nil + +(DEFUN |modeEqualSubst| (|m1| |m| |e|) + (PROG (|ISTMP#1| |m'| |op| |l1| |l2|) + (RETURN + (SEQ (COND + ((|modeEqual| |m1| |m|) 'T) + ((ATOM |m1|) + (AND (PROGN + (SPADLET |ISTMP#1| (|get| |m1| '|value| |e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |m'| (QCAR |ISTMP#1|)) 'T))) + (|modeEqual| |m'| |m|))) + ((AND (PAIRP |m1|) + (PROGN + (SPADLET |op| (QCAR |m1|)) + (SPADLET |l1| (QCDR |m1|)) + 'T) + (PAIRP |m|) (EQUAL (QCAR |m|) |op|) + (PROGN (SPADLET |l2| (QCDR |m|)) 'T) + (BOOT-EQUAL (|#| |l1|) (|#| |l2|))) + (PROG (G170784) + (SPADLET G170784 'T) + (RETURN + (DO ((G170791 NIL (NULL G170784)) + (G170792 |l1| (CDR G170792)) (|xm1| NIL) + (G170793 |l2| (CDR G170793)) (|xm2| NIL)) + ((OR G170791 (ATOM G170792) + (PROGN (SETQ |xm1| (CAR G170792)) NIL) + (ATOM G170793) + (PROGN (SETQ |xm2| (CAR G170793)) NIL)) + G170784) + (SEQ (EXIT (SETQ G170784 + (AND G170784 + (|modeEqualSubst| |xm1| |xm2| + |e|))))))))) + ('T NIL)))))) + +@ +\subsection{convertSpadToAsFile} +<<*>>= +;convertSpadToAsFile path == +; -- can assume path has type = .spad +; $globalMacroStack : local := nil -- for spad -> as translator +; $abbreviationStack: local := nil -- for spad -> as translator +; $macrosAlreadyPrinted: local := nil -- for spad -> as translator +; SETQ($badStack, nil) --ditto TEMP to check for bad code +; $newPaths: local := true --ditto TEMP +; $abbreviationsAlreadyPrinted: local := nil -- for spad -> as translator +; $convertingSpadFile : local := true +; $options: local := '((nolib)) -- translator shouldn't create nrlibs +; SETQ(HT,MAKE_-HASHTABLE 'UEQUAL) +; newName := fnameMake(pathnameDirectory path, pathnameName path, '"as") +; canDoIt := true +; if not fnameWritable? newName then +; sayKeyedMsg("S2IZ0086", [NAMESTRING newName]) +; newName := fnameMake('".", pathnameName path, '"as") +; if not fnameWritable? newName then +; sayKeyedMsg("S2IZ0087", [NAMESTRING newName]) +; canDoIt := false +; not canDoIt => 'failure +; sayKeyedMsg("S2IZ0088", [NAMESTRING newName]) +; $outStream :local := MAKE_-OUTSTREAM newName +; markSay('"#include _"axiom.as_"") +; markTerpri() +; CATCH("SPAD__READER",compiler [path]) +; SHUT $outStream +; mkCheck() +; 'done + +(DEFUN |convertSpadToAsFile| (|path|) + (PROG (|$globalMacroStack| |$abbreviationStack| + |$macrosAlreadyPrinted| |$newPaths| + |$abbreviationsAlreadyPrinted| |$convertingSpadFile| + |$options| |$outStream| |newName| |canDoIt|) + (DECLARE (SPECIAL |$globalMacroStack| |$abbreviationStack| + |$macrosAlreadyPrinted| |$newPaths| + |$abbreviationsAlreadyPrinted| + |$convertingSpadFile| |$options| |$outStream|)) + (RETURN + (PROGN + (SPADLET |$globalMacroStack| NIL) + (SPADLET |$abbreviationStack| NIL) + (SPADLET |$macrosAlreadyPrinted| NIL) + (SETQ |$badStack| NIL) + (SPADLET |$newPaths| 'T) + (SPADLET |$abbreviationsAlreadyPrinted| NIL) + (SPADLET |$convertingSpadFile| 'T) + (SPADLET |$options| '((|nolib|))) + (SETQ HT (MAKE-HASHTABLE 'UEQUAL)) + (SPADLET |newName| + (|fnameMake| (|pathnameDirectory| |path|) + (|pathnameName| |path|) (MAKESTRING "as"))) + (SPADLET |canDoIt| 'T) + (COND + ((NULL (|fnameWritable?| |newName|)) + (|sayKeyedMsg| 'S2IZ0086 (CONS (NAMESTRING |newName|) NIL)) + (SPADLET |newName| + (|fnameMake| (MAKESTRING ".") + (|pathnameName| |path|) (MAKESTRING "as"))) + (COND + ((NULL (|fnameWritable?| |newName|)) + (|sayKeyedMsg| 'S2IZ0087 + (CONS (NAMESTRING |newName|) NIL)) + (SPADLET |canDoIt| NIL)) + ('T NIL)))) + (COND + ((NULL |canDoIt|) '|failure|) + ('T + (|sayKeyedMsg| 'S2IZ0088 (CONS (NAMESTRING |newName|) NIL)) + (SPADLET |$outStream| (MAKE-OUTSTREAM |newName|)) + (|markSay| (MAKESTRING "#include \"axiom.as\"")) + (|markTerpri|) + (CATCH 'SPAD_READER (|compiler| (CONS |path| NIL))) + (SHUT |$outStream|) (|mkCheck|) '|done|)))))) + +@ +\subsection{compilerDoit} +<<*>>= +;compilerDoit(constructor, fun) == +; $byConstructors : local := [] +; $constructorsSeen : local := [] +; fun = ['rf, 'lib] => _/RQ_,LIB() -- Ignore "noquiet". +; fun = ['rf, 'nolib] => _/RF() +; fun = ['rq, 'lib] => _/RQ_,LIB() +; fun = ['rq, 'nolib] => _/RQ() +; fun = ['c, 'lib] => +; $byConstructors := [opOf x for x in constructor] +; _/RQ_,LIB() +; for ii in $byConstructors repeat +; null MEMBER(ii,$constructorsSeen) => +; sayBrightly ['">>> Warning ",'%b,ii,'%d,'" was not found"] + +(DEFUN |compilerDoit| (|constructor| |fun|) + (PROG (|$byConstructors| |$constructorsSeen|) + (DECLARE (SPECIAL |$byConstructors| |$constructorsSeen|)) + (RETURN + (SEQ (PROGN + (SPADLET |$byConstructors| NIL) + (SPADLET |$constructorsSeen| NIL) + (COND + ((BOOT-EQUAL |fun| (CONS '|rf| (CONS '|lib| NIL))) + (|/RQ,LIB|)) + ((BOOT-EQUAL |fun| (CONS '|rf| (CONS '|nolib| NIL))) + (/RF)) + ((BOOT-EQUAL |fun| (CONS '|rq| (CONS '|lib| NIL))) + (|/RQ,LIB|)) + ((BOOT-EQUAL |fun| (CONS '|rq| (CONS '|nolib| NIL))) + (/RQ)) + ((BOOT-EQUAL |fun| (CONS '|c| (CONS '|lib| NIL))) + (PROGN + (SPADLET |$byConstructors| + (PROG (G170852) + (SPADLET G170852 NIL) + (RETURN + (DO ((G170857 |constructor| + (CDR G170857)) + (|x| NIL)) + ((OR (ATOM G170857) + (PROGN + (SETQ |x| (CAR G170857)) + NIL)) + (NREVERSE0 G170852)) + (SEQ (EXIT + (SETQ G170852 + (CONS (|opOf| |x|) G170852)))))))) + (|/RQ,LIB|) + (SEQ (DO ((G170866 |$byConstructors| + (CDR G170866)) + (|ii| NIL)) + ((OR (ATOM G170866) + (PROGN + (SETQ |ii| (CAR G170866)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL + (|member| |ii| + |$constructorsSeen|)) + (EXIT + (|sayBrightly| + (CONS + (MAKESTRING ">>> Warning ") + (CONS '|%b| + (CONS |ii| + (CONS '|%d| + (CONS + (MAKESTRING + " was not found") + NIL))))))))))))))))))))) + +@ +\subsection{compilerDoitWithScreenedLisplib} +<<*>>= +;compilerDoitWithScreenedLisplib(constructor, fun) == +; EMBED('RWRITE, +; '(LAMBDA (KEY VALUE STREAM) +; (COND ((AND (EQ STREAM $libFile) +; (NOT (MEMBER KEY $saveableItems))) +; VALUE) +; ((NOT NIL) +; (RWRITE KEY VALUE STREAM)))) ) +; UNWIND_-PROTECT(compilerDoit(constructor,fun), +; SEQ(UNEMBED 'RWRITE)) + +(DEFUN |compilerDoitWithScreenedLisplib| (|constructor| |fun|) + (PROGN + (EMBED 'RWRITE + '(LAMBDA (KEY VALUE STREAM) + (COND + ((AND (EQ STREAM |$libFile|) + (NOT (MEMBER KEY |$saveableItems|))) + VALUE) + ((NOT NIL) (RWRITE KEY VALUE STREAM))))) + (UNWIND-PROTECT + (|compilerDoit| |constructor| |fun|) + (UNEMBED 'RWRITE)))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}