-- 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 --% Constructor Evaluation $noEvalTypeMsg := nil evalDomain form == startTimingProcess 'instantiation newType? form => form form is ['%store,:.] => eval 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 -- a niladic constructor instantiation goes by itself constructor? op and argl = nil => form loadIfNecessary op kind:= getConstructorKindFromDB op cosig := getDualSignatureFromDB op => [op,:[val for x in argl for typeFlag in rest cosig]] where val() == typeFlag => kind = "category" => MKQ x vector? 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 string? 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 IDENTP form and niladicConstructorFromDB form => evaluateType [form] IDENTP form and (constructor? form or form in $BuiltinConstructorNames) => throwEvalTypeMsg("S2IE0003",[form,form]) ++ Check for duplicate fields in a Union or Record domain form. checkRecordOrUnionFields body == for [[.,n,.],:fields] in tails body repeat for field in fields | field is [.,=n,.] repeat throwKeyedMsg("S2IL0030",[n]) body 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 string? form => form form = "$" => form $expandSegments : local := nil form is ['typeOf,.] => objVal getValue elaborateForm 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, : checkRecordOrUnionFields [[":",sel,evaluateType type] for ['_:,sel,type] in argl]] [op,:[evaluateType arg for arg in argl]] op='Record => [op, : checkRecordOrUnionFields [['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] op='Enumeration => -- only symbols, and they must not be repeated. for arg in argl repeat IDENTP arg => nil throwKeyedMsg("S2IL0031",nil) for [arg,:args] in tails argl repeat MEMQ(arg,args) => throwKeyedMsg("S2IL0032",[arg]) form evaluateFormAsType form IDENTP form and niladicConstructorFromDB form => evaluateType [form] IDENTP form and (constructor? form or form in $BuiltinConstructorNames) => throwEvalTypeMsg("S2IE0003",[form,form]) evaluateFormAsType form ++ `form' used in a context where a type (domain or category) is ++ expected. Attempt to fully evaluate it. Error if the resulting ++ value is not a type. When successful, the result is the reified ++ canonical form of the type. evaluateFormAsType form == form is [op,:args] and constructor? op => evaluateType1 form t := mkAtree form -- ??? Maybe we should be more careful about generalized types. bottomUp t is [m] and (member(m,$LangSupportTypes) or isCategoryForm(m,$e)) => objVal getValue t throwEvalTypeMsg("S2IE0004",[form]) ++ evaluates the arguments passed to the constructor `op'. ++ Note: only constructor instantiations go here. evaluateType1 (form is [op,:argl]) == null (sig := getConstructorSignature op) => 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 getConstructorKindFromDB opOf m = "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(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] evalForm(op,opName,argl,mmS) == -- applies the first applicable function for mm in mmS until form repeat [sig,fun,cond]:= mm (first sig) = 'interpOnly => form := first 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:= first sig form := dc='local => --[fun,:form] atom fun => isLocallyBound fun => ['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,third 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,fun,dcVector) null fun0 => throwKeyedMsg("S2IE0008",[opName]) [bpi,:domain] := fun0 EQ(bpi,function Undef) => sayKeyedMsg("S2IE0009",[opName,formatSignature rest sig,first 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 := second sig if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType evalFormMkValue(op,form,targetType) sideEffectedArg?(t,sig,opName) == opString := symbolName opName (opName ~= 'setelt) and (opString.(#opString-1) ~= char '_!) => nil dc := first sig t = dc getArgValue(a, t) == atom a and not vector? a => t' := coerceOrRetract(getBasicObject a,t) t' and getValueNormalForm t' v := getArgValue1(a, t) => v alt := altTypeOf(objMode getValue a, a, nil) => t' := coerceInt(getValue a, alt) t' := coerceOrRetract(t',t) t' and getValueNormalForm 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 getValueNormalForm t' systemErrorHere '"getArgValue1" 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]) == isLocallyBound(una := getUnname a) => $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 := object(form,tm) if $NRTmonitorIfTrue = true then sayBrightlyNT ['"Value of ",op.0,'" ===> "] pp objValUnwrap val putValue(op,val) [tm] failCheck x == x is '"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 ) -- | -- | 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 up%LET. 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