-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2008, Gabriel Dos Reis. -- 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. import '"i-analy" )package "BOOT" -- Functions which require special handlers (also see end of file) $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 _[_|_|_] ) $repeatLabel := NIL $breakCount := 0 $anonymousMapCounter := 0 ++ List of free variables in the current function $freeVariables := [] ++ List of bound variables in the current function $boundVariables := [] --% 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] setDynamicBinding(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 := [$mapName,["LAMBDA",[:vars,'envArg],body]] code := wrap compileInteractive 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] => nil $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] => nil putValue(x,getValue term2) putModeSet(x,ms) ms := bottomUp term2 ms isnt [=$Boolean] => nil -- generate an IF expression and let the rest of the code handle it -- ??? In full generality, this is still incorrect. We should be -- ??? looking up modemaps to see whether the interpretation is -- ??? unique and the target type is Boolean before going on -- ??? generating LISP IF-expression. -- gdr 2008/01/14 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] => nil $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] => nil putValue(x,getValue term2) putModeSet(x,ms) ms := bottomUp term2 ms isnt [=$Boolean] => nil -- generate an IF expression and let the rest of the code handle it cond := [mkAtreeNode "=",mkAtree "true",term1] putTarget(cond,$Boolean) -- ??? the following code generation is incorrect. -- gdr code := [mkAtreeNode "IF",cond,mkAtree "true",term2] putTarget(code,$Boolean) bottomUp code putValue(x,getValue code) putModeSet(x,ms) --% Handlers for case ++ subroutine of upcase. Handles the situation where `case' may ++ have been defined as a library function. ++ `op', `lhs' are VATs; `rhs' is unevaluated. userDefinedCase(t is [op, lhs, rhs]) == -- We want to resolve the situation by general modemap selection. -- So, we want to let bottomUp (which called us through upcase) -- to continue the work. The way we do that is to return `nil'. -- Therefore we need a VAT for `rhs' with sufficient information -- to prevent bottomUp from trying to evaluate `rhs'. putAtree(op, 'flagArgsPos, flagArguments("case",2)) r := mkAtreeNode $immediateDataSymbol m := quasiquote rhs putMode(r, m) putValue(r, objNewWrap(MKQ rhs,m)) putModeSet(r, [m]) RPLACD(cdr t, [r]) -- fix up contained for rhs. nil -- tell bottomUp to continue. upcase t == t isnt [op,lhs,rhs] => nil bottomUp lhs triple := getValue lhs objMode(triple) isnt ['Union,:unionDoms] => userDefinedCase t 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 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) -- at this point, the AST may already be badly corrupted, -- but better late than never. throwKeyedMsg("S2IS0061",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) 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($indexVars,pred,zipType,$localVars) s := [mkAtreeNode 'swhile,predVec,s] iter is ['UNTIL,pred] => predVec := mkIterZippedFun($indexVars,pred,zipType,$localVars) s := [mkAtreeNode 'suntil,predVec,s] iter is ['SUCHTHAT,pred] => putTarget(pred,$Boolean) predVec := mkIterZippedFun($indexVars,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:= #indexList for [var,:.] in indexList 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 ((m := objMode(val)) in '((Domain) (Category)) or conceptualType m = $Category) => 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)]