From cdf162160d3055657578dcc09bec96411bbff793 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sun, 27 Feb 2011 17:27:35 +0000 Subject: * interp/Makefile.in (OBJS): Remove i-spec1.$(FASLEXT) and i-spec2.$(FASLEXT). Add i-special.$(FASLEXT). * interp/i-spec1.boot, interp/i-spec2.boot: Move content to i-special.boot. Remove. --- src/interp/Makefile.in | 7 +- src/interp/i-spec1.boot | 1271 ----------------------- src/interp/i-spec2.boot | 1228 ---------------------- src/interp/i-special.boot | 2465 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 2468 insertions(+), 2503 deletions(-) delete mode 100644 src/interp/i-spec1.boot delete mode 100644 src/interp/i-spec2.boot create mode 100644 src/interp/i-special.boot (limited to 'src/interp') diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index 94a6fe83..00a0a2ad 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -94,8 +94,8 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \ i-funsel.$(FASLEXT) \ i-intern.$(FASLEXT) i-map.$(FASLEXT) \ i-output.$(FASLEXT) \ - i-spec1.$(FASLEXT) \ - i-spec2.$(FASLEXT) i-syscmd.$(FASLEXT) \ + i-special.$(FASLEXT) \ + i-syscmd.$(FASLEXT) \ i-toplev.$(FASLEXT) i-util.$(FASLEXT) \ incl.$(FASLEXT) int-top.$(FASLEXT) \ intfile.$(FASLEXT) c-util.$(FASLEXT) \ @@ -328,8 +328,7 @@ int-top.$(FASLEXT): incl.$(FASLEXT) i-toplev.$(FASLEXT) unlisp.$(FASLEXT) i-toplev.$(FASLEXT): i-analy.$(FASLEXT) i-syscmd.$(FASLEXT): i-object.$(FASLEXT) i-output.$(FASLEXT): sys-macros.$(FASLEXT) -i-spec2.$(FASLEXT): i-spec1.$(FASLEXT) -i-spec1.$(FASLEXT): i-analy.$(FASLEXT) +i-special.$(FASLEXT): i-analy.$(FASLEXT) i-funsel.$(FASLEXT): i-coerfn.$(FASLEXT) i-map.$(FASLEXT): i-object.$(FASLEXT) i-eval.$(FASLEXT): i-analy.$(FASLEXT) diff --git a/src/interp/i-spec1.boot b/src/interp/i-spec1.boot deleted file mode 100644 index ebc27251..00000000 --- a/src/interp/i-spec1.boot +++ /dev/null @@ -1,1271 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. --- All rights reserved. --- Copyright (C) 2007-2011, 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 -namespace 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 - _[_|_|_] %Macro %MLambda %Import %Export %Inline %With %Add %Match) - -$repeatLabel := NIL -$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 := second 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 := [rest v for v in sublist] - - for m in rest 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,first 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 symbolName $mapName - body := substitute(["%dynval",MKQ minivectorName],"$$$",body) - setDynamicBinding(minivectorName,LIST2VEC $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 - parms := [:vars,"envArg"] - if not $definingMap and ($genValue or $compilingMap) then - code := wrap compileInteractive [$mapName,["LAMBDA",parms,body]] - else - $freeVariables: local := [] - $boundVariables: local := [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",parms,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(third 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 := makeSymbol 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 vector? 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) - putCallInfo(term1,"and",1,2) - putTarget(term2,$Boolean) - putCallInfo(term2,"and",2,2) - ms := bottomUp term1 - ms isnt [=$Boolean] => nil -- use general modemap - $genValue => - -- ??? we should find a way to check whether the - -- ??? the type of the second operand matters or not. - not objValUnwrap(getValue term1) => -- first operand is `false' - 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 -- use general modemap - -- 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) - putCallInfo(term1,"or",1,2) - putTarget(term2,$Boolean) - putCallInfo(term2,"or",2,2) - ms := bottomUp term1 - ms isnt [=$Boolean] => nil - $genValue => - objValUnwrap(getValue term1) => -- first operand is true, we are done. - 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]) - t.rest.rest := [r] -- fix up contained for rhs. - nil -- tell bottomUp to continue. - -upcase t == - t isnt [op,lhs,rhs] => nil - putCallInfo(lhs,"case",1,2) - 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 false - code := - ['%when, - [["EQL",rhstag,["CAR",["unwrap",objVal triple]]], - true], - ['%otherwise,false]] - else - $genValue => - t' := coerceUnion2Branch triple - rhs = objMode t' => code := wrap true - code := wrap false - triple' := objNewCode(["wrap",objVal triple],objMode triple) - code := - ['%when, - [["EQUAL",MKQ rhs,["objMode",['coerceUnion2Branch,triple']]], - true], - ['%otherwise,false]] - 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 - cons? 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) - $iteratorVars: local := nil - 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)) => - iter.first := '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 - - not 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] - iter.first := first newIter - iter.rest := rest newIter - - iterMs isnt [['List,ud]] => throwKeyedMsg("S2IS0006",[index]) - put(index,'mode,ud,$env) - mkIteratorVariable index - -upLoopIterSTEP(index,lower,step,upperList) == - not 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 removeDuplicates types - put(index,'mode,type,$env) - mkIteratorVariable index - -evalCOLLECT(op,[:itrl,body],m) == - iters := [evalLoopIter itr for itr in itrl] - bod := getArgValue(body,computedMode body) - if bod isnt ['SPADCALL,:.] then bod := ['unwrap,bod] - code := timedOptimization asTupleNewCode0(second m, ['%collect,:iters,bod]) - putValue(op,object(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(getVMType t, #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] - iter.first := first newIter - iter.rest := rest newIter - - (iterMs isnt [['List,ud]]) and (iterMs isnt [['Stream,ud]]) - and (iterMs isnt [['InfinitTuple, ud]]) => - throwKeyedMsg("S2IS0006",[index]) - put(index,'mode,ud,$env) - mkIteratorVariable 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) - mkIteratorVariable 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(first $indexVars,body) - 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) - s := [mkAtreeNode fun,predVec,s] - iter is ['UNTIL,pred] => - fun := 'filterUntil - predVec := mkIterFun(indSet,pred) - s := [mkAtreeNode fun,predVec,s] - iter is ['SUCHTHAT,pred] => - fun := 'select - putTarget(pred,$Boolean) - predVec := mkIterFun(indSet,pred) - s := [mkAtreeNode fun,predVec,s] - s - -mkIterFun([index,:s],funBody) == - -- 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] - -- Check generated code for free variables and pass them into the - -- lambda as part of envArg. Since only `index' is bound, every - -- other symbol in non-operator position is a free variable. - $freeVariables: local := [] - $boundVariables: local := [index] - body := checkForFreeVariables(objVal getValue funBody,"ALL") - parms := [index,"envArg"] - val:=['function,declareUnusedParameters ['LAMBDA,parms,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 - symbol? v => - v="$$$" => v -- Placeholder for mini-vector - MEMQ(v,$boundVariables) => v - p := POSITION(v,$freeVariables) => - ["getSimpleArrayEntry","envArg",positionInVec(p,#($freeVariables))] - (locals = "ALL") or MEMQ(v,locals) => - $freeVariables := [v,:$freeVariables] - ["getSimpleArrayEntry","envArg",positionInVec(0,#($freeVariables))] - v - LISTP v => - rest(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 in '(LAMBDA QUOTE getValueFromEnvironment) => v - op = "LETT" => -- Expands to a SETQ. - ["SETF",:[checkForFreeVariables(a,locals) for a in args]] - op in '(COLLECT REPEAT %collect %loop) => - first(args) is ["STEP",var,:.] => - $boundVariables := [var,:$boundVariables] - r := [op,:[checkForFreeVariables(a,locals) for a in args]] - $boundVariables := delete(var,$boundVariables) - r - [op,:[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) => - ["getSimpleArrayEntry","envArg",positionInVec(p,#($freeVariables))] - $freeVariables := [var,:$freeVariables] - ["getSimpleArrayEntry","envArg",positionInVec(0,#($freeVariables))] - ["SETF",newvar,checkForFreeVariables(form,locals)] - error "Non-simple variable bindings are not currently supported" - op in '(LET LET_* %bind) => - vars := [first init for init in first args] - inits := [checkInit(init,locals) for init in first args] where - checkInit([var,init],locals) == - init := checkForFreeVariables(init,locals) - $boundVariables := [var,:$boundVariables] - [var,init] - body := checkForFreeVariables(rest args,locals) - $boundVariables := setDifference($boundVariables,vars) - [op,inits,:body] - op = "PROG" => - error "Non-simple variable bindings are not currently supported" - [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 := second objMode getValue s1 - t2 := second 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 rest indexList - [[.,:s],:.] := indexList - t := second 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: local := [] - $boundVariables: local := [$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] - parms := [$index,'envArg] - val:=['function,declareUnusedParameters ['LAMBDA,parms,objVal body]] - vec := mkAtreeNode gensym() - putValue(vec,objNew(['CONS,val,["VECTOR",:reverse $freeVariables]],mapMode)) - vec - -subVecNodes(new,old,form) == - atom form => - (vector? form) and (form.0 = old) => new - form - [subVecNodes(new,old,first form), :subVecNodes(new,old,rest 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 cons?(tar) and not isPartialMode(tar) then - first(tar) in aggs => - ud := - (l is [[realOp, :.]]) and (getUnname(realOp) = 'COLLECT) => tar - second tar - for x in l repeat if not getTarget(x) then putTarget(x,ud) - first(tar) in '(Matrix SquareMatrix RectangularMatrix) => - vec := ['List,underDomainOf tar] - for x in l repeat if not getTarget(x) then putTarget(x,vec) - nargs := #l - argModeSetList:= [bottomUp putCallInfo(x,"construct",i,nargs) - for x in l for i in 1..] - 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 [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 := object(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 := object(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 := object(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 member($Symbol,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) => ['%list,:argCode] - (len = 2) => ['%pair,:argCode] - ['%vector,:argCode] - putValue(op,object(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) - getAtree(op,"callingFunction") => - -- This isn't a real declaration, rather a field specification. - not IDENTP lhs => throwKeyedMsg("S2IE0020",nil) - -- ??? When we come to support field spec as type, change this. - putValue(op,objNewWrap([":",lhs,mode],mode)) - putModeSet(op,[mode]) - 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 - validateVariableNameOrElse 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 - cons? margs => -1 + #margs - 1 - nargs ~= #args => throwKeyedMsg("S2IM0008",[var]) - if $compilingMap then mkLocalVar($mapName,var) - else clearDependencies(var,true) - isLocallyBound 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 - isLocallyBound 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 rest d for var in $FormalMapVariableList repeat - SL:= [[var,:e],:SL] - x := subCopy(x,SL) - SL:= NIL - for e in rest d for var in $TriangleVariableList repeat - SL:= [[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 _ - (cons?($env) and get(form,'value,$env)) or _ - (cons?($e) and get(form,'value,$e)))) and - (member(m := objMode(val),'((Domain) (Category))) - or conceptualType m = $Category) => - objValUnwrap(val) - nil - - -++ returns true if category form `c1' implies category form `c2'. -++ Both are assumed to be definite categories, i.e. they contain -++ no variables. -categoryImplies(c1,c2) == - c2 = $Type => true - c1 is ["Join",:cats] => - or/[categoryImplies(c,c2) for c in cats] => true - c1 = c2 - -- ??? Should also check conditional definition and - -- ??? possibly attributes - -++ returns true if domain `d' satisfies category `c'. -evalCategory(d,c) == - -- tests whether domain d has category c - isPartialMode d => true -- maybe too generous - -- If this is a local variable then, its declared type - -- must imply category `c' satisfaction. - IDENTP d and (m := getmode(d,$env)) => categoryImplies(m,c) - 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 - op in '(Polynomial RationalFunction AlgebraicFunction Expression - ElementaryFunction LiouvillianFunction FunctionalExpression - CombinatorialFunction) => 'all - op = 'UnivariatePolynomial => [a] - op = 'Variable => [a] - op in '(MultivariatePolynomial DistributedMultivariatePolynomial - HomogeneousDistributedMultivariatePolynomial) => a - NIL - NIL - -containsPolynomial m == - atom 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 == - atom 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 = first(l) => deleteAll(x,rest l) - [first l,:deleteAll(x,rest l)] - - -$iteratorVars := nil - -mkIteratorVariable id == - $iteratorVars := [id,:$iteratorVars] - -- mkLocalVar('"the iterator expression",id) diff --git a/src/interp/i-spec2.boot b/src/interp/i-spec2.boot deleted file mode 100644 index 9e46ef6b..00000000 --- a/src/interp/i-spec2.boot +++ /dev/null @@ -1,1228 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- Copyright (C) 2007-2011, 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_-spec1 -namespace BOOT - -++ The `void' value object (an oxymoron). There really are constants. -$VoidValueObject := objNew(voidValue(), $Void) -$VoidCodeObject := objNew('(voidValue), $Void) - -setValueToVoid t == - putValue(t,$VoidValueObject) - putModeSet(t,[$Void]) - -setCodeToVoid t == - putValue(t,$VoidCodeObject) - putModeSet(t,[$Void]) - -++ Interpreter macros -$InterpreterMacroAlist == - '((%i . (complex 0 1)) - (%e . (exp 1)) - (%pi . (pi)) - (SF . (DoubleFloat)) - (%infinity . (infinity)) - (%plusInfinity . (plusInfinity)) - (%minusInfinity . (minusInfinity))) - - --- Functions which require special handlers (also see end of file) - ---% Handlers for map definitions - -upDEF t == - -- performs map definitions. value is thrown away - t isnt [op,def,pred,.] => nil - v:=addDefMap(["DEF",:def],pred) - not(LISTP(def)) or null(def) => - keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) - mapOp := first def - if LISTP(mapOp) then - null mapOp => - keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) - mapOp := first mapOp - put(mapOp,"value",v,$e) - setValueToVoid op - ---% Handler for package calling and $ constants - -++ Return non-nil if `form' designate a constant defined in the -++ domain designated by `domainForm'. More specifically, returns: -++ nil: no such constant -++ <%Mode>: the type of the constant. -++ T: too many constants designated by `form'. -constantInDomain?(form,domainForm) == - opAlist := getConstructorOperationsFromDB domainForm.op - key := opOf form - entryList := [entry for (entry := [.,.,.,k]) in LASSOC(key,opAlist) - | k in '(CONST ASCONST)] - entryList is [[sig,.,.,.]] => sig.target - #entryList > 2 => true - key = "One" => constantInDomain?(["1"], domainForm) - key = "Zero" => constantInDomain?(["0"], domainForm) - nil - -++ Constant `c' of `type' is referenced from domain `d'; return its value -++ in the VAT `op'. -findConstantInDomain(op,c,type,d) == - isPartialMode d => throwKeyedMsg("S2IS0020",NIL) - val := - $genValue => wrap getConstantFromDomain([c],d) - ["getConstantFromDomain",["LIST",MKQ c],MKQ d] - type := substitute(d,"$",type) - putValue(op,objNew(val,type)) - putModeSet(op,[type]) - -upDollar t == - -- Puts "dollar" property in atree node, and calls bottom up - t isnt [op,D,form] => nil - t2 := t - (not $genValue) and "or"/[CONTAINED(var,D) for var in $localVars] => - keyedMsgCompFailure("S2IS0032",NIL) - D="Lisp" => upLispCall(op,form) - if vector? D and (# D > 0) then D := D.0 - t := evaluateType unabbrev D - categoryForm? t => - throwKeyedMsg("S2IE0012", [t]) - f := getUnname form - if f = $immediateDataSymbol then - f := objValUnwrap coerceInteractive(getValue form,$OutputForm) - if f = '(construct) then f := "nil" - atom form and (f ~= $immediateDataSymbol) => - type := constantInDomain?([f],t) => - type ~= true => findConstantInDomain(op,f,type,t) - -- Ambiguous constant. FIXME: try to narrow before giving up. - throwKeyedMsg("S2IB0008h",[f,t]) - findUniqueOpInDomain(op,f,t) - - nargs := #rest form - - (ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms - - f ~= "construct" and null isOpInDomain(f,t,nargs) => - throwKeyedMsg("S2IS0023",[f,t]) - if (sig := findCommonSigInDomain(f,t,nargs)) then - for x in sig for y in form repeat - if x then putTarget(y,x) - putAtree(first form,"dollar",t) - ms := bottomUp form - f in '(One Zero) and cons? (ms) and first(ms) = $OutputForm => - throwKeyedMsg("S2IS0021",[f,t]) - putValue(op,getValue first form) - putModeSet(op,ms) - - -upDollarTuple(op, f, t, t2, args, nargs) == - -- this function tries to find a tuple function to use - -- nargs = 1 and getUnname first args = "Tuple" => NIL - -- nargs = 1 and (ms := bottomUp first args) and ms is [["Tuple",.]] => NIL - null (singles := isOpInDomain(f,t,1)) => NIL - tuple := NIL - for [[.,arg], :.] in singles while null tuple repeat - if arg is ['Tuple,.] then tuple := arg - null tuple => NIL - [.,D,form] := t2 - newArg := [mkAtreeNode "tuple",:args] - putTarget(newArg, tuple) - ms := bottomUp newArg - first ms ~= tuple => NIL - form := [first form, newArg] - putAtree(first form,"dollar",t) - ms := bottomUp form - putValue(op,getValue first form) - putModeSet(op,ms) - -upLispCall(op,t) == - -- process $Lisp calls - if atom t then code:=getUnname t else - [lispOp,:argl]:= t - null functionp lispOp.0 => - throwKeyedMsg("S2IS0024",[lispOp.0]) - for arg in argl repeat bottomUp arg - code:=[getUnname lispOp, - :[getArgValue(arg,computedMode arg) for arg in argl]] - rt := '(SExpression) - putValue(op,object(code,rt)) - putModeSet(op,[rt]) - ---% Handlers for equation - -upequation tree == - -- only handle this if there is a target of Boolean - -- this should speed things up a bit - tree isnt [op,lhs,rhs] => NIL - $Boolean ~= getTarget(op) => NIL - not vector? op => NIL - -- change equation into '=' - op.0 := "=" - bottomUp tree - ---% Handler for error - -uperror t == - -- when compiling a function, this merely inserts another argument - -- which is the name of the function. - not $compilingMap => NIL - t isnt [op,msg] => NIL - msgMs := bottomUp putCallInfo(msg,"error",1,1) - msgMs isnt [=$String] => NIL - t.rest := [mkAtree object2String $mapName,msg] - bottomUp t - ---% Handlers for free and local - -upfree t == - setCodeToVoid t - -uplocal t == - setCodeToVoid t - -upfreeWithType(var,type) == - sayKeyedMsg("S2IS0055",['"free",var]) - var - -uplocalWithType(var,type) == - sayKeyedMsg("S2IS0055",['"local",var]) - var - ---% Handlers for has - -uphas t == - t isnt [op,type,prop] => nil - -- handler for category and attribute queries - type := - x := elaborateForm type - getModeSet x is [m] and (conceptualType m = $Type or categoryForm? m) => - val := objValUnwrap getValue x - $genValue => MKQ val - ["devaluate",val] - throwKeyedMsg("S2IE0021",[type]) - catCode := - -- FIXME: when we come to support category valued variable - -- this code needs to be adapted. - prop := unabbrev prop - evaluateType0 prop => ["evaluateType", MKQ prop] - MKQ prop - code := ["NOT",["NULL",["newHasTest",type, catCode]]] - putValue(op,object(code,$Boolean)) - putModeSet(op,[$Boolean]) - ---hasTest(a,b) == --- newHasTest(a,b) --see NRUNFAST BOOT - ---% Handlers for IF - -upIF t == - t isnt [op,cond,a,b] => nil - bottomUpPredicate(cond,'"if/when") - $genValue => interpIF(op,cond,a,b) - compileIF(op,cond,a,b,t) - -compileIF(op,cond,a,b,t) == - -- type analyzer for compiled case where types of both branches of - -- IF are resolved. - ms1 := bottomUp a - [m1] := ms1 - b = "%noBranch" => - evalIF(op,rest t,$Void) - putModeSet(op,[$Void]) - b = "%noMapVal" => - -- if this was a return statement, we take the mode to be that - -- of what is being returned. - if getUnname a = 'return then - ms1 := bottomUp second a - [m1] := ms1 - evalIF(op,rest t,m1) - putModeSet(op,ms1) - ms2 := bottomUp b - [m2] := ms2 - m:= - m2=m1 => m1 - m2 = $Exit => m1 - m1 = $Exit => m2 - if m1 = $Symbol then - m1:=getMinimalVarMode(getUnname a,$declaredMode) - if m2 = $Symbol then - m2:=getMinimalVarMode(getUnname b,$declaredMode) - (r := resolveTTAny(m2,m1)) => r - rempropI($mapName,'localModemap) - rempropI($mapName,'localVars) - rempropI($mapName,'mapBody) - throwKeyedMsg("S2IS0026",[m2,m1]) - evalIF(op,rest t,m) - putModeSet(op,[m]) - -evalIF(op,[cond,a,b],m) == - -- generate code form compiled IF - elseCode:= - b="%noMapVal" => - [[MKQ true, ["throwKeyedMsg",MKQ "S2IM0018", - ["CONS",MKQ object2Identifier $mapName,NIL]]]] - b='%noBranch => - $lastLineInSEQ => [[MKQ true,["voidValue"]]] - NIL - [[MKQ true,genIFvalCode(b,m)]] - code:=['%when,[getArgValue(cond,$Boolean), - genIFvalCode(a,m)],:elseCode] - triple:= objNew(code,m) - putValue(op,triple) - -genIFvalCode(t,m) == - -- passes type information down braches of IF statement - -- So that coercions can be performed on data at branches of IF. - m1 := computedMode t - m1=m => getArgValue(t,m) - code:=objVal getValue t - IFcodeTran(code,m,m1) - -IFcodeTran(code,m,m1) == - -- coerces values at branches of IF - null code => code - code is ["spadThrowBrightly",:.] => code - m1 = $Exit => code - code isnt ['%when,[p1,a1],['%otherwise,a2]] => - m = $Void => code - code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) => - getValueNormalForm code' - throwKeyedMsgCannotCoerceWithValue(quote2Wrapped code,m1,m) - a1:=IFcodeTran(a1,m,m1) - a2:=IFcodeTran(a2,m,m1) - ['%when,[p1,a1],['%otherwise,a2]] - -interpIF(op,cond,a,b) == - -- non-compiled version of IF type analyzer. Doesn't resolve accross - -- branches of the IF. - val:= getValue cond - val:= coerceInteractive(val,$Boolean) => - objValUnwrap(val) => upIFgenValue(op,a) - b="%noBranch" => setValueToVoid op - upIFgenValue(op,b) - throwKeyedMsg("S2IS0031",NIL) - -upIFgenValue(op,tree) == - -- evaluates tree and transfers the results to op - ms:=bottomUp tree - val:= getValue tree - putValue(op,val) - putModeSet(op,ms) - ---% Handlers for is - -upis t == - t isnt [op,a,pattern] => nil - $opIsIs : local := true - upisAndIsnt t - -upisnt t == - t isnt [op,a,pattern] => nil - $opIsIs : local := nil - upisAndIsnt t - -upisAndIsnt(t:=[op,a,pattern]) == - -- handler for "is" pattern matching - mS:= bottomUp a - mS isnt [m] => - keyedSystemError("S2GE0016",['"upisAndIsnt",'"non-unique modeset"]) - putPvarModes(removeConstruct pattern,m) - evalis(op,rest t,m) - putModeSet(op,[$Boolean]) - -putPvarModes(pattern,m) == - -- Puts the modes for the pattern variables into $env - m isnt ["List",um] => throwKeyedMsg("S2IS0030",NIL) - for pvar in pattern repeat - IDENTP pvar => (not (pvar=$quadSymbol)) and put(pvar,'mode,um,$env) - pvar is ['_:,var] => - null (var=$quadSymbol) and put(var,"mode",m,$env) - pvar is ['_=,var] => - null (var=$quadSymbol) and put(var,"mode",um,$env) - putPvarModes(pvar,um) - -evalis(op,[a,pattern],mode) == - -- actually handles is and isnt - if $opIsIs - then fun := 'evalIsPredicate - else fun := 'evalIsntPredicate - if isLocalPred pattern then - code:= compileIs(a,pattern) - else code:=[fun,getArgValue(a,mode), - MKQ pattern,MKQ mode] - triple := object(code,$Boolean) - putValue(op,triple) - -isLocalPred pattern == - -- returns true if this predicate is to be compiled - for pat in pattern repeat - IDENTP pat and isLocallyBound pat => return true - pat is [":",var] and isLocallyBound var => return true - pat is ["=",var] and isLocallyBound var => return true - -compileIs(val,pattern) == - -- produce code for compiled "is" predicate. makes pattern variables - -- into local variables of the function - vars:= NIL - for pat in rest pattern repeat - IDENTP(pat) and isLocallyBound pat => vars:=[pat,:vars] - pat is [":",var] => vars:= [var,:vars] - pat is ["=",var] => vars:= [var,:vars] - predCode:=["%LET",g:=gensym(),["isPatternMatch", - getArgValue(val,computedMode val),MKQ removeConstruct pattern]] - for var in removeDuplicates vars repeat - assignCode:=[["%LET",var,["CDR",["ASSQ",MKQ var,g]]],:assignCode] - null $opIsIs => - ['%when,[["EQ",predCode,MKQ "failed"],["SEQ",:assignCode,'%true]]] - ['%when,[['%not,["EQ",predCode,MKQ "failed"]],["SEQ",:assignCode,'%true]]] - -evalIsPredicate(value,pattern,mode) == - --This function pattern matches value to pattern, and returns - --true if it matches, and false otherwise. As a side effect - --if the pattern matches then the bindings given in the pattern - --are made - pattern:= removeConstruct pattern - not ((valueAlist:=isPatternMatch(value,pattern))='failed) => - for [id,:value] in valueAlist repeat - evalLETchangeValue(id,objNewWrap(value,get(id,'mode,$env))) - true - false - -evalIsntPredicate(value,pattern,mode) == - evalIsPredicate(value,pattern,mode) => false - true - -removeConstruct pat == - -- removes the "construct" from the beginning of patterns - if pat is ["construct",:p] then pat:=p - if pat is ["cons", a, b] then pat := [a, [":", b]] - atom pat => pat - pat.first := removeConstruct first pat - pat.rest := removeConstruct rest pat - pat - -isPatternMatch(l,pats) == - -- perform the actual pattern match - $subs: local := NIL - isPatMatch(l,pats) - $subs - -isPatMatch(l,pats) == - null pats => - null l => $subs - $subs:='failed - null l => - null pats => $subs - pats is [[":",var]] => - $subs := [[var],:$subs] - $subs:='failed - pats is [pat,:restPats] => - IDENTP pat => - $subs:=[[pat,:first l],:$subs] - isPatMatch(rest l,restPats) - pat is ["=",var] => - p:=ASSQ(var,$subs) => - first l = rest p => isPatMatch(rest l, restPats) - $subs:="failed" - $subs:="failed" - pat is [":",var] => - n:=#restPats - m:=#l-n - m<0 => $subs:="failed" - ZEROP n => $subs:=[[var,:l],:$subs] - $subs:=[[var,:[x for x in l for i in 1..m]],:$subs] - isPatMatch(DROP(m,l),restPats) - isPatMatch(first l,pat) = "failed" => "failed" - isPatMatch(rest l,restPats) - keyedSystemError("S2GE0016",['"isPatMatch", - '"unknown form of is predicate"]) - ---% Handler for iterate - -upiterate t == - null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"]) - $iterateCount := $iterateCount + 1 - code := ["THROW",$repeatBodyLabel,'(voidValue)] - $genValue => THROW(eval $repeatBodyLabel,voidValue()) - putValue(t,objNew(code,$Void)) - putModeSet(t,[$Void]) - ---% Handler for break - -upbreak t == - t isnt [op,.] => nil - null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"]) - $breakCount := $breakCount + 1 - code := ["THROW",$repeatLabel,'(voidValue)] - $genValue => THROW(eval $repeatLabel,voidValue()) - putValue(op,objNew(code,$Void)) - putModeSet(op,[$Void]) - ---% Handlers for %LET - -up%LET t == - -- analyzes and evaluates the righthand side, and does the variable - -- binding - t isnt [op,lhs,rhs] => nil - $declaredMode: local := NIL - cons? lhs => - var:= getUnname first lhs - var = "construct" => upLETWithPatternOnLhs t - var = "QUOTE" => throwKeyedMsg("S2IS0027",['"A quoted form"]) - upLETWithFormOnLhs(op,lhs,rhs) - var:= getUnname lhs - var = $immediateDataSymbol => - -- following will be immediate data, so probably ok to not - -- specially format it - obj := objValUnwrap coerceInteractive(getValue lhs,$OutputForm) - throwKeyedMsg("S2IS0027",[obj]) - var in '(% %%) => -- for history - throwKeyedMsg("S2IS0027",[var]) - (IDENTP var) and not (var in '(true false elt QUOTE)) => - var ~= (var' := unabbrev(var)) => -- constructor abbreviation - throwKeyedMsg("S2IS0028",[var,var']) - if get(var,'isInterpreterFunction,$e) then - putHist(var,'isInterpreterFunction,false,$e) - sayKeyedMsg("S2IS0049",['"Function",var]) - else if get(var,'isInterpreterRule,$e) then - putHist(var,'isInterpreterRule,false,$e) - sayKeyedMsg("S2IS0049",['"Rule",var]) - (m := isType rhs) => upLETtype(op,lhs,m) - transferPropsToNode(var,lhs) - if ( m:= getMode(lhs) ) then - $declaredMode := m - putTarget(rhs,m) - if (val := getValue lhs) and (objMode val = $Boolean) and - getUnname(rhs) = 'equation then putTarget(rhs,$Boolean) - (rhsMs:= bottomUp rhs) = [$Void] => - throwKeyedMsg("S2IS0034",[var]) - val:=evalLET(lhs,rhs) - putValue(op,val) - putModeSet(op,[objMode(val)]) - throwKeyedMsg("S2IS0027",[var]) - -evalLET(lhs,rhs) == - -- lhs is a vector for a variable, and rhs is the evaluated atree - -- for the value which is coerced to the mode of lhs - $useConvertForCoercions: local := true - v' := (v:= getValue rhs) - ((not getMode lhs) and (getModeSet rhs is [.])) or - get(getUnname lhs,'autoDeclare,$env) => - v:= - $genValue => v - objNew(getValueNormalForm v,objMode v) - evalLETput(lhs,v) - t1:= objMode v - t2' := (t2 := getMode lhs) - value:= - t1 = t2 => - $genValue => v - objNew(getValueNormalForm v,objMode v) - if isPartialMode t2 then - if t1 = $Symbol and $declaredMode then - t1:= getMinimalVarMode(objValUnwrap v,$declaredMode) - t' := t2 - null (t2 := resolveTM(t1,t2)) => - if not t2 then t2 := t' - throwKeyedMsg("S2IS0035",[t1,t2]) - null (v := getArgValue(rhs,t2)) => - isWrapped(objVal v') and (v2:=coerceInteractive(v',$OutputForm)) => - throwKeyedMsg("S2IS0036",[objValUnwrap v2,t2]) - throwKeyedMsg("S2IS0037",[t2]) - t2 and object(v,t2) - value => evalLETput(lhs,value) - throwKeyedMsgCannotCoerceWithValue(objVal v,t1,getMode lhs) - -evalLETput(lhs,value) == - -- put value into the cell for lhs - name:= getUnname lhs - if not $genValue then - code:= - isLocallyBound name => - om := objMode(value) - dm := get(name,'mode,$env) - dm and not ((om = dm) or isSubDomain(om,dm) or - isSubDomain(dm,om)) => - compFailure ['" The type of the local variable", - :bright name,'"has changed in the computation."] - if dm and isSubDomain(dm,om) then put(name,'mode,om,$env) - ["%LET",name,objVal value,$mapName] - -- $mapName is set in analyzeMap - om := objMode value - dm := get(name, 'mode, $env) or objMode(get(name, 'value, $e)) - dm and (null $compilingMap) and not(om = dm) and not(isSubDomain(om, dm)) => - THROW('loopCompiler,'tryInterpOnly) - ['unwrap,['evalLETchangeValue,MKQ name, - objNewCode(['wrap,objVal value],objMode value)]] - value:= objNew(code,objMode value) - isLocallyBound name => - if not get(name,'mode,$env) then put(name,'autoDeclare,'T,$env) - put(name,'mode,objMode(value),$env) - put(name,'automode,objMode(value),$env) - $genValue and evalLETchangeValue(name,value) - putValue(lhs,value) - -upLETWithPatternOnLhs(t := [op,pattern,a]) == - $opIsIs : local := true - [m] := bottomUp a - putPvarModes(pattern,m) - object := evalis(op,[a,pattern],m) - -- have to change code to return value of a - failCode := - ['spadThrowBrightly,['concat, - '" Pattern",['QUOTE,bright form2String pattern], - '"is not matched in assignment to right-hand side."]] - if $genValue - then - null objValUnwrap object => eval failCode - putValue(op,getValue a) - else - code := ['%when,[objVal object,objVal getValue a],['%otherwise,failCode]] - putValue(op,objNew(code,m)) - putModeSet(op,[m]) - -evalLETchangeValue(name,value) == - -- write the value of name into the environment, clearing dependent - -- maps if its type changes from its last value - localEnv := cons? $env - clearCompilationsFlag := - val:= (localEnv and get(name,'value,$env)) or get(name,'value,$e) - null val => - not ((localEnv and get(name,'mode,$env)) or get(name,'mode,$e)) - objMode val ~= objMode(value) - if clearCompilationsFlag then - clearDependencies(name,true) - if localEnv and isLocallyBound name - then $env:= putHist(name,'value,value,$env) - else putIntSymTab(name,'value,value,$e) - objVal value - -upLETWithFormOnLhs(op,lhs,rhs) == - -- bottomUp for assignment to forms (setelt, table or tuple) - lhs' := getUnnameIfCan lhs - rhs' := getUnnameIfCan rhs - lhs' = "tuple" => - rhs' ~= "tuple" => throwKeyedMsg("S2IS0039",NIL) - #(lhs) ~= #(rhs) => throwKeyedMsg("S2IS0038",NIL) - -- generate a sequence of assignments, using local variables - -- to first hold the assignments so that things like - -- (t1,t2) := (t2,t1) will work. - seq := [] - temps := [gensym() for l in rest lhs] - for lvar in temps repeat mkLocalVar($mapName,lvar) - for l in reverse rest lhs for t in temps repeat - transferPropsToNode(getUnname l,l) - let := mkAtreeNode "%LET" - t' := mkAtreeNode t - if m := getMode(l) then putMode(t',m) - seq := [[let,l,t'],:seq] - for t in temps for r in reverse rest rhs - for l in reverse rest lhs repeat - let := mkAtreeNode "%LET" - t' := mkAtreeNode t - if m := getMode(l) then putMode(t',m) - seq := [[let,t',r],:seq] - seq := [mkAtreeNode 'SEQ,:seq] - ms := bottomUp seq - putValue(op,getValue seq) - putModeSet(op,ms) - rhs' = "tuple" => throwKeyedMsg("S2IS0039",NIL) - tree:= seteltable(lhs,rhs) => upSetelt(op,lhs,tree) - throwKeyedMsg("S2IS0060", NIL) --- upTableSetelt(op,lhs,rhs) - -seteltable(lhs is [f,:argl],rhs) == - -- produces the setelt form for trees such as "l.2:= 3" - null (g := getUnnameIfCan f) => NIL - g="elt" => altSeteltable [:argl, rhs] - get(g,'value,$e) is [expr,:.] and isMapExpr expr => NIL - transferPropsToNode(g,f) - getValue(lhs) or getMode(lhs) => - f is [f',:argl'] => altSeteltable [f',:argl',:argl,rhs] - altSeteltable [:lhs,rhs] - NIL - -altSeteltable args == - for x in args repeat bottomUp x - newOps := [mkAtreeNode "setelt", mkAtreeNode "set!"] - form := NIL - - -- first look for exact matches for any of the possibilities - while null form for newOp in newOps repeat - if selectMms(newOp, args, NIL) then form := [newOp, :args] - - -- now try retracting arguments after the first - while null form and ( "and"/[retractAtree(a) for a in rest args] ) repeat - while null form for newOp in newOps repeat - if selectMms(newOp, args, NIL) then form := [newOp, :args] - - form - - -upSetelt(op,lhs,tree) == - -- type analyzes implicit setelt forms - var:=opOf lhs - transferPropsToNode(getUnname var,var) - if (m1:=getMode var) then $declaredMode:= m1 - if m1 or ((v1 := getValue var) and (m1 := objMode v1)) then - putModeSet(var,[m1]) - ms := bottomUp tree - putValue(op,getValue tree) - putModeSet(op,ms) - -upTableSetelt(op,lhs is [htOp,:args],rhs) == - -- called only for undeclared, uninitialized table setelts - ("*" = (PNAME getUnname htOp).0) and (1 ~= # args) => - throwKeyedMsg("S2IS0040",NIL) - # args ~= 1 => - throwKeyedMsg("S2IS0041",[[getUnname htOp,'".[", - getUnname first args, - ['",",getUnname arg for arg in rest args],'"]"]]) - keyMode := $Any - putMode (htOp,['Table,keyMode,$Any]) - -- if we are to use a new table, we must call the "table" - -- function to give it an initial value. - bottomUp [mkAtreeNode "%LET",htOp,[mkAtreeNode 'table]] - tableCode := objVal getValue htOp - r := upSetelt(op, lhs, [mkAtreeNode "setelt",:lhs,rhs]) - $genValue => r - -- construct code - t := getValue op - putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t)) - r - -unVectorize body == - -- transforms from an atree back into a tree - vector? body => - name := getUnname body - name ~= $immediateDataSymbol => name - objValUnwrap getValue body - atom body => body - body is [op,:argl] => - newOp:=unVectorize op - if newOp = 'SUCHTHAT then newOp := "|" - if newOp = 'COERCE then newOp := "::" - if newOp = 'Dollar then newOp := "$elt" - [newOp,:unVectorize argl] - systemErrorHere ["unVectorize",body] - -isType t == - -- Returns the evaluated type if t is a tree representing a type, - -- and NIL otherwise - op:=opOf t - vector? op => - isMap(op:= getUnname op) => NIL - op = 'Mapping and cons? t => - argTypes := [isType type for type in rest t] - "or"/[null type for type in argTypes] => nil - ['Mapping, :argTypes] - isLocallyBound op => NIL - d := isDomainValuedVariable op => d - type:= - -- next line handles subscripted vars - (abbreviation?(op) or (op = 'typeOf) or - constructor?(op) or (op in '(Record Union Enumeration))) and - unabbrev unVectorize t - type and evaluateType type - d := isDomainValuedVariable op => d - NIL - -upLETtype(op,lhs,type) == - -- performs type assignment - opName:= getUnname lhs - (not $genValue) and "or"/[CONTAINED(var,type) for var in $localVars] => - compFailure ['" Cannot compile type assignment to",:bright opName] - mode := conceptualType type - val:= objNew(type,mode) - if isLocallyBound opName then put(opName,'value,val,$env) - else putHist(opName,'value,val,$e) - putValue(op,val) - -- have to fix the following - putModeSet(op,[mode]) - -assignSymbol(symbol, value, domain) == --- Special function for binding an interpreter variable from within algebra --- code. Does not do the assignment and returns nil, if the variable is --- already assigned - val := get(symbol, 'value, $e) => nil - obj := objNew(wrap value, devaluate domain) - put(symbol, 'value, obj, $e) - true - ---% Handler for Interpreter Macros - -getInterpMacroNames() == - names := [n for [n,:.] in $InterpreterMacroAlist] - if (e := CAAR $InteractiveFrame) and (m := assoc("--macros--",e)) then - names := append(names,[n for [n,:.] in rest m]) - MSORT names - -isInterpMacro name == - -- look in local and then global environment for a macro - not IDENTP name => NIL - name in $specialOps => NIL - (m := get("--macros--",name,$env)) => m - (m := get("--macros--",name,$e)) => m - (m := get("--macros--",name,$InteractiveFrame)) => m - -- $InterpreterMacroAlist will probably be phased out soon - (sv := assoc(name,$InterpreterMacroAlist)) => [NIL,:rest sv] - NIL - ---% Handlers for prefix QUOTE - -upQUOTE t == - t isnt [op,expr] => NIL - ms:= list - m:= getBasicMode expr => m - IDENTP expr => --- $useSymbolNotVariable => $Symbol - getTarget t = $Identifier => $Identifier - ['Variable,expr] - $InputForm - evalQUOTE(op,[expr],ms) - putModeSet(op,ms) - -evalQUOTE(op,[expr],[m]) == - triple:= - $genValue => objNewWrap(expr,m) - objNew(['QUOTE,expr],m) - putValue(op,triple) - ---% Quasiquotation -up_[_|_|_] t == - t isnt [op, x] => nil - mode := getTypeOfSyntax x - putValue(op, objNewWrap(x, mode)) - putModeSet(op, [mode]) - ---% Handler for pretend - -uppretend t == - t isnt [op,expr,type] => NIL - mode := evaluateType unabbrev type - not isValidType(mode) => throwKeyedMsg("S2IE0004",[mode]) - bottomUp expr - putValue(op,objNew(objVal getValue expr,mode)) - putModeSet(op,[mode]) - ---% Handlers for REDUCE - -getReduceFunction(op,type,result, locale) == - -- return the function cell for operation with the signature - -- (type,type) -> type, possible from locale - if type is ['Variable,var] then - args := [arg := mkAtreeNode var,arg] - putValue(arg,objNewWrap(var,type)) - else - args := [arg := mkAtreeNode "%1",arg] - if type=$Symbol then putValue(arg,objNewWrap("%1",$Symbol)) - putModeSet(arg,[type]) - vecOp:=mkAtreeNode op - transferPropsToNode(op,vecOp) - if locale then putAtree(vecOp,'dollar,locale) - mmS:= selectMms(vecOp,args,result) - mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS | - (isHomogeneousArgs sig) and "and"/[null c for c in cond]] - null mm => 'failed - [[dc,:sig],fun,:.]:=mm - dc='local => [MKQ [fun,:'local],:first sig] - dcVector := evalDomain dc - $compilingMap => - k := NRTgetMinivectorIndex( - NRTcompiledLookup(op,sig,dcVector),op,sig,dcVector) - ['ELT,"$$$",k] --$$$ denotes minivector - env:= - NRTcompiledLookup(op,sig,dcVector) - MKQ env - -isHomogeneous sig == - --return true if sig describes a homogeneous binary operation - sig.0=sig.1 and sig.1=sig.2 - -isHomogeneousArgs sig == - --return true if sig describes a homogeneous binary operation - sig.1=sig.2 - ---% Handlers for REPEAT - -transformREPEAT [:itrl,body] == - -- syntactic transformation of repeat iterators, called from mkAtree2 - 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 VALUE)) => - [[op,mkAtree1 b]] - it is ['_|,pred] => nil - keyedSystemError("S2GE0016", - ['"transformREPEAT",'"Unknown type of iterator"]) - [:iterList,bodyTree] - -upREPEAT t == - -- REPEATS always return void() of Void - -- assures throw to interpret-code mode goes to outermost loop - $repeatLabel : local := MKQ gensym() - $breakCount : local := 0 - $repeatBodyLabel : local := MKQ gensym() - $iterateCount : local := 0 - $compilingLoop => upREPEAT1 t - upREPEAT0 t - -upREPEAT0 t == - -- sets up catch point for interp-only mode - $compilingLoop: local := true - ms := CATCH('loopCompiler,upREPEAT1 t) - ms = 'tryInterpOnly => interpOnlyREPEAT t - ms - -upREPEAT1 t == - -- repeat loop handler with compiled body - -- see if it has the expected form - t isnt [op,:itrl,body] => NIL - -- determine the mode of the repeat loop. At the moment, if there - -- there are no iterators and there are no "break" statements, then - -- the return type is Exit, otherwise Void. - repeatMode := - null(itrl) and ($breakCount=0) => $Void - $Void - - -- if interpreting, go do that - $interpOnly => interpREPEAT(op,itrl,body,repeatMode) - - -- analyze iterators and loop body - $iteratorVars: local := nil - upLoopIters itrl - bottomUpCompile body - - -- now that the body is analyzed, we should know everything that - -- is in the UNTIL clause - for itr in itrl repeat - itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until") - - -- now go do it - evalREPEAT(op,rest t,repeatMode) - putModeSet(op,[repeatMode]) - -evalREPEAT(op,[:itrl,body],repeatMode) == - -- generate code for loop - bodyMode := computedMode body - bodyCode := getArgValue(body,bodyMode) - if $iterateCount > 0 then - bodyCode := ["CATCH",$repeatBodyLabel,bodyCode] - code := ['%loop,:[evalLoopIter itr for itr in itrl],bodyCode,voidValue()] - code := timedOptimization code - if $breakCount > 0 then code := ['CATCH,$repeatLabel,code] - val := - $genValue => - timedEVALFUN code - objNewWrap(voidValue(),repeatMode) - objNew(code,repeatMode) - putValue(op,val) - -interpOnlyREPEAT t == - -- interpret-code mode call to upREPEAT - $genValue: local := true - $interpOnly: local := true - upREPEAT1 t - -interpREPEAT(op,itrl,body,repeatMode) == - -- performs interpret-code repeat - $indexVars: local := NIL - $indexTypes: local := NIL - code := - -- we must insert a CATCH for the iterate clause - ['%loop,:[interpIter itr for itr in itrl], - ["CATCH",$repeatBodyLabel,interpLoop(body,$indexVars, - $indexTypes,nil)],voidValue()] - SPADCATCH(eval $repeatLabel,timedEVALFUN code) - val:= objNewWrap(voidValue(),repeatMode) - putValue(op,val) - putModeSet(op,[repeatMode]) - -interpLoop(expr,indexList,indexTypes,requiredType) == - -- generates code for interp-only repeat body - ['interpLoopIter,MKQ expr,MKQ indexList,["LIST",:indexList], - MKQ indexTypes, MKQ requiredType] - -interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) == - -- call interpreter on exp with loop vars in indexList with given - -- values and types, requiredType is used from interpCOLLECT - -- to indicate the required type of the result - emptyAtree exp - for i in indexList for val in indexVals for type in indexTypes repeat - put(i,'value,objNewWrap(val,type),$env) - bottomUp exp - v:= getValue exp - val := - null requiredType => v - coerceInteractive(v,requiredType) - null val => - throwKeyedMsgCannotCoerceWithValue(objVal v,objMode v,requiredType) - objValUnwrap val - ---% Handler for return - -upreturn t == - -- make sure we are in a user function - t isnt [op,val] => NIL - (null $compilingMap) and (null $interpOnly) => - throwKeyedMsg("S2IS0047",NIL) - if $mapTarget then putTarget(val,$mapTarget) - bottomUp val - if $mapTarget - then - val' := getArgValue(val, $mapTarget) - m := $mapTarget - else - val' := getValueNormalForm getValue val - m := computedMode val - cn := mapCatchName $mapName - $mapReturnTypes := insert(m, $mapReturnTypes) - $mapThrowCount := $mapThrowCount + 1 - -- if $genValue then we are interpreting the map - $genValue => THROW(cn,objNewWrap(removeQuote val',m)) - putValue(op,objNew(['THROW,MKQ cn,val'],m)) - putModeSet(op,[$Exit]) - ---% Handler for SEQ - -upSEQ u == - -- assumes that exits were translated into if-then-elses - -- handles flat SEQs and embedded returns - u isnt [op,:args] => NIL - if (target := getTarget(op)) then putTarget(last args, target) - for x in args repeat bottomUp x - null (m := computedMode last args) => - keyedSystemError("S2GE0016",['"upSEQ", - '"last line of SEQ has no mode"]) - evalSEQ(op,args,m) - putModeSet(op,[m]) - -evalSEQ(op,args,m) == - -- generate code for SEQ - [:argl,last] := args - val:= - $genValue => getValue last - bodyCode := nil - for x in args repeat - (m1 := computedMode x) and (m1 ~= '$ThrowAwayMode) => - (av := getArgValue(x,m1)) ~= voidValue() => - bodyCode := [av,:bodyCode] - code:= - bodyCode is [c] => c - ['PROGN,:reverse bodyCode] - objNew(code,m) - putValue(op,val) - ---% Handlers for tuple - -uptuple 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 => upNullTuple(op,l,tar) - isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar) - aggs := '(List) - if tar and cons?(tar) and not isPartialMode(tar) then - first(tar) in aggs => - ud := second tar - for x in l repeat if not getTarget(x) then putTarget(x,ud) - first(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] - eltTypes := replaceSymbols([first x for x in argModeSetList],l) - if not isPartialMode(tar) and tar is ['Tuple,ud] then - mode := ['Tuple, resolveTypeListAny [ud,:eltTypes]] - else mode := ['Tuple, resolveTypeListAny eltTypes] - if isPartialMode tar then tar:=resolveTM(mode,tar) - evalTuple(op,l,mode,tar) - -evalTuple(op,l,m,tar) == - [agg,:.,underMode]:= m - code := asTupleNewCode(underMode, #l, - [(getArgValue(x,underMode) or throwKeyedMsg("S2IC0007",[underMode])) for x in l]) - val := object(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]) - -upNullTuple(op,l,tar) == - -- handler for the empty tuple - defMode := - tar and tar is [a,b] and (a in '(Stream Vector List)) and - not isPartialMode(b) => ['Tuple,b] - '(Tuple (None)) - val := objNewWrap(asTupleNew(getVMType second defMode,0,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]) - ---% Handler for typeOf - -uptypeOf form == - form isnt [op, arg] => NIL - if vector? arg then transferPropsToNode(getUnname arg,arg) - if m := isType(arg) then - m := conceptualType m - else if not (m := getMode arg) then [m] := bottomUp arg - t := conceptualType m -- ??? shall we reveal more impl. details? - putValue(op, objNew(m,t)) - putModeSet(op,[t]) - ---% Handler for where - -upwhere t == - -- upwhere does the puts in where into a local environment - t isnt [op,tree,clause] => NIL - -- since the "clause" might be a local macro, we now call mkAtree - -- on the "tree" part (it is not yet a vat) - not $genValue => - compFailure [:bright '" where", - '"for compiled code is not yet implemented."] - $whereCacheList : local := nil - [env,:e] := upwhereClause(clause,$env,$e) - tree := upwhereMkAtree(tree,env,e) - if x := getAtree(op,'dollar) then - atom tree => throwKeyedMsg("S2IS0048",NIL) - putAtree(first tree,'dollar,x) - upwhereMain(tree,env,e) - val := getValue tree - putValue(op,val) - result := putModeSet(op,getModeSet tree) - wcl := [op for op in $whereCacheList] - for op in wcl repeat clearDependencies(op,'T) - result - -upwhereClause(tree,env,e) == - -- uses the variable bindings from env and e and returns an environment - -- of its own bindings - $env: local := copyHack env - $e: local := copyHack e - bottomUp tree - [$env,:$e] - -upwhereMkAtree(tree,$env,$e) == mkAtree tree - -upwhereMain(tree,$env,$e) == - -- uses local copies of $env and $e while evaluating tree - bottomUp tree - -copyHack(env) == - -- makes a copy of an environment with the exception of pairs - -- (localModemap . something) - c:= CAAR env - d:= [fn p for p in c] where fn(p) == - [first p,:[(q is ["localModemap",:.] => q; copy q) for q in rest p]] - [[d]] - - ---% Case patterns - -up%Match t == - sorry '"case pattern" - - ---% importing domains -up%Import t == - t isnt [.,:types] => nil - -- ??? shall we error in case types is nil? - for x in types repeat - $e := addDomain(devaluate objVal getValue x,$e) - setValueToVoid t - ---% Macro handling - --- Well, in fact we never handle macros in the interpreter directly. --- Rather, they are saved in the `macro processing phase' (phMacro) --- to be used in future macro expansions, and the AST we get at this --- point already went through the macro expansion massage. So, all we --- have to do is to the rubber stamp. -up%Macro t == - setValueToVoid t - -up%MLambda t == - setValueToVoid t - - ---% Sorry for unhandled input constructs -sorry kind == - throwKeyedMsg("S2IP0006",[kind]) - ---% Export -up%Export t == - sorry '"export declaration" - ---% Inline -up%Inline t == - sorry '"inline declaration" - ---% Category -up%With t == - sorry '"category definition" - ---% Domain -up%Add t == - sorry '"domain definition" - --- Creates the function names of the special function handlers and puts --- them on the property list of the function name - -for name in $specialOps repeat - functionName:=INTERNL('up,name) - property(name,'up) := functionName - diff --git a/src/interp/i-special.boot b/src/interp/i-special.boot new file mode 100644 index 00000000..6eb04e47 --- /dev/null +++ b/src/interp/i-special.boot @@ -0,0 +1,2465 @@ +-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007-2011, 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 +namespace 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 + _[_|_|_] %Macro %MLambda %Import %Export %Inline %With %Add %Match) + +$repeatLabel := NIL +$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 := second 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 := [rest v for v in sublist] + + for m in rest 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,first 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 symbolName $mapName + body := substitute(["%dynval",MKQ minivectorName],"$$$",body) + setDynamicBinding(minivectorName,LIST2VEC $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 + parms := [:vars,"envArg"] + if not $definingMap and ($genValue or $compilingMap) then + code := wrap compileInteractive [$mapName,["LAMBDA",parms,body]] + else + $freeVariables: local := [] + $boundVariables: local := [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",parms,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(third 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 := makeSymbol 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 vector? 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) + putCallInfo(term1,"and",1,2) + putTarget(term2,$Boolean) + putCallInfo(term2,"and",2,2) + ms := bottomUp term1 + ms isnt [=$Boolean] => nil -- use general modemap + $genValue => + -- ??? we should find a way to check whether the + -- ??? the type of the second operand matters or not. + not objValUnwrap(getValue term1) => -- first operand is `false' + 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 -- use general modemap + -- 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) + putCallInfo(term1,"or",1,2) + putTarget(term2,$Boolean) + putCallInfo(term2,"or",2,2) + ms := bottomUp term1 + ms isnt [=$Boolean] => nil + $genValue => + objValUnwrap(getValue term1) => -- first operand is true, we are done. + 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]) + t.rest.rest := [r] -- fix up contained for rhs. + nil -- tell bottomUp to continue. + +upcase t == + t isnt [op,lhs,rhs] => nil + putCallInfo(lhs,"case",1,2) + 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 false + code := + ['%when, + [["EQL",rhstag,["CAR",["unwrap",objVal triple]]], + true], + ['%otherwise,false]] + else + $genValue => + t' := coerceUnion2Branch triple + rhs = objMode t' => code := wrap true + code := wrap false + triple' := objNewCode(["wrap",objVal triple],objMode triple) + code := + ['%when, + [["EQUAL",MKQ rhs,["objMode",['coerceUnion2Branch,triple']]], + true], + ['%otherwise,false]] + 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 + cons? 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) + $iteratorVars: local := nil + 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)) => + iter.first := '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 + + not 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] + iter.first := first newIter + iter.rest := rest newIter + + iterMs isnt [['List,ud]] => throwKeyedMsg("S2IS0006",[index]) + put(index,'mode,ud,$env) + mkIteratorVariable index + +upLoopIterSTEP(index,lower,step,upperList) == + not 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 removeDuplicates types + put(index,'mode,type,$env) + mkIteratorVariable index + +evalCOLLECT(op,[:itrl,body],m) == + iters := [evalLoopIter itr for itr in itrl] + bod := getArgValue(body,computedMode body) + if bod isnt ['SPADCALL,:.] then bod := ['unwrap,bod] + code := timedOptimization asTupleNewCode0(second m, ['%collect,:iters,bod]) + putValue(op,object(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(getVMType t, #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] + iter.first := first newIter + iter.rest := rest newIter + + (iterMs isnt [['List,ud]]) and (iterMs isnt [['Stream,ud]]) + and (iterMs isnt [['InfinitTuple, ud]]) => + throwKeyedMsg("S2IS0006",[index]) + put(index,'mode,ud,$env) + mkIteratorVariable 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) + mkIteratorVariable 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(first $indexVars,body) + 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) + s := [mkAtreeNode fun,predVec,s] + iter is ['UNTIL,pred] => + fun := 'filterUntil + predVec := mkIterFun(indSet,pred) + s := [mkAtreeNode fun,predVec,s] + iter is ['SUCHTHAT,pred] => + fun := 'select + putTarget(pred,$Boolean) + predVec := mkIterFun(indSet,pred) + s := [mkAtreeNode fun,predVec,s] + s + +mkIterFun([index,:s],funBody) == + -- 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] + -- Check generated code for free variables and pass them into the + -- lambda as part of envArg. Since only `index' is bound, every + -- other symbol in non-operator position is a free variable. + $freeVariables: local := [] + $boundVariables: local := [index] + body := checkForFreeVariables(objVal getValue funBody,"ALL") + parms := [index,"envArg"] + val:=['function,declareUnusedParameters ['LAMBDA,parms,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 + symbol? v => + v="$$$" => v -- Placeholder for mini-vector + MEMQ(v,$boundVariables) => v + p := POSITION(v,$freeVariables) => + ["getSimpleArrayEntry","envArg",positionInVec(p,#($freeVariables))] + (locals = "ALL") or MEMQ(v,locals) => + $freeVariables := [v,:$freeVariables] + ["getSimpleArrayEntry","envArg",positionInVec(0,#($freeVariables))] + v + LISTP v => + rest(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 in '(LAMBDA QUOTE getValueFromEnvironment) => v + op = "LETT" => -- Expands to a SETQ. + ["SETF",:[checkForFreeVariables(a,locals) for a in args]] + op in '(COLLECT REPEAT %collect %loop) => + first(args) is ["STEP",var,:.] => + $boundVariables := [var,:$boundVariables] + r := [op,:[checkForFreeVariables(a,locals) for a in args]] + $boundVariables := delete(var,$boundVariables) + r + [op,:[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) => + ["getSimpleArrayEntry","envArg",positionInVec(p,#($freeVariables))] + $freeVariables := [var,:$freeVariables] + ["getSimpleArrayEntry","envArg",positionInVec(0,#($freeVariables))] + ["SETF",newvar,checkForFreeVariables(form,locals)] + error "Non-simple variable bindings are not currently supported" + op in '(LET LET_* %bind) => + vars := [first init for init in first args] + inits := [checkInit(init,locals) for init in first args] where + checkInit([var,init],locals) == + init := checkForFreeVariables(init,locals) + $boundVariables := [var,:$boundVariables] + [var,init] + body := checkForFreeVariables(rest args,locals) + $boundVariables := setDifference($boundVariables,vars) + [op,inits,:body] + op = "PROG" => + error "Non-simple variable bindings are not currently supported" + [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 := second objMode getValue s1 + t2 := second 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 rest indexList + [[.,:s],:.] := indexList + t := second 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: local := [] + $boundVariables: local := [$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] + parms := [$index,'envArg] + val:=['function,declareUnusedParameters ['LAMBDA,parms,objVal body]] + vec := mkAtreeNode gensym() + putValue(vec,objNew(['CONS,val,["VECTOR",:reverse $freeVariables]],mapMode)) + vec + +subVecNodes(new,old,form) == + atom form => + (vector? form) and (form.0 = old) => new + form + [subVecNodes(new,old,first form), :subVecNodes(new,old,rest 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 cons?(tar) and not isPartialMode(tar) then + first(tar) in aggs => + ud := + (l is [[realOp, :.]]) and (getUnname(realOp) = 'COLLECT) => tar + second tar + for x in l repeat if not getTarget(x) then putTarget(x,ud) + first(tar) in '(Matrix SquareMatrix RectangularMatrix) => + vec := ['List,underDomainOf tar] + for x in l repeat if not getTarget(x) then putTarget(x,vec) + nargs := #l + argModeSetList:= [bottomUp putCallInfo(x,"construct",i,nargs) + for x in l for i in 1..] + 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 [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 := object(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 := object(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 := object(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 member($Symbol,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) => ['%list,:argCode] + (len = 2) => ['%pair,:argCode] + ['%vector,:argCode] + putValue(op,object(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) + getAtree(op,"callingFunction") => + -- This isn't a real declaration, rather a field specification. + not IDENTP lhs => throwKeyedMsg("S2IE0020",nil) + -- ??? When we come to support field spec as type, change this. + putValue(op,objNewWrap([":",lhs,mode],mode)) + putModeSet(op,[mode]) + 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 + validateVariableNameOrElse 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 + cons? margs => -1 + #margs + 1 + nargs ~= #args => throwKeyedMsg("S2IM0008",[var]) + if $compilingMap then mkLocalVar($mapName,var) + else clearDependencies(var,true) + isLocallyBound 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 + isLocallyBound 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 rest d for var in $FormalMapVariableList repeat + SL:= [[var,:e],:SL] + x := subCopy(x,SL) + SL:= NIL + for e in rest d for var in $TriangleVariableList repeat + SL:= [[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 _ + (cons?($env) and get(form,'value,$env)) or _ + (cons?($e) and get(form,'value,$e)))) and + (member(m := objMode(val),'((Domain) (Category))) + or conceptualType m = $Category) => + objValUnwrap(val) + nil + + +++ returns true if category form `c1' implies category form `c2'. +++ Both are assumed to be definite categories, i.e. they contain +++ no variables. +categoryImplies(c1,c2) == + c2 = $Type => true + c1 is ["Join",:cats] => + or/[categoryImplies(c,c2) for c in cats] => true + c1 = c2 + -- ??? Should also check conditional definition and + -- ??? possibly attributes + +++ returns true if domain `d' satisfies category `c'. +evalCategory(d,c) == + -- tests whether domain d has category c + isPartialMode d => true -- maybe too generous + -- If this is a local variable then, its declared type + -- must imply category `c' satisfaction. + IDENTP d and (m := getmode(d,$env)) => categoryImplies(m,c) + 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 + op in '(Polynomial RationalFunction AlgebraicFunction Expression + ElementaryFunction LiouvillianFunction FunctionalExpression + CombinatorialFunction) => 'all + op = 'UnivariatePolynomial => [a] + op = 'Variable => [a] + op in '(MultivariatePolynomial DistributedMultivariatePolynomial + HomogeneousDistributedMultivariatePolynomial) => a + NIL + NIL + +containsPolynomial m == + atom 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 == + atom 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 = first(l) => deleteAll(x,rest l) + [first l,:deleteAll(x,rest l)] + + +$iteratorVars := nil + +mkIteratorVariable id == + $iteratorVars := [id,:$iteratorVars] + -- mkLocalVar('"the iterator expression",id) + + +++ The `void' value object (an oxymoron). There really are constants. +$VoidValueObject := objNew(voidValue(), $Void) +$VoidCodeObject := objNew('(voidValue), $Void) + +setValueToVoid t == + putValue(t,$VoidValueObject) + putModeSet(t,[$Void]) + +setCodeToVoid t == + putValue(t,$VoidCodeObject) + putModeSet(t,[$Void]) + +++ Interpreter macros +$InterpreterMacroAlist == + '((%i . (complex 0 1)) + (%e . (exp 1)) + (%pi . (pi)) + (SF . (DoubleFloat)) + (%infinity . (infinity)) + (%plusInfinity . (plusInfinity)) + (%minusInfinity . (minusInfinity))) + + +-- Functions which require special handlers (also see end of file) + +--% Handlers for map definitions + +upDEF t == + -- performs map definitions. value is thrown away + t isnt [op,def,pred,.] => nil + v:=addDefMap(["DEF",:def],pred) + not(LISTP(def)) or null(def) => + keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) + mapOp := first def + if LISTP(mapOp) then + null mapOp => + keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) + mapOp := first mapOp + put(mapOp,"value",v,$e) + setValueToVoid op + +--% Handler for package calling and $ constants + +++ Return non-nil if `form' designate a constant defined in the +++ domain designated by `domainForm'. More specifically, returns: +++ nil: no such constant +++ <%Mode>: the type of the constant. +++ T: too many constants designated by `form'. +constantInDomain?(form,domainForm) == + opAlist := getConstructorOperationsFromDB domainForm.op + key := opOf form + entryList := [entry for (entry := [.,.,.,k]) in LASSOC(key,opAlist) + | k in '(CONST ASCONST)] + entryList is [[sig,.,.,.]] => sig.target + #entryList > 2 => true + key = "One" => constantInDomain?(["1"], domainForm) + key = "Zero" => constantInDomain?(["0"], domainForm) + nil + +++ Constant `c' of `type' is referenced from domain `d'; return its value +++ in the VAT `op'. +findConstantInDomain(op,c,type,d) == + isPartialMode d => throwKeyedMsg("S2IS0020",NIL) + val := + $genValue => wrap getConstantFromDomain([c],d) + ["getConstantFromDomain",["LIST",MKQ c],MKQ d] + type := substitute(d,"$",type) + putValue(op,objNew(val,type)) + putModeSet(op,[type]) + +upDollar t == + -- Puts "dollar" property in atree node, and calls bottom up + t isnt [op,D,form] => nil + t2 := t + (not $genValue) and "or"/[CONTAINED(var,D) for var in $localVars] => + keyedMsgCompFailure("S2IS0032",NIL) + D="Lisp" => upLispCall(op,form) + if vector? D and (# D > 0) then D := D.0 + t := evaluateType unabbrev D + categoryForm? t => + throwKeyedMsg("S2IE0012", [t]) + f := getUnname form + if f = $immediateDataSymbol then + f := objValUnwrap coerceInteractive(getValue form,$OutputForm) + if f = '(construct) then f := "nil" + atom form and (f ~= $immediateDataSymbol) => + type := constantInDomain?([f],t) => + type ~= true => findConstantInDomain(op,f,type,t) + -- Ambiguous constant. FIXME: try to narrow before giving up. + throwKeyedMsg("S2IB0008h",[f,t]) + findUniqueOpInDomain(op,f,t) + + nargs := #rest form + + (ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms + + f ~= "construct" and null isOpInDomain(f,t,nargs) => + throwKeyedMsg("S2IS0023",[f,t]) + if (sig := findCommonSigInDomain(f,t,nargs)) then + for x in sig for y in form repeat + if x then putTarget(y,x) + putAtree(first form,"dollar",t) + ms := bottomUp form + f in '(One Zero) and cons? (ms) and first(ms) = $OutputForm => + throwKeyedMsg("S2IS0021",[f,t]) + putValue(op,getValue first form) + putModeSet(op,ms) + + +upDollarTuple(op, f, t, t2, args, nargs) == + -- this function tries to find a tuple function to use + -- nargs = 1 and getUnname first args = "Tuple" => NIL + -- nargs = 1 and (ms := bottomUp first args) and ms is [["Tuple",.]] => NIL + null (singles := isOpInDomain(f,t,1)) => NIL + tuple := NIL + for [[.,arg], :.] in singles while null tuple repeat + if arg is ['Tuple,.] then tuple := arg + null tuple => NIL + [.,D,form] := t2 + newArg := [mkAtreeNode "tuple",:args] + putTarget(newArg, tuple) + ms := bottomUp newArg + first ms ~= tuple => NIL + form := [first form, newArg] + putAtree(first form,"dollar",t) + ms := bottomUp form + putValue(op,getValue first form) + putModeSet(op,ms) + +upLispCall(op,t) == + -- process $Lisp calls + if atom t then code:=getUnname t else + [lispOp,:argl]:= t + null functionp lispOp.0 => + throwKeyedMsg("S2IS0024",[lispOp.0]) + for arg in argl repeat bottomUp arg + code:=[getUnname lispOp, + :[getArgValue(arg,computedMode arg) for arg in argl]] + rt := '(SExpression) + putValue(op,object(code,rt)) + putModeSet(op,[rt]) + +--% Handlers for equation + +upequation tree == + -- only handle this if there is a target of Boolean + -- this should speed things up a bit + tree isnt [op,lhs,rhs] => NIL + $Boolean ~= getTarget(op) => NIL + not vector? op => NIL + -- change equation into '=' + op.0 := "=" + bottomUp tree + +--% Handler for error + +uperror t == + -- when compiling a function, this merely inserts another argument + -- which is the name of the function. + not $compilingMap => NIL + t isnt [op,msg] => NIL + msgMs := bottomUp putCallInfo(msg,"error",1,1) + msgMs isnt [=$String] => NIL + t.rest := [mkAtree object2String $mapName,msg] + bottomUp t + +--% Handlers for free and local + +upfree t == + setCodeToVoid t + +uplocal t == + setCodeToVoid t + +upfreeWithType(var,type) == + sayKeyedMsg("S2IS0055",['"free",var]) + var + +uplocalWithType(var,type) == + sayKeyedMsg("S2IS0055",['"local",var]) + var + +--% Handlers for has + +uphas t == + t isnt [op,type,prop] => nil + -- handler for category and attribute queries + type := + x := elaborateForm type + getModeSet x is [m] and (conceptualType m = $Type or categoryForm? m) => + val := objValUnwrap getValue x + $genValue => MKQ val + ["devaluate",val] + throwKeyedMsg("S2IE0021",[type]) + catCode := + -- FIXME: when we come to support category valued variable + -- this code needs to be adapted. + prop := unabbrev prop + evaluateType0 prop => ["evaluateType", MKQ prop] + MKQ prop + code := ["NOT",["NULL",["newHasTest",type, catCode]]] + putValue(op,object(code,$Boolean)) + putModeSet(op,[$Boolean]) + +--hasTest(a,b) == +-- newHasTest(a,b) --see NRUNFAST BOOT + +--% Handlers for IF + +upIF t == + t isnt [op,cond,a,b] => nil + bottomUpPredicate(cond,'"if/when") + $genValue => interpIF(op,cond,a,b) + compileIF(op,cond,a,b,t) + +compileIF(op,cond,a,b,t) == + -- type analyzer for compiled case where types of both branches of + -- IF are resolved. + ms1 := bottomUp a + [m1] := ms1 + b = "%noBranch" => + evalIF(op,rest t,$Void) + putModeSet(op,[$Void]) + b = "%noMapVal" => + -- if this was a return statement, we take the mode to be that + -- of what is being returned. + if getUnname a = 'return then + ms1 := bottomUp second a + [m1] := ms1 + evalIF(op,rest t,m1) + putModeSet(op,ms1) + ms2 := bottomUp b + [m2] := ms2 + m:= + m2=m1 => m1 + m2 = $Exit => m1 + m1 = $Exit => m2 + if m1 = $Symbol then + m1:=getMinimalVarMode(getUnname a,$declaredMode) + if m2 = $Symbol then + m2:=getMinimalVarMode(getUnname b,$declaredMode) + (r := resolveTTAny(m2,m1)) => r + rempropI($mapName,'localModemap) + rempropI($mapName,'localVars) + rempropI($mapName,'mapBody) + throwKeyedMsg("S2IS0026",[m2,m1]) + evalIF(op,rest t,m) + putModeSet(op,[m]) + +evalIF(op,[cond,a,b],m) == + -- generate code form compiled IF + elseCode:= + b="%noMapVal" => + [[MKQ true, ["throwKeyedMsg",MKQ "S2IM0018", + ["CONS",MKQ object2Identifier $mapName,NIL]]]] + b='%noBranch => + $lastLineInSEQ => [[MKQ true,["voidValue"]]] + NIL + [[MKQ true,genIFvalCode(b,m)]] + code:=['%when,[getArgValue(cond,$Boolean), + genIFvalCode(a,m)],:elseCode] + triple:= objNew(code,m) + putValue(op,triple) + +genIFvalCode(t,m) == + -- passes type information down braches of IF statement + -- So that coercions can be performed on data at branches of IF. + m1 := computedMode t + m1=m => getArgValue(t,m) + code:=objVal getValue t + IFcodeTran(code,m,m1) + +IFcodeTran(code,m,m1) == + -- coerces values at branches of IF + null code => code + code is ["spadThrowBrightly",:.] => code + m1 = $Exit => code + code isnt ['%when,[p1,a1],['%otherwise,a2]] => + m = $Void => code + code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) => + getValueNormalForm code' + throwKeyedMsgCannotCoerceWithValue(quote2Wrapped code,m1,m) + a1:=IFcodeTran(a1,m,m1) + a2:=IFcodeTran(a2,m,m1) + ['%when,[p1,a1],['%otherwise,a2]] + +interpIF(op,cond,a,b) == + -- non-compiled version of IF type analyzer. Doesn't resolve accross + -- branches of the IF. + val:= getValue cond + val:= coerceInteractive(val,$Boolean) => + objValUnwrap(val) => upIFgenValue(op,a) + b="%noBranch" => setValueToVoid op + upIFgenValue(op,b) + throwKeyedMsg("S2IS0031",NIL) + +upIFgenValue(op,tree) == + -- evaluates tree and transfers the results to op + ms:=bottomUp tree + val:= getValue tree + putValue(op,val) + putModeSet(op,ms) + +--% Handlers for is + +upis t == + t isnt [op,a,pattern] => nil + $opIsIs : local := true + upisAndIsnt t + +upisnt t == + t isnt [op,a,pattern] => nil + $opIsIs : local := nil + upisAndIsnt t + +upisAndIsnt(t:=[op,a,pattern]) == + -- handler for "is" pattern matching + mS:= bottomUp a + mS isnt [m] => + keyedSystemError("S2GE0016",['"upisAndIsnt",'"non-unique modeset"]) + putPvarModes(removeConstruct pattern,m) + evalis(op,rest t,m) + putModeSet(op,[$Boolean]) + +putPvarModes(pattern,m) == + -- Puts the modes for the pattern variables into $env + m isnt ["List",um] => throwKeyedMsg("S2IS0030",NIL) + for pvar in pattern repeat + IDENTP pvar => (not (pvar=$quadSymbol)) and put(pvar,'mode,um,$env) + pvar is ['_:,var] => + null (var=$quadSymbol) and put(var,"mode",m,$env) + pvar is ['_=,var] => + null (var=$quadSymbol) and put(var,"mode",um,$env) + putPvarModes(pvar,um) + +evalis(op,[a,pattern],mode) == + -- actually handles is and isnt + if $opIsIs + then fun := 'evalIsPredicate + else fun := 'evalIsntPredicate + if isLocalPred pattern then + code:= compileIs(a,pattern) + else code:=[fun,getArgValue(a,mode), + MKQ pattern,MKQ mode] + triple := object(code,$Boolean) + putValue(op,triple) + +isLocalPred pattern == + -- returns true if this predicate is to be compiled + for pat in pattern repeat + IDENTP pat and isLocallyBound pat => return true + pat is [":",var] and isLocallyBound var => return true + pat is ["=",var] and isLocallyBound var => return true + +compileIs(val,pattern) == + -- produce code for compiled "is" predicate. makes pattern variables + -- into local variables of the function + vars:= NIL + for pat in rest pattern repeat + IDENTP(pat) and isLocallyBound pat => vars:=[pat,:vars] + pat is [":",var] => vars:= [var,:vars] + pat is ["=",var] => vars:= [var,:vars] + predCode:=["%LET",g:=gensym(),["isPatternMatch", + getArgValue(val,computedMode val),MKQ removeConstruct pattern]] + for var in removeDuplicates vars repeat + assignCode:=[["%LET",var,["CDR",["ASSQ",MKQ var,g]]],:assignCode] + null $opIsIs => + ['%when,[["EQ",predCode,MKQ "failed"],["SEQ",:assignCode,'%true]]] + ['%when,[['%not,["EQ",predCode,MKQ "failed"]],["SEQ",:assignCode,'%true]]] + +evalIsPredicate(value,pattern,mode) == + --This function pattern matches value to pattern, and returns + --true if it matches, and false otherwise. As a side effect + --if the pattern matches then the bindings given in the pattern + --are made + pattern:= removeConstruct pattern + not ((valueAlist:=isPatternMatch(value,pattern))='failed) => + for [id,:value] in valueAlist repeat + evalLETchangeValue(id,objNewWrap(value,get(id,'mode,$env))) + true + false + +evalIsntPredicate(value,pattern,mode) == + evalIsPredicate(value,pattern,mode) => false + true + +removeConstruct pat == + -- removes the "construct" from the beginning of patterns + if pat is ["construct",:p] then pat:=p + if pat is ["cons", a, b] then pat := [a, [":", b]] + atom pat => pat + pat.first := removeConstruct first pat + pat.rest := removeConstruct rest pat + pat + +isPatternMatch(l,pats) == + -- perform the actual pattern match + $subs: local := NIL + isPatMatch(l,pats) + $subs + +isPatMatch(l,pats) == + null pats => + null l => $subs + $subs:='failed + null l => + null pats => $subs + pats is [[":",var]] => + $subs := [[var],:$subs] + $subs:='failed + pats is [pat,:restPats] => + IDENTP pat => + $subs:=[[pat,:first l],:$subs] + isPatMatch(rest l,restPats) + pat is ["=",var] => + p:=ASSQ(var,$subs) => + first l = rest p => isPatMatch(rest l, restPats) + $subs:="failed" + $subs:="failed" + pat is [":",var] => + n:=#restPats + m:=#l-n + m<0 => $subs:="failed" + ZEROP n => $subs:=[[var,:l],:$subs] + $subs:=[[var,:[x for x in l for i in 1..m]],:$subs] + isPatMatch(DROP(m,l),restPats) + isPatMatch(first l,pat) = "failed" => "failed" + isPatMatch(rest l,restPats) + keyedSystemError("S2GE0016",['"isPatMatch", + '"unknown form of is predicate"]) + +--% Handler for iterate + +upiterate t == + null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"]) + $iterateCount := $iterateCount + 1 + code := ["THROW",$repeatBodyLabel,'(voidValue)] + $genValue => THROW(eval $repeatBodyLabel,voidValue()) + putValue(t,objNew(code,$Void)) + putModeSet(t,[$Void]) + +--% Handler for break + +upbreak t == + t isnt [op,.] => nil + null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"]) + $breakCount := $breakCount + 1 + code := ["THROW",$repeatLabel,'(voidValue)] + $genValue => THROW(eval $repeatLabel,voidValue()) + putValue(op,objNew(code,$Void)) + putModeSet(op,[$Void]) + +--% Handlers for %LET + +up%LET t == + -- analyzes and evaluates the righthand side, and does the variable + -- binding + t isnt [op,lhs,rhs] => nil + $declaredMode: local := NIL + cons? lhs => + var:= getUnname first lhs + var = "construct" => upLETWithPatternOnLhs t + var = "QUOTE" => throwKeyedMsg("S2IS0027",['"A quoted form"]) + upLETWithFormOnLhs(op,lhs,rhs) + var:= getUnname lhs + var = $immediateDataSymbol => + -- following will be immediate data, so probably ok to not + -- specially format it + obj := objValUnwrap coerceInteractive(getValue lhs,$OutputForm) + throwKeyedMsg("S2IS0027",[obj]) + var in '(% %%) => -- for history + throwKeyedMsg("S2IS0027",[var]) + (IDENTP var) and not (var in '(true false elt QUOTE)) => + var ~= (var' := unabbrev(var)) => -- constructor abbreviation + throwKeyedMsg("S2IS0028",[var,var']) + if get(var,'isInterpreterFunction,$e) then + putHist(var,'isInterpreterFunction,false,$e) + sayKeyedMsg("S2IS0049",['"Function",var]) + else if get(var,'isInterpreterRule,$e) then + putHist(var,'isInterpreterRule,false,$e) + sayKeyedMsg("S2IS0049",['"Rule",var]) + (m := isType rhs) => upLETtype(op,lhs,m) + transferPropsToNode(var,lhs) + if ( m:= getMode(lhs) ) then + $declaredMode := m + putTarget(rhs,m) + if (val := getValue lhs) and (objMode val = $Boolean) and + getUnname(rhs) = 'equation then putTarget(rhs,$Boolean) + (rhsMs:= bottomUp rhs) = [$Void] => + throwKeyedMsg("S2IS0034",[var]) + val:=evalLET(lhs,rhs) + putValue(op,val) + putModeSet(op,[objMode(val)]) + throwKeyedMsg("S2IS0027",[var]) + +evalLET(lhs,rhs) == + -- lhs is a vector for a variable, and rhs is the evaluated atree + -- for the value which is coerced to the mode of lhs + $useConvertForCoercions: local := true + v' := (v:= getValue rhs) + ((not getMode lhs) and (getModeSet rhs is [.])) or + get(getUnname lhs,'autoDeclare,$env) => + v:= + $genValue => v + objNew(getValueNormalForm v,objMode v) + evalLETput(lhs,v) + t1:= objMode v + t2' := (t2 := getMode lhs) + value:= + t1 = t2 => + $genValue => v + objNew(getValueNormalForm v,objMode v) + if isPartialMode t2 then + if t1 = $Symbol and $declaredMode then + t1:= getMinimalVarMode(objValUnwrap v,$declaredMode) + t' := t2 + null (t2 := resolveTM(t1,t2)) => + if not t2 then t2 := t' + throwKeyedMsg("S2IS0035",[t1,t2]) + null (v := getArgValue(rhs,t2)) => + isWrapped(objVal v') and (v2:=coerceInteractive(v',$OutputForm)) => + throwKeyedMsg("S2IS0036",[objValUnwrap v2,t2]) + throwKeyedMsg("S2IS0037",[t2]) + t2 and object(v,t2) + value => evalLETput(lhs,value) + throwKeyedMsgCannotCoerceWithValue(objVal v,t1,getMode lhs) + +evalLETput(lhs,value) == + -- put value into the cell for lhs + name:= getUnname lhs + if not $genValue then + code:= + isLocallyBound name => + om := objMode(value) + dm := get(name,'mode,$env) + dm and not ((om = dm) or isSubDomain(om,dm) or + isSubDomain(dm,om)) => + compFailure ['" The type of the local variable", + :bright name,'"has changed in the computation."] + if dm and isSubDomain(dm,om) then put(name,'mode,om,$env) + ["%LET",name,objVal value,$mapName] + -- $mapName is set in analyzeMap + om := objMode value + dm := get(name, 'mode, $env) or objMode(get(name, 'value, $e)) + dm and (null $compilingMap) and not(om = dm) and not(isSubDomain(om, dm)) => + THROW('loopCompiler,'tryInterpOnly) + ['unwrap,['evalLETchangeValue,MKQ name, + objNewCode(['wrap,objVal value],objMode value)]] + value:= objNew(code,objMode value) + isLocallyBound name => + if not get(name,'mode,$env) then put(name,'autoDeclare,'T,$env) + put(name,'mode,objMode(value),$env) + put(name,'automode,objMode(value),$env) + $genValue and evalLETchangeValue(name,value) + putValue(lhs,value) + +upLETWithPatternOnLhs(t := [op,pattern,a]) == + $opIsIs : local := true + [m] := bottomUp a + putPvarModes(pattern,m) + object := evalis(op,[a,pattern],m) + -- have to change code to return value of a + failCode := + ['spadThrowBrightly,['concat, + '" Pattern",['QUOTE,bright form2String pattern], + '"is not matched in assignment to right-hand side."]] + if $genValue + then + null objValUnwrap object => eval failCode + putValue(op,getValue a) + else + code := ['%when,[objVal object,objVal getValue a],['%otherwise,failCode]] + putValue(op,objNew(code,m)) + putModeSet(op,[m]) + +evalLETchangeValue(name,value) == + -- write the value of name into the environment, clearing dependent + -- maps if its type changes from its last value + localEnv := cons? $env + clearCompilationsFlag := + val:= (localEnv and get(name,'value,$env)) or get(name,'value,$e) + null val => + not ((localEnv and get(name,'mode,$env)) or get(name,'mode,$e)) + objMode val ~= objMode(value) + if clearCompilationsFlag then + clearDependencies(name,true) + if localEnv and isLocallyBound name + then $env:= putHist(name,'value,value,$env) + else putIntSymTab(name,'value,value,$e) + objVal value + +upLETWithFormOnLhs(op,lhs,rhs) == + -- bottomUp for assignment to forms (setelt, table or tuple) + lhs' := getUnnameIfCan lhs + rhs' := getUnnameIfCan rhs + lhs' = "tuple" => + rhs' ~= "tuple" => throwKeyedMsg("S2IS0039",NIL) + #(lhs) ~= #(rhs) => throwKeyedMsg("S2IS0038",NIL) + -- generate a sequence of assignments, using local variables + -- to first hold the assignments so that things like + -- (t1,t2) := (t2,t1) will work. + seq := [] + temps := [gensym() for l in rest lhs] + for lvar in temps repeat mkLocalVar($mapName,lvar) + for l in reverse rest lhs for t in temps repeat + transferPropsToNode(getUnname l,l) + let := mkAtreeNode "%LET" + t' := mkAtreeNode t + if m := getMode(l) then putMode(t',m) + seq := [[let,l,t'],:seq] + for t in temps for r in reverse rest rhs + for l in reverse rest lhs repeat + let := mkAtreeNode "%LET" + t' := mkAtreeNode t + if m := getMode(l) then putMode(t',m) + seq := [[let,t',r],:seq] + seq := [mkAtreeNode 'SEQ,:seq] + ms := bottomUp seq + putValue(op,getValue seq) + putModeSet(op,ms) + rhs' = "tuple" => throwKeyedMsg("S2IS0039",NIL) + tree:= seteltable(lhs,rhs) => upSetelt(op,lhs,tree) + throwKeyedMsg("S2IS0060", NIL) +-- upTableSetelt(op,lhs,rhs) + +seteltable(lhs is [f,:argl],rhs) == + -- produces the setelt form for trees such as "l.2:= 3" + null (g := getUnnameIfCan f) => NIL + g="elt" => altSeteltable [:argl, rhs] + get(g,'value,$e) is [expr,:.] and isMapExpr expr => NIL + transferPropsToNode(g,f) + getValue(lhs) or getMode(lhs) => + f is [f',:argl'] => altSeteltable [f',:argl',:argl,rhs] + altSeteltable [:lhs,rhs] + NIL + +altSeteltable args == + for x in args repeat bottomUp x + newOps := [mkAtreeNode "setelt", mkAtreeNode "set!"] + form := NIL + + -- first look for exact matches for any of the possibilities + while null form for newOp in newOps repeat + if selectMms(newOp, args, NIL) then form := [newOp, :args] + + -- now try retracting arguments after the first + while null form and ( "and"/[retractAtree(a) for a in rest args] ) repeat + while null form for newOp in newOps repeat + if selectMms(newOp, args, NIL) then form := [newOp, :args] + + form + + +upSetelt(op,lhs,tree) == + -- type analyzes implicit setelt forms + var:=opOf lhs + transferPropsToNode(getUnname var,var) + if (m1:=getMode var) then $declaredMode:= m1 + if m1 or ((v1 := getValue var) and (m1 := objMode v1)) then + putModeSet(var,[m1]) + ms := bottomUp tree + putValue(op,getValue tree) + putModeSet(op,ms) + +upTableSetelt(op,lhs is [htOp,:args],rhs) == + -- called only for undeclared, uninitialized table setelts + ("*" = (PNAME getUnname htOp).0) and (1 ~= # args) => + throwKeyedMsg("S2IS0040",NIL) + # args ~= 1 => + throwKeyedMsg("S2IS0041",[[getUnname htOp,'".[", + getUnname first args, + ['",",getUnname arg for arg in rest args],'"]"]]) + keyMode := $Any + putMode (htOp,['Table,keyMode,$Any]) + -- if we are to use a new table, we must call the "table" + -- function to give it an initial value. + bottomUp [mkAtreeNode "%LET",htOp,[mkAtreeNode 'table]] + tableCode := objVal getValue htOp + r := upSetelt(op, lhs, [mkAtreeNode "setelt",:lhs,rhs]) + $genValue => r + -- construct code + t := getValue op + putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t)) + r + +unVectorize body == + -- transforms from an atree back into a tree + vector? body => + name := getUnname body + name ~= $immediateDataSymbol => name + objValUnwrap getValue body + atom body => body + body is [op,:argl] => + newOp:=unVectorize op + if newOp = 'SUCHTHAT then newOp := "|" + if newOp = 'COERCE then newOp := "::" + if newOp = 'Dollar then newOp := "$elt" + [newOp,:unVectorize argl] + systemErrorHere ["unVectorize",body] + +isType t == + -- Returns the evaluated type if t is a tree representing a type, + -- and NIL otherwise + op:=opOf t + vector? op => + isMap(op:= getUnname op) => NIL + op = 'Mapping and cons? t => + argTypes := [isType type for type in rest t] + "or"/[null type for type in argTypes] => nil + ['Mapping, :argTypes] + isLocallyBound op => NIL + d := isDomainValuedVariable op => d + type:= + -- next line handles subscripted vars + (abbreviation?(op) or (op = 'typeOf) or + constructor?(op) or (op in '(Record Union Enumeration))) and + unabbrev unVectorize t + type and evaluateType type + d := isDomainValuedVariable op => d + NIL + +upLETtype(op,lhs,type) == + -- performs type assignment + opName:= getUnname lhs + (not $genValue) and "or"/[CONTAINED(var,type) for var in $localVars] => + compFailure ['" Cannot compile type assignment to",:bright opName] + mode := conceptualType type + val:= objNew(type,mode) + if isLocallyBound opName then put(opName,'value,val,$env) + else putHist(opName,'value,val,$e) + putValue(op,val) + -- have to fix the following + putModeSet(op,[mode]) + +assignSymbol(symbol, value, domain) == +-- Special function for binding an interpreter variable from within algebra +-- code. Does not do the assignment and returns nil, if the variable is +-- already assigned + val := get(symbol, 'value, $e) => nil + obj := objNew(wrap value, devaluate domain) + put(symbol, 'value, obj, $e) + true + +--% Handler for Interpreter Macros + +getInterpMacroNames() == + names := [n for [n,:.] in $InterpreterMacroAlist] + if (e := CAAR $InteractiveFrame) and (m := assoc("--macros--",e)) then + names := append(names,[n for [n,:.] in rest m]) + MSORT names + +isInterpMacro name == + -- look in local and then global environment for a macro + not IDENTP name => NIL + name in $specialOps => NIL + (m := get("--macros--",name,$env)) => m + (m := get("--macros--",name,$e)) => m + (m := get("--macros--",name,$InteractiveFrame)) => m + -- $InterpreterMacroAlist will probably be phased out soon + (sv := assoc(name,$InterpreterMacroAlist)) => [NIL,:rest sv] + NIL + +--% Handlers for prefix QUOTE + +upQUOTE t == + t isnt [op,expr] => NIL + ms:= list + m:= getBasicMode expr => m + IDENTP expr => +-- $useSymbolNotVariable => $Symbol + getTarget t = $Identifier => $Identifier + ['Variable,expr] + $InputForm + evalQUOTE(op,[expr],ms) + putModeSet(op,ms) + +evalQUOTE(op,[expr],[m]) == + triple:= + $genValue => objNewWrap(expr,m) + objNew(['QUOTE,expr],m) + putValue(op,triple) + +--% Quasiquotation +up_[_|_|_] t == + t isnt [op, x] => nil + mode := getTypeOfSyntax x + putValue(op, objNewWrap(x, mode)) + putModeSet(op, [mode]) + +--% Handler for pretend + +uppretend t == + t isnt [op,expr,type] => NIL + mode := evaluateType unabbrev type + not isValidType(mode) => throwKeyedMsg("S2IE0004",[mode]) + bottomUp expr + putValue(op,objNew(objVal getValue expr,mode)) + putModeSet(op,[mode]) + +--% Handlers for REDUCE + +getReduceFunction(op,type,result, locale) == + -- return the function cell for operation with the signature + -- (type,type) -> type, possible from locale + if type is ['Variable,var] then + args := [arg := mkAtreeNode var,arg] + putValue(arg,objNewWrap(var,type)) + else + args := [arg := mkAtreeNode "%1",arg] + if type=$Symbol then putValue(arg,objNewWrap("%1",$Symbol)) + putModeSet(arg,[type]) + vecOp:=mkAtreeNode op + transferPropsToNode(op,vecOp) + if locale then putAtree(vecOp,'dollar,locale) + mmS:= selectMms(vecOp,args,result) + mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS | + (isHomogeneousArgs sig) and "and"/[null c for c in cond]] + null mm => 'failed + [[dc,:sig],fun,:.]:=mm + dc='local => [MKQ [fun,:'local],:first sig] + dcVector := evalDomain dc + $compilingMap => + k := NRTgetMinivectorIndex( + NRTcompiledLookup(op,sig,dcVector),op,sig,dcVector) + ['ELT,"$$$",k] --$$$ denotes minivector + env:= + NRTcompiledLookup(op,sig,dcVector) + MKQ env + +isHomogeneous sig == + --return true if sig describes a homogeneous binary operation + sig.0=sig.1 and sig.1=sig.2 + +isHomogeneousArgs sig == + --return true if sig describes a homogeneous binary operation + sig.1=sig.2 + +--% Handlers for REPEAT + +transformREPEAT [:itrl,body] == + -- syntactic transformation of repeat iterators, called from mkAtree2 + 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 VALUE)) => + [[op,mkAtree1 b]] + it is ['_|,pred] => nil + keyedSystemError("S2GE0016", + ['"transformREPEAT",'"Unknown type of iterator"]) + [:iterList,bodyTree] + +upREPEAT t == + -- REPEATS always return void() of Void + -- assures throw to interpret-code mode goes to outermost loop + $repeatLabel : local := MKQ gensym() + $breakCount : local := 0 + $repeatBodyLabel : local := MKQ gensym() + $iterateCount : local := 0 + $compilingLoop => upREPEAT1 t + upREPEAT0 t + +upREPEAT0 t == + -- sets up catch point for interp-only mode + $compilingLoop: local := true + ms := CATCH('loopCompiler,upREPEAT1 t) + ms = 'tryInterpOnly => interpOnlyREPEAT t + ms + +upREPEAT1 t == + -- repeat loop handler with compiled body + -- see if it has the expected form + t isnt [op,:itrl,body] => NIL + -- determine the mode of the repeat loop. At the moment, if there + -- there are no iterators and there are no "break" statements, then + -- the return type is Exit, otherwise Void. + repeatMode := + null(itrl) and ($breakCount=0) => $Void + $Void + + -- if interpreting, go do that + $interpOnly => interpREPEAT(op,itrl,body,repeatMode) + + -- analyze iterators and loop body + $iteratorVars: local := nil + upLoopIters itrl + bottomUpCompile body + + -- now that the body is analyzed, we should know everything that + -- is in the UNTIL clause + for itr in itrl repeat + itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until") + + -- now go do it + evalREPEAT(op,rest t,repeatMode) + putModeSet(op,[repeatMode]) + +evalREPEAT(op,[:itrl,body],repeatMode) == + -- generate code for loop + bodyMode := computedMode body + bodyCode := getArgValue(body,bodyMode) + if $iterateCount > 0 then + bodyCode := ["CATCH",$repeatBodyLabel,bodyCode] + code := ['%loop,:[evalLoopIter itr for itr in itrl],bodyCode,voidValue()] + code := timedOptimization code + if $breakCount > 0 then code := ['CATCH,$repeatLabel,code] + val := + $genValue => + timedEVALFUN code + objNewWrap(voidValue(),repeatMode) + objNew(code,repeatMode) + putValue(op,val) + +interpOnlyREPEAT t == + -- interpret-code mode call to upREPEAT + $genValue: local := true + $interpOnly: local := true + upREPEAT1 t + +interpREPEAT(op,itrl,body,repeatMode) == + -- performs interpret-code repeat + $indexVars: local := NIL + $indexTypes: local := NIL + code := + -- we must insert a CATCH for the iterate clause + ['%loop,:[interpIter itr for itr in itrl], + ["CATCH",$repeatBodyLabel,interpLoop(body,$indexVars, + $indexTypes,nil)],voidValue()] + SPADCATCH(eval $repeatLabel,timedEVALFUN code) + val:= objNewWrap(voidValue(),repeatMode) + putValue(op,val) + putModeSet(op,[repeatMode]) + +interpLoop(expr,indexList,indexTypes,requiredType) == + -- generates code for interp-only repeat body + ['interpLoopIter,MKQ expr,MKQ indexList,["LIST",:indexList], + MKQ indexTypes, MKQ requiredType] + +interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) == + -- call interpreter on exp with loop vars in indexList with given + -- values and types, requiredType is used from interpCOLLECT + -- to indicate the required type of the result + emptyAtree exp + for i in indexList for val in indexVals for type in indexTypes repeat + put(i,'value,objNewWrap(val,type),$env) + bottomUp exp + v:= getValue exp + val := + null requiredType => v + coerceInteractive(v,requiredType) + null val => + throwKeyedMsgCannotCoerceWithValue(objVal v,objMode v,requiredType) + objValUnwrap val + +--% Handler for return + +upreturn t == + -- make sure we are in a user function + t isnt [op,val] => NIL + (null $compilingMap) and (null $interpOnly) => + throwKeyedMsg("S2IS0047",NIL) + if $mapTarget then putTarget(val,$mapTarget) + bottomUp val + if $mapTarget + then + val' := getArgValue(val, $mapTarget) + m := $mapTarget + else + val' := getValueNormalForm getValue val + m := computedMode val + cn := mapCatchName $mapName + $mapReturnTypes := insert(m, $mapReturnTypes) + $mapThrowCount := $mapThrowCount + 1 + -- if $genValue then we are interpreting the map + $genValue => THROW(cn,objNewWrap(removeQuote val',m)) + putValue(op,objNew(['THROW,MKQ cn,val'],m)) + putModeSet(op,[$Exit]) + +--% Handler for SEQ + +upSEQ u == + -- assumes that exits were translated into if-then-elses + -- handles flat SEQs and embedded returns + u isnt [op,:args] => NIL + if (target := getTarget(op)) then putTarget(last args, target) + for x in args repeat bottomUp x + null (m := computedMode last args) => + keyedSystemError("S2GE0016",['"upSEQ", + '"last line of SEQ has no mode"]) + evalSEQ(op,args,m) + putModeSet(op,[m]) + +evalSEQ(op,args,m) == + -- generate code for SEQ + [:argl,last] := args + val:= + $genValue => getValue last + bodyCode := nil + for x in args repeat + (m1 := computedMode x) and (m1 ~= '$ThrowAwayMode) => + (av := getArgValue(x,m1)) ~= voidValue() => + bodyCode := [av,:bodyCode] + code:= + bodyCode is [c] => c + ['PROGN,:reverse bodyCode] + objNew(code,m) + putValue(op,val) + +--% Handlers for tuple + +uptuple 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 => upNullTuple(op,l,tar) + isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar) + aggs := '(List) + if tar and cons?(tar) and not isPartialMode(tar) then + first(tar) in aggs => + ud := second tar + for x in l repeat if not getTarget(x) then putTarget(x,ud) + first(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] + eltTypes := replaceSymbols([first x for x in argModeSetList],l) + if not isPartialMode(tar) and tar is ['Tuple,ud] then + mode := ['Tuple, resolveTypeListAny [ud,:eltTypes]] + else mode := ['Tuple, resolveTypeListAny eltTypes] + if isPartialMode tar then tar:=resolveTM(mode,tar) + evalTuple(op,l,mode,tar) + +evalTuple(op,l,m,tar) == + [agg,:.,underMode]:= m + code := asTupleNewCode(underMode, #l, + [(getArgValue(x,underMode) or throwKeyedMsg("S2IC0007",[underMode])) for x in l]) + val := object(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]) + +upNullTuple(op,l,tar) == + -- handler for the empty tuple + defMode := + tar and tar is [a,b] and (a in '(Stream Vector List)) and + not isPartialMode(b) => ['Tuple,b] + '(Tuple (None)) + val := objNewWrap(asTupleNew(getVMType second defMode,0,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]) + +--% Handler for typeOf + +uptypeOf form == + form isnt [op, arg] => NIL + if vector? arg then transferPropsToNode(getUnname arg,arg) + if m := isType(arg) then + m := conceptualType m + else if not (m := getMode arg) then [m] := bottomUp arg + t := conceptualType m -- ??? shall we reveal more impl. details? + putValue(op, objNew(m,t)) + putModeSet(op,[t]) + +--% Handler for where + +upwhere t == + -- upwhere does the puts in where into a local environment + t isnt [op,tree,clause] => NIL + -- since the "clause" might be a local macro, we now call mkAtree + -- on the "tree" part (it is not yet a vat) + not $genValue => + compFailure [:bright '" where", + '"for compiled code is not yet implemented."] + $whereCacheList : local := nil + [env,:e] := upwhereClause(clause,$env,$e) + tree := upwhereMkAtree(tree,env,e) + if x := getAtree(op,'dollar) then + atom tree => throwKeyedMsg("S2IS0048",NIL) + putAtree(first tree,'dollar,x) + upwhereMain(tree,env,e) + val := getValue tree + putValue(op,val) + result := putModeSet(op,getModeSet tree) + wcl := [op for op in $whereCacheList] + for op in wcl repeat clearDependencies(op,'T) + result + +upwhereClause(tree,env,e) == + -- uses the variable bindings from env and e and returns an environment + -- of its own bindings + $env: local := copyHack env + $e: local := copyHack e + bottomUp tree + [$env,:$e] + +upwhereMkAtree(tree,$env,$e) == mkAtree tree + +upwhereMain(tree,$env,$e) == + -- uses local copies of $env and $e while evaluating tree + bottomUp tree + +copyHack(env) == + -- makes a copy of an environment with the exception of pairs + -- (localModemap . something) + c:= CAAR env + d:= [fn p for p in c] where fn(p) == + [first p,:[(q is ["localModemap",:.] => q; copy q) for q in rest p]] + [[d]] + + +--% Case patterns + +up%Match t == + sorry '"case pattern" + + +--% importing domains +up%Import t == + t isnt [.,:types] => nil + -- ??? shall we error in case types is nil? + for x in types repeat + $e := addDomain(devaluate objVal getValue x,$e) + setValueToVoid t + +--% Macro handling + +-- Well, in fact we never handle macros in the interpreter directly. +-- Rather, they are saved in the `macro processing phase' (phMacro) +-- to be used in future macro expansions, and the AST we get at this +-- point already went through the macro expansion massage. So, all we +-- have to do is to the rubber stamp. +up%Macro t == + setValueToVoid t + +up%MLambda t == + setValueToVoid t + + +--% Sorry for unhandled input constructs +sorry kind == + throwKeyedMsg("S2IP0006",[kind]) + +--% Export +up%Export t == + sorry '"export declaration" + +--% Inline +up%Inline t == + sorry '"inline declaration" + +--% Category +up%With t == + sorry '"category definition" + +--% Domain +up%Add t == + sorry '"domain definition" + +-- Creates the function names of the special function handlers and puts +-- them on the property list of the function name + +for name in $specialOps repeat + functionName:=INTERNL('up,name) + property(name,'up) := functionName + + -- cgit v1.2.3