From 0850ca5458cb09b2d04cec162558500e9a05cf4a Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 14:50:49 +0000 Subject: Revert commits to the wrong tree. --- src/interp/i-eval.boot | 452 ------------------------------------------------- 1 file changed, 452 deletions(-) delete mode 100644 src/interp/i-eval.boot (limited to 'src/interp/i-eval.boot') diff --git a/src/interp/i-eval.boot b/src/interp/i-eval.boot deleted file mode 100644 index 673ff85d..00000000 --- a/src/interp/i-eval.boot +++ /dev/null @@ -1,452 +0,0 @@ --- 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 ) --- | --- | 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 -- cgit v1.2.3