diff options
Diffstat (limited to 'src/interp/i-eval.boot')
| -rw-r--r-- | src/interp/i-eval.boot | 452 |
1 files changed, 452 insertions, 0 deletions
diff --git a/src/interp/i-eval.boot b/src/interp/i-eval.boot new file mode 100644 index 00000000..673ff85d --- /dev/null +++ b/src/interp/i-eval.boot @@ -0,0 +1,452 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +--% Constructor Evaluation + +$noEvalTypeMsg := nil + +evalDomain form == + if $evalDomain then + sayMSG concat('" instantiating","%b",prefix2String form,"%d") + startTimingProcess 'instantiation + newType? form => form + result := eval mkEvalable form + stopTimingProcess 'instantiation + result + +mkEvalable form == + form is [op,:argl] => + op="QUOTE" => form + op="WRAPPED" => mkEvalable devaluate argl + op="Record" => mkEvalableRecord form + op="Union" => mkEvalableUnion form + op="Mapping"=> mkEvalableMapping form + op="Enumeration" => form + loadIfNecessary op + kind:= GETDATABASE(op,'CONSTRUCTORKIND) + cosig := GETDATABASE(op, 'COSIG) => + [op,:[val for x in argl for typeFlag in rest cosig]] where val == + typeFlag => + kind = 'category => MKQ x + VECP x => MKQ x + loadIfNecessary x + mkEvalable x + x is ['QUOTE,:.] => x + x is ['_#,y] => ['SIZE,MKQ y] + MKQ x + [op,:[mkEvalable x for x in argl]] + form=$EmptyMode => $Integer + IDENTP form and constructor?(form) => [form] + FBPIP form => BPINAME form + form + +mkEvalableMapping form == + [first form,:[mkEvalable d for d in rest form]] + +mkEvalableRecord form == + [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] + +mkEvalableUnion form == + isTaggedUnion form => + [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] + [first form,:[mkEvalable d for d in rest form]] + +evaluateType0 form == + -- Takes a parsed, unabbreviated type and evaluates it, replacing + -- type valued variables with their values, and calling bottomUp + -- on non-type valued arguemnts to the constructor + -- and finally checking to see whether the type satisfies the + -- conditions of its modemap + -- However, the input might be an attribute, not a type + -- $noEvalTypeMsg: fluid := true + domain:= isDomainValuedVariable form => domain + form = $EmptyMode => form + form = "?" => $EmptyMode + STRINGP form => form + form = "$" => form + $expandSegments : local := nil + form is ['typeOf,.] => + form' := mkAtree form + bottomUp form' + objVal getValue(form') + form is [op,:argl] => + op='CATEGORY => + argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]] + form + op in '(Join Mapping) => + [op,:[evaluateType arg for arg in argl]] + op='Union => + argl and first argl is [x,.,.] and member(x,'(_: Declare)) => + [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] + [op,:[evaluateType arg for arg in argl]] + op='Record => + [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] + op='Enumeration => form + constructor? op => evaluateType1 form + NIL + constructor? form => + ATOM form => evaluateType [form] + throwEvalTypeMsg("S2IE0003",[form,form]) + +evaluateType form == + -- Takes a parsed, unabbreviated type and evaluates it, replacing + -- type valued variables with their values, and calling bottomUp + -- on non-type valued arguemnts to the constructor + -- and finally checking to see whether the type satisfies the + -- conditions of its modemap + domain:= isDomainValuedVariable form => domain + form = $EmptyMode => form + form = "?" => $EmptyMode + STRINGP form => form + form = "$" => form + $expandSegments : local := nil + form is ['typeOf,.] => + form' := mkAtree form + bottomUp form' + objVal getValue(form') + form is [op,:argl] => + op='CATEGORY => + argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]] + form + op in '(Join Mapping) => + [op,:[evaluateType arg for arg in argl]] + op='Union => + argl and first argl is [x,.,.] and member(x,'(_: Declare)) => + [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] + [op,:[evaluateType arg for arg in argl]] + op='Record => + [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] + op='Enumeration => form + evaluateType1 form + constructor? form => + ATOM form => evaluateType [form] + throwEvalTypeMsg("S2IE0003",[form,form]) + throwEvalTypeMsg("S2IE0004",[form]) + +evaluateType1 form == + --evaluates the arguments passed to a constructor + [op,:argl]:= form + constructor? op => + null (sig := getConstructorSignature form) => + throwEvalTypeMsg("S2IE0005",[form]) + [.,:ml] := sig + ml := replaceSharps(ml,form) + # argl ^= #ml => throwEvalTypeMsg("S2IE0003",[form,form]) + for x in argl for m in ml for argnum in 1.. repeat + typeList := [v,:typeList] where v == + categoryForm?(m) => + m := evaluateType MSUBSTQ(x,'_$,m) + evalCategory(x' := (evaluateType x), m) => x' + throwEvalTypeMsg("S2IE0004",[form]) + m := evaluateType m + GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and + (tree := mkAtree x) and putTarget(tree,m) and ((bottomUp tree) is [m1]) => + [zt,:zv]:= z1:= getAndEvalConstructorArgument tree + (v:= coerceOrRetract(z1,m)) => objValUnwrap v + throwKeyedMsgCannotCoerceWithValue(zv,zt,m) + if x = $EmptyMode then x := $quadSymbol + throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form]) + [op,:NREVERSE typeList] + throwEvalTypeMsg("S2IE0007",[op]) + +throwEvalTypeMsg(msg, args) == + $noEvalTypeMsg => spadThrow() + throwKeyedMsg(msg, args) + +makeOrdinal i == + ('(first second third fourth fifth sixth seventh eighth ninth tenth)).(i-1) + +evaluateSignature sig == + -- calls evaluateType on a signature + sig is [ ='SIGNATURE,fun,sigl] => + ['SIGNATURE,fun, + [(t = '_$ => t; evaluateType(t)) for t in sigl]] + sig + +--% Code Evaluation + +-- This code generates, then evaluates code during the bottom up phase +-- of interpretation + +splitIntoBlocksOf200 a == + null a => nil + [[first (r:=x) for x in tails a for i in 1..200], + :splitIntoBlocksOf200 rest r] + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +evalForm(op,opName,argl,mmS) == + -- applies the first applicable function + + for mm in mmS until form repeat + [sig,fun,cond]:= mm + (CAR sig) = 'interpOnly => form := CAR sig + #argl ^= #CDDR sig => 'skip ---> RDJ 6/95 + form:= + $genValue or null cond => + [getArgValue2(x,t,sideEffectedArg?(t,sig,opName),opName) or return NIL + for x in argl for t in CDDR sig] + [getArgValueComp2(x,t,c,sideEffectedArg?(t,sig,opName),opName) or return NIL + for x in argl for t in CDDR sig for c in cond] + form or null argl => + dc:= CAR sig + form := + dc='local => --[fun,:form] + atom fun => + fun in $localVars => ['SPADCALL,:form,fun] + [fun,:form,NIL] + ['SPADCALL,:form,fun] + dc is ["__FreeFunction__",:freeFun] => + ['SPADCALL,:form,freeFun] + fun is ['XLAM,xargs,:xbody] => + rec := first form + xbody is [['RECORDELT,.,ind,len]] => + optRECORDELT([CAAR xbody,rec,ind,len]) + xbody is [['SETRECORDELT,.,ind,len,.]] => + optSETRECORDELT([CAAR xbody,rec,ind,len,CADDR form]) + xbody is [['RECORDCOPY,.,len]] => + optRECORDCOPY([CAAR xbody,rec,len]) + ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)] + dcVector := evalDomain dc + fun0 := + newType? CAAR mm => + mm' := first ncSigTransform mm + ncGetFunction(opName, first mm', rest mm') + NRTcompileEvalForm(opName,rest sig,dcVector) + null fun0 => throwKeyedMsg("S2IE0008",[opName]) + [bpi,:domain] := fun0 + EQ(bpi,function Undef) => + sayKeyedMsg("S2IE0009",[opName,formatSignature CDR sig,CAR sig]) + NIL + if $NRTmonitorIfTrue = true then + sayBrightlyNT ['"Applying ",first fun0,'" to:"] + pp [devaluateDeeply x for x in form] + _$:fluid := domain + ['SPADCALL, :form, fun0] + not form => nil +-- not form => throwKeyedMsg("S2IE0008",[opName]) + form='interpOnly => rewriteMap(op,opName,argl) + targetType := CADR sig + if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType + evalFormMkValue(op,form,targetType) + +sideEffectedArg?(t,sig,opName) == + opString := SYMBOL_-NAME opName + (opName ^= 'setelt) and (ELT(opString, #opString-1) ^= char '_!) => nil + dc := first sig + t = dc + +getArgValue(a, t) == + atom a and not VECP a => + t' := coerceOrRetract(getBasicObject a,t) + t' and wrapped2Quote objVal t' + v := getArgValue1(a, t) => v + alt := altTypeOf(objMode getValue a, a, nil) => + t' := coerceInt(getValue a, alt) + t' := coerceOrRetract(t',t) + t' and wrapped2Quote objVal t' + nil + +getArgValue1(a,t) == + -- creates a value for a, coercing to t + t' := getValue(a) => + (m := getMode a) and (m is ['Mapping,:ml]) and (m = t) and + objValUnwrap(t') is ['MAP,:.] => + getMappingArgValue(a,t,m) + t' := coerceOrRetract(t',t) + t' and wrapped2Quote objVal t' + systemErrorHere '"getArgValue" + +getArgValue2(a,t,se?,opName) == + se? and (objMode(getValue a) ^= t) => + throwKeyedMsg("S2IE0013", [opName, objMode(getValue a), t]) + getArgValue(a,t) + +getArgValueOrThrow(x, type) == + getArgValue(x,type) or throwKeyedMsg("S2IC0007",[type]) + +getMappingArgValue(a,t,m is ['Mapping,:ml]) == + (una := getUnname a) in $localVars => + $genValue => + name := get(una,'name,$env) + a.0 := name + mmS := selectLocalMms(a,name,rest ml, nil) + or/[mm for mm in mmS | + (mm is [[., :ml1],oldName,:.] and ml=ml1)] => MKQ [oldName] + NIL + una + mmS := selectLocalMms(a,una,rest ml, nil) + or/[mm for mm in mmS | + (mm is [[., :ml1],oldName,:.] and ml=ml1)] => MKQ [oldName] + NIL + +getArgValueComp2(arg, type, cond, se?, opName) == + se? and (objMode(getValue arg) ^= type) => + throwKeyedMsg("S2IE0013", [opName, objMode(getValue arg), type]) + getArgValueComp(arg, type, cond) + +getArgValueComp(arg,type,cond) == + -- getArgValue for compiled case. if there is a condition then + -- v must be data to verify that coerceInteractive succeeds. + v:= getArgValue(arg,type) + null v => nil + null cond => v + v is ['QUOTE,:.] or getBasicMode v => v + n := getUnnameIfCan arg + if num := isSharpVarWithNum n then + not $compilingMap => n := 'unknownVar + alias := get($mapName,'alias,$e) + n := alias.(num - 1) + keyedMsgCompFailure("S2IE0010",[n]) + +evalFormMkValue(op,form,tm) == + val:= + u:= + $genValue => wrap timedEVALFUN form + form + objNew(u,tm) +--+ + if $NRTmonitorIfTrue = true then + sayBrightlyNT ['"Value of ",op.0,'" ===> "] + pp unwrap u + putValue(op,val) + [tm] + +failCheck x == + x = '"failed" => + stopTimingProcess peekTimedName() + THROW('interpreter,objNewWrap('"failed",$String)) + x = $coerceFailure => + NIL + x + +--% Some Antique Comments About the Interpreter + +--EVAL BOOT contains the top level interface to the Scratchhpad-II +--interpreter. The Entry point into the interpreter from the parser is +--processInteractive. +--The type analysis algorithm is contained in the file BOTMUP BOOT, +--and MODSEL boot, +--the map handling routines are in MAP BOOT and NEWMAP BOOT, and +--the interactive coerce routines are in COERCE BOOT and COERCEFN BOOT. +-- +--Conventions: +-- All spad values in the interpreter are passed around in triples. +-- These are lists of three items: [value,mode,environment]. The value +-- may be wrapped (this is a pair whose CAR is the atom WRAPPED and +-- whose CDR is the value), which indicates that it is a real value, +-- or unwrapped in which case it needs to be EVALed to produce the +-- proper value. The mode is the type of value, and should always be +-- completely specified (not contain $EmptyMode). The environment +-- is always empty, and is included for historical reasons. +-- +--Modemaps: +-- Modemaps are descriptions of compiled Spad function which the +-- interpreter uses to perform type analysis. They consist of patterns +-- of types for the arguments, and conditions the types must satisfy +-- for the function to apply. For each function name there is a list +-- of modemaps in file MODEMAP DATABASE for each distinct function with +-- that name. The following is the list of the modemaps for "*" +-- (multiplication. The first modemap (the one with the labels) is for +-- module mltiplication which is multiplication of an element of a +-- module by a member of its scalar domain. +-- +-- This is the signature pattern for the modemap, it is of the form: +-- (DomainOfComputation TargetType <ArgumentType ...>) +-- | +-- | This is the predicate that needs to be +-- | satisfied for the modemap to apply +-- | | +-- V | +-- /-----------/ | +-- ( ( (*1 *1 *2 *1) V +-- /-----------------------------------------------------------/ +-- ( (AND (ofCategory *1 (Module *2)) (ofCategory *2 (SimpleRing))) ) +-- . CATDEF) <-- This is the file where the function was defined +-- ( (*1 *1 *2 *1) +-- ( (AND (isDomain *2 (Integer)) (ofCategory *1 (AbelianGroup))) ) +-- . CATDEF) +-- ( (*1 *1 *2 *1) +-- ( (AND +-- (isDomain *2 (NonNegativeInteger)) +-- (ofCategory *1 (AbelianMonoid))) ) +-- . CATDEF) +-- ((*1 *1 *1 *1) ((ofCategory *1 (SemiGroup)) ) . CATDEF) +-- ) +-- +--Environments: +-- Environments associate properties with atoms. +-- (see CUTIL BOOT for the exact structure of environments). +-- Some common properties are: +-- modeSet: +-- During interpretation we build a modeSet property for each node in +-- the expression. This is (in theory) a list of all the types +-- possible for the node. In the current implementation these +-- modeSets always contain a single type. +-- value: +-- Value properties are always triples. This is where the values of +-- variables are stored. We also build value properties for internal +-- nodes during the bottom up phase. +-- mode: +-- This is the declared type of an identifier. +-- +-- There are several different environments used in the interpreter: +-- $InteractiveFrame : this is the environment where the user +-- values are stored. Any side effects of evaluation of a top-level +-- expression are stored in this environment. It is always used as +-- the starting environment for interpretation. +-- $e : This is the name used for $InteractiveFrame while interpreting. +-- $env : This is local environment used by the interpreter. +-- Only temporary information (such as types of local variables is +-- stored in $env. +-- It is thrown away after evaluation of each expression. +-- +--Frequently used global variables: +-- $genValue : if true then evaluate generated code, otherwise leave +-- code unevaluated. If $genValue is false then we are compiling. +-- $op: name of the top level operator (unused except in map printing) +-- $mapList: list of maps being type analyzed, used in recursive +-- map type anlysis. +-- $compilingMap: true when compiling a map, used to detect where to +-- THROW when interpret-only is invoked +-- $compilingLoop: true when compiling a loop body, used to control +-- nesting level of interp-only loop CATCH points +-- $interpOnly: true when in interpret only mode, used to call +-- alternate forms of COLLECT and REPEAT. +-- $inCOLLECT: true when compiling a COLLECT, used only for hacked +-- stream compiler. +-- $StreamFrame: used in printing streams, it is the environment +-- where local stream variables are stored +-- $declaredMode: Weak type propagation for symbols, set in upCOERCE +-- and upLET. This variable is used to determine +-- the alternate polynomial types of Symbols. +-- $localVars: list of local variables in a map body +-- $MapArgumentTypeList: hack for stream compilation |