-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2010, 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 VECP D and (SIZE(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 VECP 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:=["COND",[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 ["COND",[p1,a1],[''T,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) ['COND,[p1,a1],[''T,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 => ["COND",[["EQ",predCode,MKQ "failed"],["SEQ",:assignCode,MKQ 'T]]] ["COND",[["NOT",["EQ",predCode,MKQ "failed"]],["SEQ",:assignCode,MKQ 'T]]] 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 := ['COND,[objVal object,objVal getValue a],[''T,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 VECP 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 VECP 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 VECP 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