diff --git a/changelog b/changelog index cd38104..cb533bc 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090822 tpd src/axiom-website/patches.html 20090822.04.tpd.patch +20090822 tpd src/interp/Makefile move i-spec1.boot to i-spec1.lisp +20090822 tpd src/interp/i-spec1.lisp added, rewritten from i-spec1.boot +20090822 tpd src/interp/i-spec1.boot removed, rewritten to i-spec1.lisp 20090822 tpd src/axiom-website/patches.html 20090822.03.tpd.patch 20090822 tpd src/interp/Makefile move i-resolv.boot to i-resolv.lisp 20090822 tpd src/interp/i-resolv.lisp added, rewritten from i-resolv.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index eb550f4..d166aca 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1840,5 +1840,7 @@ i-map.lisp rewrite from boot to lisp
i-output.lisp rewrite from boot to lisp
20090822.03.tpd.patch i-resolv.lisp rewrite from boot to lisp
+20090822.04.tpd.patch +i-spec1.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index cfbf1b5..8f22799 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -431,7 +431,7 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/info.boot.dvi ${DOC}/interop.boot.dvi \ ${DOC}/intfile.boot.dvi \ ${DOC}/intint.lisp.dvi ${DOC}/int-top.boot.dvi \ - ${DOC}/i-spec1.boot.dvi ${DOC}/i-spec2.boot.dvi \ + ${DOC}/i-spec2.boot.dvi \ ${DOC}/i-syscmd.boot.dvi ${DOC}/iterator.boot.dvi \ ${DOC}/i-toplev.boot.dvi ${DOC}/i-util.boot.dvi \ ${DOC}/lisplib.boot.dvi ${DOC}/macex.boot.dvi \ @@ -3318,46 +3318,27 @@ ${MID}/i-resolv.lisp: ${IN}/i-resolv.lisp.pamphlet @ -\subsection{i-spec1.boot} +\subsection{i-spec1.lisp} <>= -${OUT}/i-spec1.${O}: ${MID}/i-spec1.clisp - @ echo 312 making ${OUT}/i-spec1.${O} from ${MID}/i-spec1.clisp - @ (cd ${MID} ; \ +${OUT}/i-spec1.${O}: ${MID}/i-spec1.lisp + @ echo 136 making ${OUT}/i-spec1.${O} from ${MID}/i-spec1.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/i-spec1.clisp"' \ + echo '(progn (compile-file "${MID}/i-spec1.lisp"' \ ':output-file "${OUT}/i-spec1.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/i-spec1.clisp"' \ + echo '(progn (compile-file "${MID}/i-spec1.lisp"' \ ':output-file "${OUT}/i-spec1.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/i-spec1.clisp: ${IN}/i-spec1.boot.pamphlet - @ echo 313 making ${MID}/i-spec1.clisp from ${IN}/i-spec1.boot.pamphlet +<>= +${MID}/i-spec1.lisp: ${IN}/i-spec1.lisp.pamphlet + @ echo 137 making ${MID}/i-spec1.lisp from \ + ${IN}/i-spec1.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/i-spec1.boot.pamphlet >i-spec1.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "i-spec1.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "i-spec1.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm i-spec1.boot ) - -@ -<>= -${DOC}/i-spec1.boot.dvi: ${IN}/i-spec1.boot.pamphlet - @echo 314 making ${DOC}/i-spec1.boot.dvi \ - from ${IN}/i-spec1.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/i-spec1.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} i-spec1.boot ; \ - rm -f ${DOC}/i-spec1.boot.pamphlet ; \ - rm -f ${DOC}/i-spec1.boot.tex ; \ - rm -f ${DOC}/i-spec1.boot ) + ${TANGLE} ${IN}/i-spec1.lisp.pamphlet >i-spec1.lisp ) @ @@ -6496,8 +6477,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/i-spec1.boot.pamphlet b/src/interp/i-spec1.boot.pamphlet deleted file mode 100644 index f114eef..0000000 --- a/src/interp/i-spec1.boot.pamphlet +++ /dev/null @@ -1,1300 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-spec1.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} -Handlers for Special Forms (1 of 2) - -This file contains the functions which do type analysis and -evaluation of special functions in the interpreter. -Special functions are ones which are not defined in the algebra -code, such as assignment, construct, COLLECT and declaration. - -Operators which require special handlers all have a LISP "up" -property which is the name of the special handler, which is -always the word "up" followed by the operator name. -If an operator has this "up" property the handler is called -automatically from bottomUp instead of general modemap selection. - -The up handlers are usually split into two pieces, the first is -the up function itself, which performs the type analysis, and an -"eval" function, which generates (and executes, if required) the -code for the function. -The up functions always take a single argument, which is the -entire attributed tree for the operation, and return the modeSet -of the node, which is a singleton list containing the type -computed for the node. -The eval functions can take any arguments deemed necessary. -Actual evaluation is done if $genValue is true, otherwise code is -generated. -(See the function analyzeMap for other things that may affect -what is generated in these functions.) - -These functions are required to do two things: - 1) do a putValue on the operator vector with the computed value - of the node, which is a triple. This is usually done in the - eval functions. - 2) do a putModeSet on the operator vector with a list of the - computed type of the node. This is usually done in the - up functions. - -There are several special modes used in these functions: - 1) Void is the mode that should be used for all statements - that do not otherwise return values, such as declarations, - loops, IF-THEN's without ELSE's, etc.. - 2) $NoValueMode and $ThrowAwayMode used to be used in situations - where Void is now used, and are being phased out completely. -\end{verbatim} -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - - --- Functions which require special handlers (also see end of file) - -SETANDFILEQ($repeatLabel, NIL) -SETANDFILEQ($breakCount, 0) -SETANDFILEQ($anonymousMapCounter, 0) - -SETANDFILEQ($specialOps, '( - ADEF AlgExtension and case COERCE COLLECT construct Declare DEF Dollar - equation error free has IF is isnt iterate break LET local MDEF or - pretend QUOTE REDUCE REPEAT return SEQ TARGET Tuple typeOf where )) - ---% Void stuff - -voidValue() == '"()" - ---% Handlers for Anonymous Function Definitions - -upADEF t == - t isnt [.,[vars,types,.,body],pred,.] => NIL - -- do some checking on what we got - for var in vars repeat - if not IDENTP(var) then throwKeyedMsg("S2IS0057",[var]) - -- unabbreviate types - types := [(if t then evaluateType unabbrev t else NIL) for t in types] - -- we do not allow partial types - if isPartialMode(m := first types) then throwKeyedMsg("S2IS0058",[m]) - - -- we want everything to be declared or nothing. The exception is that - -- we do not require a target type since we will compute one anyway. - if null(m) and rest types then - m := first rest types - types' := rest rest types - else - types' := rest types - for type in types' repeat - if (type and null m) or (m and null type) then - throwKeyedMsg("S2IS0059",NIL) - if isPartialMode type then throwKeyedMsg("S2IS0058",[type]) - --- $localVars: local := nil --- $freeVars: local := nil --- $env: local := [[NIL]] - $compilingMap : local := true - - -- if there is a predicate, merge it in with the body - if pred ^= true then body := ['IF,pred,body,'noMapVal] - - tar := getTarget t - null m and tar is ['Mapping,.,:argTypes] and (#vars = #argTypes) => - if isPartialMode tar then throwKeyedMsg("S2IS0058",[tar]) - evalTargetedADEF(t,vars,rest tar,body) - null m => evalUntargetedADEF(t,vars,types,body) - evalTargetedADEF(t,vars,types,body) - -evalUntargetedADEF(t,vars,types,body) == - -- recreate a parse form - if vars is [var] - then vars := var - else vars := ['Tuple,:vars] - val := objNewWrap(["+->",vars,body],$AnonymousFunction) - putValue(t,val) - putModeSet(t,[objMode val]) - -evalTargetedADEF(t,vars,types,body) == - $mapName : local := makeInternalMapName('"anonymousFunction", - #vars,$anonymousMapCounter,'"internal") - $anonymousMapCounter := 1 + $anonymousMapCounter - $compilingMap : local := true -- state that we are trying to compile - $mapThrowCount : local := 0 -- number of "return"s encountered - $mapReturnTypes : local := nil -- list of types from returns - $repeatLabel : local := nil -- for loops; see upREPEAT - $breakCount : local := 0 -- breaks from loops; ditto - - -- now substitute formal names for the parm variables - -- this is used in the interpret-code case, but isn't so bad any way - -- since it makes the bodies look more like regular map bodies - - sublist := [[var,:GENSYM()] for var in vars] - body := sublisNQ(sublist,body) - vars := [CDR v for v in sublist] - - for m in CDR types for var in vars repeat - $env:= put(var,'mode,m,$env) - mkLocalVar($mapName,var) - for lvar in getLocalVars($mapName,body) repeat - mkLocalVar($mapName,lvar) - -- set up catch point for interpret-code mode - x := CATCH('mapCompiler,compileTargetedADEF(t,vars,types,body)) - x = 'tryInterpOnly => mkInterpTargetedADEF(t,vars,types,body) - x - -mkInterpTargetedADEF(t,vars,types,oldBody) == - null first types => - throwKeyedMsg("S2IS0056",NIL) - throwMessage '" map result type needed but not present." - arglCode := ['LIST,:[argCode for type in rest types for var in vars]] - where argCode == ['putValueValue,['mkAtreeNode,MKQ var], - objNewCode(['wrap,var],type)] - put($mapName,'mapBody,oldBody,$e) - body := ['rewriteMap1,MKQ $mapName,arglCode,MKQ types] - compileADEFBody(t,vars,types,body,first types) - -compileTargetedADEF(t,vars,types,body) == - val := compileBody(body,CAR types) - computedResultType := objMode val - body := wrapMapBodyWithCatch flattenCOND objVal val - compileADEFBody(t,vars,types,body,computedResultType) - -compileADEFBody(t,vars,types,body,computedResultType) == ---+ - $compiledOpNameList := [$mapName] - minivectorName := makeInternalMapMinivectorName(PNAME $mapName) - $minivectorNames := [[$mapName,:minivectorName],:$minivectorNames] - body := SUBST(minivectorName,"$$$",body) - if $compilingInputFile then - $minivectorCode := [:$minivectorCode,minivectorName] - SET(minivectorName,LIST2REFVEC $minivector) - - -- The use of the three variables $definingMap, $genValue and $compilingMap - -- is to cover the following cases: - -- - -- $definingMap: This is set in analyzeMap and covers examples like: - -- addx x == ((y: Integer): Integer +-> x + y) - -- g := addx 10 - -- g 3 - -- i.e. we are storing the mapping as an object. - -- - -- $compilingMap: This covers mappings which are created and applied "on the - -- "fly", for example: - -- [map(h +-> D(h, t), v) for v in [t]] - -- - -- $genValue: This seems to be needed when we create a map as an argument - -- for a constructor, e.g.: - -- Dx: LODO(EXPR INT, f +-> D(f, x)) := D() - -- - -- MCD 13/3/96 - if not $definingMap and ($genValue or $compilingMap) then - fun := ['function,['LAMBDA,[:vars,'envArg],body]] - code := wrap timedEVALFUN ['LIST,fun] - else - $freeVariables := [] - $boundVariables := [minivectorName,:vars] - -- CCL does not support upwards funargs, so we check for any free variables - -- and pass them into the lambda as part of envArg. - body := checkForFreeVariables(body,"ALL") - fun := ['function,['LAMBDA,[:vars,'envArg],body]] - code := ['CONS, fun, ["VECTOR", :reverse $freeVariables]] - - val := objNew(code,rt := ['Mapping,computedResultType,:rest types]) - putValue(t,val) - putModeSet(t,[rt]) - ---% Handler for Algebraic Extensions - -upAlgExtension t == - -- handler for algebraic extension declaration. These are of - -- the form "a | a**2+1", and have the effect that "a" is declared - -- to be a simple algebraic extension, with respect to the given - -- polynomial, and given the value "a" in this type. - t isnt [op,var,eq] => nil - null $genValue => throwKeyedMsg("S2IS0001",NIL) - a := getUnname var - clearCmdParts ['propert,a] --clear properties of a - algExtension:= eq2AlgExtension eq - upmode := ['UnivariatePolynomial,a,$EmptyMode] - $declaredMode : local := upmode - putTarget(algExtension,upmode) - ms:= bottomUp algExtension - triple:= getValue algExtension - upmode:= resolveTMOrCroak(objMode(triple),upmode) - null (T:= coerceInteractive(triple,upmode)) => - throwKeyedMsgCannotCoerceWithValue(objVal(triple), - objMode(triple),upmode) - newmode := objMode T - (field := resolveTCat(CADDR newmode,'(Field))) or - throwKeyedMsg("S2IS0002",[eq]) - pd:= ['UnivariatePolynomial,a,field] - null (canonicalAE:= coerceInteractive(T,pd)) => - throwKeyedMsgCannotCoerceWithValue(objVal T,objMode T,pd) - sae:= ['SimpleAlgebraicExtension,field,pd,objValUnwrap canonicalAE] - saeTypeSynonym := INTERN STRCONC('"SAE",STRINGIMAGE a) - saeTypeSynonymValue := objNew(sae,'(Domain)) - fun := getFunctionFromDomain('generator,sae,NIL) - expr:= wrap SPADCALL(fun) - putHist(saeTypeSynonym,'value,saeTypeSynonymValue,$e) - putHist(a,'mode,sae,$e) - putHist(a,'value,T2:= objNew(expr,sae),$e) - clearDependencies(a,true) - if $printTypeIfTrue then - sayKeyedMsg("S2IS0003",NIL) - sayMSG concat ['%l,'" ",saeTypeSynonym,'" := ", - :prefix2String objVal saeTypeSynonymValue] - sayMSG concat ['" ",a,'" : ",saeTypeSynonym,'" := ",a] - putValue(op,T2) - putModeSet(op,[sae]) - -eq2AlgExtension eq == - -- transforms "a=b" to a-b for processing - eq is [op,:l] and VECP op and (getUnname op='equation) => - [mkAtreeNode "-",:l] - eq - ---% Handlers for booleans - -upand x == - -- generates code for and forms. The second argument is only - -- evaluated if the first argument is true. - x isnt [op,term1,term2] => NIL - putTarget(term1,$Boolean) - putTarget(term2,$Boolean) - ms := bottomUp term1 - ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[1,'"_"and_""],term1) - $genValue => - BooleanEquality(objValUnwrap(getValue term1), - getConstantFromDomain('(false),$Boolean)) => - putValue(x,getValue term1) - putModeSet(x,ms) - -- first term is true, so look at the second one - ms := bottomUp term2 - ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"and_""],term2) - putValue(x,getValue term2) - putModeSet(x,ms) - - ms := bottomUp term2 - ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"and_""],term2) - -- generate an IF expression and let the rest of the code handle it - cond := [mkAtreeNode "=",mkAtree 'false,term1] - putTarget(cond,$Boolean) - code := [mkAtreeNode 'IF,cond,mkAtree 'false,term2] - putTarget(code,$Boolean) - bottomUp code - putValue(x,getValue code) - putModeSet(x,ms) - -upor x == - -- generates code for or forms. The second argument is only - -- evaluated if the first argument is false. - x isnt [op,term1,term2] => NIL - putTarget(term1,$Boolean) - putTarget(term2,$Boolean) - ms := bottomUp term1 - ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[1,'"_"or_""],term1) - $genValue => - BooleanEquality(objValUnwrap(getValue term1), - getConstantFromDomain('(true),$Boolean)) => - putValue(x,getValue term1) - putModeSet(x,ms) - -- first term is false, so look at the second one - ms := bottomUp term2 - ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"or_""],term2) - putValue(x,getValue term2) - putModeSet(x,ms) - - ms := bottomUp term2 - ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"or_""],term2) - -- generate an IF expression and let the rest of the code handle it - cond := [mkAtreeNode "=",mkAtree 'true,term1] - putTarget(cond,$Boolean) - code := [mkAtreeNode 'IF,cond,mkAtree 'true,term2] - putTarget(code,$Boolean) - bottomUp code - putValue(x,getValue code) - putModeSet(x,ms) - ---% Handlers for case - -upcase t == - t isnt [op,lhs,rhs] => nil - bottomUp lhs - triple := getValue lhs - objMode(triple) isnt ['Union,:unionDoms] => - throwKeyedMsg("S2IS0004",NIL) - if (rhs' := isDomainValuedVariable(rhs)) then rhs := rhs' - if first unionDoms is ['_:,.,.] then - for i in 0.. for d in unionDoms repeat - if d is ['_:,=rhs,.] then rhstag := i - if NULL rhstag then error "upcase: bad Union form" - $genValue => - rhstag = first unwrap objVal triple => code := wrap 'TRUE - code := wrap NIL - code := - ['COND, - [['EQL,rhstag,['CAR,['unwrap,objVal triple]]], - ''TRUE], - [''T,NIL]] - else - $genValue => - t' := coerceUnion2Branch triple - rhs = objMode t' => code := wrap 'TRUE - code := wrap NIL - triple' := objNewCode(['wrap,objVal triple],objMode triple) - code := - ['COND, - [['EQUAL,MKQ rhs,['objMode,['coerceUnion2Branch,triple']]], - ''TRUE], - [''T,NIL]] - putValue(op,objNew(code,$Boolean)) - putModeSet(op,[$Boolean]) - ---% Handlers for TARGET - -upTARGET t == - -- Evaluates the rhs to a mode,which is used as the target type for - -- the lhs. - t isnt [op,lhs,rhs] => nil - -- do not (yet) support local variables on the rhs - (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] => - keyedMsgCompFailure("S2IC0010",[rhs]) - $declaredMode: local := NIL - m:= evaluateType unabbrev rhs - not isLegitimateMode(m,NIL,NIL) => throwKeyedMsg("S2IE0004",[m]) - categoryForm?(m) => throwKeyedMsg("S2IE0014",[m]) - $declaredMode:= m - not atom(lhs) and putTarget(lhs,m) - ms := bottomUp lhs - first ms ^= m => - throwKeyedMsg("S2IC0011",[first ms,m]) - putValue(op,getValue lhs) - putModeSet(op,ms) - ---% Handlers for COERCE - -upCOERCE t == - -- evaluate the lhs and then tries to coerce the result to the - -- mode which is the rhs. - -- previous to 5/16/89, this had the same semantics as - -- (lhs@rhs) :: rhs - -- this must be made explicit now. - t isnt [op,lhs,rhs] => nil - $useConvertForCoercions : local := true - -- do not (yet) support local variables on the rhs - (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] => - keyedMsgCompFailure("S2IC0006",[rhs]) - $declaredMode: local := NIL - m := evaluateType unabbrev rhs - not isLegitimateMode(m,NIL,NIL) => throwKeyedMsg("S2IE0004",[m]) - categoryForm?(m) => throwKeyedMsg("S2IE0014",[m]) - $declaredMode:= m - -- 05/16/89 (RSS) following line commented out to give correct - -- semantic difference between :: and @ - bottomUp lhs - type:=evalCOERCE(op,lhs,m) - putModeSet(op,[type]) - -evalCOERCE(op,tree,m) == - -- the value of tree is coerced to mode m - -- this is not necessary, if the target property of tree was used - v := getValue tree - t1 := objMode(v) - if $genValue and t1 is ['Union,:.] then - v := coerceUnion2Branch v - t1 := objMode(v) - e := objVal(v) - value:= - t1=m => v - t2 := - if isPartialMode m - then - $genValue and (t1 = '(Symbol)) and containsPolynomial m => - resolveTM(['UnivariatePolynomial,objValUnwrap(v),'(Integer)],m) - resolveTM(t1,m) - else m - null t2 => throwKeyedMsgCannotCoerceWithValue(e,t1,m) - $genValue => coerceOrRetract(v,t2) - objNew(getArgValue(tree,t2),t2) - val:= value or throwKeyedMsgCannotCoerceWithValue(e,t1,m) - putValue(op,val) - objMode(val) - ---% Handlers for COLLECT - -transformCollect [:itrl,body] == - -- syntactic transformation for COLLECT form, called from mkAtree1 - iterList:=[:iterTran1 for it in itrl] where iterTran1 == - it is ['STEP,index,lower,step,:upperList] => - [['STEP,index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper - for upper in upperList]]] - it is ['IN,index,s] => - [['IN,index,mkAtree1 s]] - it is ['ON,index,s] => - [['IN,index,mkAtree1 ['tails,s]]] - it is ['WHILE,b] => - [['WHILE,mkAtree1 b]] - it is ['_|,pred] => - [['SUCHTHAT,mkAtree1 pred]] - it is [op,:.] and (op in '(VALUE UNTIL)) => nil - bodyTree:=mkAtree1 body - iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where - iterTran2 == - it is ['STEP,:.] => nil - it is ['IN,:.] => nil - it is ['ON,:.] => nil - it is ['WHILE,:.] => nil - it is [op,b] and (op in '(UNTIL)) => - [[op,mkAtree1 b]] - it is ['_|,pred] => nil - keyedSystemError("S2GE0016", - ['"transformCollect",'"Unknown type of iterator"]) - [:iterList,bodyTree] - -upCOLLECT t == - -- $compilingLoop variable insures that throw to interp-only mode - -- goes to the outermost loop. - $compilingLoop => upCOLLECT1 t - upCOLLECT0 t - -upCOLLECT0 t == - -- sets up catch point for interpret-code mode - $compilingLoop: local := true - ms:=CATCH('loopCompiler,upCOLLECT1 t) - ms = 'tryInterpOnly => interpOnlyCOLLECT t - ms - -upCOLLECT1 t == - t isnt [op,:itrl,body] => nil - -- upCOLLECT with compiled body - if (target := getTarget t) and not getTarget(body) then - if target is [agg,S] and agg in '(List Vector Stream InfiniteTuple) then - putTarget(body,S) - $interpOnly => interpCOLLECT(op,itrl,body) - isStreamCollect itrl => collectStream(t,op,itrl,body) - upLoopIters itrl - ms:= bottomUpCompile body - [m]:= ms - for itr in itrl repeat - itr is ['UNTIL, pred] => bottomUpCompilePredicate(pred,'"until") - mode:= ['Tuple,m] - evalCOLLECT(op,rest t,mode) - putModeSet(op,[mode]) - -upLoopIters itrl == - -- type analyze iterator loop iterators - for iter in itrl repeat - iter is ['WHILE,pred] => - bottomUpCompilePredicate(pred,'"while") - iter is ['SUCHTHAT,pred] => - bottomUpCompilePredicate(pred,'"|") - iter is ['UNTIL,:.] => - NIL -- handle after body is analyzed - iter is ['IN,index,s] => - upLoopIterIN(iter,index,s) - iter is ['STEP,index,lower,step,:upperList] => - upLoopIterSTEP(index,lower,step,upperList) - -- following is an optimization - typeIsASmallInteger(get(index,'mode,$env)) => - RPLACA(iter,'ISTEP) - NIL -- should have error msg here? - -upLoopIterIN(iter,index,s) == - iterMs := bottomUp s - - null IDENTP index => throwKeyedMsg("S2IS0005",[index]) - - if $genValue and first iterMs is ['Union,:.] then - v := coerceUnion2Branch getValue s - m := objMode v - putValue(s,v) - putMode(s,m) - iterMs := [m] - putModeSet(s,iterMs) - - -- transform segment variable into STEP - iterMs is [['Segment,.]] or iterMs is [['UniversalSegment,.]] => - lower := [mkAtreeNode 'lo,s] - step := [mkAtreeNode 'incr, s] - upperList := - CAAR(iterMs) = 'Segment => [[mkAtreeNode 'hi,s]] - NIL - upLoopIterSTEP(index,lower,step,upperList) - newIter := ['STEP,index,lower,step,:upperList] - RPLACA(iter,CAR newIter) - RPLACD(iter,CDR newIter) - - iterMs isnt [['List,ud]] => throwKeyedMsg("S2IS0006",[index]) - put(index,'mode,ud,$env) - mkLocalVar('"the iterator expression",index) - -upLoopIterSTEP(index,lower,step,upperList) == - null IDENTP index => throwKeyedMsg("S2IS0005",[index]) - ltype := IFCAR bottomUpUseSubdomain(lower) - not (typeIsASmallInteger(ltype) or isEqualOrSubDomain(ltype,$Integer))=> - throwKeyedMsg("S2IS0007",['"lower"]) - stype := IFCAR bottomUpUseSubdomain(step) - not (typeIsASmallInteger(stype) or isEqualOrSubDomain(stype,$Integer))=> - throwKeyedMsg("S2IS0008",NIL) - types := [ltype] - utype := nil - for upper in upperList repeat - utype := IFCAR bottomUpUseSubdomain(upper) - not (typeIsASmallInteger(utype) or isEqualOrSubDomain(utype,$Integer))=> - throwKeyedMsg("S2IS0007",['"upper"]) - if utype then types := [utype, :types] - else types := [stype, :types] - type := resolveTypeListAny REMDUP types - put(index,'mode,type,$env) - mkLocalVar('"the iterator expression",index) - -evalCOLLECT(op,[:itrl,body],m) == - iters := [evalLoopIter itr for itr in itrl] - bod := getArgValue(body,computedMode body) - if bod isnt ['SPADCALL,:.] then bode := ['unwrap,bod] - code := timedOptimization asTupleNewCode0 ['COLLECT,:iters,bod] - if $genValue then code := wrap timedEVALFUN code - putValue(op,objNew(code,m)) - -falseFun(x) == nil - -evalLoopIter itr == - -- generate code for loop iterator - itr is ['STEP,index,lower,step,:upperList] => - ['STEP,getUnname index,getArgValue(lower,$Integer), - getArgValue(step,$Integer), - :[getArgValue(upper,$Integer) for upper in upperList]] - itr is ['ISTEP,index,lower,step,:upperList] => - ['ISTEP,getUnname index,getArgValue(lower,$SmallInteger), - getArgValue(step,$SmallInteger), - :[getArgValue(upper,$SmallInteger) for upper in upperList]] - itr is ['IN,index,s] => - ['IN,getUnname index,getArgValue(s,['List,get(index,'mode,$env)])] - (itr is [x,pred]) and (x in '(WHILE UNTIL SUCHTHAT)) => - [x,getArgValue(pred,$Boolean)] - -interpCOLLECT(op,itrl,body) == - -- interpret-code mode COLLECT handler - $collectTypeList: local := NIL - $indexVars: local := NIL - $indexTypes: local := NIL - emptyAtree op - emptyAtree itrl - emptyAtree body - code := ['COLLECT,:[interpIter itr for itr in itrl], - interpCOLLECTbody(body,$indexVars,$indexTypes)] - value := timedEVALFUN code - t := - null value => '(None) - last $collectTypeList - rm := ['Tuple,t] - value := [objValUnwrap coerceInteractive(objNewWrap(v,m),t) - for v in value for m in $collectTypeList] - putValue(op,objNewWrap(asTupleNew(#value, value),rm)) - putModeSet(op,[rm]) - -interpIter itr == - -- interpret loop iterator - itr is ['STEP,index,lower,step,:upperList] => - $indexVars:= [getUnname index,:$indexVars] - [m]:= bottomUp lower - $indexTypes:= [m,:$indexTypes] - for up in upperList repeat bottomUp up - ['STEP,getUnname index,getArgValue(lower,$Integer), - getArgValue(step,$Integer), - :[getArgValue(upper,$Integer) for upper in upperList]] - itr is ['ISTEP,index,lower,step,:upperList] => - $indexVars:= [getUnname index,:$indexVars] - [m]:= bottomUp lower - $indexTypes:= [m,:$indexTypes] - for up in upperList repeat bottomUp up - ['ISTEP,getUnname index,getArgValue(lower,$SmallInteger), - getArgValue(step,$SmallInteger), - :[getArgValue(upper,$SmallInteger) for upper in upperList]] - itr is ['IN,index,s] => - $indexVars:=[getUnname index,:$indexVars] - [m]:= bottomUp s - m isnt ['List,um] => throwKeyedMsg("S2IS0009",[m]) - $indexTypes:=[um,:$indexTypes] - ['IN,getUnname index,getArgValue(s,m)] - (itr is [x,pred]) and (x in '(WHILE UNTIL SUCHTHAT)) => - [x,interpLoop(pred,$indexVars,$indexTypes,$Boolean)] - -interpOnlyCOLLECT t == - -- called when compilation failed in COLLECT body, not in compiling map - $genValue: local := true - $interpOnly: local := true - upCOLLECT t - -interpCOLLECTbody(expr,indexList,indexTypes) == - -- generate code for interpret-code collect - ['interpCOLLECTbodyIter,MKQ expr,MKQ indexList,['LIST,:indexList], - MKQ indexTypes] - -interpCOLLECTbodyIter(exp,indexList,indexVals,indexTypes) == - -- execute interpret-code collect body. keeps list of type of - -- elements in list in $collectTypeList. - emptyAtree exp - for i in indexList for val in indexVals for type in indexTypes repeat - put(i,'value,objNewWrap(val,type),$env) - [m]:=bottomUp exp - $collectTypeList:= - null $collectTypeList => [rm:=m] - [:$collectTypeList,rm:=resolveTT(m,last $collectTypeList)] - null rm => throwKeyedMsg("S2IS0010",NIL) - value:= - rm ^= m => coerceInteractive(getValue exp,rm) - getValue exp - objValUnwrap(value) - ---% Stream Collect functions - -isStreamCollect itrl == - -- calls bottomUp on iterators and if any of them are streams - -- then whole shebang is a stream - isStream := false - for itr in itrl until isStream repeat - itr is ['IN,.,s] => - iterMs := bottomUp s - iterMs is [['Stream,:.]] => isStream := true - iterMs is [['InfiniteTuple,:.]] => isStream := true - iterMs is [['UniversalSegment,:.]] => isStream := true - itr is ['STEP,.,.,.] => isStream := true - isStream - -collectStream(t,op,itrl,body) == - v := CATCH('loopCompiler,collectStream1(t,op,itrl,body)) - v = 'tryInterpOnly => throwKeyedMsg("S2IS0011",NIL) - v - -collectStream1(t,op,itrl,body) == - $indexVars:local := NIL - upStreamIters itrl - if #$indexVars = 1 then mode:=collectOneStream(t,op,itrl,body) - else mode:=collectSeveralStreams(t,op,itrl,body) - putModeSet(op,[mode]) - -upStreamIters itrl == - -- type analyze stream collect loop iterators - for iter in itrl repeat - iter is ['IN,index,s] => - upStreamIterIN(iter,index,s) - iter is ['STEP,index,lower,step,:upperList] => - upStreamIterSTEP(index,lower,step,upperList) - -upStreamIterIN(iter,index,s) == - iterMs := bottomUp s - - -- transform segment variable into STEP - iterMs is [['Segment,.]] or iterMs is [['UniversalSegment,.]] => - lower := [mkAtreeNode 'lo, s] - step := [mkAtreeNode 'incr, s] - upperList := - CAAR(iterMs) = 'Segment => [[mkAtreeNode 'hi,s]] - NIL - upStreamIterSTEP(index,lower,step,upperList) - newIter := ['STEP,index,lower,step,:upperList] - RPLACA(iter,CAR newIter) - RPLACD(iter,CDR newIter) - - (iterMs isnt [['List,ud]]) and (iterMs isnt [['Stream,ud]]) - and (iterMs isnt [['InfinitTuple, ud]]) => - throwKeyedMsg("S2IS0006",[index]) - put(index,'mode,ud,$env) - mkLocalVar('"the iterator expression",index) - s := - iterMs is [['List,ud],:.] => - form:=[mkAtreeNode 'pretend, [mkAtreeNode 'COERCE,s,['Stream,ud]], - ['InfiniteTuple, ud]] - bottomUp form - form - s - $indexVars:= [[index,:s],:$indexVars] - -upStreamIterSTEP(index,lower,step,upperList) == - null isEqualOrSubDomain(ltype := IFCAR bottomUpUseSubdomain(lower), - $Integer) => throwKeyedMsg("S2IS0007",['"lower"]) - null isEqualOrSubDomain(stype := IFCAR bottomUpUseSubdomain(step), - $Integer) => throwKeyedMsg("S2IS0008",NIL) - for upper in upperList repeat - null isEqualOrSubDomain(IFCAR bottomUpUseSubdomain(upper), - $Integer) => throwKeyedMsg("S2IS0007",['"upper"]) - - put(index,'mode,type := resolveTT(ltype,stype),$env) - null type => throwKeyedMsg("S2IS0010", nil) - mkLocalVar('"the iterator expression",index) - - s := - null upperList => - -- create the function that does the appropriate incrementing - genFun := 'generate - form := [mkAtreeNode genFun, - [[mkAtreeNode 'Dollar, ['IncrementingMaps,type], - mkAtreeNode 'incrementBy],step],lower] - bottomUp form - form - form := [mkAtreeNode 'SEGMENT,lower,first upperList] - putTarget(form,['Segment,type]) - form := [mkAtreeNode 'construct,form] - putTarget(form,['List,['Segment,type]]) - form := [mkAtreeNode 'expand,form] - putTarget(form,'(List (Integer))) - form:=[mkAtreeNode 'pretend, [mkAtreeNode 'COERCE,form,['Stream,$Integer]], - ['InfiniteTuple, $Integer]] - bottomUp form - form - $indexVars:= [[index,:s],:$indexVars] - -collectOneStream(t,op,itrl,body) == - -- build stream collect for case of iterating over a single stream - -- In this case we don't need to build records - form := mkAndApplyPredicates itrl - bodyVec := mkIterFun(CAR $indexVars,body,$localVars) - form := [mkAtreeNode 'map,bodyVec,form] - bottomUp form - val := getValue form - m := objMode val - m isnt ['Stream, ud] and m isnt ['InfiniteTuple, ud] => - systemError '"Not a Stream" - newVal := objNew(objVal val, ['InfiniteTuple, ud]) - putValue(op,newVal) - objMode newVal - -mkAndApplyPredicates itrl == - -- for one index variable case for now. may generalize later - [indSet] := $indexVars - [.,:s] := indSet - for iter in itrl repeat - iter is ['WHILE,pred] => - fun := 'filterWhile - predVec := mkIterFun(indSet,pred,$localVars) - s := [mkAtreeNode fun,predVec,s] - iter is ['UNTIL,pred] => - fun := 'filterUntil - predVec := mkIterFun(indSet,pred,$localVars) - s := [mkAtreeNode fun,predVec,s] - iter is ['SUCHTHAT,pred] => - fun := 'select - putTarget(pred,$Boolean) - predVec := mkIterFun(indSet,pred,$localVars) - s := [mkAtreeNode fun,predVec,s] - s - -mkIterFun([index,:s],funBody,$localVars) == - -- transform funBody into a lambda with index as the parameter - mode := objMode getValue s - mode isnt ['Stream, indMode] and mode isnt ['InfiniteTuple, indMode] => - keyedSystemError('"S2GE0016", '("mkIterFun" "bad stream index type")) - put(index,'mode,indMode,$env) - mkLocalVar($mapName,index) - [m]:=bottomUpCompile funBody - mapMode := ['Mapping,m,indMode] - $freeVariables := [] - $boundVariables := [index] - -- CCL does not support upwards funargs, so we check for any free variables - -- and pass them into the lambda as part of envArg. - body := checkForFreeVariables(getValue funBody,$localVars) - val:=['function,['LAMBDA,[index,'envArg],objVal body]] - vec := mkAtreeNode GENSYM() - putValue(vec,objNew(['CONS,val,["VECTOR",:reverse $freeVariables]],mapMode)) - vec - -checkForFreeVariables(v,locals) == - -- v is the body of a lambda expression. The list $boundVariables is all the - -- bound variables, the parameter locals contains local variables which might - -- be free, or the token ALL, which means that any parameter is a candidate - -- to be free. - NULL v => v - SYMBOLP v => - v="$$$" => v -- Placeholder for mini-vector - MEMQ(v,$boundVariables) => v - p := POSITION(v,$freeVariables) => - ["ELT","envArg",positionInVec(p,#($freeVariables))] - (locals = "ALL") or MEMQ(v,locals) => - $freeVariables := [v,:$freeVariables] - ["ELT","envArg",positionInVec(0,#($freeVariables))] - v - LISTP v => - CDR(LASTTAIL v) => -- Must be a better way to check for a genuine list? - v - [op,:args] := v - LISTP op => - -- Might have a mode at the front of a list, or be calling a function - -- which returns a function. - [checkForFreeVariables(op,locals),:[checkForFreeVariables(a,locals) for a in args]] - op = "LETT" => -- Expands to a SETQ. - ["SETF",:[checkForFreeVariables(a,locals) for a in args]] - op = "COLLECT" => -- Introduces a new bound variable? - first(args) is ["STEP",var,:.] => - $boundVariables := [var,:$boundVariables] - r := ["COLLECT",:[checkForFreeVariables(a,locals) for a in args]] - $boundVariables := DELETE(var,$boundVariables) - r - ["COLLECT",:[checkForFreeVariables(a,locals) for a in args]] - op = "REPEAT" => -- Introduces a new bound variable? - first(args) is ["STEP",var,:.] => - $boundVariables := [var,:$boundVariables] - r := ["REPEAT",:[checkForFreeVariables(a,locals) for a in args]] - $boundVariables := DELETE(var,$boundVariables) - r - ["REPEAT",:[checkForFreeVariables(a,locals) for a in args]] - op = "LET" => - args is [var,form,name] => - -- This is some bizarre LET, not what one would expect in Common Lisp! - -- Treat var as a free variable, since it may be bound out of scope - -- if we are in a lambda within another lambda. - newvar := - p := POSITION(var,$freeVariables) => - ["ELT","envArg",positionInVec(p,#($freeVariables))] - $freeVariables := [var,:$freeVariables] - ["ELT","envArg",positionInVec(0,#($freeVariables))] - ["SETF",newvar,checkForFreeVariables(form,locals)] - error "Non-simple variable bindings are not currently supported" - op = "PROG" => - error "Non-simple variable bindings are not currently supported" - op = "LAMBDA" => v - op = "QUOTE" => v - op = "getValueFromEnvironment" => v - [op,:[checkForFreeVariables(a,locals) for a in args]] - v - -positionInVec(p,l) == - -- We cons up the free list, but need to keep positions consistent so - -- count from the end of the list. - l-p-1 - -collectSeveralStreams(t,op,itrl,body) == - -- performs collects over several streams in parallel - $index: local := nil - [form,:zipType] := mkZipCode $indexVars - form := mkAndApplyZippedPredicates(form,zipType,itrl) - vec := mkIterZippedFun($indexVars,body,zipType,$localVars) - form := [mkAtreeNode 'map, vec, form] - bottomUp form - val := getValue form - m := objMode val - m isnt ['Stream, ud] and m isnt ['InfiniteTuple, ud] => - systemError '"Not a Stream" - newVal := objNew(objVal val, ['InfiniteTuple, ud]) - putValue(op,newVal) - objMode newVal - -mkZipCode indexList == - -- create interpreter form for turning a list of parallel streams - -- into a stream of nested record types. returns [form,:recordType] - #indexList = 2 => - [[.,:s2],[.,:s1]] := indexList - t1 := CADR objMode getValue s1 - t2 := CADR objMode getValue s2 - zipType := ['Record,['_:,'part1,t1], ['_:,'part2,t2] ] - zipFun := [mkAtreeNode 'Dollar, ['MakeRecord,mkEvalable t1, - mkEvalable t2], - mkAtreeNode 'makeRecord] - form := [mkAtreeNode 'map,zipFun,s1,s2] - [form,:zipType] - [form,:zipType] := mkZipCode CDR indexList - [[.,:s],:.] := indexList - t := CADR objMode getValue s - zipFun := [mkAtreeNode 'Dollar, ['MakeRecord,mkEvalable t, - mkEvalable zipType], - mkAtreeNode 'makeRecord] - form := [mkAtreeNode 'map,zipFun,s,form] - zipType := ['Record,['_:,'part1,t],['_:,'part2,zipType]] - [form,:zipType] - -mkAndApplyZippedPredicates (s,zipType,itrl) == - -- for one index variable case for now. may generalize later - for iter in itrl repeat - iter is ['WHILE,pred] => - predVec := mkIterZippedFun($indexList,pred,zipType,$localVars) - s := [mkAtreeNode 'swhile,predVec,s] - iter is ['UNTIL,pred] => - predVec := mkIterZippedFun($indexList,pred,zipType,$localVars) - s := [mkAtreeNode 'suntil,predVec,s] - iter is ['SUCHTHAT,pred] => - putTarget(pred,$Boolean) - predVec := mkIterZippedFun($indexList,pred,zipType,$localVars) - s := [mkAtreeNode 'select,predVec,s] - s - -mkIterZippedFun(indexList,funBody,zipType,$localVars) == - -- transform funBody into a lamda with $index as the parameter - numVars:= #$indexVars - for [var,:.] in $indexVars repeat - funBody := subVecNodes(mkIterVarSub(var,numVars),var,funBody) - put($index,'mode,zipType,$env) - mkLocalVar($mapName,$index) - [m]:=bottomUpCompile funBody - mapMode := ['Mapping,m,zipType] - $freeVariables := [] - $boundVariables := [$index] - -- CCL does not support upwards funargs, so we check for any free variables - -- and pass them into the lambda as part of envArg. - body := - [checkForFreeVariables(form,$localVars) for form in getValue funBody] - val:=['function,['LAMBDA,[$index,'envArg],objVal body]] - vec := mkAtreeNode GENSYM() - putValue(vec,objNew(['CONS,val,["VECTOR",:reverse $freeVariables]],mapMode)) - vec - -subVecNodes(new,old,form) == - ATOM form => - (VECP form) and (form.0 = old) => new - form - [subVecNodes(new,old,CAR form), :subVecNodes(new,old,CDR form)] - -mkIterVarSub(var,numVars) == - n := iterVarPos var - n=2 => - [mkAtreeNode 'elt,mkNestedElts(numVars-2),mkAtreeNode 'part2] - n=1 => - [mkAtreeNode 'elt,mkNestedElts(numVars-2),mkAtreeNode 'part1] - [mkAtreeNode 'elt,mkNestedElts(numVars-n),mkAtreeNode 'part1] - -iterVarPos var == - for [index,:.] in reverse $indexVars for i in 1.. repeat - index=var => return(i) - -mkNestedElts n == - n=0 => mkAtreeNode($index or ($index:= GENSYM())) - [mkAtreeNode 'elt, mkNestedElts(n-1), mkAtreeNode 'part2] - ---% Handlers for construct - -upconstruct t == - --Computes the common mode set of the construct by resolving across - --the argument list, and evaluating - t isnt [op,:l] => nil - dol := getAtree(op,'dollar) - tar := getTarget(op) or dol - null l => upNullList(op,l,tar) - tar is ['Record,:types] => upRecordConstruct(op,l,tar) - isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar) - aggs := '(List) - if tar and PAIRP(tar) and ^isPartialMode(tar) then - CAR(tar) in aggs => - ud := - (l is [[realOp, :.]]) and (getUnname(realOp) = 'COLLECT) => tar - CADR tar - for x in l repeat if not getTarget(x) then putTarget(x,ud) - CAR(tar) in '(Matrix SquareMatrix RectangularMatrix) => - vec := ['List,underDomainOf tar] - for x in l repeat if not getTarget(x) then putTarget(x,vec) - argModeSetList:= [bottomUp x for x in l] - dol and dol is [topType,:.] and not (topType in aggs) => - (mmS:= selectMms(op,l,tar)) and (mS:= evalForm(op,getUnname op,l,mmS)) => - putModeSet(op,mS) - NIL - (tar and tar is [topType,:.] and not (topType in aggs)) and - (mmS:= modemapsHavingTarget(selectMms(op,l,tar),tar)) and - (mS:= evalForm(op,getUnname op,l,mmS)) => - putModeSet(op,mS) - eltTypes := replaceSymbols([first x for x in argModeSetList],l) - eltTypes is [['Tuple, td]] => - mode := ['List, td] - evalTupleConstruct(op, l, mode, tar) - eltTypes is [['InfiniteTuple, td]] => - mode := ['Stream, td] - evalInfiniteTupleConstruct(op, l, mode, tar) - if not isPartialMode(tar) and tar is ['List,ud] then - mode := ['List, resolveTypeListAny cons(ud,eltTypes)] - else mode := ['List, resolveTypeListAny eltTypes] - if isPartialMode tar then tar:=resolveTM(mode,tar) - evalconstruct(op,l,mode,tar) - -modemapsHavingTarget(mmS,target) == - -- returns those modemaps have the signature result matching the - -- given target - [mm for mm in mmS | ([[.,res,:.],:.] := mm) and res = target] - -evalTupleConstruct(op,l,m,tar) == - ['List, ud] := m - code := ['APPEND, - :([["asTupleAsList", getArgValueOrThrow(x,['Tuple, ud])] for x in l])] - val := - $genValue => objNewWrap(timedEVALFUN code,m) - objNew(code,m) - - (val1 := coerceInteractive(val,tar or m)) => - putValue(op,val1) - putModeSet(op,[tar or m]) - putValue(op,val) - putModeSet(op,[m]) - -evalInfiniteTupleConstruct(op,l,m,tar) == - ['Stream, ud] := m - code := first [(getArgValue(x,['InfiniteTuple, ud]) or - throwKeyedMsg("S2IC0007",[['InifinteTuple, ud]])) for x in l] - val := - $genValue => objNewWrap(timedEVALFUN code,m) - objNew(code,m) - if tar then val1 := coerceInteractive(val,tar) else val1 := val - - val1 => - putValue(op,val1) - putModeSet(op,[tar or m]) - putValue(op,val) - putModeSet(op,[m]) - -evalconstruct(op,l,m,tar) == - [agg,:.,underMode]:= m - code := ['LIST, :(argCode:=[(getArgValue(x,underMode) or - throwKeyedMsg("S2IC0007",[underMode])) for x in l])] - val := - $genValue => objNewWrap(timedEVALFUN code,m) - objNew(code,m) - if tar then val1 := coerceInteractive(val,tar) else val1 := val - - val1 => - putValue(op,val1) - putModeSet(op,[tar or m]) - putValue(op,val) - putModeSet(op,[m]) - -replaceSymbols(modeList,l) == - -- replaces symbol types with their corresponding polynomial types - -- if not all type are symbols - not ($Symbol in modeList) => modeList - modeList is [a,:b] and and/[a=x for x in b] => modeList - [if m=$Symbol then getMinimalVarMode(objValUnwrap(getValue arg), - $declaredMode) else m for m in modeList for arg in l] - -upNullList(op,l,tar) == - -- handler for [] (empty list) - defMode := - tar and tar is [a,b] and (a in '(Stream Vector List)) and - not isPartialMode(b) => ['List,b] - '(List (None)) - val := objNewWrap(NIL,defMode) - tar and not isPartialMode(tar) => - null (val' := coerceInteractive(val,tar)) => - throwKeyedMsg("S2IS0013",[tar]) - putValue(op,val') - putModeSet(op,[tar]) - putValue(op,val) - putModeSet(op,[defMode]) - -upTaggedUnionConstruct(op,l,tar) == - -- special handler for tagged union constructors - tar isnt [.,:types] => nil - #l ^= 1 => throwKeyedMsg("S2IS0051",[#l,tar]) - bottomUp first l - obj := getValue first l - (code := coerceInteractive(getValue first l,tar)) or - throwKeyedMsgCannotCoerceWithValue(objVal obj, objMode obj,tar) - putValue(op,code) - putModeSet(op,[tar]) - -upRecordConstruct(op,l,tar) == - -- special handler for record constructors - tar isnt [.,:types] => nil - argModes := nil - for arg in l repeat bottomUp arg - argCode := - [(getArgValue(arg,type) or throwKeyedMsgCannotCoerceWithValue( - objVal getValue arg,objMode getValue arg,type)) - for arg in l for ['_:,.,type] in types] - len := #l - code := - (len = 1) => ['CONS, :argCode, '()] - (len = 2) => ['CONS,:argCode] - ['VECTOR,:argCode] - if $genValue then code := wrap timedEVALFUN code - putValue(op,objNew(code,tar)) - putModeSet(op,[tar]) - ---% Handlers for declarations - -upDeclare t == - t isnt [op,lhs,rhs] => nil - (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] => - keyedMsgCompFailure("S2IS0014",[lhs]) - mode := evaluateType unabbrev rhs - mode = $Void => throwKeyedMsgSP("S2IS0015",NIL,op) - not isLegitimateMode(mode,nil,nil) => throwKeyedMsgSP("S2IE0004",[mode],op) - categoryForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'category],op) - packageForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'package],op) - junk := - lhs is ['free,['Tuple,:vars]] or lhs is ['free,['LISTOF,:vars]] or - lhs is ['free,:vars] => - for var in vars repeat declare(['free,var],mode) - lhs is ['local,['Tuple,:vars]] or lhs is ['local,['LISTOF,:vars]] or - lhs is ['local,:vars] => - for var in vars repeat declare(['local,var],mode) - lhs is ['Tuple,:vars] or lhs is ['LISTOF,:vars] => - for var in vars repeat declare(var,mode) - declare(lhs,mode) - putValue(op,objNewWrap(voidValue(), $Void)) - putModeSet(op,[$Void]) - -declare(var,mode) == - -- performs declaration. - -- 10/31/89: no longer coerces value to new declared type - if var is ['local,v] then - uplocalWithType(v,mode) - var := v - if var is ['free,v] then - upfreeWithType(v,mode) - var := v - not IDENTP(var) => - throwKeyedMsg("S2IS0016",[STRINGIMAGE var]) - var in '(% %%) => throwKeyedMsg("S2IS0050",[var]) - if get(var,'isInterpreterFunction,$e) then - mode isnt ['Mapping,.,:args] => - throwKeyedMsg("S2IS0017",[var,mode]) - -- validate that the new declaration has the defined # of args - mapval := objVal get(var,'value,$e) - -- mapval looks like '(MAP (args . defn)) - margs := CAADR mapval - -- if one args, margs is not a pair, just #1 or NIL - -- otherwise it looks like (Tuple #1 #2 ...) - nargs := - null margs => 0 - PAIRP margs => -1 + #margs - 1 - nargs ^= #args => throwKeyedMsg("S2IM0008",[var]) - if $compilingMap then mkLocalVar($mapName,var) - else clearDependencies(var,true) - isLocalVar(var) => put(var,'mode,mode,$env) - mode is ['Mapping,:.] => declareMap(var,mode) - v := get(var,'value,$e) => - -- only allow this if either - -- - value already has given type - -- - new mode is same as old declared mode - objMode(v) = mode => putHist(var,'mode,mode,$e) - mode = get(var,'mode,$e) => NIL -- nothing to do - throwKeyedMsg("S2IS0052",[var,mode]) - putHist(var,'mode,mode,$e) - -declareMap(var,mode) == - -- declare a Mapping property - (v:=get(var,'value,$e)) and objVal(v) isnt ['MAP,:.] => - throwKeyedMsg("S2IS0019",[var]) - isPartialMode mode => throwKeyedMsg("S2IM0004",NIL) - putHist(var,'mode,mode,$e) - -getAndEvalConstructorArgument tree == - triple := getValue tree - objMode triple = '(Domain) => triple - isWrapped objVal(triple) => triple - isLocalVar objVal triple => compFailure('" Local variable or parameter used in type") - objNewWrap(timedEVALFUN objVal(triple), objMode(triple)) - -replaceSharps(x,d) == - -- replaces all sharps in x by the arguments of domain d - -- all replaces the triangle variables - SL:= NIL - for e in CDR d for var in $FormalMapVariableList repeat - SL:= CONS(CONS(var,e),SL) - x := subCopy(x,SL) - SL:= NIL - for e in CDR d for var in $TriangleVariableList repeat - SL:= CONS(CONS(var,e),SL) - subCopy(x,SL) - -isDomainValuedVariable form == - -- returns the value of form if form is a variable with a type value - IDENTP form and (val := ( - get(form,'value,$InteractiveFrame) or _ - (PAIRP($env) and get(form,'value,$env)) or _ - (PAIRP($e) and get(form,'value,$e)))) and - objMode(val) in '((Domain) (SubDomain (Domain))) => - objValUnwrap(val) - nil - -evalCategory(d,c) == - -- tests whether domain d has category c - isPartialMode d or ofCategory(d,c) - -isOkInterpMode m == - isPartialMode(m) => isLegitimateMode(m,nil,nil) - isValidType(m) and isLegitimateMode(m,nil,nil) - -isLegitimateRecordOrTaggedUnion u == - and/[x is [":",.,d] and isLegitimateMode(d,nil,nil) for x in u] - -isPolynomialMode m == - -- If m is a polynomial type this function returns a list of its - -- variables, and nil otherwise - m is [op,a,:rargs] => - a := removeQuote a - MEMQ(op,'(Polynomial RationalFunction AlgebraicFunction Expression - ElementaryFunction LiouvillianFunction FunctionalExpression - CombinatorialFunction ))=> 'all - op = 'UnivariatePolynomial => LIST a - op = 'Variable => LIST a - MEMQ(op,'(MultivariatePolynomial DistributedMultivariatePolynomial - HomogeneousDistributedMultivariatePolynomial)) => a - NIL - NIL - -containsPolynomial m == - not PAIRP(m) => NIL - [d,:.] := m - d in $univariateDomains or d in $multivariateDomains or - d in '(Polynomial RationalFunction) => true - (m' := underDomainOf m) and containsPolynomial m' - -containsVariables m == - not PAIRP(m) => NIL - [d,:.] := m - d in $univariateDomains or d in $multivariateDomains => true - (m' := underDomainOf m) and containsVariables m' - -listOfDuplicates l == - l is [x,:l'] => - x in l' => [x,:listOfDuplicates deleteAll(x,l')] - listOfDuplicates l' - --- The following function removes all occurrences of x from the list l - -deleteAll(x,l) == - null l => nil - x = CAR(l) => deleteAll(x,CDR l) - [first l,:deleteAll(x,rest l)] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-spec1.lisp.pamphlet b/src/interp/i-spec1.lisp.pamphlet new file mode 100644 index 0000000..f95bf06 --- /dev/null +++ b/src/interp/i-spec1.lisp.pamphlet @@ -0,0 +1,5057 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-spec1.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\begin{verbatim} +Handlers for Special Forms (1 of 2) + +This file contains the functions which do type analysis and +evaluation of special functions in the interpreter. +Special functions are ones which are not defined in the algebra +code, such as assignment, construct, COLLECT and declaration. + +Operators which require special handlers all have a LISP "up" +property which is the name of the special handler, which is +always the word "up" followed by the operator name. +If an operator has this "up" property the handler is called +automatically from bottomUp instead of general modemap selection. + +The up handlers are usually split into two pieces, the first is +the up function itself, which performs the type analysis, and an +"eval" function, which generates (and executes, if required) the +code for the function. +The up functions always take a single argument, which is the +entire attributed tree for the operation, and return the modeSet +of the node, which is a singleton list containing the type +computed for the node. +The eval functions can take any arguments deemed necessary. +Actual evaluation is done if $genValue is true, otherwise code is +generated. +(See the function analyzeMap for other things that may affect +what is generated in these functions.) + +These functions are required to do two things: + 1) do a putValue on the operator vector with the computed value + of the node, which is a triple. This is usually done in the + eval functions. + 2) do a putModeSet on the operator vector with a list of the + computed type of the node. This is usually done in the + up functions. + +There are several special modes used in these functions: + 1) Void is the mode that should be used for all statements + that do not otherwise return values, such as declarations, + loops, IF-THEN's without ELSE's, etc.. + 2) $NoValueMode and $ThrowAwayMode used to be used in situations + where Void is now used, and are being phased out completely. +\end{verbatim} +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;SETANDFILEQ($repeatLabel, NIL) + +(SETANDFILEQ |$repeatLabel| NIL) + +;SETANDFILEQ($breakCount, 0) + +(SETANDFILEQ |$breakCount| 0) + +;SETANDFILEQ($anonymousMapCounter, 0) + +(SETANDFILEQ |$anonymousMapCounter| 0) + +;SETANDFILEQ($specialOps, '( +; ADEF AlgExtension and case COERCE COLLECT construct Declare DEF Dollar +; equation error free has IF is isnt iterate break LET local MDEF or +; pretend QUOTE REDUCE REPEAT return SEQ TARGET Tuple typeOf where )) + +(SETANDFILEQ |$specialOps| + '(ADEF |AlgExtension| |and| |case| COERCE COLLECT |construct| + |Declare| DEF |Dollar| |equation| |error| |free| |has| IF + |is| |isnt| |iterate| |break| LET |local| MDEF |or| + |pretend| QUOTE REDUCE REPEAT |return| SEQ TARGET |Tuple| + |typeOf| |where|)) + +;--% Void stuff +;voidValue() == '"()" + +(DEFUN |voidValue| NIL (MAKESTRING "()")) + +;--% Handlers for Anonymous Function Definitions +;upADEF t == +; t isnt [.,[vars,types,.,body],pred,.] => NIL +; -- do some checking on what we got +; for var in vars repeat +; if not IDENTP(var) then throwKeyedMsg("S2IS0057",[var]) +; -- unabbreviate types +; types := [(if t then evaluateType unabbrev t else NIL) for t in types] +; -- we do not allow partial types +; if isPartialMode(m := first types) then throwKeyedMsg("S2IS0058",[m]) +; -- we want everything to be declared or nothing. The exception is that +; -- we do not require a target type since we will compute one anyway. +; if null(m) and rest types then +; m := first rest types +; types' := rest rest types +; else +; types' := rest types +; for type in types' repeat +; if (type and null m) or (m and null type) then +; throwKeyedMsg("S2IS0059",NIL) +; if isPartialMode type then throwKeyedMsg("S2IS0058",[type]) +;-- $localVars: local := nil +;-- $freeVars: local := nil +;-- $env: local := [[NIL]] +; $compilingMap : local := true +; -- if there is a predicate, merge it in with the body +; if pred ^= true then body := ['IF,pred,body,'noMapVal] +; tar := getTarget t +; null m and tar is ['Mapping,.,:argTypes] and (#vars = #argTypes) => +; if isPartialMode tar then throwKeyedMsg("S2IS0058",[tar]) +; evalTargetedADEF(t,vars,rest tar,body) +; null m => evalUntargetedADEF(t,vars,types,body) +; evalTargetedADEF(t,vars,types,body) + +(DEFUN |upADEF| (|t|) + (PROG (|$compilingMap| |ISTMP#2| |vars| |ISTMP#3| |ISTMP#4| |ISTMP#5| + |ISTMP#6| |pred| |ISTMP#7| |types| |m| |types'| |body| + |tar| |ISTMP#1| |argTypes|) + (DECLARE (SPECIAL |$compilingMap|)) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |vars| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |types| + (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) + NIL) + (PROGN + (SPADLET |body| + (QCAR |ISTMP#5|)) + 'T))))))))) + (PROGN + (SPADLET |ISTMP#6| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#6|) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#6|)) + (SPADLET |ISTMP#7| + (QCDR |ISTMP#6|)) + (AND (PAIRP |ISTMP#7|) + (EQ (QCDR |ISTMP#7|) NIL))))))))) + NIL) + ('T + (DO ((G166148 |vars| (CDR G166148)) (|var| NIL)) + ((OR (ATOM G166148) + (PROGN (SETQ |var| (CAR G166148)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (IDENTP |var|)) + (|throwKeyedMsg| 'S2IS0057 + (CONS |var| NIL))) + ('T NIL))))) + (SPADLET |types| + (PROG (G166158) + (SPADLET G166158 NIL) + (RETURN + (DO ((G166163 |types| (CDR G166163)) + (|t| NIL)) + ((OR (ATOM G166163) + (PROGN + (SETQ |t| (CAR G166163)) + NIL)) + (NREVERSE0 G166158)) + (SEQ (EXIT (SETQ G166158 + (CONS + (COND + (|t| + (|evaluateType| + (|unabbrev| |t|))) + ('T NIL)) + G166158)))))))) + (COND + ((|isPartialMode| (SPADLET |m| (CAR |types|))) + (|throwKeyedMsg| 'S2IS0058 (CONS |m| NIL)))) + (COND + ((AND (NULL |m|) (CDR |types|)) + (SPADLET |m| (CAR (CDR |types|))) + (SPADLET |types'| (CDR (CDR |types|)))) + ('T (SPADLET |types'| (CDR |types|)))) + (DO ((G166174 |types'| (CDR G166174)) (|type| NIL)) + ((OR (ATOM G166174) + (PROGN (SETQ |type| (CAR G166174)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((OR (AND |type| (NULL |m|)) + (AND |m| (NULL |type|))) + (|throwKeyedMsg| 'S2IS0059 NIL))) + (COND + ((|isPartialMode| |type|) + (|throwKeyedMsg| 'S2IS0058 + (CONS |type| NIL))) + ('T NIL)))))) + (SPADLET |$compilingMap| 'T) + (COND + ((NEQUAL |pred| 'T) + (SPADLET |body| + (CONS 'IF + (CONS |pred| + (CONS |body| + (CONS '|noMapVal| NIL))))))) + (SPADLET |tar| (|getTarget| |t|)) + (COND + ((AND (NULL |m|) (PAIRP |tar|) + (EQ (QCAR |tar|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |tar|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |argTypes| (QCDR |ISTMP#1|)) + 'T))) + (BOOT-EQUAL (|#| |vars|) (|#| |argTypes|))) + (COND + ((|isPartialMode| |tar|) + (|throwKeyedMsg| 'S2IS0058 (CONS |tar| NIL)))) + (|evalTargetedADEF| |t| |vars| (CDR |tar|) |body|)) + ((NULL |m|) + (|evalUntargetedADEF| |t| |vars| |types| |body|)) + ('T (|evalTargetedADEF| |t| |vars| |types| |body|))))))))) + +;evalUntargetedADEF(t,vars,types,body) == +; -- recreate a parse form +; if vars is [var] +; then vars := var +; else vars := ['Tuple,:vars] +; val := objNewWrap(["+->",vars,body],$AnonymousFunction) +; putValue(t,val) +; putModeSet(t,[objMode val]) + +(DEFUN |evalUntargetedADEF| (|t| |vars| |types| |body|) + (PROG (|var| |val|) + (RETURN + (PROGN + (COND + ((AND (PAIRP |vars|) (EQ (QCDR |vars|) NIL) + (PROGN (SPADLET |var| (QCAR |vars|)) 'T)) + (SPADLET |vars| |var|)) + ('T (SPADLET |vars| (CONS '|Tuple| |vars|)))) + (SPADLET |val| + (|objNewWrap| + (CONS '+-> (CONS |vars| (CONS |body| NIL))) + |$AnonymousFunction|)) + (|putValue| |t| |val|) + (|putModeSet| |t| (CONS (|objMode| |val|) NIL)))))) + +;evalTargetedADEF(t,vars,types,body) == +; $mapName : local := makeInternalMapName('"anonymousFunction", +; #vars,$anonymousMapCounter,'"internal") +; $anonymousMapCounter := 1 + $anonymousMapCounter +; $compilingMap : local := true -- state that we are trying to compile +; $mapThrowCount : local := 0 -- number of "return"s encountered +; $mapReturnTypes : local := nil -- list of types from returns +; $repeatLabel : local := nil -- for loops; see upREPEAT +; $breakCount : local := 0 -- breaks from loops; ditto +; -- now substitute formal names for the parm variables +; -- this is used in the interpret-code case, but isn't so bad any way +; -- since it makes the bodies look more like regular map bodies +; sublist := [[var,:GENSYM()] for var in vars] +; body := sublisNQ(sublist,body) +; vars := [CDR v for v in sublist] +; for m in CDR types for var in vars repeat +; $env:= put(var,'mode,m,$env) +; mkLocalVar($mapName,var) +; for lvar in getLocalVars($mapName,body) repeat +; mkLocalVar($mapName,lvar) +; -- set up catch point for interpret-code mode +; x := CATCH('mapCompiler,compileTargetedADEF(t,vars,types,body)) +; x = 'tryInterpOnly => mkInterpTargetedADEF(t,vars,types,body) +; x + +(DEFUN |evalTargetedADEF| (|t| |vars| |types| |body|) + (PROG (|$mapName| |$compilingMap| |$mapThrowCount| |$mapReturnTypes| + |$repeatLabel| |$breakCount| |sublist| |x|) + (DECLARE (SPECIAL |$mapName| |$compilingMap| |$mapThrowCount| + |$mapReturnTypes| |$repeatLabel| |$breakCount|)) + (RETURN + (SEQ (PROGN + (SPADLET |$mapName| + (|makeInternalMapName| + (MAKESTRING "anonymousFunction") (|#| |vars|) + |$anonymousMapCounter| + (MAKESTRING "internal"))) + (SPADLET |$anonymousMapCounter| + (PLUS 1 |$anonymousMapCounter|)) + (SPADLET |$compilingMap| 'T) + (SPADLET |$mapThrowCount| 0) + (SPADLET |$mapReturnTypes| NIL) + (SPADLET |$repeatLabel| NIL) + (SPADLET |$breakCount| 0) + (SPADLET |sublist| + (PROG (G166221) + (SPADLET G166221 NIL) + (RETURN + (DO ((G166226 |vars| (CDR G166226)) + (|var| NIL)) + ((OR (ATOM G166226) + (PROGN + (SETQ |var| (CAR G166226)) + NIL)) + (NREVERSE0 G166221)) + (SEQ (EXIT (SETQ G166221 + (CONS (CONS |var| (GENSYM)) + G166221)))))))) + (SPADLET |body| (|sublisNQ| |sublist| |body|)) + (SPADLET |vars| + (PROG (G166236) + (SPADLET G166236 NIL) + (RETURN + (DO ((G166241 |sublist| (CDR G166241)) + (|v| NIL)) + ((OR (ATOM G166241) + (PROGN + (SETQ |v| (CAR G166241)) + NIL)) + (NREVERSE0 G166236)) + (SEQ (EXIT (SETQ G166236 + (CONS (CDR |v|) G166236)))))))) + (DO ((G166253 (CDR |types|) (CDR G166253)) (|m| NIL) + (G166254 |vars| (CDR G166254)) (|var| NIL)) + ((OR (ATOM G166253) + (PROGN (SETQ |m| (CAR G166253)) NIL) + (ATOM G166254) + (PROGN (SETQ |var| (CAR G166254)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |$env| + (|put| |var| '|mode| |m| |$env|)) + (|mkLocalVar| |$mapName| |var|))))) + (DO ((G166266 (|getLocalVars| |$mapName| |body|) + (CDR G166266)) + (|lvar| NIL)) + ((OR (ATOM G166266) + (PROGN (SETQ |lvar| (CAR G166266)) NIL)) + NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) + (SPADLET |x| + (CATCH '|mapCompiler| + (|compileTargetedADEF| |t| |vars| |types| + |body|))) + (COND + ((BOOT-EQUAL |x| '|tryInterpOnly|) + (|mkInterpTargetedADEF| |t| |vars| |types| |body|)) + ('T |x|))))))) + +;mkInterpTargetedADEF(t,vars,types,oldBody) == +; null first types => +; throwKeyedMsg("S2IS0056",NIL) +; throwMessage '" map result type needed but not present." +; arglCode := ['LIST,:[argCode for type in rest types for var in vars]] +; where argCode == ['putValueValue,['mkAtreeNode,MKQ var], +; objNewCode(['wrap,var],type)] +; put($mapName,'mapBody,oldBody,$e) +; body := ['rewriteMap1,MKQ $mapName,arglCode,MKQ types] +; compileADEFBody(t,vars,types,body,first types) + +(DEFUN |mkInterpTargetedADEF| (|t| |vars| |types| |oldBody|) + (PROG (|arglCode| |body|) + (RETURN + (SEQ (COND + ((NULL (CAR |types|)) (|throwKeyedMsg| 'S2IS0056 NIL) + (|throwMessage| + (MAKESTRING + " map result type needed but not present."))) + ('T + (SPADLET |arglCode| + (CONS 'LIST + (PROG (G166309) + (SPADLET G166309 NIL) + (RETURN + (DO ((G166315 (CDR |types|) + (CDR G166315)) + (|type| NIL) + (G166316 |vars| + (CDR G166316)) + (|var| NIL)) + ((OR (ATOM G166315) + (PROGN + (SETQ |type| (CAR G166315)) + NIL) + (ATOM G166316) + (PROGN + (SETQ |var| (CAR G166316)) + NIL)) + (NREVERSE0 G166309)) + (SEQ + (EXIT + (SETQ G166309 + (CONS + (CONS '|putValueValue| + (CONS + (CONS '|mkAtreeNode| + (CONS (MKQ |var|) NIL)) + (CONS + (|objNewCode| + (CONS '|wrap| + (CONS |var| NIL)) + |type|) + NIL))) + G166309))))))))) + (|put| |$mapName| '|mapBody| |oldBody| |$e|) + (SPADLET |body| + (CONS '|rewriteMap1| + (CONS (MKQ |$mapName|) + (CONS |arglCode| + (CONS (MKQ |types|) NIL))))) + (|compileADEFBody| |t| |vars| |types| |body| + (CAR |types|)))))))) + +;compileTargetedADEF(t,vars,types,body) == +; val := compileBody(body,CAR types) +; computedResultType := objMode val +; body := wrapMapBodyWithCatch flattenCOND objVal val +; compileADEFBody(t,vars,types,body,computedResultType) + +(DEFUN |compileTargetedADEF| (|t| |vars| |types| |body|) + (PROG (|val| |computedResultType|) + (RETURN + (PROGN + (SPADLET |val| (|compileBody| |body| (CAR |types|))) + (SPADLET |computedResultType| (|objMode| |val|)) + (SPADLET |body| + (|wrapMapBodyWithCatch| + (|flattenCOND| (|objVal| |val|)))) + (|compileADEFBody| |t| |vars| |types| |body| + |computedResultType|))))) + +;compileADEFBody(t,vars,types,body,computedResultType) == +;--+ +; $compiledOpNameList := [$mapName] +; minivectorName := makeInternalMapMinivectorName(PNAME $mapName) +; $minivectorNames := [[$mapName,:minivectorName],:$minivectorNames] +; body := SUBST(minivectorName,"$$$",body) +; if $compilingInputFile then +; $minivectorCode := [:$minivectorCode,minivectorName] +; SET(minivectorName,LIST2REFVEC $minivector) +; -- The use of the three variables $definingMap, $genValue and $compilingMap +; -- is to cover the following cases: +; -- +; -- $definingMap: This is set in analyzeMap and covers examples like: +; -- addx x == ((y: Integer): Integer +-> x + y) +; -- g := addx 10 +; -- g 3 +; -- i.e. we are storing the mapping as an object. +; -- +; -- $compilingMap: This covers mappings which are created and applied "on the +; -- "fly", for example: +; -- [map(h +-> D(h, t), v) for v in [t]] +; -- +; -- $genValue: This seems to be needed when we create a map as an argument +; -- for a constructor, e.g.: +; -- Dx: LODO(EXPR INT, f +-> D(f, x)) := D() +; -- +; -- MCD 13/3/96 +; if not $definingMap and ($genValue or $compilingMap) then +; fun := ['function,['LAMBDA,[:vars,'envArg],body]] +; code := wrap timedEVALFUN ['LIST,fun] +; else +; $freeVariables := [] +; $boundVariables := [minivectorName,:vars] +; -- CCL does not support upwards funargs, so we check for any free variables +; -- and pass them into the lambda as part of envArg. +; body := checkForFreeVariables(body,"ALL") +; fun := ['function,['LAMBDA,[:vars,'envArg],body]] +; code := ['CONS, fun, ["VECTOR", :reverse $freeVariables]] +; val := objNew(code,rt := ['Mapping,computedResultType,:rest types]) +; putValue(t,val) +; putModeSet(t,[rt]) + +(DEFUN |compileADEFBody| + (|t| |vars| |types| |body| |computedResultType|) + (PROG (|minivectorName| |fun| |code| |rt| |val|) + (RETURN + (PROGN + (SPADLET |$compiledOpNameList| (CONS |$mapName| NIL)) + (SPADLET |minivectorName| + (|makeInternalMapMinivectorName| (PNAME |$mapName|))) + (SPADLET |$minivectorNames| + (CONS (CONS |$mapName| |minivectorName|) + |$minivectorNames|)) + (SPADLET |body| (MSUBST |minivectorName| '$$$ |body|)) + (COND + (|$compilingInputFile| + (SPADLET |$minivectorCode| + (APPEND |$minivectorCode| + (CONS |minivectorName| NIL))))) + (SET |minivectorName| (LIST2REFVEC |$minivector|)) + (COND + ((AND (NULL |$definingMap|) (OR |$genValue| |$compilingMap|)) + (SPADLET |fun| + (CONS '|function| + (CONS (CONS 'LAMBDA + (CONS + (APPEND |vars| + (CONS '|envArg| NIL)) + (CONS |body| NIL))) + NIL))) + (SPADLET |code| + (|wrap| (|timedEVALFUN| + (CONS 'LIST (CONS |fun| NIL)))))) + ('T (SPADLET |$freeVariables| NIL) + (SPADLET |$boundVariables| (CONS |minivectorName| |vars|)) + (SPADLET |body| (|checkForFreeVariables| |body| 'ALL)) + (SPADLET |fun| + (CONS '|function| + (CONS (CONS 'LAMBDA + (CONS + (APPEND |vars| + (CONS '|envArg| NIL)) + (CONS |body| NIL))) + NIL))) + (SPADLET |code| + (CONS 'CONS + (CONS |fun| + (CONS (CONS 'VECTOR + (REVERSE |$freeVariables|)) + NIL)))))) + (SPADLET |val| + (|objNew| |code| + (SPADLET |rt| + (CONS '|Mapping| + (CONS |computedResultType| + (CDR |types|)))))) + (|putValue| |t| |val|) + (|putModeSet| |t| (CONS |rt| NIL)))))) + +;--% Handler for Algebraic Extensions +;upAlgExtension t == +; -- handler for algebraic extension declaration. These are of +; -- the form "a | a**2+1", and have the effect that "a" is declared +; -- to be a simple algebraic extension, with respect to the given +; -- polynomial, and given the value "a" in this type. +; t isnt [op,var,eq] => nil +; null $genValue => throwKeyedMsg("S2IS0001",NIL) +; a := getUnname var +; clearCmdParts ['propert,a] --clear properties of a +; algExtension:= eq2AlgExtension eq +; upmode := ['UnivariatePolynomial,a,$EmptyMode] +; $declaredMode : local := upmode +; putTarget(algExtension,upmode) +; ms:= bottomUp algExtension +; triple:= getValue algExtension +; upmode:= resolveTMOrCroak(objMode(triple),upmode) +; null (T:= coerceInteractive(triple,upmode)) => +; throwKeyedMsgCannotCoerceWithValue(objVal(triple), +; objMode(triple),upmode) +; newmode := objMode T +; (field := resolveTCat(CADDR newmode,'(Field))) or +; throwKeyedMsg("S2IS0002",[eq]) +; pd:= ['UnivariatePolynomial,a,field] +; null (canonicalAE:= coerceInteractive(T,pd)) => +; throwKeyedMsgCannotCoerceWithValue(objVal T,objMode T,pd) +; sae:= ['SimpleAlgebraicExtension,field,pd,objValUnwrap canonicalAE] +; saeTypeSynonym := INTERN STRCONC('"SAE",STRINGIMAGE a) +; saeTypeSynonymValue := objNew(sae,'(Domain)) +; fun := getFunctionFromDomain('generator,sae,NIL) +; expr:= wrap SPADCALL(fun) +; putHist(saeTypeSynonym,'value,saeTypeSynonymValue,$e) +; putHist(a,'mode,sae,$e) +; putHist(a,'value,T2:= objNew(expr,sae),$e) +; clearDependencies(a,true) +; if $printTypeIfTrue then +; sayKeyedMsg("S2IS0003",NIL) +; sayMSG concat ['%l,'" ",saeTypeSynonym,'" := ", +; :prefix2String objVal saeTypeSynonymValue] +; sayMSG concat ['" ",a,'" : ",saeTypeSynonym,'" := ",a] +; putValue(op,T2) +; putModeSet(op,[sae]) + +(DEFUN |upAlgExtension| (|t|) + (PROG (|$declaredMode| |op| |ISTMP#1| |var| |ISTMP#2| |eq| |a| + |algExtension| |ms| |triple| |upmode| T$ |newmode| |field| + |pd| |canonicalAE| |sae| |saeTypeSynonym| + |saeTypeSynonymValue| |fun| |expr| T2) + (DECLARE (SPECIAL |$declaredMode|)) + (RETURN + (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |eq| (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ((NULL |$genValue|) (|throwKeyedMsg| 'S2IS0001 NIL)) + ('T (SPADLET |a| (|getUnname| |var|)) + (|clearCmdParts| (CONS '|propert| (CONS |a| NIL))) + (SPADLET |algExtension| (|eq2AlgExtension| |eq|)) + (SPADLET |upmode| + (CONS '|UnivariatePolynomial| + (CONS |a| (CONS |$EmptyMode| NIL)))) + (SPADLET |$declaredMode| |upmode|) + (|putTarget| |algExtension| |upmode|) + (SPADLET |ms| (|bottomUp| |algExtension|)) + (SPADLET |triple| (|getValue| |algExtension|)) + (SPADLET |upmode| + (|resolveTMOrCroak| (|objMode| |triple|) |upmode|)) + (COND + ((NULL (SPADLET T$ (|coerceInteractive| |triple| |upmode|))) + (|throwKeyedMsgCannotCoerceWithValue| (|objVal| |triple|) + (|objMode| |triple|) |upmode|)) + ('T (SPADLET |newmode| (|objMode| T$)) + (OR (SPADLET |field| + (|resolveTCat| (CADDR |newmode|) '(|Field|))) + (|throwKeyedMsg| 'S2IS0002 (CONS |eq| NIL))) + (SPADLET |pd| + (CONS '|UnivariatePolynomial| + (CONS |a| (CONS |field| NIL)))) + (COND + ((NULL (SPADLET |canonicalAE| + (|coerceInteractive| T$ |pd|))) + (|throwKeyedMsgCannotCoerceWithValue| (|objVal| T$) + (|objMode| T$) |pd|)) + ('T + (SPADLET |sae| + (CONS '|SimpleAlgebraicExtension| + (CONS |field| + (CONS |pd| + (CONS + (|objValUnwrap| |canonicalAE|) + NIL))))) + (SPADLET |saeTypeSynonym| + (INTERN (STRCONC (MAKESTRING "SAE") + (STRINGIMAGE |a|)))) + (SPADLET |saeTypeSynonymValue| + (|objNew| |sae| '(|Domain|))) + (SPADLET |fun| + (|getFunctionFromDomain| '|generator| |sae| + NIL)) + (SPADLET |expr| (|wrap| (SPADCALL |fun|))) + (|putHist| |saeTypeSynonym| '|value| + |saeTypeSynonymValue| |$e|) + (|putHist| |a| '|mode| |sae| |$e|) + (|putHist| |a| '|value| + (SPADLET T2 (|objNew| |expr| |sae|)) |$e|) + (|clearDependencies| |a| 'T) + (COND + (|$printTypeIfTrue| (|sayKeyedMsg| 'S2IS0003 NIL) + (|sayMSG| + (|concat| + (CONS '|%l| + (CONS (MAKESTRING " ") + (CONS |saeTypeSynonym| + (CONS (MAKESTRING " := ") + (|prefix2String| + (|objVal| |saeTypeSynonymValue|)))))))) + (|sayMSG| + (|concat| + (CONS (MAKESTRING " ") + (CONS |a| + (CONS (MAKESTRING " : ") + (CONS |saeTypeSynonym| + (CONS (MAKESTRING " := ") + (CONS |a| NIL)))))))))) + (|putValue| |op| T2) + (|putModeSet| |op| (CONS |sae| NIL))))))))))) + +;eq2AlgExtension eq == +; -- transforms "a=b" to a-b for processing +; eq is [op,:l] and VECP op and (getUnname op='equation) => +; [mkAtreeNode "-",:l] +; eq + +(DEFUN |eq2AlgExtension| (|eq|) + (PROG (|op| |l|) + (RETURN + (COND + ((AND (PAIRP |eq|) + (PROGN + (SPADLET |op| (QCAR |eq|)) + (SPADLET |l| (QCDR |eq|)) + 'T) + (VECP |op|) (BOOT-EQUAL (|getUnname| |op|) '|equation|)) + (CONS (|mkAtreeNode| '-) |l|)) + ('T |eq|))))) + +;--% Handlers for booleans +;upand x == +; -- generates code for and forms. The second argument is only +; -- evaluated if the first argument is true. +; x isnt [op,term1,term2] => NIL +; putTarget(term1,$Boolean) +; putTarget(term2,$Boolean) +; ms := bottomUp term1 +; ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[1,'"_"and_""],term1) +; $genValue => +; BooleanEquality(objValUnwrap(getValue term1), +; getConstantFromDomain('(false),$Boolean)) => +; putValue(x,getValue term1) +; putModeSet(x,ms) +; -- first term is true, so look at the second one +; ms := bottomUp term2 +; ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"and_""],term2) +; putValue(x,getValue term2) +; putModeSet(x,ms) +; ms := bottomUp term2 +; ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"and_""],term2) +; -- generate an IF expression and let the rest of the code handle it +; cond := [mkAtreeNode "=",mkAtree 'false,term1] +; putTarget(cond,$Boolean) +; code := [mkAtreeNode 'IF,cond,mkAtree 'false,term2] +; putTarget(code,$Boolean) +; bottomUp code +; putValue(x,getValue code) +; putModeSet(x,ms) + +(DEFUN |upand| (|x|) + (PROG (|op| |ISTMP#1| |term1| |ISTMP#2| |term2| |ms| |cond| |code|) + (RETURN + (COND + ((NULL (AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |term1| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |term2| (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ('T (|putTarget| |term1| |$Boolean|) + (|putTarget| |term2| |$Boolean|) + (SPADLET |ms| (|bottomUp| |term1|)) + (COND + ((NULL (AND (PAIRP |ms|) (EQ (QCDR |ms|) NIL) + (EQUAL (QCAR |ms|) |$Boolean|))) + (|throwKeyedMsgSP| 'S2IS0054 + (CONS 1 (CONS (MAKESTRING "\"and\"") NIL)) |term1|)) + (|$genValue| + (COND + ((|BooleanEquality| + (|objValUnwrap| (|getValue| |term1|)) + (|getConstantFromDomain| '(|false|) |$Boolean|)) + (|putValue| |x| (|getValue| |term1|)) + (|putModeSet| |x| |ms|)) + ('T (SPADLET |ms| (|bottomUp| |term2|)) + (COND + ((NULL (AND (PAIRP |ms|) (EQ (QCDR |ms|) NIL) + (EQUAL (QCAR |ms|) |$Boolean|))) + (|throwKeyedMsgSP| 'S2IS0054 + (CONS 2 (CONS (MAKESTRING "\"and\"") NIL)) + |term2|)) + ('T (|putValue| |x| (|getValue| |term2|)) + (|putModeSet| |x| |ms|)))))) + ('T (SPADLET |ms| (|bottomUp| |term2|)) + (COND + ((NULL (AND (PAIRP |ms|) (EQ (QCDR |ms|) NIL) + (EQUAL (QCAR |ms|) |$Boolean|))) + (|throwKeyedMsgSP| 'S2IS0054 + (CONS 2 (CONS (MAKESTRING "\"and\"") NIL)) |term2|)) + ('T + (SPADLET |cond| + (CONS (|mkAtreeNode| '=) + (CONS (|mkAtree| '|false|) + (CONS |term1| NIL)))) + (|putTarget| |cond| |$Boolean|) + (SPADLET |code| + (CONS (|mkAtreeNode| 'IF) + (CONS |cond| + (CONS (|mkAtree| '|false|) + (CONS |term2| NIL))))) + (|putTarget| |code| |$Boolean|) (|bottomUp| |code|) + (|putValue| |x| (|getValue| |code|)) + (|putModeSet| |x| |ms|)))))))))) + +;upor x == +; -- generates code for or forms. The second argument is only +; -- evaluated if the first argument is false. +; x isnt [op,term1,term2] => NIL +; putTarget(term1,$Boolean) +; putTarget(term2,$Boolean) +; ms := bottomUp term1 +; ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[1,'"_"or_""],term1) +; $genValue => +; BooleanEquality(objValUnwrap(getValue term1), +; getConstantFromDomain('(true),$Boolean)) => +; putValue(x,getValue term1) +; putModeSet(x,ms) +; -- first term is false, so look at the second one +; ms := bottomUp term2 +; ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"or_""],term2) +; putValue(x,getValue term2) +; putModeSet(x,ms) +; ms := bottomUp term2 +; ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"or_""],term2) +; -- generate an IF expression and let the rest of the code handle it +; cond := [mkAtreeNode "=",mkAtree 'true,term1] +; putTarget(cond,$Boolean) +; code := [mkAtreeNode 'IF,cond,mkAtree 'true,term2] +; putTarget(code,$Boolean) +; bottomUp code +; putValue(x,getValue code) +; putModeSet(x,ms) + +(DEFUN |upor| (|x|) + (PROG (|op| |ISTMP#1| |term1| |ISTMP#2| |term2| |ms| |cond| |code|) + (RETURN + (COND + ((NULL (AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |term1| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |term2| (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ('T (|putTarget| |term1| |$Boolean|) + (|putTarget| |term2| |$Boolean|) + (SPADLET |ms| (|bottomUp| |term1|)) + (COND + ((NULL (AND (PAIRP |ms|) (EQ (QCDR |ms|) NIL) + (EQUAL (QCAR |ms|) |$Boolean|))) + (|throwKeyedMsgSP| 'S2IS0054 + (CONS 1 (CONS (MAKESTRING "\"or\"") NIL)) |term1|)) + (|$genValue| + (COND + ((|BooleanEquality| + (|objValUnwrap| (|getValue| |term1|)) + (|getConstantFromDomain| '(|true|) |$Boolean|)) + (|putValue| |x| (|getValue| |term1|)) + (|putModeSet| |x| |ms|)) + ('T (SPADLET |ms| (|bottomUp| |term2|)) + (COND + ((NULL (AND (PAIRP |ms|) (EQ (QCDR |ms|) NIL) + (EQUAL (QCAR |ms|) |$Boolean|))) + (|throwKeyedMsgSP| 'S2IS0054 + (CONS 2 (CONS (MAKESTRING "\"or\"") NIL)) + |term2|)) + ('T (|putValue| |x| (|getValue| |term2|)) + (|putModeSet| |x| |ms|)))))) + ('T (SPADLET |ms| (|bottomUp| |term2|)) + (COND + ((NULL (AND (PAIRP |ms|) (EQ (QCDR |ms|) NIL) + (EQUAL (QCAR |ms|) |$Boolean|))) + (|throwKeyedMsgSP| 'S2IS0054 + (CONS 2 (CONS (MAKESTRING "\"or\"") NIL)) |term2|)) + ('T + (SPADLET |cond| + (CONS (|mkAtreeNode| '=) + (CONS (|mkAtree| '|true|) + (CONS |term1| NIL)))) + (|putTarget| |cond| |$Boolean|) + (SPADLET |code| + (CONS (|mkAtreeNode| 'IF) + (CONS |cond| + (CONS (|mkAtree| '|true|) + (CONS |term2| NIL))))) + (|putTarget| |code| |$Boolean|) (|bottomUp| |code|) + (|putValue| |x| (|getValue| |code|)) + (|putModeSet| |x| |ms|)))))))))) + +;--% Handlers for case +;upcase t == +; t isnt [op,lhs,rhs] => nil +; bottomUp lhs +; triple := getValue lhs +; objMode(triple) isnt ['Union,:unionDoms] => +; throwKeyedMsg("S2IS0004",NIL) +; if (rhs' := isDomainValuedVariable(rhs)) then rhs := rhs' +; if first unionDoms is ['_:,.,.] then +; for i in 0.. for d in unionDoms repeat +; if d is ['_:,=rhs,.] then rhstag := i +; if NULL rhstag then error "upcase: bad Union form" +; $genValue => +; rhstag = first unwrap objVal triple => code := wrap 'TRUE +; code := wrap NIL +; code := +; ['COND, +; [['EQL,rhstag,['CAR,['unwrap,objVal triple]]], +; ''TRUE], +; [''T,NIL]] +; else +; $genValue => +; t' := coerceUnion2Branch triple +; rhs = objMode t' => code := wrap 'TRUE +; code := wrap NIL +; triple' := objNewCode(['wrap,objVal triple],objMode triple) +; code := +; ['COND, +; [['EQUAL,MKQ rhs,['objMode,['coerceUnion2Branch,triple']]], +; ''TRUE], +; [''T,NIL]] +; putValue(op,objNew(code,$Boolean)) +; putModeSet(op,[$Boolean]) + +(DEFUN |upcase| (|t|) + (PROG (|op| |lhs| |triple| |unionDoms| |rhs'| |rhs| |ISTMP#3| + |ISTMP#1| |ISTMP#2| |rhstag| |t'| |triple'| |code|) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |lhs| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |rhs| + (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ('T (|bottomUp| |lhs|) + (SPADLET |triple| (|getValue| |lhs|)) + (COND + ((NULL (PROGN + (SPADLET |ISTMP#1| (|objMode| |triple|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Union|) + (PROGN + (SPADLET |unionDoms| (QCDR |ISTMP#1|)) + 'T)))) + (|throwKeyedMsg| 'S2IS0004 NIL)) + ('T + (COND + ((SPADLET |rhs'| (|isDomainValuedVariable| |rhs|)) + (SPADLET |rhs| |rhs'|))) + (COND + ((PROGN + (SPADLET |ISTMP#1| (CAR |unionDoms|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|:|) + (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))))))) + (DO ((|i| 0 (QSADD1 |i|)) + (G166560 |unionDoms| (CDR G166560)) + (|d| NIL)) + ((OR (ATOM G166560) + (PROGN (SETQ |d| (CAR G166560)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |d|) + (EQ (QCAR |d|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |d|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |rhs|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (SPADLET |rhstag| |i|)) + ('T NIL))))) + (COND + ((NULL |rhstag|) + (|error| '|upcase: bad Union form|))) + (COND + (|$genValue| + (COND + ((BOOT-EQUAL |rhstag| + (CAR (|unwrap| (|objVal| |triple|)))) + (SPADLET |code| (|wrap| 'TRUE))) + ('T (SPADLET |code| (|wrap| NIL))))) + ('T + (SPADLET |code| + (CONS 'COND + (CONS + (CONS + (CONS 'EQL + (CONS |rhstag| + (CONS + (CONS 'CAR + (CONS + (CONS '|unwrap| + (CONS (|objVal| |triple|) + NIL)) + NIL)) + NIL))) + (CONS ''TRUE NIL)) + (CONS (CONS ''T (CONS NIL NIL)) + NIL))))))) + (|$genValue| + (SPADLET |t'| (|coerceUnion2Branch| |triple|)) + (COND + ((BOOT-EQUAL |rhs| (|objMode| |t'|)) + (SPADLET |code| (|wrap| 'TRUE))) + ('T (SPADLET |code| (|wrap| NIL))))) + ('T + (SPADLET |triple'| + (|objNewCode| + (CONS '|wrap| + (CONS (|objVal| |triple|) NIL)) + (|objMode| |triple|))) + (SPADLET |code| + (CONS 'COND + (CONS + (CONS + (CONS 'EQUAL + (CONS (MKQ |rhs|) + (CONS + (CONS '|objMode| + (CONS + (CONS '|coerceUnion2Branch| + (CONS |triple'| NIL)) + NIL)) + NIL))) + (CONS ''TRUE NIL)) + (CONS (CONS ''T (CONS NIL NIL)) + NIL)))))) + (|putValue| |op| (|objNew| |code| |$Boolean|)) + (|putModeSet| |op| (CONS |$Boolean| NIL)))))))))) + +;--% Handlers for TARGET +;upTARGET t == +; -- Evaluates the rhs to a mode,which is used as the target type for +; -- the lhs. +; t isnt [op,lhs,rhs] => nil +; -- do not (yet) support local variables on the rhs +; (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] => +; keyedMsgCompFailure("S2IC0010",[rhs]) +; $declaredMode: local := NIL +; m:= evaluateType unabbrev rhs +; not isLegitimateMode(m,NIL,NIL) => throwKeyedMsg("S2IE0004",[m]) +; categoryForm?(m) => throwKeyedMsg("S2IE0014",[m]) +; $declaredMode:= m +; not atom(lhs) and putTarget(lhs,m) +; ms := bottomUp lhs +; first ms ^= m => +; throwKeyedMsg("S2IC0011",[first ms,m]) +; putValue(op,getValue lhs) +; putModeSet(op,ms) + +(DEFUN |upTARGET| (|t|) + (PROG (|$declaredMode| |op| |ISTMP#1| |lhs| |ISTMP#2| |rhs| |m| |ms|) + (DECLARE (SPECIAL |$declaredMode|)) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |lhs| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |rhs| + (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ((AND (NULL |$genValue|) + (PROG (G166618) + (SPADLET G166618 NIL) + (RETURN + (DO ((G166624 NIL G166618) + (G166625 |$localVars| (CDR G166625)) + (|var| NIL)) + ((OR G166624 (ATOM G166625) + (PROGN + (SETQ |var| (CAR G166625)) + NIL)) + G166618) + (SEQ (EXIT (SETQ G166618 + (OR G166618 + (CONTAINED |var| |rhs|))))))))) + (|keyedMsgCompFailure| 'S2IC0010 (CONS |rhs| NIL))) + ('T (SPADLET |$declaredMode| NIL) + (SPADLET |m| (|evaluateType| (|unabbrev| |rhs|))) + (COND + ((NULL (|isLegitimateMode| |m| NIL NIL)) + (|throwKeyedMsg| 'S2IE0004 (CONS |m| NIL))) + ((|categoryForm?| |m|) + (|throwKeyedMsg| 'S2IE0014 (CONS |m| NIL))) + ('T (SPADLET |$declaredMode| |m|) + (AND (NULL (ATOM |lhs|)) (|putTarget| |lhs| |m|)) + (SPADLET |ms| (|bottomUp| |lhs|)) + (COND + ((NEQUAL (CAR |ms|) |m|) + (|throwKeyedMsg| 'S2IC0011 + (CONS (CAR |ms|) (CONS |m| NIL)))) + ('T (|putValue| |op| (|getValue| |lhs|)) + (|putModeSet| |op| |ms|))))))))))) + +;--% Handlers for COERCE +;upCOERCE t == +; -- evaluate the lhs and then tries to coerce the result to the +; -- mode which is the rhs. +; -- previous to 5/16/89, this had the same semantics as +; -- (lhs@rhs) :: rhs +; -- this must be made explicit now. +; t isnt [op,lhs,rhs] => nil +; $useConvertForCoercions : local := true +; -- do not (yet) support local variables on the rhs +; (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] => +; keyedMsgCompFailure("S2IC0006",[rhs]) +; $declaredMode: local := NIL +; m := evaluateType unabbrev rhs +; not isLegitimateMode(m,NIL,NIL) => throwKeyedMsg("S2IE0004",[m]) +; categoryForm?(m) => throwKeyedMsg("S2IE0014",[m]) +; $declaredMode:= m +; -- 05/16/89 (RSS) following line commented out to give correct +; -- semantic difference between :: and @ +; bottomUp lhs +; type:=evalCOERCE(op,lhs,m) +; putModeSet(op,[type]) + +(DEFUN |upCOERCE| (|t|) + (PROG (|$useConvertForCoercions| |$declaredMode| |op| |ISTMP#1| |lhs| + |ISTMP#2| |rhs| |m| |type|) + (DECLARE (SPECIAL |$useConvertForCoercions| |$declaredMode|)) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |lhs| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |rhs| + (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ('T (SPADLET |$useConvertForCoercions| 'T) + (COND + ((AND (NULL |$genValue|) + (PROG (G166672) + (SPADLET G166672 NIL) + (RETURN + (DO ((G166678 NIL G166672) + (G166679 |$localVars| (CDR G166679)) + (|var| NIL)) + ((OR G166678 (ATOM G166679) + (PROGN + (SETQ |var| (CAR G166679)) + NIL)) + G166672) + (SEQ (EXIT (SETQ G166672 + (OR G166672 + (CONTAINED |var| |rhs|))))))))) + (|keyedMsgCompFailure| 'S2IC0006 (CONS |rhs| NIL))) + ('T (SPADLET |$declaredMode| NIL) + (SPADLET |m| (|evaluateType| (|unabbrev| |rhs|))) + (COND + ((NULL (|isLegitimateMode| |m| NIL NIL)) + (|throwKeyedMsg| 'S2IE0004 (CONS |m| NIL))) + ((|categoryForm?| |m|) + (|throwKeyedMsg| 'S2IE0014 (CONS |m| NIL))) + ('T (SPADLET |$declaredMode| |m|) (|bottomUp| |lhs|) + (SPADLET |type| (|evalCOERCE| |op| |lhs| |m|)) + (|putModeSet| |op| (CONS |type| NIL)))))))))))) + +;evalCOERCE(op,tree,m) == +; -- the value of tree is coerced to mode m +; -- this is not necessary, if the target property of tree was used +; v := getValue tree +; t1 := objMode(v) +; if $genValue and t1 is ['Union,:.] then +; v := coerceUnion2Branch v +; t1 := objMode(v) +; e := objVal(v) +; value:= +; t1=m => v +; t2 := +; if isPartialMode m +; then +; $genValue and (t1 = '(Symbol)) and containsPolynomial m => +; resolveTM(['UnivariatePolynomial,objValUnwrap(v),'(Integer)],m) +; resolveTM(t1,m) +; else m +; null t2 => throwKeyedMsgCannotCoerceWithValue(e,t1,m) +; $genValue => coerceOrRetract(v,t2) +; objNew(getArgValue(tree,t2),t2) +; val:= value or throwKeyedMsgCannotCoerceWithValue(e,t1,m) +; putValue(op,val) +; objMode(val) + +(DEFUN |evalCOERCE| (|op| |tree| |m|) + (PROG (|v| |t1| |e| |t2| |value| |val|) + (RETURN + (PROGN + (SPADLET |v| (|getValue| |tree|)) + (SPADLET |t1| (|objMode| |v|)) + (COND + ((AND |$genValue| (PAIRP |t1|) (EQ (QCAR |t1|) '|Union|)) + (SPADLET |v| (|coerceUnion2Branch| |v|)) + (SPADLET |t1| (|objMode| |v|)))) + (SPADLET |e| (|objVal| |v|)) + (SPADLET |value| + (COND + ((BOOT-EQUAL |t1| |m|) |v|) + ('T + (SPADLET |t2| + (COND + ((|isPartialMode| |m|) + (COND + ((AND |$genValue| + (BOOT-EQUAL |t1| '(|Symbol|)) + (|containsPolynomial| |m|)) + (|resolveTM| + (CONS '|UnivariatePolynomial| + (CONS (|objValUnwrap| |v|) + (CONS '(|Integer|) NIL))) + |m|)) + ('T (|resolveTM| |t1| |m|)))) + ('T |m|))) + (COND + ((NULL |t2|) + (|throwKeyedMsgCannotCoerceWithValue| |e| |t1| + |m|)) + (|$genValue| (|coerceOrRetract| |v| |t2|)) + ('T (|objNew| (|getArgValue| |tree| |t2|) |t2|)))))) + (SPADLET |val| + (OR |value| + (|throwKeyedMsgCannotCoerceWithValue| |e| |t1| + |m|))) + (|putValue| |op| |val|) + (|objMode| |val|))))) + +;--% Handlers for COLLECT +;transformCollect [:itrl,body] == +; -- syntactic transformation for COLLECT form, called from mkAtree1 +; iterList:=[:iterTran1 for it in itrl] where iterTran1 == +; it is ['STEP,index,lower,step,:upperList] => +; [['STEP,index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper +; for upper in upperList]]] +; it is ['IN,index,s] => +; [['IN,index,mkAtree1 s]] +; it is ['ON,index,s] => +; [['IN,index,mkAtree1 ['tails,s]]] +; it is ['WHILE,b] => +; [['WHILE,mkAtree1 b]] +; it is ['_|,pred] => +; [['SUCHTHAT,mkAtree1 pred]] +; it is [op,:.] and (op in '(VALUE UNTIL)) => nil +; bodyTree:=mkAtree1 body +; iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where +; iterTran2 == +; it is ['STEP,:.] => nil +; it is ['IN,:.] => nil +; it is ['ON,:.] => nil +; it is ['WHILE,:.] => nil +; it is [op,b] and (op in '(UNTIL)) => +; [[op,mkAtree1 b]] +; it is ['_|,pred] => nil +; keyedSystemError("S2GE0016", +; ['"transformCollect",'"Unknown type of iterator"]) +; [:iterList,bodyTree] + +(DEFUN |transformCollect| (G166863) + (PROG (|LETTMP#1| |body| |itrl| |lower| |ISTMP#3| |step| |upperList| + |index| |ISTMP#2| |s| |bodyTree| |op| |b| |ISTMP#1| |pred| + |iterList|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (REVERSE G166863)) + (SPADLET |body| (CAR |LETTMP#1|)) + (SPADLET |itrl| (NREVERSE (CDR |LETTMP#1|))) + (SPADLET |iterList| + (PROG (G166918) + (SPADLET G166918 NIL) + (RETURN + (DO ((G166958 |itrl| (CDR G166958)) + (|it| NIL)) + ((OR (ATOM G166958) + (PROGN + (SETQ |it| (CAR G166958)) + NIL)) + G166918) + (SEQ (EXIT (SETQ G166918 + (APPEND G166918 + (COND + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'STEP) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |lower| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |step| + (QCAR + |ISTMP#3|)) + (SPADLET + |upperList| + (QCDR + |ISTMP#3|)) + 'T)))))))) + (CONS + (CONS 'STEP + (CONS |index| + (CONS + (|mkAtree1| |lower|) + (CONS + (|mkAtree1| |step|) + (PROG (G166968) + (SPADLET G166968 + NIL) + (RETURN + (DO + ((G166973 + |upperList| + (CDR G166973)) + (|upper| NIL)) + ((OR + (ATOM + G166973) + (PROGN + (SETQ |upper| + (CAR + G166973)) + NIL)) + (NREVERSE0 + G166968)) + (SEQ + (EXIT + (SETQ + G166968 + (CONS + (|mkAtree1| + |upper|) + G166968))))))))))) + NIL)) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'IN) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| + (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)))))) + (CONS + (CONS 'IN + (CONS |index| + (CONS (|mkAtree1| |s|) + NIL))) + NIL)) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'ON) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| + (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)))))) + (CONS + (CONS 'IN + (CONS |index| + (CONS + (|mkAtree1| + (CONS '|tails| + (CONS |s| NIL))) + NIL))) + NIL)) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'WHILE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) + NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#1|)) + 'T)))) + (CONS + (CONS 'WHILE + (CONS (|mkAtree1| |b|) + NIL)) + NIL)) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) '|\||) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) + NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (CONS + (CONS 'SUCHTHAT + (CONS (|mkAtree1| |pred|) + NIL)) + NIL)) + ((AND (PAIRP |it|) + (PROGN + (SPADLET |op| + (QCAR |it|)) + 'T) + (|member| |op| + '(VALUE UNTIL))) + NIL)))))))))) + (SPADLET |bodyTree| (|mkAtree1| |body|)) + (SPADLET |iterList| + (NCONC |iterList| + (PROG (G166979) + (SPADLET G166979 NIL) + (RETURN + (DO ((G166993 |itrl| + (CDR G166993)) + (|it| NIL)) + ((OR (ATOM G166993) + (PROGN + (SETQ |it| (CAR G166993)) + NIL)) + G166979) + (SEQ + (EXIT + (SETQ G166979 + (APPEND G166979 + (COND + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'STEP)) + NIL) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'IN)) + NIL) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'ON)) + NIL) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'WHILE)) + NIL) + ((AND (PAIRP |it|) + (PROGN + (SPADLET |op| (QCAR |it|)) + (SPADLET |ISTMP#1| + (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#1|)) + 'T))) + (|member| |op| '(UNTIL))) + (CONS + (CONS |op| + (CONS (|mkAtree1| |b|) NIL)) + NIL)) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) '|\||) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + NIL) + ('T + (|keyedSystemError| 'S2GE0016 + (CONS + (MAKESTRING + "transformCollect") + (CONS + (MAKESTRING + "Unknown type of iterator") + NIL)))))))))))))) + (APPEND |iterList| (CONS |bodyTree| NIL))))))) + +;upCOLLECT t == +; -- $compilingLoop variable insures that throw to interp-only mode +; -- goes to the outermost loop. +; $compilingLoop => upCOLLECT1 t +; upCOLLECT0 t + +(DEFUN |upCOLLECT| (|t|) + (COND (|$compilingLoop| (|upCOLLECT1| |t|)) ('T (|upCOLLECT0| |t|)))) + +;upCOLLECT0 t == +; -- sets up catch point for interpret-code mode +; $compilingLoop: local := true +; ms:=CATCH('loopCompiler,upCOLLECT1 t) +; ms = 'tryInterpOnly => interpOnlyCOLLECT t +; ms + +(DEFUN |upCOLLECT0| (|t|) + (PROG (|$compilingLoop| |ms|) + (DECLARE (SPECIAL |$compilingLoop|)) + (RETURN + (PROGN + (SPADLET |$compilingLoop| 'T) + (SPADLET |ms| (CATCH '|loopCompiler| (|upCOLLECT1| |t|))) + (COND + ((BOOT-EQUAL |ms| '|tryInterpOnly|) + (|interpOnlyCOLLECT| |t|)) + ('T |ms|)))))) + +;upCOLLECT1 t == +; t isnt [op,:itrl,body] => nil +; -- upCOLLECT with compiled body +; if (target := getTarget t) and not getTarget(body) then +; if target is [agg,S] and agg in '(List Vector Stream InfiniteTuple) then +; putTarget(body,S) +; $interpOnly => interpCOLLECT(op,itrl,body) +; isStreamCollect itrl => collectStream(t,op,itrl,body) +; upLoopIters itrl +; ms:= bottomUpCompile body +; [m]:= ms +; for itr in itrl repeat +; itr is ['UNTIL, pred] => bottomUpCompilePredicate(pred,'"until") +; mode:= ['Tuple,m] +; evalCOLLECT(op,rest t,mode) +; putModeSet(op,[mode]) + +(DEFUN |upCOLLECT1| (|t|) + (PROG (|op| |ISTMP#2| |body| |itrl| |target| |agg| S |ms| |m| + |ISTMP#1| |pred| |mode|) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |body| (QCAR |ISTMP#2|)) + (SPADLET |itrl| (QCDR |ISTMP#2|)) + 'T) + (PROGN + (SPADLET |itrl| (NREVERSE |itrl|)) + 'T))))) + NIL) + ('T + (COND + ((AND (SPADLET |target| (|getTarget| |t|)) + (NULL (|getTarget| |body|))) + (COND + ((AND (PAIRP |target|) + (PROGN + (SPADLET |agg| (QCAR |target|)) + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET S (QCAR |ISTMP#1|)) + 'T))) + (|member| |agg| + '(|List| |Vector| |Stream| + |InfiniteTuple|))) + (|putTarget| |body| S)) + ('T NIL)))) + (COND + (|$interpOnly| (|interpCOLLECT| |op| |itrl| |body|)) + ((|isStreamCollect| |itrl|) + (|collectStream| |t| |op| |itrl| |body|)) + ('T (|upLoopIters| |itrl|) + (SPADLET |ms| (|bottomUpCompile| |body|)) + (SPADLET |m| (CAR |ms|)) + (SEQ (DO ((G167093 |itrl| (CDR G167093)) + (|itr| NIL)) + ((OR (ATOM G167093) + (PROGN + (SETQ |itr| (CAR G167093)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |itr|) + (EQ (QCAR |itr|) 'UNTIL) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |itr|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (EXIT + (|bottomUpCompilePredicate| + |pred| (MAKESTRING "until")))))))) + (SPADLET |mode| (CONS '|Tuple| (CONS |m| NIL))) + (|evalCOLLECT| |op| (CDR |t|) |mode|) + (|putModeSet| |op| (CONS |mode| NIL))))))))))) + +;upLoopIters itrl == +; -- type analyze iterator loop iterators +; for iter in itrl repeat +; iter is ['WHILE,pred] => +; bottomUpCompilePredicate(pred,'"while") +; iter is ['SUCHTHAT,pred] => +; bottomUpCompilePredicate(pred,'"|") +; iter is ['UNTIL,:.] => +; NIL -- handle after body is analyzed +; iter is ['IN,index,s] => +; upLoopIterIN(iter,index,s) +; iter is ['STEP,index,lower,step,:upperList] => +; upLoopIterSTEP(index,lower,step,upperList) +; -- following is an optimization +; typeIsASmallInteger(get(index,'mode,$env)) => +; RPLACA(iter,'ISTEP) +; NIL -- should have error msg here? + +(DEFUN |upLoopIters| (|itrl|) + (PROG (|pred| |s| |ISTMP#1| |index| |ISTMP#2| |lower| |ISTMP#3| + |step| |upperList|) + (RETURN + (SEQ (DO ((G167214 |itrl| (CDR G167214)) (|iter| NIL)) + ((OR (ATOM G167214) + (PROGN (SETQ |iter| (CAR G167214)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |iter|) + (EQ (QCAR |iter|) 'WHILE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |iter|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (|bottomUpCompilePredicate| |pred| + (MAKESTRING "while"))) + ((AND (PAIRP |iter|) + (EQ (QCAR |iter|) 'SUCHTHAT) + (PROGN + (SPADLET |ISTMP#1| (QCDR |iter|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (|bottomUpCompilePredicate| |pred| + (MAKESTRING "|"))) + ((AND (PAIRP |iter|) + (EQ (QCAR |iter|) 'UNTIL)) + NIL) + ((AND (PAIRP |iter|) (EQ (QCAR |iter|) 'IN) + (PROGN + (SPADLET |ISTMP#1| (QCDR |iter|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| + (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)))))) + (|upLoopIterIN| |iter| |index| |s|)) + ((AND (PAIRP |iter|) (EQ (QCAR |iter|) 'STEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |iter|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |lower| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |step| + (QCAR |ISTMP#3|)) + (SPADLET |upperList| + (QCDR |ISTMP#3|)) + 'T)))))))) + (|upLoopIterSTEP| |index| |lower| |step| + |upperList|) + (COND + ((|typeIsASmallInteger| + (|get| |index| '|mode| |$env|)) + (RPLACA |iter| 'ISTEP)))) + ('T NIL))))))))) + +;upLoopIterIN(iter,index,s) == +; iterMs := bottomUp s +; null IDENTP index => throwKeyedMsg("S2IS0005",[index]) +; if $genValue and first iterMs is ['Union,:.] then +; v := coerceUnion2Branch getValue s +; m := objMode v +; putValue(s,v) +; putMode(s,m) +; iterMs := [m] +; putModeSet(s,iterMs) +; -- transform segment variable into STEP +; iterMs is [['Segment,.]] or iterMs is [['UniversalSegment,.]] => +; lower := [mkAtreeNode 'lo,s] +; step := [mkAtreeNode 'incr, s] +; upperList := +; CAAR(iterMs) = 'Segment => [[mkAtreeNode 'hi,s]] +; NIL +; upLoopIterSTEP(index,lower,step,upperList) +; newIter := ['STEP,index,lower,step,:upperList] +; RPLACA(iter,CAR newIter) +; RPLACD(iter,CDR newIter) +; iterMs isnt [['List,ud]] => throwKeyedMsg("S2IS0006",[index]) +; put(index,'mode,ud,$env) +; mkLocalVar('"the iterator expression",index) + +(DEFUN |upLoopIterIN| (|iter| |index| |s|) + (PROG (|v| |m| |iterMs| |lower| |step| |upperList| |newIter| + |ISTMP#1| |ISTMP#2| |ud|) + (RETURN + (PROGN + (SPADLET |iterMs| (|bottomUp| |s|)) + (COND + ((NULL (IDENTP |index|)) + (|throwKeyedMsg| 'S2IS0005 (CONS |index| NIL))) + ('T + (COND + ((AND |$genValue| + (PROGN + (SPADLET |ISTMP#1| (CAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Union|)))) + (SPADLET |v| (|coerceUnion2Branch| (|getValue| |s|))) + (SPADLET |m| (|objMode| |v|)) (|putValue| |s| |v|) + (|putMode| |s| |m|) (SPADLET |iterMs| (CONS |m| NIL)) + (|putModeSet| |s| |iterMs|))) + (COND + ((OR (AND (PAIRP |iterMs|) (EQ (QCDR |iterMs|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Segment|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (AND (PAIRP |iterMs|) (EQ (QCDR |iterMs|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|UniversalSegment|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL))))))) + (SPADLET |lower| + (CONS (|mkAtreeNode| '|lo|) (CONS |s| NIL))) + (SPADLET |step| + (CONS (|mkAtreeNode| '|incr|) (CONS |s| NIL))) + (SPADLET |upperList| + (COND + ((BOOT-EQUAL (CAAR |iterMs|) '|Segment|) + (CONS (CONS (|mkAtreeNode| '|hi|) + (CONS |s| NIL)) + NIL)) + ('T NIL))) + (|upLoopIterSTEP| |index| |lower| |step| |upperList|) + (SPADLET |newIter| + (CONS 'STEP + (CONS |index| + (CONS |lower| + (CONS |step| |upperList|))))) + (RPLACA |iter| (CAR |newIter|)) + (RPLACD |iter| (CDR |newIter|))) + ((NULL (AND (PAIRP |iterMs|) (EQ (QCDR |iterMs|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|List|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ud| + (QCAR |ISTMP#2|)) + 'T))))))) + (|throwKeyedMsg| 'S2IS0006 (CONS |index| NIL))) + ('T (|put| |index| '|mode| |ud| |$env|) + (|mkLocalVar| (MAKESTRING "the iterator expression") + |index|))))))))) + +;upLoopIterSTEP(index,lower,step,upperList) == +; null IDENTP index => throwKeyedMsg("S2IS0005",[index]) +; ltype := IFCAR bottomUpUseSubdomain(lower) +; not (typeIsASmallInteger(ltype) or isEqualOrSubDomain(ltype,$Integer))=> +; throwKeyedMsg("S2IS0007",['"lower"]) +; stype := IFCAR bottomUpUseSubdomain(step) +; not (typeIsASmallInteger(stype) or isEqualOrSubDomain(stype,$Integer))=> +; throwKeyedMsg("S2IS0008",NIL) +; types := [ltype] +; utype := nil +; for upper in upperList repeat +; utype := IFCAR bottomUpUseSubdomain(upper) +; not (typeIsASmallInteger(utype) or isEqualOrSubDomain(utype,$Integer))=> +; throwKeyedMsg("S2IS0007",['"upper"]) +; if utype then types := [utype, :types] +; else types := [stype, :types] +; type := resolveTypeListAny REMDUP types +; put(index,'mode,type,$env) +; mkLocalVar('"the iterator expression",index) + +(DEFUN |upLoopIterSTEP| (|index| |lower| |step| |upperList|) + (PROG (|ltype| |stype| |utype| |types| |type|) + (RETURN + (SEQ (COND + ((NULL (IDENTP |index|)) + (|throwKeyedMsg| 'S2IS0005 (CONS |index| NIL))) + ('T + (SPADLET |ltype| + (IFCAR (|bottomUpUseSubdomain| |lower|))) + (COND + ((NULL (OR (|typeIsASmallInteger| |ltype|) + (|isEqualOrSubDomain| |ltype| |$Integer|))) + (|throwKeyedMsg| 'S2IS0007 + (CONS (MAKESTRING "lower") NIL))) + ('T + (SPADLET |stype| + (IFCAR (|bottomUpUseSubdomain| |step|))) + (COND + ((NULL (OR (|typeIsASmallInteger| |stype|) + (|isEqualOrSubDomain| |stype| |$Integer|))) + (|throwKeyedMsg| 'S2IS0008 NIL)) + ('T (SPADLET |types| (CONS |ltype| NIL)) + (SPADLET |utype| NIL) + (DO ((G167292 |upperList| (CDR G167292)) + (|upper| NIL)) + ((OR (ATOM G167292) + (PROGN + (SETQ |upper| (CAR G167292)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |utype| + (IFCAR + (|bottomUpUseSubdomain| |upper|))) + (COND + ((NULL + (OR + (|typeIsASmallInteger| |utype|) + (|isEqualOrSubDomain| |utype| + |$Integer|))) + (|throwKeyedMsg| 'S2IS0007 + (CONS (MAKESTRING "upper") NIL)))))))) + (COND + (|utype| (SPADLET |types| (CONS |utype| |types|))) + ('T (SPADLET |types| (CONS |stype| |types|)))) + (SPADLET |type| + (|resolveTypeListAny| (REMDUP |types|))) + (|put| |index| '|mode| |type| |$env|) + (|mkLocalVar| + (MAKESTRING "the iterator expression") |index|))))))))))) + +;evalCOLLECT(op,[:itrl,body],m) == +; iters := [evalLoopIter itr for itr in itrl] +; bod := getArgValue(body,computedMode body) +; if bod isnt ['SPADCALL,:.] then bode := ['unwrap,bod] +; code := timedOptimization asTupleNewCode0 ['COLLECT,:iters,bod] +; if $genValue then code := wrap timedEVALFUN code +; putValue(op,objNew(code,m)) + +(DEFUN |evalCOLLECT| (|op| G167310 |m|) + (PROG (|LETTMP#1| |body| |itrl| |iters| |bod| |bode| |code|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (REVERSE G167310)) + (SPADLET |body| (CAR |LETTMP#1|)) + (SPADLET |itrl| (NREVERSE (CDR |LETTMP#1|))) + (SPADLET |iters| + (PROG (G167325) + (SPADLET G167325 NIL) + (RETURN + (DO ((G167330 |itrl| (CDR G167330)) + (|itr| NIL)) + ((OR (ATOM G167330) + (PROGN + (SETQ |itr| (CAR G167330)) + NIL)) + (NREVERSE0 G167325)) + (SEQ (EXIT (SETQ G167325 + (CONS (|evalLoopIter| |itr|) + G167325)))))))) + (SPADLET |bod| + (|getArgValue| |body| (|computedMode| |body|))) + (COND + ((NULL (AND (PAIRP |bod|) (EQ (QCAR |bod|) 'SPADCALL))) + (SPADLET |bode| (CONS '|unwrap| (CONS |bod| NIL))))) + (SPADLET |code| + (|timedOptimization| + (|asTupleNewCode0| + (CONS 'COLLECT + (APPEND |iters| (CONS |bod| NIL)))))) + (COND + (|$genValue| + (SPADLET |code| (|wrap| (|timedEVALFUN| |code|))))) + (|putValue| |op| (|objNew| |code| |m|))))))) + +;falseFun(x) == nil + +(DEFUN |falseFun| (|x|) NIL) + +;evalLoopIter itr == +; -- generate code for loop iterator +; itr is ['STEP,index,lower,step,:upperList] => +; ['STEP,getUnname index,getArgValue(lower,$Integer), +; getArgValue(step,$Integer), +; :[getArgValue(upper,$Integer) for upper in upperList]] +; itr is ['ISTEP,index,lower,step,:upperList] => +; ['ISTEP,getUnname index,getArgValue(lower,$SmallInteger), +; getArgValue(step,$SmallInteger), +; :[getArgValue(upper,$SmallInteger) for upper in upperList]] +; itr is ['IN,index,s] => +; ['IN,getUnname index,getArgValue(s,['List,get(index,'mode,$env)])] +; (itr is [x,pred]) and (x in '(WHILE UNTIL SUCHTHAT)) => +; [x,getArgValue(pred,$Boolean)] + +(DEFUN |evalLoopIter| (|itr|) + (PROG (|lower| |ISTMP#3| |step| |upperList| |index| |ISTMP#2| |s| |x| + |ISTMP#1| |pred|) + (RETURN + (SEQ (COND + ((AND (PAIRP |itr|) (EQ (QCAR |itr|) 'STEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |itr|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |lower| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |step| (QCAR |ISTMP#3|)) + (SPADLET |upperList| + (QCDR |ISTMP#3|)) + 'T)))))))) + (CONS 'STEP + (CONS (|getUnname| |index|) + (CONS (|getArgValue| |lower| |$Integer|) + (CONS (|getArgValue| |step| |$Integer|) + (PROG (G167465) + (SPADLET G167465 NIL) + (RETURN + (DO + ((G167470 |upperList| + (CDR G167470)) + (|upper| NIL)) + ((OR (ATOM G167470) + (PROGN + (SETQ |upper| + (CAR G167470)) + NIL)) + (NREVERSE0 G167465)) + (SEQ + (EXIT + (SETQ G167465 + (CONS + (|getArgValue| |upper| + |$Integer|) + G167465)))))))))))) + ((AND (PAIRP |itr|) (EQ (QCAR |itr|) 'ISTEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |itr|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |lower| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |step| (QCAR |ISTMP#3|)) + (SPADLET |upperList| + (QCDR |ISTMP#3|)) + 'T)))))))) + (CONS 'ISTEP + (CONS (|getUnname| |index|) + (CONS (|getArgValue| |lower| |$SmallInteger|) + (CONS (|getArgValue| |step| + |$SmallInteger|) + (PROG (G167480) + (SPADLET G167480 NIL) + (RETURN + (DO + ((G167485 |upperList| + (CDR G167485)) + (|upper| NIL)) + ((OR (ATOM G167485) + (PROGN + (SETQ |upper| + (CAR G167485)) + NIL)) + (NREVERSE0 G167480)) + (SEQ + (EXIT + (SETQ G167480 + (CONS + (|getArgValue| |upper| + |$SmallInteger|) + G167480)))))))))))) + ((AND (PAIRP |itr|) (EQ (QCAR |itr|) 'IN) + (PROGN + (SPADLET |ISTMP#1| (QCDR |itr|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| (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)))))) + (CONS 'IN + (CONS (|getUnname| |index|) + (CONS (|getArgValue| |s| + (CONS '|List| + (CONS + (|get| |index| '|mode| |$env|) + NIL))) + NIL)))) + ((AND (PAIRP |itr|) + (PROGN + (SPADLET |x| (QCAR |itr|)) + (SPADLET |ISTMP#1| (QCDR |itr|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |pred| (QCAR |ISTMP#1|)) 'T))) + (|member| |x| '(WHILE UNTIL SUCHTHAT))) + (CONS |x| (CONS (|getArgValue| |pred| |$Boolean|) NIL)))))))) + +;interpCOLLECT(op,itrl,body) == +; -- interpret-code mode COLLECT handler +; $collectTypeList: local := NIL +; $indexVars: local := NIL +; $indexTypes: local := NIL +; emptyAtree op +; emptyAtree itrl +; emptyAtree body +; code := ['COLLECT,:[interpIter itr for itr in itrl], +; interpCOLLECTbody(body,$indexVars,$indexTypes)] +; value := timedEVALFUN code +; t := +; null value => '(None) +; last $collectTypeList +; rm := ['Tuple,t] +; value := [objValUnwrap coerceInteractive(objNewWrap(v,m),t) +; for v in value for m in $collectTypeList] +; putValue(op,objNewWrap(asTupleNew(#value, value),rm)) +; putModeSet(op,[rm]) + +(DEFUN |interpCOLLECT| (|op| |itrl| |body|) + (PROG (|$collectTypeList| |$indexVars| |$indexTypes| |code| |t| |rm| + |value|) + (DECLARE (SPECIAL |$collectTypeList| |$indexVars| |$indexTypes|)) + (RETURN + (SEQ (PROGN + (SPADLET |$collectTypeList| NIL) + (SPADLET |$indexVars| NIL) + (SPADLET |$indexTypes| NIL) + (|emptyAtree| |op|) + (|emptyAtree| |itrl|) + (|emptyAtree| |body|) + (SPADLET |code| + (CONS 'COLLECT + (APPEND (PROG (G167523) + (SPADLET G167523 NIL) + (RETURN + (DO + ((G167528 |itrl| + (CDR G167528)) + (|itr| NIL)) + ((OR (ATOM G167528) + (PROGN + (SETQ |itr| + (CAR G167528)) + NIL)) + (NREVERSE0 G167523)) + (SEQ + (EXIT + (SETQ G167523 + (CONS (|interpIter| |itr|) + G167523))))))) + (CONS + (|interpCOLLECTbody| |body| + |$indexVars| |$indexTypes|) + NIL)))) + (SPADLET |value| (|timedEVALFUN| |code|)) + (SPADLET |t| + (COND + ((NULL |value|) '(|None|)) + ('T (|last| |$collectTypeList|)))) + (SPADLET |rm| (CONS '|Tuple| (CONS |t| NIL))) + (SPADLET |value| + (PROG (G167539) + (SPADLET G167539 NIL) + (RETURN + (DO ((G167545 |value| (CDR G167545)) + (|v| NIL) + (G167546 |$collectTypeList| + (CDR G167546)) + (|m| NIL)) + ((OR (ATOM G167545) + (PROGN + (SETQ |v| (CAR G167545)) + NIL) + (ATOM G167546) + (PROGN + (SETQ |m| (CAR G167546)) + NIL)) + (NREVERSE0 G167539)) + (SEQ (EXIT (SETQ G167539 + (CONS + (|objValUnwrap| + (|coerceInteractive| + (|objNewWrap| |v| |m|) |t|)) + G167539)))))))) + (|putValue| |op| + (|objNewWrap| + (|asTupleNew| (|#| |value|) |value|) |rm|)) + (|putModeSet| |op| (CONS |rm| NIL))))))) + +;interpIter itr == +; -- interpret loop iterator +; itr is ['STEP,index,lower,step,:upperList] => +; $indexVars:= [getUnname index,:$indexVars] +; [m]:= bottomUp lower +; $indexTypes:= [m,:$indexTypes] +; for up in upperList repeat bottomUp up +; ['STEP,getUnname index,getArgValue(lower,$Integer), +; getArgValue(step,$Integer), +; :[getArgValue(upper,$Integer) for upper in upperList]] +; itr is ['ISTEP,index,lower,step,:upperList] => +; $indexVars:= [getUnname index,:$indexVars] +; [m]:= bottomUp lower +; $indexTypes:= [m,:$indexTypes] +; for up in upperList repeat bottomUp up +; ['ISTEP,getUnname index,getArgValue(lower,$SmallInteger), +; getArgValue(step,$SmallInteger), +; :[getArgValue(upper,$SmallInteger) for upper in upperList]] +; itr is ['IN,index,s] => +; $indexVars:=[getUnname index,:$indexVars] +; [m]:= bottomUp s +; m isnt ['List,um] => throwKeyedMsg("S2IS0009",[m]) +; $indexTypes:=[um,:$indexTypes] +; ['IN,getUnname index,getArgValue(s,m)] +; (itr is [x,pred]) and (x in '(WHILE UNTIL SUCHTHAT)) => +; [x,interpLoop(pred,$indexVars,$indexTypes,$Boolean)] + +(DEFUN |interpIter| (|itr|) + (PROG (|lower| |ISTMP#3| |step| |upperList| |index| |ISTMP#2| |s| + |LETTMP#1| |m| |um| |x| |ISTMP#1| |pred|) + (RETURN + (SEQ (COND + ((AND (PAIRP |itr|) (EQ (QCAR |itr|) 'STEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |itr|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |lower| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |step| (QCAR |ISTMP#3|)) + (SPADLET |upperList| + (QCDR |ISTMP#3|)) + 'T)))))))) + (SPADLET |$indexVars| + (CONS (|getUnname| |index|) |$indexVars|)) + (SPADLET |LETTMP#1| (|bottomUp| |lower|)) + (SPADLET |m| (CAR |LETTMP#1|)) + (SPADLET |$indexTypes| (CONS |m| |$indexTypes|)) + (DO ((G167709 |upperList| (CDR G167709)) (|up| NIL)) + ((OR (ATOM G167709) + (PROGN (SETQ |up| (CAR G167709)) NIL)) + NIL) + (SEQ (EXIT (|bottomUp| |up|)))) + (CONS 'STEP + (CONS (|getUnname| |index|) + (CONS (|getArgValue| |lower| |$Integer|) + (CONS (|getArgValue| |step| |$Integer|) + (PROG (G167719) + (SPADLET G167719 NIL) + (RETURN + (DO + ((G167724 |upperList| + (CDR G167724)) + (|upper| NIL)) + ((OR (ATOM G167724) + (PROGN + (SETQ |upper| + (CAR G167724)) + NIL)) + (NREVERSE0 G167719)) + (SEQ + (EXIT + (SETQ G167719 + (CONS + (|getArgValue| |upper| + |$Integer|) + G167719)))))))))))) + ((AND (PAIRP |itr|) (EQ (QCAR |itr|) 'ISTEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |itr|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |lower| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |step| (QCAR |ISTMP#3|)) + (SPADLET |upperList| + (QCDR |ISTMP#3|)) + 'T)))))))) + (SPADLET |$indexVars| + (CONS (|getUnname| |index|) |$indexVars|)) + (SPADLET |LETTMP#1| (|bottomUp| |lower|)) + (SPADLET |m| (CAR |LETTMP#1|)) + (SPADLET |$indexTypes| (CONS |m| |$indexTypes|)) + (DO ((G167733 |upperList| (CDR G167733)) (|up| NIL)) + ((OR (ATOM G167733) + (PROGN (SETQ |up| (CAR G167733)) NIL)) + NIL) + (SEQ (EXIT (|bottomUp| |up|)))) + (CONS 'ISTEP + (CONS (|getUnname| |index|) + (CONS (|getArgValue| |lower| |$SmallInteger|) + (CONS (|getArgValue| |step| + |$SmallInteger|) + (PROG (G167743) + (SPADLET G167743 NIL) + (RETURN + (DO + ((G167748 |upperList| + (CDR G167748)) + (|upper| NIL)) + ((OR (ATOM G167748) + (PROGN + (SETQ |upper| + (CAR G167748)) + NIL)) + (NREVERSE0 G167743)) + (SEQ + (EXIT + (SETQ G167743 + (CONS + (|getArgValue| |upper| + |$SmallInteger|) + G167743)))))))))))) + ((AND (PAIRP |itr|) (EQ (QCAR |itr|) 'IN) + (PROGN + (SPADLET |ISTMP#1| (QCDR |itr|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| (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)))))) + (SPADLET |$indexVars| + (CONS (|getUnname| |index|) |$indexVars|)) + (SPADLET |LETTMP#1| (|bottomUp| |s|)) + (SPADLET |m| (CAR |LETTMP#1|)) + (COND + ((NULL (AND (PAIRP |m|) (EQ (QCAR |m|) '|List|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |um| (QCAR |ISTMP#1|)) + 'T))))) + (|throwKeyedMsg| 'S2IS0009 (CONS |m| NIL))) + ('T (SPADLET |$indexTypes| (CONS |um| |$indexTypes|)) + (CONS 'IN + (CONS (|getUnname| |index|) + (CONS (|getArgValue| |s| |m|) NIL)))))) + ((AND (PAIRP |itr|) + (PROGN + (SPADLET |x| (QCAR |itr|)) + (SPADLET |ISTMP#1| (QCDR |itr|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |pred| (QCAR |ISTMP#1|)) 'T))) + (|member| |x| '(WHILE UNTIL SUCHTHAT))) + (CONS |x| + (CONS (|interpLoop| |pred| |$indexVars| + |$indexTypes| |$Boolean|) + NIL)))))))) + +;interpOnlyCOLLECT t == +; -- called when compilation failed in COLLECT body, not in compiling map +; $genValue: local := true +; $interpOnly: local := true +; upCOLLECT t + +(DEFUN |interpOnlyCOLLECT| (|t|) + (PROG (|$genValue| |$interpOnly|) + (DECLARE (SPECIAL |$genValue| |$interpOnly|)) + (RETURN + (PROGN + (SPADLET |$genValue| 'T) + (SPADLET |$interpOnly| 'T) + (|upCOLLECT| |t|))))) + +;interpCOLLECTbody(expr,indexList,indexTypes) == +; -- generate code for interpret-code collect +; ['interpCOLLECTbodyIter,MKQ expr,MKQ indexList,['LIST,:indexList], +; MKQ indexTypes] + +(DEFUN |interpCOLLECTbody| (|expr| |indexList| |indexTypes|) + (CONS '|interpCOLLECTbodyIter| + (CONS (MKQ |expr|) + (CONS (MKQ |indexList|) + (CONS (CONS 'LIST |indexList|) + (CONS (MKQ |indexTypes|) NIL)))))) + +;interpCOLLECTbodyIter(exp,indexList,indexVals,indexTypes) == +; -- execute interpret-code collect body. keeps list of type of +; -- elements in list in $collectTypeList. +; emptyAtree exp +; for i in indexList for val in indexVals for type in indexTypes repeat +; put(i,'value,objNewWrap(val,type),$env) +; [m]:=bottomUp exp +; $collectTypeList:= +; null $collectTypeList => [rm:=m] +; [:$collectTypeList,rm:=resolveTT(m,last $collectTypeList)] +; null rm => throwKeyedMsg("S2IS0010",NIL) +; value:= +; rm ^= m => coerceInteractive(getValue exp,rm) +; getValue exp +; objValUnwrap(value) + +(DEFUN |interpCOLLECTbodyIter| + (|exp| |indexList| |indexVals| |indexTypes|) + (PROG (|LETTMP#1| |m| |rm| |value|) + (RETURN + (SEQ (PROGN + (|emptyAtree| |exp|) + (DO ((G167820 |indexList| (CDR G167820)) (|i| NIL) + (G167821 |indexVals| (CDR G167821)) (|val| NIL) + (G167822 |indexTypes| (CDR G167822)) + (|type| NIL)) + ((OR (ATOM G167820) + (PROGN (SETQ |i| (CAR G167820)) NIL) + (ATOM G167821) + (PROGN (SETQ |val| (CAR G167821)) NIL) + (ATOM G167822) + (PROGN (SETQ |type| (CAR G167822)) NIL)) + NIL) + (SEQ (EXIT (|put| |i| '|value| + (|objNewWrap| |val| |type|) |$env|)))) + (SPADLET |LETTMP#1| (|bottomUp| |exp|)) + (SPADLET |m| (CAR |LETTMP#1|)) + (SPADLET |$collectTypeList| + (COND + ((NULL |$collectTypeList|) + (CONS (SPADLET |rm| |m|) NIL)) + ('T + (APPEND |$collectTypeList| + (CONS (SPADLET |rm| + (|resolveTT| |m| + (|last| |$collectTypeList|))) + NIL))))) + (COND + ((NULL |rm|) (|throwKeyedMsg| 'S2IS0010 NIL)) + ('T + (SPADLET |value| + (COND + ((NEQUAL |rm| |m|) + (|coerceInteractive| (|getValue| |exp|) + |rm|)) + ('T (|getValue| |exp|)))) + (|objValUnwrap| |value|)))))))) + +;--% Stream Collect functions +;isStreamCollect itrl == +; -- calls bottomUp on iterators and if any of them are streams +; -- then whole shebang is a stream +; isStream := false +; for itr in itrl until isStream repeat +; itr is ['IN,.,s] => +; iterMs := bottomUp s +; iterMs is [['Stream,:.]] => isStream := true +; iterMs is [['InfiniteTuple,:.]] => isStream := true +; iterMs is [['UniversalSegment,:.]] => isStream := true +; itr is ['STEP,.,.,.] => isStream := true +; isStream + +(DEFUN |isStreamCollect| (|itrl|) + (PROG (|s| |iterMs| |ISTMP#1| |ISTMP#2| |ISTMP#3| |isStream|) + (RETURN + (SEQ (PROGN + (SPADLET |isStream| NIL) + (DO ((G167896 |itrl| (CDR G167896)) (|itr| NIL) + (G167897 NIL |isStream|)) + ((OR (ATOM G167896) + (PROGN (SETQ |itr| (CAR G167896)) NIL) + G167897) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |itr|) (EQ (QCAR |itr|) 'IN) + (PROGN + (SPADLET |ISTMP#1| (QCDR |itr|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |s| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |iterMs| (|bottomUp| |s|)) + (COND + ((AND (PAIRP |iterMs|) + (EQ (QCDR |iterMs|) NIL) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Stream|)))) + (SPADLET |isStream| 'T)) + ((AND (PAIRP |iterMs|) + (EQ (QCDR |iterMs|) NIL) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|InfiniteTuple|)))) + (SPADLET |isStream| 'T)) + ((AND (PAIRP |iterMs|) + (EQ (QCDR |iterMs|) NIL) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|UniversalSegment|)))) + (SPADLET |isStream| 'T)))) + ((AND (PAIRP |itr|) (EQ (QCAR |itr|) 'STEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |itr|)) + (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|) + (EQ (QCDR |ISTMP#3|) NIL)))))))) + (SPADLET |isStream| 'T)))))) + |isStream|))))) + +;collectStream(t,op,itrl,body) == +; v := CATCH('loopCompiler,collectStream1(t,op,itrl,body)) +; v = 'tryInterpOnly => throwKeyedMsg("S2IS0011",NIL) +; v + +(DEFUN |collectStream| (|t| |op| |itrl| |body|) + (PROG (|v|) + (RETURN + (PROGN + (SPADLET |v| + (CATCH '|loopCompiler| + (|collectStream1| |t| |op| |itrl| |body|))) + (COND + ((BOOT-EQUAL |v| '|tryInterpOnly|) + (|throwKeyedMsg| 'S2IS0011 NIL)) + ('T |v|)))))) + +;collectStream1(t,op,itrl,body) == +; $indexVars:local := NIL +; upStreamIters itrl +; if #$indexVars = 1 then mode:=collectOneStream(t,op,itrl,body) +; else mode:=collectSeveralStreams(t,op,itrl,body) +; putModeSet(op,[mode]) + +(DEFUN |collectStream1| (|t| |op| |itrl| |body|) + (PROG (|$indexVars| |mode|) + (DECLARE (SPECIAL |$indexVars|)) + (RETURN + (PROGN + (SPADLET |$indexVars| NIL) + (|upStreamIters| |itrl|) + (COND + ((EQL (|#| |$indexVars|) 1) + (SPADLET |mode| (|collectOneStream| |t| |op| |itrl| |body|))) + ('T + (SPADLET |mode| + (|collectSeveralStreams| |t| |op| |itrl| |body|)))) + (|putModeSet| |op| (CONS |mode| NIL)))))) + +;upStreamIters itrl == +; -- type analyze stream collect loop iterators +; for iter in itrl repeat +; iter is ['IN,index,s] => +; upStreamIterIN(iter,index,s) +; iter is ['STEP,index,lower,step,:upperList] => +; upStreamIterSTEP(index,lower,step,upperList) + +(DEFUN |upStreamIters| (|itrl|) + (PROG (|s| |ISTMP#1| |index| |ISTMP#2| |lower| |ISTMP#3| |step| + |upperList|) + (RETURN + (SEQ (DO ((G168016 |itrl| (CDR G168016)) (|iter| NIL)) + ((OR (ATOM G168016) + (PROGN (SETQ |iter| (CAR G168016)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |iter|) (EQ (QCAR |iter|) 'IN) + (PROGN + (SPADLET |ISTMP#1| (QCDR |iter|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| + (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)))))) + (|upStreamIterIN| |iter| |index| |s|)) + ((AND (PAIRP |iter|) (EQ (QCAR |iter|) 'STEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |iter|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |lower| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |step| + (QCAR |ISTMP#3|)) + (SPADLET |upperList| + (QCDR |ISTMP#3|)) + 'T)))))))) + (|upStreamIterSTEP| |index| |lower| |step| + |upperList|)))))))))) + +;upStreamIterIN(iter,index,s) == +; iterMs := bottomUp s +; -- transform segment variable into STEP +; iterMs is [['Segment,.]] or iterMs is [['UniversalSegment,.]] => +; lower := [mkAtreeNode 'lo, s] +; step := [mkAtreeNode 'incr, s] +; upperList := +; CAAR(iterMs) = 'Segment => [[mkAtreeNode 'hi,s]] +; NIL +; upStreamIterSTEP(index,lower,step,upperList) +; newIter := ['STEP,index,lower,step,:upperList] +; RPLACA(iter,CAR newIter) +; RPLACD(iter,CDR newIter) +; (iterMs isnt [['List,ud]]) and (iterMs isnt [['Stream,ud]]) +; and (iterMs isnt [['InfinitTuple, ud]]) => +; throwKeyedMsg("S2IS0006",[index]) +; put(index,'mode,ud,$env) +; mkLocalVar('"the iterator expression",index) +; s := +; iterMs is [['List,ud],:.] => +; form:=[mkAtreeNode 'pretend, [mkAtreeNode 'COERCE,s,['Stream,ud]], +; ['InfiniteTuple, ud]] +; bottomUp form +; form +; s +; $indexVars:= [[index,:s],:$indexVars] + +(DEFUN |upStreamIterIN| (|iter| |index| |s|) + (PROG (|iterMs| |lower| |step| |upperList| |newIter| |ISTMP#1| + |ISTMP#2| |ud| |form|) + (RETURN + (PROGN + (SPADLET |iterMs| (|bottomUp| |s|)) + (COND + ((OR (AND (PAIRP |iterMs|) (EQ (QCDR |iterMs|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Segment|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (AND (PAIRP |iterMs|) (EQ (QCDR |iterMs|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|UniversalSegment|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL))))))) + (SPADLET |lower| + (CONS (|mkAtreeNode| '|lo|) (CONS |s| NIL))) + (SPADLET |step| + (CONS (|mkAtreeNode| '|incr|) (CONS |s| NIL))) + (SPADLET |upperList| + (COND + ((BOOT-EQUAL (CAAR |iterMs|) '|Segment|) + (CONS (CONS (|mkAtreeNode| '|hi|) + (CONS |s| NIL)) + NIL)) + ('T NIL))) + (|upStreamIterSTEP| |index| |lower| |step| |upperList|) + (SPADLET |newIter| + (CONS 'STEP + (CONS |index| + (CONS |lower| + (CONS |step| |upperList|))))) + (RPLACA |iter| (CAR |newIter|)) + (RPLACD |iter| (CDR |newIter|))) + ((AND (NULL (AND (PAIRP |iterMs|) (EQ (QCDR |iterMs|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|List|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ud| (QCAR |ISTMP#2|)) + 'T))))))) + (NULL (AND (PAIRP |iterMs|) (EQ (QCDR |iterMs|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Stream|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ud| (QCAR |ISTMP#2|)) + 'T))))))) + (NULL (AND (PAIRP |iterMs|) (EQ (QCDR |iterMs|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|InfinitTuple|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ud| (QCAR |ISTMP#2|)) + 'T)))))))) + (|throwKeyedMsg| 'S2IS0006 (CONS |index| NIL))) + ('T (|put| |index| '|mode| |ud| |$env|) + (|mkLocalVar| (MAKESTRING "the iterator expression") + |index|) + (SPADLET |s| + (COND + ((AND (PAIRP |iterMs|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |iterMs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|List|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ud| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |form| + (CONS (|mkAtreeNode| '|pretend|) + (CONS + (CONS (|mkAtreeNode| 'COERCE) + (CONS |s| + (CONS + (CONS '|Stream| + (CONS |ud| NIL)) + NIL))) + (CONS + (CONS '|InfiniteTuple| + (CONS |ud| NIL)) + NIL)))) + (|bottomUp| |form|) |form|) + ('T |s|))) + (SPADLET |$indexVars| + (CONS (CONS |index| |s|) |$indexVars|)))))))) + +;upStreamIterSTEP(index,lower,step,upperList) == +; null isEqualOrSubDomain(ltype := IFCAR bottomUpUseSubdomain(lower), +; $Integer) => throwKeyedMsg("S2IS0007",['"lower"]) +; null isEqualOrSubDomain(stype := IFCAR bottomUpUseSubdomain(step), +; $Integer) => throwKeyedMsg("S2IS0008",NIL) +; for upper in upperList repeat +; null isEqualOrSubDomain(IFCAR bottomUpUseSubdomain(upper), +; $Integer) => throwKeyedMsg("S2IS0007",['"upper"]) +; put(index,'mode,type := resolveTT(ltype,stype),$env) +; null type => throwKeyedMsg("S2IS0010", nil) +; mkLocalVar('"the iterator expression",index) +; s := +; null upperList => +; -- create the function that does the appropriate incrementing +; genFun := 'generate +; form := [mkAtreeNode genFun, +; [[mkAtreeNode 'Dollar, ['IncrementingMaps,type], +; mkAtreeNode 'incrementBy],step],lower] +; bottomUp form +; form +; form := [mkAtreeNode 'SEGMENT,lower,first upperList] +; putTarget(form,['Segment,type]) +; form := [mkAtreeNode 'construct,form] +; putTarget(form,['List,['Segment,type]]) +; form := [mkAtreeNode 'expand,form] +; putTarget(form,'(List (Integer))) +; form:=[mkAtreeNode 'pretend, [mkAtreeNode 'COERCE,form,['Stream,$Integer]], +; ['InfiniteTuple, $Integer]] +; bottomUp form +; form +; $indexVars:= [[index,:s],:$indexVars] + +(DEFUN |upStreamIterSTEP| (|index| |lower| |step| |upperList|) + (PROG (|ltype| |stype| |type| |genFun| |form| |s|) + (RETURN + (SEQ (COND + ((NULL (|isEqualOrSubDomain| + (SPADLET |ltype| + (IFCAR (|bottomUpUseSubdomain| + |lower|))) + |$Integer|)) + (|throwKeyedMsg| 'S2IS0007 + (CONS (MAKESTRING "lower") NIL))) + ((NULL (|isEqualOrSubDomain| + (SPADLET |stype| + (IFCAR (|bottomUpUseSubdomain| |step|))) + |$Integer|)) + (|throwKeyedMsg| 'S2IS0008 NIL)) + ('T + (SEQ (DO ((G168126 |upperList| (CDR G168126)) + (|upper| NIL)) + ((OR (ATOM G168126) + (PROGN (SETQ |upper| (CAR G168126)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL + (|isEqualOrSubDomain| + (IFCAR + (|bottomUpUseSubdomain| |upper|)) + |$Integer|)) + (EXIT + (|throwKeyedMsg| 'S2IS0007 + (CONS (MAKESTRING "upper") NIL)))))))) + (|put| |index| '|mode| + (SPADLET |type| + (|resolveTT| |ltype| |stype|)) + |$env|) + (COND + ((NULL |type|) + (EXIT (|throwKeyedMsg| 'S2IS0010 NIL)))) + (|mkLocalVar| (MAKESTRING "the iterator expression") + |index|) + (SPADLET |s| + (COND + ((NULL |upperList|) + (SPADLET |genFun| '|generate|) + (SPADLET |form| + (CONS (|mkAtreeNode| |genFun|) + (CONS + (CONS + (CONS + (|mkAtreeNode| '|Dollar|) + (CONS + (CONS '|IncrementingMaps| + (CONS |type| NIL)) + (CONS + (|mkAtreeNode| + '|incrementBy|) + NIL))) + (CONS |step| NIL)) + (CONS |lower| NIL)))) + (|bottomUp| |form|) |form|) + ('T + (SPADLET |form| + (CONS (|mkAtreeNode| 'SEGMENT) + (CONS |lower| + (CONS (CAR |upperList|) NIL)))) + (|putTarget| |form| + (CONS '|Segment| (CONS |type| NIL))) + (SPADLET |form| + (CONS + (|mkAtreeNode| '|construct|) + (CONS |form| NIL))) + (|putTarget| |form| + (CONS '|List| + (CONS + (CONS '|Segment| + (CONS |type| NIL)) + NIL))) + (SPADLET |form| + (CONS (|mkAtreeNode| '|expand|) + (CONS |form| NIL))) + (|putTarget| |form| + '(|List| (|Integer|))) + (SPADLET |form| + (CONS + (|mkAtreeNode| '|pretend|) + (CONS + (CONS (|mkAtreeNode| 'COERCE) + (CONS |form| + (CONS + (CONS '|Stream| + (CONS |$Integer| NIL)) + NIL))) + (CONS + (CONS '|InfiniteTuple| + (CONS |$Integer| NIL)) + NIL)))) + (|bottomUp| |form|) |form|))) + (SPADLET |$indexVars| + (CONS (CONS |index| |s|) |$indexVars|))))))))) + +;collectOneStream(t,op,itrl,body) == +; -- build stream collect for case of iterating over a single stream +; -- In this case we don't need to build records +; form := mkAndApplyPredicates itrl +; bodyVec := mkIterFun(CAR $indexVars,body,$localVars) +; form := [mkAtreeNode 'map,bodyVec,form] +; bottomUp form +; val := getValue form +; m := objMode val +; m isnt ['Stream, ud] and m isnt ['InfiniteTuple, ud] => +; systemError '"Not a Stream" +; newVal := objNew(objVal val, ['InfiniteTuple, ud]) +; putValue(op,newVal) +; objMode newVal + +(DEFUN |collectOneStream| (|t| |op| |itrl| |body|) + (PROG (|bodyVec| |form| |val| |m| |ISTMP#1| |ud| |newVal|) + (RETURN + (PROGN + (SPADLET |form| (|mkAndApplyPredicates| |itrl|)) + (SPADLET |bodyVec| + (|mkIterFun| (CAR |$indexVars|) |body| |$localVars|)) + (SPADLET |form| + (CONS (|mkAtreeNode| '|map|) + (CONS |bodyVec| (CONS |form| NIL)))) + (|bottomUp| |form|) + (SPADLET |val| (|getValue| |form|)) + (SPADLET |m| (|objMode| |val|)) + (COND + ((AND (NULL (AND (PAIRP |m|) (EQ (QCAR |m|) '|Stream|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ud| (QCAR |ISTMP#1|)) + 'T))))) + (NULL (AND (PAIRP |m|) (EQ (QCAR |m|) '|InfiniteTuple|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ud| (QCAR |ISTMP#1|)) + 'T)))))) + (|systemError| (MAKESTRING "Not a Stream"))) + ('T + (SPADLET |newVal| + (|objNew| (|objVal| |val|) + (CONS '|InfiniteTuple| (CONS |ud| NIL)))) + (|putValue| |op| |newVal|) (|objMode| |newVal|))))))) + +;mkAndApplyPredicates itrl == +; -- for one index variable case for now. may generalize later +; [indSet] := $indexVars +; [.,:s] := indSet +; for iter in itrl repeat +; iter is ['WHILE,pred] => +; fun := 'filterWhile +; predVec := mkIterFun(indSet,pred,$localVars) +; s := [mkAtreeNode fun,predVec,s] +; iter is ['UNTIL,pred] => +; fun := 'filterUntil +; predVec := mkIterFun(indSet,pred,$localVars) +; s := [mkAtreeNode fun,predVec,s] +; iter is ['SUCHTHAT,pred] => +; fun := 'select +; putTarget(pred,$Boolean) +; predVec := mkIterFun(indSet,pred,$localVars) +; s := [mkAtreeNode fun,predVec,s] +; s + +(DEFUN |mkAndApplyPredicates| (|itrl|) + (PROG (|indSet| |ISTMP#1| |pred| |fun| |predVec| |s|) + (RETURN + (SEQ (PROGN + (SPADLET |indSet| (CAR |$indexVars|)) + (SPADLET |s| (CDR |indSet|)) + (DO ((G168208 |itrl| (CDR G168208)) (|iter| NIL)) + ((OR (ATOM G168208) + (PROGN (SETQ |iter| (CAR G168208)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |iter|) + (EQ (QCAR |iter|) 'WHILE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |iter|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |fun| '|filterWhile|) + (SPADLET |predVec| + (|mkIterFun| |indSet| |pred| + |$localVars|)) + (SPADLET |s| + (CONS (|mkAtreeNode| |fun|) + (CONS |predVec| (CONS |s| NIL))))) + ((AND (PAIRP |iter|) + (EQ (QCAR |iter|) 'UNTIL) + (PROGN + (SPADLET |ISTMP#1| (QCDR |iter|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |fun| '|filterUntil|) + (SPADLET |predVec| + (|mkIterFun| |indSet| |pred| + |$localVars|)) + (SPADLET |s| + (CONS (|mkAtreeNode| |fun|) + (CONS |predVec| (CONS |s| NIL))))) + ((AND (PAIRP |iter|) + (EQ (QCAR |iter|) 'SUCHTHAT) + (PROGN + (SPADLET |ISTMP#1| (QCDR |iter|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (PROGN + (SPADLET |fun| '|select|) + (|putTarget| |pred| |$Boolean|) + (SPADLET |predVec| + (|mkIterFun| |indSet| |pred| + |$localVars|)) + (SPADLET |s| + (CONS (|mkAtreeNode| |fun|) + (CONS |predVec| + (CONS |s| NIL)))))))))) + |s|))))) + +;mkIterFun([index,:s],funBody,$localVars) == +; -- transform funBody into a lambda with index as the parameter +; mode := objMode getValue s +; mode isnt ['Stream, indMode] and mode isnt ['InfiniteTuple, indMode] => +; keyedSystemError('"S2GE0016", '("mkIterFun" "bad stream index type")) +; put(index,'mode,indMode,$env) +; mkLocalVar($mapName,index) +; [m]:=bottomUpCompile funBody +; mapMode := ['Mapping,m,indMode] +; $freeVariables := [] +; $boundVariables := [index] +; -- CCL does not support upwards funargs, so we check for any free variables +; -- and pass them into the lambda as part of envArg. +; body := checkForFreeVariables(getValue funBody,$localVars) +; val:=['function,['LAMBDA,[index,'envArg],objVal body]] +; vec := mkAtreeNode GENSYM() +; putValue(vec,objNew(['CONS,val,["VECTOR",:reverse $freeVariables]],mapMode)) +; vec + +(DEFUN |mkIterFun| (G168248 |funBody| |$localVars|) + (DECLARE (SPECIAL |$localVars|)) + (PROG (|index| |s| |mode| |ISTMP#1| |indMode| |LETTMP#1| |m| + |mapMode| |body| |val| |vec|) + (RETURN + (PROGN + (SPADLET |index| (CAR G168248)) + (SPADLET |s| (CDR G168248)) + (SPADLET |mode| (|objMode| (|getValue| |s|))) + (COND + ((AND (NULL (AND (PAIRP |mode|) (EQ (QCAR |mode|) '|Stream|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |mode|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |indMode| + (QCAR |ISTMP#1|)) + 'T))))) + (NULL (AND (PAIRP |mode|) + (EQ (QCAR |mode|) '|InfiniteTuple|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |mode|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |indMode| + (QCAR |ISTMP#1|)) + 'T)))))) + (|keyedSystemError| (MAKESTRING "S2GE0016") + '("mkIterFun" "bad stream index type"))) + ('T (|put| |index| '|mode| |indMode| |$env|) + (|mkLocalVar| |$mapName| |index|) + (SPADLET |LETTMP#1| (|bottomUpCompile| |funBody|)) + (SPADLET |m| (CAR |LETTMP#1|)) + (SPADLET |mapMode| + (CONS '|Mapping| (CONS |m| (CONS |indMode| NIL)))) + (SPADLET |$freeVariables| NIL) + (SPADLET |$boundVariables| (CONS |index| NIL)) + (SPADLET |body| + (|checkForFreeVariables| (|getValue| |funBody|) + |$localVars|)) + (SPADLET |val| + (CONS '|function| + (CONS (CONS 'LAMBDA + (CONS + (CONS |index| + (CONS '|envArg| NIL)) + (CONS (|objVal| |body|) NIL))) + NIL))) + (SPADLET |vec| (|mkAtreeNode| (GENSYM))) + (|putValue| |vec| + (|objNew| + (CONS 'CONS + (CONS |val| + (CONS (CONS 'VECTOR + (REVERSE |$freeVariables|)) + NIL))) + |mapMode|)) + |vec|)))))) + +;checkForFreeVariables(v,locals) == +; -- v is the body of a lambda expression. The list $boundVariables is all the +; -- bound variables, the parameter locals contains local variables which might +; -- be free, or the token ALL, which means that any parameter is a candidate +; -- to be free. +; NULL v => v +; SYMBOLP v => +; v="$$$" => v -- Placeholder for mini-vector +; MEMQ(v,$boundVariables) => v +; p := POSITION(v,$freeVariables) => +; ["ELT","envArg",positionInVec(p,#($freeVariables))] +; (locals = "ALL") or MEMQ(v,locals) => +; $freeVariables := [v,:$freeVariables] +; ["ELT","envArg",positionInVec(0,#($freeVariables))] +; v +; LISTP v => +; CDR(LASTTAIL v) => -- Must be a better way to check for a genuine list? +; v +; [op,:args] := v +; LISTP op => +; -- Might have a mode at the front of a list, or be calling a function +; -- which returns a function. +; [checkForFreeVariables(op,locals),:[checkForFreeVariables(a,locals) for a in args]] +; op = "LETT" => -- Expands to a SETQ. +; ["SETF",:[checkForFreeVariables(a,locals) for a in args]] +; op = "COLLECT" => -- Introduces a new bound variable? +; first(args) is ["STEP",var,:.] => +; $boundVariables := [var,:$boundVariables] +; r := ["COLLECT",:[checkForFreeVariables(a,locals) for a in args]] +; $boundVariables := DELETE(var,$boundVariables) +; r +; ["COLLECT",:[checkForFreeVariables(a,locals) for a in args]] +; op = "REPEAT" => -- Introduces a new bound variable? +; first(args) is ["STEP",var,:.] => +; $boundVariables := [var,:$boundVariables] +; r := ["REPEAT",:[checkForFreeVariables(a,locals) for a in args]] +; $boundVariables := DELETE(var,$boundVariables) +; r +; ["REPEAT",:[checkForFreeVariables(a,locals) for a in args]] +; op = "LET" => +; args is [var,form,name] => +; -- This is some bizarre LET, not what one would expect in Common Lisp! +; -- Treat var as a free variable, since it may be bound out of scope +; -- if we are in a lambda within another lambda. +; newvar := +; p := POSITION(var,$freeVariables) => +; ["ELT","envArg",positionInVec(p,#($freeVariables))] +; $freeVariables := [var,:$freeVariables] +; ["ELT","envArg",positionInVec(0,#($freeVariables))] +; ["SETF",newvar,checkForFreeVariables(form,locals)] +; error "Non-simple variable bindings are not currently supported" +; op = "PROG" => +; error "Non-simple variable bindings are not currently supported" +; op = "LAMBDA" => v +; op = "QUOTE" => v +; op = "getValueFromEnvironment" => v +; [op,:[checkForFreeVariables(a,locals) for a in args]] +; v + +(DEFUN |checkForFreeVariables| (|v| |locals|) + (PROG (|op| |args| |r| |var| |ISTMP#1| |form| |ISTMP#2| |name| |p| + |newvar|) + (RETURN + (SEQ (COND + ((NULL |v|) |v|) + ((SYMBOLP |v|) + (COND + ((BOOT-EQUAL |v| '$$$) |v|) + ((MEMQ |v| |$boundVariables|) |v|) + ((SPADLET |p| (POSITION |v| |$freeVariables|)) + (CONS 'ELT + (CONS '|envArg| + (CONS (|positionInVec| |p| + (|#| |$freeVariables|)) + NIL)))) + ((OR (BOOT-EQUAL |locals| 'ALL) (MEMQ |v| |locals|)) + (SPADLET |$freeVariables| (CONS |v| |$freeVariables|)) + (CONS 'ELT + (CONS '|envArg| + (CONS (|positionInVec| 0 + (|#| |$freeVariables|)) + NIL)))) + ('T |v|))) + ((LISTP |v|) + (COND + ((CDR (LASTTAIL |v|)) |v|) + ('T (SPADLET |op| (CAR |v|)) (SPADLET |args| (CDR |v|)) + (COND + ((LISTP |op|) + (CONS (|checkForFreeVariables| |op| |locals|) + (PROG (G168349) + (SPADLET G168349 NIL) + (RETURN + (DO ((G168354 |args| (CDR G168354)) + (|a| NIL)) + ((OR (ATOM G168354) + (PROGN + (SETQ |a| (CAR G168354)) + NIL)) + (NREVERSE0 G168349)) + (SEQ (EXIT + (SETQ G168349 + (CONS + (|checkForFreeVariables| |a| + |locals|) + G168349))))))))) + ((BOOT-EQUAL |op| 'LETT) + (CONS 'SETF + (PROG (G168364) + (SPADLET G168364 NIL) + (RETURN + (DO ((G168369 |args| (CDR G168369)) + (|a| NIL)) + ((OR (ATOM G168369) + (PROGN + (SETQ |a| (CAR G168369)) + NIL)) + (NREVERSE0 G168364)) + (SEQ (EXIT + (SETQ G168364 + (CONS + (|checkForFreeVariables| |a| + |locals|) + G168364))))))))) + ((BOOT-EQUAL |op| 'COLLECT) + (COND + ((PROGN + (SPADLET |ISTMP#1| (CAR |args|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'STEP) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |var| (QCAR |ISTMP#2|)) + 'T))))) + (SPADLET |$boundVariables| + (CONS |var| |$boundVariables|)) + (SPADLET |r| + (CONS 'COLLECT + (PROG (G168379) + (SPADLET G168379 NIL) + (RETURN + (DO + ((G168384 |args| + (CDR G168384)) + (|a| NIL)) + ((OR (ATOM G168384) + (PROGN + (SETQ |a| + (CAR G168384)) + NIL)) + (NREVERSE0 G168379)) + (SEQ + (EXIT + (SETQ G168379 + (CONS + (|checkForFreeVariables| + |a| |locals|) + G168379))))))))) + (SPADLET |$boundVariables| + (|delete| |var| |$boundVariables|)) + |r|) + ('T + (CONS 'COLLECT + (PROG (G168394) + (SPADLET G168394 NIL) + (RETURN + (DO ((G168399 |args| + (CDR G168399)) + (|a| NIL)) + ((OR (ATOM G168399) + (PROGN + (SETQ |a| (CAR G168399)) + NIL)) + (NREVERSE0 G168394)) + (SEQ + (EXIT + (SETQ G168394 + (CONS + (|checkForFreeVariables| |a| + |locals|) + G168394))))))))))) + ((BOOT-EQUAL |op| 'REPEAT) + (COND + ((PROGN + (SPADLET |ISTMP#1| (CAR |args|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'STEP) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |var| (QCAR |ISTMP#2|)) + 'T))))) + (SPADLET |$boundVariables| + (CONS |var| |$boundVariables|)) + (SPADLET |r| + (CONS 'REPEAT + (PROG (G168409) + (SPADLET G168409 NIL) + (RETURN + (DO + ((G168414 |args| + (CDR G168414)) + (|a| NIL)) + ((OR (ATOM G168414) + (PROGN + (SETQ |a| + (CAR G168414)) + NIL)) + (NREVERSE0 G168409)) + (SEQ + (EXIT + (SETQ G168409 + (CONS + (|checkForFreeVariables| + |a| |locals|) + G168409))))))))) + (SPADLET |$boundVariables| + (|delete| |var| |$boundVariables|)) + |r|) + ('T + (CONS 'REPEAT + (PROG (G168424) + (SPADLET G168424 NIL) + (RETURN + (DO ((G168429 |args| + (CDR G168429)) + (|a| NIL)) + ((OR (ATOM G168429) + (PROGN + (SETQ |a| (CAR G168429)) + NIL)) + (NREVERSE0 G168424)) + (SEQ + (EXIT + (SETQ G168424 + (CONS + (|checkForFreeVariables| |a| + |locals|) + G168424))))))))))) + ((BOOT-EQUAL |op| 'LET) + (COND + ((AND (PAIRP |args|) + (PROGN + (SPADLET |var| (QCAR |args|)) + (SPADLET |ISTMP#1| (QCDR |args|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |form| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |name| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |newvar| + (COND + ((SPADLET |p| + (POSITION |var| |$freeVariables|)) + (CONS 'ELT + (CONS '|envArg| + (CONS + (|positionInVec| |p| + (|#| |$freeVariables|)) + NIL)))) + ('T + (SPADLET |$freeVariables| + (CONS |var| |$freeVariables|)) + (CONS 'ELT + (CONS '|envArg| + (CONS + (|positionInVec| 0 + (|#| |$freeVariables|)) + NIL)))))) + (CONS 'SETF + (CONS |newvar| + (CONS + (|checkForFreeVariables| |form| + |locals|) + NIL)))) + ('T + (|error| '|Non-simple variable bindings are not currently supported|)))) + ((BOOT-EQUAL |op| 'PROG) + (|error| '|Non-simple variable bindings are not currently supported|)) + ((BOOT-EQUAL |op| 'LAMBDA) |v|) + ((BOOT-EQUAL |op| 'QUOTE) |v|) + ((BOOT-EQUAL |op| '|getValueFromEnvironment|) |v|) + ('T + (CONS |op| + (PROG (G168439) + (SPADLET G168439 NIL) + (RETURN + (DO ((G168444 |args| (CDR G168444)) + (|a| NIL)) + ((OR (ATOM G168444) + (PROGN + (SETQ |a| (CAR G168444)) + NIL)) + (NREVERSE0 G168439)) + (SEQ (EXIT + (SETQ G168439 + (CONS + (|checkForFreeVariables| |a| + |locals|) + G168439))))))))))))) + ('T |v|)))))) + +;positionInVec(p,l) == +; -- We cons up the free list, but need to keep positions consistent so +; -- count from the end of the list. +; l-p-1 + +(DEFUN |positionInVec| (|p| |l|) (SPADDIFFERENCE (SPADDIFFERENCE |l| |p|) 1)) + +;collectSeveralStreams(t,op,itrl,body) == +; -- performs collects over several streams in parallel +; $index: local := nil +; [form,:zipType] := mkZipCode $indexVars +; form := mkAndApplyZippedPredicates(form,zipType,itrl) +; vec := mkIterZippedFun($indexVars,body,zipType,$localVars) +; form := [mkAtreeNode 'map, vec, form] +; bottomUp form +; val := getValue form +; m := objMode val +; m isnt ['Stream, ud] and m isnt ['InfiniteTuple, ud] => +; systemError '"Not a Stream" +; newVal := objNew(objVal val, ['InfiniteTuple, ud]) +; putValue(op,newVal) +; objMode newVal + +(DEFUN |collectSeveralStreams| (|t| |op| |itrl| |body|) + (PROG (|$index| |LETTMP#1| |zipType| |vec| |form| |val| |m| |ISTMP#1| + |ud| |newVal|) + (DECLARE (SPECIAL |$index|)) + (RETURN + (PROGN + (SPADLET |$index| NIL) + (SPADLET |LETTMP#1| (|mkZipCode| |$indexVars|)) + (SPADLET |form| (CAR |LETTMP#1|)) + (SPADLET |zipType| (CDR |LETTMP#1|)) + (SPADLET |form| + (|mkAndApplyZippedPredicates| |form| |zipType| |itrl|)) + (SPADLET |vec| + (|mkIterZippedFun| |$indexVars| |body| |zipType| + |$localVars|)) + (SPADLET |form| + (CONS (|mkAtreeNode| '|map|) + (CONS |vec| (CONS |form| NIL)))) + (|bottomUp| |form|) + (SPADLET |val| (|getValue| |form|)) + (SPADLET |m| (|objMode| |val|)) + (COND + ((AND (NULL (AND (PAIRP |m|) (EQ (QCAR |m|) '|Stream|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ud| (QCAR |ISTMP#1|)) + 'T))))) + (NULL (AND (PAIRP |m|) (EQ (QCAR |m|) '|InfiniteTuple|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ud| (QCAR |ISTMP#1|)) + 'T)))))) + (|systemError| (MAKESTRING "Not a Stream"))) + ('T + (SPADLET |newVal| + (|objNew| (|objVal| |val|) + (CONS '|InfiniteTuple| (CONS |ud| NIL)))) + (|putValue| |op| |newVal|) (|objMode| |newVal|))))))) + +;mkZipCode indexList == +; -- create interpreter form for turning a list of parallel streams +; -- into a stream of nested record types. returns [form,:recordType] +; #indexList = 2 => +; [[.,:s2],[.,:s1]] := indexList +; t1 := CADR objMode getValue s1 +; t2 := CADR objMode getValue s2 +; zipType := ['Record,['_:,'part1,t1], ['_:,'part2,t2] ] +; zipFun := [mkAtreeNode 'Dollar, ['MakeRecord,mkEvalable t1, +; mkEvalable t2], +; mkAtreeNode 'makeRecord] +; form := [mkAtreeNode 'map,zipFun,s1,s2] +; [form,:zipType] +; [form,:zipType] := mkZipCode CDR indexList +; [[.,:s],:.] := indexList +; t := CADR objMode getValue s +; zipFun := [mkAtreeNode 'Dollar, ['MakeRecord,mkEvalable t, +; mkEvalable zipType], +; mkAtreeNode 'makeRecord] +; form := [mkAtreeNode 'map,zipFun,s,form] +; zipType := ['Record,['_:,'part1,t],['_:,'part2,zipType]] +; [form,:zipType] + +(DEFUN |mkZipCode| (|indexList|) + (PROG (|s2| |s1| |t1| |t2| |LETTMP#1| |s| |t| |zipFun| |form| + |zipType|) + (RETURN + (COND + ((EQL (|#| |indexList|) 2) (SPADLET |s2| (CDAR |indexList|)) + (SPADLET |s1| (CDADR |indexList|)) + (SPADLET |t1| (CADR (|objMode| (|getValue| |s1|)))) + (SPADLET |t2| (CADR (|objMode| (|getValue| |s2|)))) + (SPADLET |zipType| + (CONS '|Record| + (CONS (CONS '|:| + (CONS '|part1| (CONS |t1| NIL))) + (CONS (CONS '|:| + (CONS '|part2| (CONS |t2| NIL))) + NIL)))) + (SPADLET |zipFun| + (CONS (|mkAtreeNode| '|Dollar|) + (CONS (CONS '|MakeRecord| + (CONS (|mkEvalable| |t1|) + (CONS (|mkEvalable| |t2|) NIL))) + (CONS (|mkAtreeNode| '|makeRecord|) NIL)))) + (SPADLET |form| + (CONS (|mkAtreeNode| '|map|) + (CONS |zipFun| (CONS |s1| (CONS |s2| NIL))))) + (CONS |form| |zipType|)) + ('T (SPADLET |LETTMP#1| (|mkZipCode| (CDR |indexList|))) + (SPADLET |form| (CAR |LETTMP#1|)) + (SPADLET |zipType| (CDR |LETTMP#1|)) + (SPADLET |s| (CDAR |indexList|)) + (SPADLET |t| (CADR (|objMode| (|getValue| |s|)))) + (SPADLET |zipFun| + (CONS (|mkAtreeNode| '|Dollar|) + (CONS (CONS '|MakeRecord| + (CONS (|mkEvalable| |t|) + (CONS (|mkEvalable| |zipType|) + NIL))) + (CONS (|mkAtreeNode| '|makeRecord|) NIL)))) + (SPADLET |form| + (CONS (|mkAtreeNode| '|map|) + (CONS |zipFun| (CONS |s| (CONS |form| NIL))))) + (SPADLET |zipType| + (CONS '|Record| + (CONS (CONS '|:| + (CONS '|part1| (CONS |t| NIL))) + (CONS (CONS '|:| + (CONS '|part2| + (CONS |zipType| NIL))) + NIL)))) + (CONS |form| |zipType|)))))) + +;mkAndApplyZippedPredicates (s,zipType,itrl) == +; -- for one index variable case for now. may generalize later +; for iter in itrl repeat +; iter is ['WHILE,pred] => +; predVec := mkIterZippedFun($indexList,pred,zipType,$localVars) +; s := [mkAtreeNode 'swhile,predVec,s] +; iter is ['UNTIL,pred] => +; predVec := mkIterZippedFun($indexList,pred,zipType,$localVars) +; s := [mkAtreeNode 'suntil,predVec,s] +; iter is ['SUCHTHAT,pred] => +; putTarget(pred,$Boolean) +; predVec := mkIterZippedFun($indexList,pred,zipType,$localVars) +; s := [mkAtreeNode 'select,predVec,s] +; s + +(DEFUN |mkAndApplyZippedPredicates| (|s| |zipType| |itrl|) + (PROG (|ISTMP#1| |pred| |predVec|) + (RETURN + (SEQ (PROGN + (DO ((G168589 |itrl| (CDR G168589)) (|iter| NIL)) + ((OR (ATOM G168589) + (PROGN (SETQ |iter| (CAR G168589)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |iter|) + (EQ (QCAR |iter|) 'WHILE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |iter|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |predVec| + (|mkIterZippedFun| |$indexList| + |pred| |zipType| |$localVars|)) + (SPADLET |s| + (CONS (|mkAtreeNode| '|swhile|) + (CONS |predVec| (CONS |s| NIL))))) + ((AND (PAIRP |iter|) + (EQ (QCAR |iter|) 'UNTIL) + (PROGN + (SPADLET |ISTMP#1| (QCDR |iter|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |predVec| + (|mkIterZippedFun| |$indexList| + |pred| |zipType| |$localVars|)) + (SPADLET |s| + (CONS (|mkAtreeNode| '|suntil|) + (CONS |predVec| (CONS |s| NIL))))) + ((AND (PAIRP |iter|) + (EQ (QCAR |iter|) 'SUCHTHAT) + (PROGN + (SPADLET |ISTMP#1| (QCDR |iter|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (PROGN + (|putTarget| |pred| |$Boolean|) + (SPADLET |predVec| + (|mkIterZippedFun| |$indexList| + |pred| |zipType| |$localVars|)) + (SPADLET |s| + (CONS (|mkAtreeNode| '|select|) + (CONS |predVec| + (CONS |s| NIL)))))))))) + |s|))))) + +;mkIterZippedFun(indexList,funBody,zipType,$localVars) == +; -- transform funBody into a lamda with $index as the parameter +; numVars:= #$indexVars +; for [var,:.] in $indexVars repeat +; funBody := subVecNodes(mkIterVarSub(var,numVars),var,funBody) +; put($index,'mode,zipType,$env) +; mkLocalVar($mapName,$index) +; [m]:=bottomUpCompile funBody +; mapMode := ['Mapping,m,zipType] +; $freeVariables := [] +; $boundVariables := [$index] +; -- CCL does not support upwards funargs, so we check for any free variables +; -- and pass them into the lambda as part of envArg. +; body := +; [checkForFreeVariables(form,$localVars) for form in getValue funBody] +; val:=['function,['LAMBDA,[$index,'envArg],objVal body]] +; vec := mkAtreeNode GENSYM() +; putValue(vec,objNew(['CONS,val,["VECTOR",:reverse $freeVariables]],mapMode)) +; vec + +(DEFUN |mkIterZippedFun| (|indexList| |funBody| |zipType| |$localVars|) + (DECLARE (SPECIAL |$localVars|)) + (PROG (|numVars| |var| |LETTMP#1| |m| |mapMode| |body| |val| |vec|) + (RETURN + (SEQ (PROGN + (SPADLET |numVars| (|#| |$indexVars|)) + (DO ((G168623 |$indexVars| (CDR G168623)) + (G168610 NIL)) + ((OR (ATOM G168623) + (PROGN (SETQ G168610 (CAR G168623)) NIL) + (PROGN + (PROGN + (SPADLET |var| (CAR G168610)) + G168610) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |funBody| + (|subVecNodes| + (|mkIterVarSub| |var| |numVars|) + |var| |funBody|))))) + (|put| |$index| '|mode| |zipType| |$env|) + (|mkLocalVar| |$mapName| |$index|) + (SPADLET |LETTMP#1| (|bottomUpCompile| |funBody|)) + (SPADLET |m| (CAR |LETTMP#1|)) + (SPADLET |mapMode| + (CONS '|Mapping| (CONS |m| (CONS |zipType| NIL)))) + (SPADLET |$freeVariables| NIL) + (SPADLET |$boundVariables| (CONS |$index| NIL)) + (SPADLET |body| + (PROG (G168634) + (SPADLET G168634 NIL) + (RETURN + (DO ((G168639 (|getValue| |funBody|) + (CDR G168639)) + (|form| NIL)) + ((OR (ATOM G168639) + (PROGN + (SETQ |form| (CAR G168639)) + NIL)) + (NREVERSE0 G168634)) + (SEQ (EXIT (SETQ G168634 + (CONS + (|checkForFreeVariables| + |form| |$localVars|) + G168634)))))))) + (SPADLET |val| + (CONS '|function| + (CONS (CONS 'LAMBDA + (CONS + (CONS |$index| + (CONS '|envArg| NIL)) + (CONS (|objVal| |body|) NIL))) + NIL))) + (SPADLET |vec| (|mkAtreeNode| (GENSYM))) + (|putValue| |vec| + (|objNew| + (CONS 'CONS + (CONS |val| + (CONS (CONS 'VECTOR + (REVERSE |$freeVariables|)) + NIL))) + |mapMode|)) + |vec|))))) + +;subVecNodes(new,old,form) == +; ATOM form => +; (VECP form) and (form.0 = old) => new +; form +; [subVecNodes(new,old,CAR form), :subVecNodes(new,old,CDR form)] + +(DEFUN |subVecNodes| (|new| |old| |form|) + (COND + ((ATOM |form|) + (COND + ((AND (VECP |form|) (BOOT-EQUAL (ELT |form| 0) |old|)) |new|) + ('T |form|))) + ('T + (CONS (|subVecNodes| |new| |old| (CAR |form|)) + (|subVecNodes| |new| |old| (CDR |form|)))))) + +;mkIterVarSub(var,numVars) == +; n := iterVarPos var +; n=2 => +; [mkAtreeNode 'elt,mkNestedElts(numVars-2),mkAtreeNode 'part2] +; n=1 => +; [mkAtreeNode 'elt,mkNestedElts(numVars-2),mkAtreeNode 'part1] +; [mkAtreeNode 'elt,mkNestedElts(numVars-n),mkAtreeNode 'part1] + +(DEFUN |mkIterVarSub| (|var| |numVars|) + (PROG (|n|) + (RETURN + (PROGN + (SPADLET |n| (|iterVarPos| |var|)) + (COND + ((EQL |n| 2) + (CONS (|mkAtreeNode| '|elt|) + (CONS (|mkNestedElts| (SPADDIFFERENCE |numVars| 2)) + (CONS (|mkAtreeNode| '|part2|) NIL)))) + ((EQL |n| 1) + (CONS (|mkAtreeNode| '|elt|) + (CONS (|mkNestedElts| (SPADDIFFERENCE |numVars| 2)) + (CONS (|mkAtreeNode| '|part1|) NIL)))) + ('T + (CONS (|mkAtreeNode| '|elt|) + (CONS (|mkNestedElts| (SPADDIFFERENCE |numVars| |n|)) + (CONS (|mkAtreeNode| '|part1|) NIL))))))))) + +;iterVarPos var == +; for [index,:.] in reverse $indexVars for i in 1.. repeat +; index=var => return(i) + +(DEFUN |iterVarPos| (|var|) + (PROG (|index|) + (RETURN + (SEQ (DO ((G168679 (REVERSE |$indexVars|) (CDR G168679)) + (G168671 NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G168679) + (PROGN (SETQ G168671 (CAR G168679)) NIL) + (PROGN + (PROGN + (SPADLET |index| (CAR G168671)) + G168671) + NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |index| |var|) + (EXIT (RETURN |i|))))))))))) + +;mkNestedElts n == +; n=0 => mkAtreeNode($index or ($index:= GENSYM())) +; [mkAtreeNode 'elt, mkNestedElts(n-1), mkAtreeNode 'part2] + +(DEFUN |mkNestedElts| (|n|) + (COND + ((EQL |n| 0) + (|mkAtreeNode| (OR |$index| (SPADLET |$index| (GENSYM))))) + ('T + (CONS (|mkAtreeNode| '|elt|) + (CONS (|mkNestedElts| (SPADDIFFERENCE |n| 1)) + (CONS (|mkAtreeNode| '|part2|) NIL)))))) + +;--% Handlers for construct +;upconstruct t == +; --Computes the common mode set of the construct by resolving across +; --the argument list, and evaluating +; t isnt [op,:l] => nil +; dol := getAtree(op,'dollar) +; tar := getTarget(op) or dol +; null l => upNullList(op,l,tar) +; tar is ['Record,:types] => upRecordConstruct(op,l,tar) +; isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar) +; aggs := '(List) +; if tar and PAIRP(tar) and ^isPartialMode(tar) then +; CAR(tar) in aggs => +; ud := +; (l is [[realOp, :.]]) and (getUnname(realOp) = 'COLLECT) => tar +; CADR tar +; for x in l repeat if not getTarget(x) then putTarget(x,ud) +; CAR(tar) in '(Matrix SquareMatrix RectangularMatrix) => +; vec := ['List,underDomainOf tar] +; for x in l repeat if not getTarget(x) then putTarget(x,vec) +; argModeSetList:= [bottomUp x for x in l] +; dol and dol is [topType,:.] and not (topType in aggs) => +; (mmS:= selectMms(op,l,tar)) and (mS:= evalForm(op,getUnname op,l,mmS)) => +; putModeSet(op,mS) +; NIL +; (tar and tar is [topType,:.] and not (topType in aggs)) and +; (mmS:= modemapsHavingTarget(selectMms(op,l,tar),tar)) and +; (mS:= evalForm(op,getUnname op,l,mmS)) => +; putModeSet(op,mS) +; eltTypes := replaceSymbols([first x for x in argModeSetList],l) +; eltTypes is [['Tuple, td]] => +; mode := ['List, td] +; evalTupleConstruct(op, l, mode, tar) +; eltTypes is [['InfiniteTuple, td]] => +; mode := ['Stream, td] +; evalInfiniteTupleConstruct(op, l, mode, tar) +; if not isPartialMode(tar) and tar is ['List,ud] then +; mode := ['List, resolveTypeListAny cons(ud,eltTypes)] +; else mode := ['List, resolveTypeListAny eltTypes] +; if isPartialMode tar then tar:=resolveTM(mode,tar) +; evalconstruct(op,l,mode,tar) + +(DEFUN |upconstruct| (|t|) + (PROG (|op| |l| |dol| |types| |aggs| |realOp| |vec| |argModeSetList| + |topType| |mmS| |mS| |eltTypes| |ISTMP#2| |td| |ISTMP#1| + |ud| |mode| |tar|) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |l| (QCDR |t|)) + 'T))) + NIL) + ('T (SPADLET |dol| (|getAtree| |op| '|dollar|)) + (SPADLET |tar| (OR (|getTarget| |op|) |dol|)) + (COND + ((NULL |l|) (|upNullList| |op| |l| |tar|)) + ((AND (PAIRP |tar|) (EQ (QCAR |tar|) '|Record|) + (PROGN (SPADLET |types| (QCDR |tar|)) 'T)) + (|upRecordConstruct| |op| |l| |tar|)) + ((|isTaggedUnion| |tar|) + (|upTaggedUnionConstruct| |op| |l| |tar|)) + ('T (SPADLET |aggs| '(|List|)) + (COND + ((AND |tar| (PAIRP |tar|) + (NULL (|isPartialMode| |tar|))) + (COND + ((|member| (CAR |tar|) |aggs|) + (SPADLET |ud| + (COND + ((AND (PAIRP |l|) (EQ (QCDR |l|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |l|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |realOp| + (QCAR |ISTMP#1|)) + 'T))) + (BOOT-EQUAL (|getUnname| |realOp|) + 'COLLECT)) + |tar|) + ('T (CADR |tar|)))) + (DO ((G168737 |l| (CDR G168737)) (|x| NIL)) + ((OR (ATOM G168737) + (PROGN (SETQ |x| (CAR G168737)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (|getTarget| |x|)) + (|putTarget| |x| |ud|)) + ('T NIL)))))) + ((|member| (CAR |tar|) + '(|Matrix| |SquareMatrix| + |RectangularMatrix|)) + (SPADLET |vec| + (CONS '|List| + (CONS (|underDomainOf| |tar|) + NIL))) + (DO ((G168746 |l| (CDR G168746)) (|x| NIL)) + ((OR (ATOM G168746) + (PROGN (SETQ |x| (CAR G168746)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (|getTarget| |x|)) + (|putTarget| |x| |vec|)) + ('T NIL))))))))) + (SPADLET |argModeSetList| + (PROG (G168756) + (SPADLET G168756 NIL) + (RETURN + (DO ((G168761 |l| (CDR G168761)) + (|x| NIL)) + ((OR (ATOM G168761) + (PROGN + (SETQ |x| (CAR G168761)) + NIL)) + (NREVERSE0 G168756)) + (SEQ (EXIT + (SETQ G168756 + (CONS (|bottomUp| |x|) + G168756)))))))) + (COND + ((AND |dol| (PAIRP |dol|) + (PROGN (SPADLET |topType| (QCAR |dol|)) 'T) + (NULL (|member| |topType| |aggs|))) + (COND + ((AND (SPADLET |mmS| + (|selectMms| |op| |l| |tar|)) + (SPADLET |mS| + (|evalForm| |op| + (|getUnname| |op|) |l| |mmS|))) + (|putModeSet| |op| |mS|)) + ('T NIL))) + ((AND |tar| (PAIRP |tar|) + (PROGN (SPADLET |topType| (QCAR |tar|)) 'T) + (NULL (|member| |topType| |aggs|)) + (SPADLET |mmS| + (|modemapsHavingTarget| + (|selectMms| |op| |l| |tar|) + |tar|)) + (SPADLET |mS| + (|evalForm| |op| (|getUnname| |op|) + |l| |mmS|))) + (|putModeSet| |op| |mS|)) + ('T + (SPADLET |eltTypes| + (|replaceSymbols| + (PROG (G168771) + (SPADLET G168771 NIL) + (RETURN + (DO + ((G168776 |argModeSetList| + (CDR G168776)) + (|x| NIL)) + ((OR (ATOM G168776) + (PROGN + (SETQ |x| (CAR G168776)) + NIL)) + (NREVERSE0 G168771)) + (SEQ + (EXIT + (SETQ G168771 + (CONS (CAR |x|) G168771))))))) + |l|)) + (COND + ((AND (PAIRP |eltTypes|) + (EQ (QCDR |eltTypes|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |eltTypes|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Tuple|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |td| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |mode| (CONS '|List| (CONS |td| NIL))) + (|evalTupleConstruct| |op| |l| |mode| |tar|)) + ((AND (PAIRP |eltTypes|) + (EQ (QCDR |eltTypes|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |eltTypes|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|InfiniteTuple|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |td| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |mode| + (CONS '|Stream| (CONS |td| NIL))) + (|evalInfiniteTupleConstruct| |op| |l| |mode| + |tar|)) + ('T + (COND + ((AND (NULL (|isPartialMode| |tar|)) + (PAIRP |tar|) (EQ (QCAR |tar|) '|List|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |tar|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ud| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |mode| + (CONS '|List| + (CONS + (|resolveTypeListAny| + (CONS |ud| |eltTypes|)) + NIL)))) + ('T + (SPADLET |mode| + (CONS '|List| + (CONS + (|resolveTypeListAny| |eltTypes|) + NIL))))) + (COND + ((|isPartialMode| |tar|) + (SPADLET |tar| (|resolveTM| |mode| |tar|)))) + (|evalconstruct| |op| |l| |mode| |tar|))))))))))))) + +;modemapsHavingTarget(mmS,target) == +; -- returns those modemaps have the signature result matching the +; -- given target +; [mm for mm in mmS | ([[.,res,:.],:.] := mm) and res = target] + +(DEFUN |modemapsHavingTarget| (|mmS| |target|) + (PROG (|res|) + (RETURN + (SEQ (PROG (G168825) + (SPADLET G168825 NIL) + (RETURN + (DO ((G168831 |mmS| (CDR G168831)) (|mm| NIL)) + ((OR (ATOM G168831) + (PROGN (SETQ |mm| (CAR G168831)) NIL)) + (NREVERSE0 G168825)) + (SEQ (EXIT (COND + ((AND (PROGN + (SPADLET |res| (CADAR |mm|)) + |mm|) + (BOOT-EQUAL |res| |target|)) + (SETQ G168825 (CONS |mm| G168825))))))))))))) + +;evalTupleConstruct(op,l,m,tar) == +; ['List, ud] := m +; code := ['APPEND, +; :([["asTupleAsList", getArgValueOrThrow(x,['Tuple, ud])] for x in l])] +; val := +; $genValue => objNewWrap(timedEVALFUN code,m) +; objNew(code,m) +; (val1 := coerceInteractive(val,tar or m)) => +; putValue(op,val1) +; putModeSet(op,[tar or m]) +; putValue(op,val) +; putModeSet(op,[m]) + +(DEFUN |evalTupleConstruct| (|op| |l| |m| |tar|) + (PROG (|ud| |code| |val| |val1|) + (RETURN + (SEQ (PROGN + (SPADLET |ud| (CADR |m|)) + (SPADLET |code| + (CONS 'APPEND + (PROG (G168851) + (SPADLET G168851 NIL) + (RETURN + (DO ((G168856 |l| (CDR G168856)) + (|x| NIL)) + ((OR (ATOM G168856) + (PROGN + (SETQ |x| (CAR G168856)) + NIL)) + (NREVERSE0 G168851)) + (SEQ (EXIT + (SETQ G168851 + (CONS + (CONS '|asTupleAsList| + (CONS + (|getArgValueOrThrow| |x| + (CONS '|Tuple| + (CONS |ud| NIL))) + NIL)) + G168851))))))))) + (SPADLET |val| + (COND + (|$genValue| + (|objNewWrap| (|timedEVALFUN| |code|) |m|)) + ('T (|objNew| |code| |m|)))) + (COND + ((SPADLET |val1| + (|coerceInteractive| |val| (OR |tar| |m|))) + (|putValue| |op| |val1|) + (|putModeSet| |op| (CONS (OR |tar| |m|) NIL))) + ('T (|putValue| |op| |val|) + (|putModeSet| |op| (CONS |m| NIL))))))))) + +;evalInfiniteTupleConstruct(op,l,m,tar) == +; ['Stream, ud] := m +; code := first [(getArgValue(x,['InfiniteTuple, ud]) or +; throwKeyedMsg("S2IC0007",[['InifinteTuple, ud]])) for x in l] +; val := +; $genValue => objNewWrap(timedEVALFUN code,m) +; objNew(code,m) +; if tar then val1 := coerceInteractive(val,tar) else val1 := val +; val1 => +; putValue(op,val1) +; putModeSet(op,[tar or m]) +; putValue(op,val) +; putModeSet(op,[m]) + +(DEFUN |evalInfiniteTupleConstruct| (|op| |l| |m| |tar|) + (PROG (|ud| |code| |val| |val1|) + (RETURN + (SEQ (PROGN + (SPADLET |ud| (CADR |m|)) + (SPADLET |code| + (CAR (PROG (G168879) + (SPADLET G168879 NIL) + (RETURN + (DO ((G168884 |l| (CDR G168884)) + (|x| NIL)) + ((OR (ATOM G168884) + (PROGN + (SETQ |x| (CAR G168884)) + NIL)) + (NREVERSE0 G168879)) + (SEQ (EXIT + (SETQ G168879 + (CONS + (OR + (|getArgValue| |x| + (CONS '|InfiniteTuple| + (CONS |ud| NIL))) + (|throwKeyedMsg| 'S2IC0007 + (CONS + (CONS '|InifinteTuple| + (CONS |ud| NIL)) + NIL))) + G168879))))))))) + (SPADLET |val| + (COND + (|$genValue| + (|objNewWrap| (|timedEVALFUN| |code|) |m|)) + ('T (|objNew| |code| |m|)))) + (COND + (|tar| (SPADLET |val1| + (|coerceInteractive| |val| |tar|))) + ('T (SPADLET |val1| |val|))) + (COND + (|val1| (|putValue| |op| |val1|) + (|putModeSet| |op| (CONS (OR |tar| |m|) NIL))) + ('T (|putValue| |op| |val|) + (|putModeSet| |op| (CONS |m| NIL))))))))) + +;evalconstruct(op,l,m,tar) == +; [agg,:.,underMode]:= m +; code := ['LIST, :(argCode:=[(getArgValue(x,underMode) or +; throwKeyedMsg("S2IC0007",[underMode])) for x in l])] +; val := +; $genValue => objNewWrap(timedEVALFUN code,m) +; objNew(code,m) +; if tar then val1 := coerceInteractive(val,tar) else val1 := val +; val1 => +; putValue(op,val1) +; putModeSet(op,[tar or m]) +; putValue(op,val) +; putModeSet(op,[m]) + +(DEFUN |evalconstruct| (|op| |l| |m| |tar|) + (PROG (|agg| |LETTMP#1| |underMode| |argCode| |code| |val| |val1|) + (RETURN + (SEQ (PROGN + (SPADLET |agg| (CAR |m|)) + (SPADLET |LETTMP#1| (REVERSE (CDR |m|))) + (SPADLET |underMode| (CAR |LETTMP#1|)) + (SPADLET |code| + (CONS 'LIST + (SPADLET |argCode| + (PROG (G168910) + (SPADLET G168910 NIL) + (RETURN + (DO + ((G168915 |l| + (CDR G168915)) + (|x| NIL)) + ((OR (ATOM G168915) + (PROGN + (SETQ |x| + (CAR G168915)) + NIL)) + (NREVERSE0 G168910)) + (SEQ + (EXIT + (SETQ G168910 + (CONS + (OR + (|getArgValue| |x| + |underMode|) + (|throwKeyedMsg| + 'S2IC0007 + (CONS |underMode| NIL))) + G168910)))))))))) + (SPADLET |val| + (COND + (|$genValue| + (|objNewWrap| (|timedEVALFUN| |code|) |m|)) + ('T (|objNew| |code| |m|)))) + (COND + (|tar| (SPADLET |val1| + (|coerceInteractive| |val| |tar|))) + ('T (SPADLET |val1| |val|))) + (COND + (|val1| (|putValue| |op| |val1|) + (|putModeSet| |op| (CONS (OR |tar| |m|) NIL))) + ('T (|putValue| |op| |val|) + (|putModeSet| |op| (CONS |m| NIL))))))))) + +;replaceSymbols(modeList,l) == +; -- replaces symbol types with their corresponding polynomial types +; -- if not all type are symbols +; not ($Symbol in modeList) => modeList +; modeList is [a,:b] and and/[a=x for x in b] => modeList +; [if m=$Symbol then getMinimalVarMode(objValUnwrap(getValue arg), +; $declaredMode) else m for m in modeList for arg in l] + +(DEFUN |replaceSymbols| (|modeList| |l|) + (PROG (|a| |b|) + (RETURN + (SEQ (COND + ((NULL (|member| |$Symbol| |modeList|)) |modeList|) + ((AND (PAIRP |modeList|) + (PROGN + (SPADLET |a| (QCAR |modeList|)) + (SPADLET |b| (QCDR |modeList|)) + 'T) + (PROG (G168937) + (SPADLET G168937 'T) + (RETURN + (DO ((G168943 NIL (NULL G168937)) + (G168944 |b| (CDR G168944)) (|x| NIL)) + ((OR G168943 (ATOM G168944) + (PROGN (SETQ |x| (CAR G168944)) NIL)) + G168937) + (SEQ (EXIT (SETQ G168937 + (AND G168937 + (BOOT-EQUAL |a| |x|))))))))) + |modeList|) + ('T + (PROG (G168956) + (SPADLET G168956 NIL) + (RETURN + (DO ((G168962 |modeList| (CDR G168962)) (|m| NIL) + (G168963 |l| (CDR G168963)) (|arg| NIL)) + ((OR (ATOM G168962) + (PROGN (SETQ |m| (CAR G168962)) NIL) + (ATOM G168963) + (PROGN (SETQ |arg| (CAR G168963)) NIL)) + (NREVERSE0 G168956)) + (SEQ (EXIT (SETQ G168956 + (CONS + (COND + ((BOOT-EQUAL |m| |$Symbol|) + (|getMinimalVarMode| + (|objValUnwrap| + (|getValue| |arg|)) + |$declaredMode|)) + ('T |m|)) + G168956))))))))))))) + +;upNullList(op,l,tar) == +; -- handler for [] (empty list) +; defMode := +; tar and tar is [a,b] and (a in '(Stream Vector List)) and +; not isPartialMode(b) => ['List,b] +; '(List (None)) +; val := objNewWrap(NIL,defMode) +; tar and not isPartialMode(tar) => +; null (val' := coerceInteractive(val,tar)) => +; throwKeyedMsg("S2IS0013",[tar]) +; putValue(op,val') +; putModeSet(op,[tar]) +; putValue(op,val) +; putModeSet(op,[defMode]) + +(DEFUN |upNullList| (|op| |l| |tar|) + (PROG (|a| |ISTMP#1| |b| |defMode| |val| |val'|) + (RETURN + (PROGN + (SPADLET |defMode| + (COND + ((AND |tar| (PAIRP |tar|) + (PROGN + (SPADLET |a| (QCAR |tar|)) + (SPADLET |ISTMP#1| (QCDR |tar|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#1|)) + 'T))) + (|member| |a| '(|Stream| |Vector| |List|)) + (NULL (|isPartialMode| |b|))) + (CONS '|List| (CONS |b| NIL))) + ('T '(|List| (|None|))))) + (SPADLET |val| (|objNewWrap| NIL |defMode|)) + (COND + ((AND |tar| (NULL (|isPartialMode| |tar|))) + (COND + ((NULL (SPADLET |val'| (|coerceInteractive| |val| |tar|))) + (|throwKeyedMsg| 'S2IS0013 (CONS |tar| NIL))) + ('T (|putValue| |op| |val'|) + (|putModeSet| |op| (CONS |tar| NIL))))) + ('T (|putValue| |op| |val|) + (|putModeSet| |op| (CONS |defMode| NIL)))))))) + +;upTaggedUnionConstruct(op,l,tar) == +; -- special handler for tagged union constructors +; tar isnt [.,:types] => nil +; #l ^= 1 => throwKeyedMsg("S2IS0051",[#l,tar]) +; bottomUp first l +; obj := getValue first l +; (code := coerceInteractive(getValue first l,tar)) or +; throwKeyedMsgCannotCoerceWithValue(objVal obj, objMode obj,tar) +; putValue(op,code) +; putModeSet(op,[tar]) + +(DEFUN |upTaggedUnionConstruct| (|op| |l| |tar|) + (PROG (|types| |obj| |code|) + (RETURN + (COND + ((NULL (AND (PAIRP |tar|) + (PROGN (SPADLET |types| (QCDR |tar|)) 'T))) + NIL) + ((NEQUAL (|#| |l|) 1) + (|throwKeyedMsg| 'S2IS0051 (CONS (|#| |l|) (CONS |tar| NIL)))) + ('T (|bottomUp| (CAR |l|)) + (SPADLET |obj| (|getValue| (CAR |l|))) + (OR (SPADLET |code| + (|coerceInteractive| (|getValue| (CAR |l|)) + |tar|)) + (|throwKeyedMsgCannotCoerceWithValue| (|objVal| |obj|) + (|objMode| |obj|) |tar|)) + (|putValue| |op| |code|) (|putModeSet| |op| (CONS |tar| NIL))))))) + +;upRecordConstruct(op,l,tar) == +; -- special handler for record constructors +; tar isnt [.,:types] => nil +; argModes := nil +; for arg in l repeat bottomUp arg +; argCode := +; [(getArgValue(arg,type) or throwKeyedMsgCannotCoerceWithValue( +; objVal getValue arg,objMode getValue arg,type)) +; for arg in l for ['_:,.,type] in types] +; len := #l +; code := +; (len = 1) => ['CONS, :argCode, '()] +; (len = 2) => ['CONS,:argCode] +; ['VECTOR,:argCode] +; if $genValue then code := wrap timedEVALFUN code +; putValue(op,objNew(code,tar)) +; putModeSet(op,[tar]) + +(DEFUN |upRecordConstruct| (|op| |l| |tar|) + (PROG (|types| |argModes| |type| |argCode| |len| |code|) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |tar|) + (PROGN (SPADLET |types| (QCDR |tar|)) 'T))) + NIL) + ('T (SPADLET |argModes| NIL) + (DO ((G169015 |l| (CDR G169015)) (|arg| NIL)) + ((OR (ATOM G169015) + (PROGN (SETQ |arg| (CAR G169015)) NIL)) + NIL) + (SEQ (EXIT (|bottomUp| |arg|)))) + (SPADLET |argCode| + (PROG (G169027) + (SPADLET G169027 NIL) + (RETURN + (DO ((G169034 |l| (CDR G169034)) + (|arg| NIL) + (G169035 |types| (CDR G169035)) + (G169007 NIL)) + ((OR (ATOM G169034) + (PROGN + (SETQ |arg| (CAR G169034)) + NIL) + (ATOM G169035) + (PROGN + (SETQ G169007 (CAR G169035)) + NIL) + (PROGN + (PROGN + (SPADLET |type| + (CADDR G169007)) + G169007) + NIL)) + (NREVERSE0 G169027)) + (SEQ (EXIT (SETQ G169027 + (CONS + (OR + (|getArgValue| |arg| |type|) + (|throwKeyedMsgCannotCoerceWithValue| + (|objVal| + (|getValue| |arg|)) + (|objMode| + (|getValue| |arg|)) + |type|)) + G169027)))))))) + (SPADLET |len| (|#| |l|)) + (SPADLET |code| + (COND + ((EQL |len| 1) + (CONS 'CONS + (APPEND |argCode| (CONS 'NIL NIL)))) + ((EQL |len| 2) (CONS 'CONS |argCode|)) + ('T (CONS 'VECTOR |argCode|)))) + (COND + (|$genValue| + (SPADLET |code| (|wrap| (|timedEVALFUN| |code|))))) + (|putValue| |op| (|objNew| |code| |tar|)) + (|putModeSet| |op| (CONS |tar| NIL)))))))) + +;--% Handlers for declarations +;upDeclare t == +; t isnt [op,lhs,rhs] => nil +; (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] => +; keyedMsgCompFailure("S2IS0014",[lhs]) +; mode := evaluateType unabbrev rhs +; mode = $Void => throwKeyedMsgSP("S2IS0015",NIL,op) +; not isLegitimateMode(mode,nil,nil) => throwKeyedMsgSP("S2IE0004",[mode],op) +; categoryForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'category],op) +; packageForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'package],op) +; junk := +; lhs is ['free,['Tuple,:vars]] or lhs is ['free,['LISTOF,:vars]] or +; lhs is ['free,:vars] => +; for var in vars repeat declare(['free,var],mode) +; lhs is ['local,['Tuple,:vars]] or lhs is ['local,['LISTOF,:vars]] or +; lhs is ['local,:vars] => +; for var in vars repeat declare(['local,var],mode) +; lhs is ['Tuple,:vars] or lhs is ['LISTOF,:vars] => +; for var in vars repeat declare(var,mode) +; declare(lhs,mode) +; putValue(op,objNewWrap(voidValue(), $Void)) +; putModeSet(op,[$Void]) + +(DEFUN |upDeclare| (|t|) + (PROG (|op| |lhs| |rhs| |mode| |ISTMP#1| |ISTMP#2| |vars| |junk|) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |lhs| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |rhs| + (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ((AND (NULL |$genValue|) + (PROG (G169122) + (SPADLET G169122 NIL) + (RETURN + (DO ((G169128 NIL G169122) + (G169129 |$localVars| (CDR G169129)) + (|var| NIL)) + ((OR G169128 (ATOM G169129) + (PROGN + (SETQ |var| (CAR G169129)) + NIL)) + G169122) + (SEQ (EXIT (SETQ G169122 + (OR G169122 + (CONTAINED |var| |rhs|))))))))) + (|keyedMsgCompFailure| 'S2IS0014 (CONS |lhs| NIL))) + ('T (SPADLET |mode| (|evaluateType| (|unabbrev| |rhs|))) + (COND + ((BOOT-EQUAL |mode| |$Void|) + (|throwKeyedMsgSP| 'S2IS0015 NIL |op|)) + ((NULL (|isLegitimateMode| |mode| NIL NIL)) + (|throwKeyedMsgSP| 'S2IE0004 (CONS |mode| NIL) |op|)) + ((|categoryForm?| |mode|) + (|throwKeyedMsgSP| 'S2IE0011 + (CONS |mode| (CONS '|category| NIL)) |op|)) + ((|packageForm?| |mode|) + (|throwKeyedMsgSP| 'S2IE0011 + (CONS |mode| (CONS '|package| NIL)) |op|)) + ('T + (SPADLET |junk| + (COND + ((OR (AND (PAIRP |lhs|) + (EQ (QCAR |lhs|) '|free|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |lhs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) + '|Tuple|) + (PROGN + (SPADLET |vars| + (QCDR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |lhs|) + (EQ (QCAR |lhs|) '|free|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |lhs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) + 'LISTOF) + (PROGN + (SPADLET |vars| + (QCDR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |lhs|) + (EQ (QCAR |lhs|) '|free|) + (PROGN + (SPADLET |vars| (QCDR |lhs|)) + 'T))) + (DO ((G169139 |vars| (CDR G169139)) + (|var| NIL)) + ((OR (ATOM G169139) + (PROGN + (SETQ |var| (CAR G169139)) + NIL)) + NIL) + (SEQ (EXIT + (|declare| + (CONS '|free| (CONS |var| NIL)) + |mode|))))) + ((OR (AND (PAIRP |lhs|) + (EQ (QCAR |lhs|) '|local|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |lhs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) + '|Tuple|) + (PROGN + (SPADLET |vars| + (QCDR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |lhs|) + (EQ (QCAR |lhs|) '|local|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |lhs|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) + 'LISTOF) + (PROGN + (SPADLET |vars| + (QCDR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |lhs|) + (EQ (QCAR |lhs|) '|local|) + (PROGN + (SPADLET |vars| (QCDR |lhs|)) + 'T))) + (DO ((G169148 |vars| (CDR G169148)) + (|var| NIL)) + ((OR (ATOM G169148) + (PROGN + (SETQ |var| (CAR G169148)) + NIL)) + NIL) + (SEQ (EXIT + (|declare| + (CONS '|local| (CONS |var| NIL)) + |mode|))))) + ((OR (AND (PAIRP |lhs|) + (EQ (QCAR |lhs|) '|Tuple|) + (PROGN + (SPADLET |vars| (QCDR |lhs|)) + 'T)) + (AND (PAIRP |lhs|) + (EQ (QCAR |lhs|) 'LISTOF) + (PROGN + (SPADLET |vars| (QCDR |lhs|)) + 'T))) + (DO ((G169157 |vars| (CDR G169157)) + (|var| NIL)) + ((OR (ATOM G169157) + (PROGN + (SETQ |var| (CAR G169157)) + NIL)) + NIL) + (SEQ (EXIT (|declare| |var| |mode|))))) + ('T (|declare| |lhs| |mode|)))) + (|putValue| |op| (|objNewWrap| (|voidValue|) |$Void|)) + (|putModeSet| |op| (CONS |$Void| NIL)))))))))) + +;declare(var,mode) == +; -- performs declaration. +; -- 10/31/89: no longer coerces value to new declared type +; if var is ['local,v] then +; uplocalWithType(v,mode) +; var := v +; if var is ['free,v] then +; upfreeWithType(v,mode) +; var := v +; not IDENTP(var) => +; throwKeyedMsg("S2IS0016",[STRINGIMAGE var]) +; var in '(% %%) => throwKeyedMsg("S2IS0050",[var]) +; if get(var,'isInterpreterFunction,$e) then +; mode isnt ['Mapping,.,:args] => +; throwKeyedMsg("S2IS0017",[var,mode]) +; -- validate that the new declaration has the defined # of args +; mapval := objVal get(var,'value,$e) +; -- mapval looks like '(MAP (args . defn)) +; margs := CAADR mapval +; -- if one args, margs is not a pair, just #1 or NIL +; -- otherwise it looks like (Tuple #1 #2 ...) +; nargs := +; null margs => 0 +; PAIRP margs => -1 + #margs +; 1 +; nargs ^= #args => throwKeyedMsg("S2IM0008",[var]) +; if $compilingMap then mkLocalVar($mapName,var) +; else clearDependencies(var,true) +; isLocalVar(var) => put(var,'mode,mode,$env) +; mode is ['Mapping,:.] => declareMap(var,mode) +; v := get(var,'value,$e) => +; -- only allow this if either +; -- - value already has given type +; -- - new mode is same as old declared mode +; objMode(v) = mode => putHist(var,'mode,mode,$e) +; mode = get(var,'mode,$e) => NIL -- nothing to do +; throwKeyedMsg("S2IS0052",[var,mode]) +; putHist(var,'mode,mode,$e) + +(DEFUN |declare| (|var| |mode|) + (PROG (|ISTMP#1| |args| |mapval| |margs| |nargs| |v|) + (RETURN + (PROGN + (COND + ((AND (PAIRP |var|) (EQ (QCAR |var|) '|local|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |var|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |v| (QCAR |ISTMP#1|)) 'T)))) + (|uplocalWithType| |v| |mode|) (SPADLET |var| |v|))) + (COND + ((AND (PAIRP |var|) (EQ (QCAR |var|) '|free|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |var|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |v| (QCAR |ISTMP#1|)) 'T)))) + (|upfreeWithType| |v| |mode|) (SPADLET |var| |v|))) + (COND + ((NULL (IDENTP |var|)) + (|throwKeyedMsg| 'S2IS0016 (CONS (STRINGIMAGE |var|) NIL))) + ((|member| |var| '(% %%)) + (|throwKeyedMsg| 'S2IS0050 (CONS |var| NIL))) + ('T + (COND + ((|get| |var| '|isInterpreterFunction| |$e|) + (COND + ((NULL (AND (PAIRP |mode|) + (EQ (QCAR |mode|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |mode|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |args| (QCDR |ISTMP#1|)) + 'T))))) + (|throwKeyedMsg| 'S2IS0017 + (CONS |var| (CONS |mode| NIL)))) + ('T + (SPADLET |mapval| + (|objVal| (|get| |var| '|value| |$e|))) + (SPADLET |margs| (CAADR |mapval|)) + (SPADLET |nargs| + (COND + ((NULL |margs|) 0) + ((PAIRP |margs|) + (PLUS (SPADDIFFERENCE 1) (|#| |margs|))) + ('T 1))) + (COND + ((NEQUAL |nargs| (|#| |args|)) + (|throwKeyedMsg| 'S2IM0008 (CONS |var| NIL)))))))) + (COND + (|$compilingMap| (|mkLocalVar| |$mapName| |var|)) + ('T (|clearDependencies| |var| 'T))) + (COND + ((|isLocalVar| |var|) (|put| |var| '|mode| |mode| |$env|)) + ((AND (PAIRP |mode|) (EQ (QCAR |mode|) '|Mapping|)) + (|declareMap| |var| |mode|)) + ((SPADLET |v| (|get| |var| '|value| |$e|)) + (COND + ((BOOT-EQUAL (|objMode| |v|) |mode|) + (|putHist| |var| '|mode| |mode| |$e|)) + ((BOOT-EQUAL |mode| (|get| |var| '|mode| |$e|)) NIL) + ('T + (|throwKeyedMsg| 'S2IS0052 + (CONS |var| (CONS |mode| NIL)))))) + ('T (|putHist| |var| '|mode| |mode| |$e|))))))))) + +;declareMap(var,mode) == +; -- declare a Mapping property +; (v:=get(var,'value,$e)) and objVal(v) isnt ['MAP,:.] => +; throwKeyedMsg("S2IS0019",[var]) +; isPartialMode mode => throwKeyedMsg("S2IM0004",NIL) +; putHist(var,'mode,mode,$e) + +(DEFUN |declareMap| (|var| |mode|) + (PROG (|v| |ISTMP#1|) + (RETURN + (COND + ((AND (SPADLET |v| (|get| |var| '|value| |$e|)) + (NULL (PROGN + (SPADLET |ISTMP#1| (|objVal| |v|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'MAP))))) + (|throwKeyedMsg| 'S2IS0019 (CONS |var| NIL))) + ((|isPartialMode| |mode|) (|throwKeyedMsg| 'S2IM0004 NIL)) + ('T (|putHist| |var| '|mode| |mode| |$e|)))))) + +;getAndEvalConstructorArgument tree == +; triple := getValue tree +; objMode triple = '(Domain) => triple +; isWrapped objVal(triple) => triple +; isLocalVar objVal triple => compFailure('" Local variable or parameter used in type") +; objNewWrap(timedEVALFUN objVal(triple), objMode(triple)) + +(DEFUN |getAndEvalConstructorArgument| (|tree|) + (PROG (|triple|) + (RETURN + (PROGN + (SPADLET |triple| (|getValue| |tree|)) + (COND + ((BOOT-EQUAL (|objMode| |triple|) '(|Domain|)) |triple|) + ((|isWrapped| (|objVal| |triple|)) |triple|) + ((|isLocalVar| (|objVal| |triple|)) + (|compFailure| + (MAKESTRING + " Local variable or parameter used in type"))) + ('T + (|objNewWrap| (|timedEVALFUN| (|objVal| |triple|)) + (|objMode| |triple|)))))))) + +;replaceSharps(x,d) == +; -- replaces all sharps in x by the arguments of domain d +; -- all replaces the triangle variables +; SL:= NIL +; for e in CDR d for var in $FormalMapVariableList repeat +; SL:= CONS(CONS(var,e),SL) +; x := subCopy(x,SL) +; SL:= NIL +; for e in CDR d for var in $TriangleVariableList repeat +; SL:= CONS(CONS(var,e),SL) +; subCopy(x,SL) + +(DEFUN |replaceSharps| (|x| |d|) + (PROG (SL) + (RETURN + (SEQ (PROGN + (SPADLET SL NIL) + (DO ((G169241 (CDR |d|) (CDR G169241)) (|e| NIL) + (G169242 |$FormalMapVariableList| (CDR G169242)) + (|var| NIL)) + ((OR (ATOM G169241) + (PROGN (SETQ |e| (CAR G169241)) NIL) + (ATOM G169242) + (PROGN (SETQ |var| (CAR G169242)) NIL)) + NIL) + (SEQ (EXIT (SPADLET SL (CONS (CONS |var| |e|) SL))))) + (SPADLET |x| (|subCopy| |x| SL)) + (SPADLET SL NIL) + (DO ((G169255 (CDR |d|) (CDR G169255)) (|e| NIL) + (G169256 |$TriangleVariableList| (CDR G169256)) + (|var| NIL)) + ((OR (ATOM G169255) + (PROGN (SETQ |e| (CAR G169255)) NIL) + (ATOM G169256) + (PROGN (SETQ |var| (CAR G169256)) NIL)) + NIL) + (SEQ (EXIT (SPADLET SL (CONS (CONS |var| |e|) SL))))) + (|subCopy| |x| SL)))))) + +;isDomainValuedVariable form == +; -- returns the value of form if form is a variable with a type value +; IDENTP form and (val := ( +; get(form,'value,$InteractiveFrame) or _ +; (PAIRP($env) and get(form,'value,$env)) or _ +; (PAIRP($e) and get(form,'value,$e)))) and +; objMode(val) in '((Domain) (SubDomain (Domain))) => +; objValUnwrap(val) +; nil + +(DEFUN |isDomainValuedVariable| (|form|) + (PROG (|val|) + (RETURN + (COND + ((AND (IDENTP |form|) + (SPADLET |val| + (OR (|get| |form| '|value| |$InteractiveFrame|) + (AND (PAIRP |$env|) + (|get| |form| '|value| |$env|)) + (AND (PAIRP |$e|) + (|get| |form| '|value| |$e|)))) + (|member| (|objMode| |val|) + '((|Domain|) (|SubDomain| (|Domain|))))) + (|objValUnwrap| |val|)) + ('T NIL))))) + +;evalCategory(d,c) == +; -- tests whether domain d has category c +; isPartialMode d or ofCategory(d,c) + +(DEFUN |evalCategory| (|d| |c|) + (OR (|isPartialMode| |d|) (|ofCategory| |d| |c|))) + +;isOkInterpMode m == +; isPartialMode(m) => isLegitimateMode(m,nil,nil) +; isValidType(m) and isLegitimateMode(m,nil,nil) + +(DEFUN |isOkInterpMode| (|m|) + (COND + ((|isPartialMode| |m|) (|isLegitimateMode| |m| NIL NIL)) + ('T (AND (|isValidType| |m|) (|isLegitimateMode| |m| NIL NIL))))) + +;isLegitimateRecordOrTaggedUnion u == +; and/[x is [":",.,d] and isLegitimateMode(d,nil,nil) for x in u] + +(DEFUN |isLegitimateRecordOrTaggedUnion| (|u|) + (PROG (|ISTMP#1| |ISTMP#2| |d|) + (RETURN + (SEQ (PROG (G169295) + (SPADLET G169295 'T) + (RETURN + (DO ((G169307 NIL (NULL G169295)) + (G169308 |u| (CDR G169308)) (|x| NIL)) + ((OR G169307 (ATOM G169308) + (PROGN (SETQ |x| (CAR G169308)) NIL)) + G169295) + (SEQ (EXIT (SETQ G169295 + (AND G169295 + (AND (PAIRP |x|) + (EQ (QCAR |x|) '|:|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |d| + (QCAR |ISTMP#2|)) + 'T))))) + (|isLegitimateMode| |d| NIL + NIL))))))))))))) + +;isPolynomialMode m == +; -- If m is a polynomial type this function returns a list of its +; -- variables, and nil otherwise +; m is [op,a,:rargs] => +; a := removeQuote a +; MEMQ(op,'(Polynomial RationalFunction AlgebraicFunction Expression +; ElementaryFunction LiouvillianFunction FunctionalExpression +; CombinatorialFunction ))=> 'all +; op = 'UnivariatePolynomial => LIST a +; op = 'Variable => LIST a +; MEMQ(op,'(MultivariatePolynomial DistributedMultivariatePolynomial +; HomogeneousDistributedMultivariatePolynomial)) => a +; NIL +; NIL + +(DEFUN |isPolynomialMode| (|m|) + (PROG (|op| |ISTMP#1| |rargs| |a|) + (RETURN + (COND + ((AND (PAIRP |m|) + (PROGN + (SPADLET |op| (QCAR |m|)) + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |rargs| (QCDR |ISTMP#1|)) + 'T)))) + (SPADLET |a| (|removeQuote| |a|)) + (COND + ((MEMQ |op| + '(|Polynomial| |RationalFunction| |AlgebraicFunction| + |Expression| |ElementaryFunction| + |LiouvillianFunction| |FunctionalExpression| + |CombinatorialFunction|)) + '|all|) + ((BOOT-EQUAL |op| '|UnivariatePolynomial|) (LIST |a|)) + ((BOOT-EQUAL |op| '|Variable|) (LIST |a|)) + ((MEMQ |op| + '(|MultivariatePolynomial| + |DistributedMultivariatePolynomial| + |HomogeneousDistributedMultivariatePolynomial|)) + |a|) + ('T NIL))) + ('T NIL))))) + +;containsPolynomial m == +; not PAIRP(m) => NIL +; [d,:.] := m +; d in $univariateDomains or d in $multivariateDomains or +; d in '(Polynomial RationalFunction) => true +; (m' := underDomainOf m) and containsPolynomial m' + +(DEFUN |containsPolynomial| (|m|) + (PROG (|d| |m'|) + (RETURN + (COND + ((NULL (PAIRP |m|)) NIL) + ('T (SPADLET |d| (CAR |m|)) + (COND + ((OR (|member| |d| |$univariateDomains|) + (|member| |d| |$multivariateDomains|) + (|member| |d| '(|Polynomial| |RationalFunction|))) + 'T) + ('T + (AND (SPADLET |m'| (|underDomainOf| |m|)) + (|containsPolynomial| |m'|))))))))) + +;containsVariables m == +; not PAIRP(m) => NIL +; [d,:.] := m +; d in $univariateDomains or d in $multivariateDomains => true +; (m' := underDomainOf m) and containsVariables m' + +(DEFUN |containsVariables| (|m|) + (PROG (|d| |m'|) + (RETURN + (COND + ((NULL (PAIRP |m|)) NIL) + ('T (SPADLET |d| (CAR |m|)) + (COND + ((OR (|member| |d| |$univariateDomains|) + (|member| |d| |$multivariateDomains|)) + 'T) + ('T + (AND (SPADLET |m'| (|underDomainOf| |m|)) + (|containsVariables| |m'|))))))))) + +;listOfDuplicates l == +; l is [x,:l'] => +; x in l' => [x,:listOfDuplicates deleteAll(x,l')] +; listOfDuplicates l' + +(DEFUN |listOfDuplicates| (|l|) + (PROG (|x| |l'|) + (RETURN + (SEQ (COND + ((AND (PAIRP |l|) + (PROGN + (SPADLET |x| (QCAR |l|)) + (SPADLET |l'| (QCDR |l|)) + 'T)) + (EXIT (COND + ((|member| |x| |l'|) + (CONS |x| + (|listOfDuplicates| + (|deleteAll| |x| |l'|)))) + ('T (|listOfDuplicates| |l'|)))))))))) + +;-- The following function removes all occurrences of x from the list l +;deleteAll(x,l) == +; null l => nil +; x = CAR(l) => deleteAll(x,CDR l) +; [first l,:deleteAll(x,rest l)] + +(DEFUN |deleteAll| (|x| |l|) + (COND + ((NULL |l|) NIL) + ((BOOT-EQUAL |x| (CAR |l|)) (|deleteAll| |x| (CDR |l|))) + ('T (CONS (CAR |l|) (|deleteAll| |x| (CDR |l|)))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}