1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2-- All rights reserved. 3-- 4-- Redistribution and use in source and binary forms, with or without 5-- modification, are permitted provided that the following conditions are 6-- met: 7-- 8-- - Redistributions of source code must retain the above copyright 9-- notice, this list of conditions and the following disclaimer. 10-- 11-- - Redistributions in binary form must reproduce the above copyright 12-- notice, this list of conditions and the following disclaimer in 13-- the documentation and/or other materials provided with the 14-- distribution. 15-- 16-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17-- names of its contributors may be used to endorse or promote products 18-- derived from this software without specific prior written permission. 19-- 20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32)package "BOOT" 33 34-- Initialize for use in msgdb 35$genValue := false 36 37--% Constructor Evaluation 38 39-- For use from compiled code 40 41quoteNontypeArgs(t) == 42 t is [.] => t 43 op := opOf t 44 loadIfNecessary op 45 args := rest t 46 cs := rest GETDATABASE(op, 'COSIG) 47 nargs := [if c then quoteNontypeArgs(a) else ["QUOTE", a] 48 for a in args for c in cs] 49 [op, :nargs] 50 51evalType(t) == EVAL(quoteNontypeArgs(t)) 52 53--- 54 55$noEvalTypeMsg := nil 56$evalDomain := nil 57 58evalDomain form == 59 if $evalDomain then 60 sayMSG concat('" instantiating","%b",prefix2String form,"%d") 61 startTimingProcess 'instantiation 62 result := eval mkEvalable form 63 stopTimingProcess 'instantiation 64 result 65 66mkEvalable form == 67 form is [op,:argl] => 68 op="QUOTE" => form 69 op="WRAPPED" => mkEvalable devaluate argl 70 op="Record" => mkEvalableRecord form 71 op="Union" => mkEvalableUnion form 72 op="Mapping"=> mkEvalableMapping form 73 op="Enumeration" => form 74 loadIfNecessary op 75 kind:= GETDATABASE(op,'CONSTRUCTORKIND) 76 cosig := GETDATABASE(op, 'COSIG) => 77 [op,:[val for x in argl for typeFlag in rest cosig]] where val == 78 typeFlag => 79 kind = 'category => MKQ x 80 VECP x => MKQ x 81 mkEvalable x 82 x is ['QUOTE,:.] => x 83 x is ['_#,y] => ['SIZE,MKQ y] 84 MKQ x 85 [op,:[mkEvalable x for x in argl]] 86 form=$EmptyMode => $Integer 87 IDENTP form and constructor?(form) => [form] 88 FBPIP form => BREAK() 89 form 90 91mkEvalableMapping form == 92 [first form,:[mkEvalable d for d in rest form]] 93 94mkEvalableRecord form == 95 [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] 96 97mkEvalableUnion form == 98 isTaggedUnion form => 99 [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] 100 [first form,:[mkEvalable d for d in rest form]] 101 102evaluateType form == 103 -- Takes a parsed, unabbreviated type and evaluates it, replacing 104 -- type valued variables with their values, and calling bottomUp 105 -- on non-type valued arguments to the constructor 106 -- and finally checking to see whether the type satisfies the 107 -- conditions of its modemap 108 domain:= isDomainValuedVariable form => domain 109 form = $EmptyMode => form 110 form = "?" => $EmptyMode 111 STRINGP form => form 112 form = "$" => form 113 form is ['typeOf,.] => 114 form' := mkAtree form 115 bottomUp form' 116 objVal getValue(form') 117 form is [op,:argl] => 118 op='CATEGORY => 119 argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]] 120 form 121 op in '(Join Mapping) => 122 [op,:[evaluateType arg for arg in argl]] 123 op='Union => 124 argl and first argl is [x,.,.] and member(x,'(_: Declare)) => 125 [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] 126 [op,:[evaluateType arg for arg in argl]] 127 op='Record => 128 [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] 129 op='Enumeration => form 130 evaluateFormAsType form 131 constructor? form => 132 ATOM form => evaluateType [form] 133 throwEvalTypeMsg("S2IE0003",[form,form]) 134 throwEvalTypeMsg("S2IE0004", [form]) 135 136++ `form' used in a context where a type (domain or category) is 137++ expected. Attempt to fully evaluate it. Error if the resulting 138++ value is not a type. When successful, the result is the reified 139++ canonical form of the type. 140evaluateFormAsType form == 141 form is [op,:args] and constructor? op => evaluateType1 form 142 t := mkAtree form 143 -- ??? Maybe we should be more careful about generalized types. 144 bottomUp t is [m] and (m = ["Mode"] or isCategoryForm(m)) => 145 objVal getValue t 146 throwEvalTypeMsg("S2IE0004",[form]) 147 148evaluateType1 form == 149 --evaluates the arguments passed to a constructor 150 [op,:argl]:= form 151 constructor? op => 152 null (sig := getConstructorSignature form) => 153 throwEvalTypeMsg("S2IE0005",[form]) 154 [.,:ml] := sig 155 ml := replaceSharps(ml,form) 156 # argl ~= #ml => throwEvalTypeMsg("S2IE0003",[form,form]) 157 for x in argl for m in ml for argnum in 1.. repeat 158 typeList := [v,:typeList] where v == 159 categoryForm?(m) => 160 m := evaluateType MSUBSTQ(x,'_$,m) 161 evalCategory(x' := (evaluateType x), m) => x' 162 throwEvalTypeMsg("S2IE0004",[form]) 163 m := evaluateType m 164 GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and 165 (tree := mkAtree x) and putTarget(tree,m) and ((bottomUp tree) is [m1]) => 166 [zt,:zv]:= z1:= getAndEvalConstructorArgument tree 167 (v1 := coerceOrRetract(z1, m)) => objValUnwrap v1 168 throwKeyedMsgCannotCoerceWithValue(zv,zt,m) 169 throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form]) 170 [op,:NREVERSE typeList] 171 throwEvalTypeMsg("S2IE0007",[op]) 172 173throwEvalTypeMsg(msg, args) == 174 $justUnparseType : local := true 175 $noEvalTypeMsg => spadThrow() 176 throwKeyedMsg(msg, args) 177 178makeOrdinal i == 179 ('(first second third fourth fifth sixth seventh eighth ninth tenth)).(i-1) 180 181evaluateSignature sig == 182 -- calls evaluateType on a signature 183 sig is [ ='SIGNATURE,fun,sigl] => 184 ['SIGNATURE,fun, 185 [(t = '_$ => t; evaluateType(t)) for t in sigl]] 186 sig 187 188--% Code Evaluation 189 190-- This code generates, then evaluates code during the bottom up phase 191-- of interpretation 192 193splitIntoBlocksOf200 a == 194 null a => nil 195 [[first (r:=x) for x in tails a for i in 1..200], 196 :splitIntoBlocksOf200 rest r] 197 198evalForm(op,opName,argl,mmS) == 199 -- applies the first applicable function 200 201 for mm in mmS until form repeat 202 [sig,fun,cond]:= mm 203 (CAR sig) = 'interpOnly => form := CAR sig 204 #argl ~= #CDDR sig => 'skip ---> RDJ 6/95 205 form:= 206 $genValue or null cond => 207 [getArgValue2(x,t,sideEffectedArg?(t,sig,opName),opName) or return NIL 208 for x in argl for t in CDDR sig] 209 [getArgValueComp2(x,t,c,sideEffectedArg?(t,sig,opName),opName) or return NIL 210 for x in argl for t in CDDR sig for c in cond] 211 form or null argl => 212 dc:= CAR sig 213 form := 214 dc='local => --[fun,:form] 215 atom fun => 216 fun in $localVars => ['SPADCALL,:form,fun] 217 [fun,:form,NIL] 218 ['SPADCALL,:form,fun] 219 dc is ["__FreeFunction__",:freeFun] => 220 ['SPADCALL,:form,freeFun] 221 fun is ['XLAM,xargs,:xbody] => 222 rec := first form 223 xbody is [['RECORDELT,.,ind,len]] => 224 optRECORDELT([CAAR xbody,rec,ind,len]) 225 xbody is [['SETRECORDELT,.,ind,len,.]] => 226 optSETRECORDELT([CAAR xbody,rec,ind,len,CADDR form]) 227 xbody is [['RECORDCOPY,.,len]] => 228 optRECORDCOPY([CAAR xbody,rec,len]) 229 ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)] 230 dcVector := evalDomain dc 231 fun0 := NRTcompileEvalForm(opName,fun,dcVector) 232 null fun0 => throwKeyedMsg("S2IE0008",[opName]) 233 [bpi,:domain] := fun0 234 EQ(bpi,function Undef) => 235 sayKeyedMsg("S2IE0009",[opName,formatSignature CDR sig,CAR sig]) 236 NIL 237 if $NRTmonitorIfTrue = true then 238 sayBrightlyNT ['"Applying ",first fun0,'" to:"] 239 pp [devaluateDeeply x for x in form] 240 _$:fluid := domain 241 ['SPADCALL, :form, fun0] 242 not form => nil 243-- not form => throwKeyedMsg("S2IE0008",[opName]) 244 form='interpOnly => rewriteMap(op,opName,argl) 245 targetType := CADR sig 246 if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType 247 evalFormMkValue(op,form,targetType) 248 249sideEffectedArg?(t,sig,opName) == 250 opString := SYMBOL_-NAME opName 251 (opName ~= "setelt!") and (ELT(opString, #opString-1) ~= char '_!) => nil 252 dc := first sig 253 t = dc 254 255getArgValue(a, t) == 256 atom a and not VECP a => 257 t' := coerceOrRetract(getBasicObject a,t) 258 t' and wrapped2Quote objVal t' 259 v := getArgValue1(a, t) => v 260 alt := altTypeOf(objMode getValue a, a, nil) => 261 t' := coerceInt(getValue a, alt) 262 t' := coerceOrRetract(t',t) 263 t' and wrapped2Quote objVal t' 264 nil 265 266getArgValue1(a,t) == 267 -- creates a value for a, coercing to t 268 t' := getValue(a) => 269 (m := getMode a) and (m is ['Mapping,:ml]) and (m = t) and 270 objValUnwrap(t') is ['SPADMAP, :.] => 271 getMappingArgValue(a,t,m) 272 t' := coerceOrRetract(t',t) 273 t' and wrapped2Quote objVal t' 274 systemErrorHere '"getArgValue" 275 276getArgValue2(a,t,se?,opName) == 277 se? and (objMode(getValue a) ~= t) => 278 throwKeyedMsg("S2IE0013", [opName, objMode(getValue a), t]) 279 getArgValue(a,t) 280 281getArgValueOrThrow(x, type) == 282 getArgValue(x,type) or throwKeyedMsg("S2IC0007",[type]) 283 284getMappingArgValue(a,t,m is ['Mapping,:ml]) == 285 (una := getUnname a) in $localVars => 286 $genValue => 287 name := get(una,'name,$env) 288 a.0 := name 289 mmS := selectLocalMms(a,name,rest ml, nil) 290 or/[mm for mm in mmS | 291 (mm is [[., :ml1],oldName,:.] and ml=ml1)] => 292 MKQ [COERCE(oldName, 'FUNCTION)] 293 NIL 294 una 295 mmS := selectLocalMms(a,una,rest ml, nil) 296 or/[mm for mm in mmS | 297 (mm is [[., :ml1],oldName,:.] and ml=ml1)] => 298 MKQ [COERCE(oldName, 'FUNCTION)] 299 NIL 300 301getArgValueComp2(arg, type, cond, se?, opName) == 302 se? and (objMode(getValue arg) ~= type) => 303 throwKeyedMsg("S2IE0013", [opName, objMode(getValue arg), type]) 304 getArgValueComp(arg, type, cond) 305 306getArgValueComp(arg,type,cond) == 307 -- getArgValue for compiled case. if there is a condition then 308 -- v must be data to verify that coerceInteractive succeeds. 309 v:= getArgValue(arg,type) 310 null v => nil 311 null cond => v 312 v is ['QUOTE,:.] or getBasicMode v => v 313 n := getUnnameIfCan arg 314 if num := isSharpVarWithNum n then 315 not $compilingMap => n := 'unknownVar 316 alias := get($mapName,'alias,$e) 317 n := alias.(num - 1) 318 keyedMsgCompFailure("S2IE0010",[n]) 319 320evalFormMkValue(op,form,tm) == 321 val:= 322 u:= 323 $genValue => wrap timedEVALFUN form 324 form 325 objNew(u,tm) 326--+ 327 if $NRTmonitorIfTrue = true then 328 sayBrightlyNT ['"Value of ",op.0,'" ===> "] 329 pp unwrap u 330 putValue(op,val) 331 [tm] 332 333--% Some Antique Comments About the Interpreter 334 335--EVAL BOOT contains the top level interface to the Scratchhpad-II 336--interpreter. The Entry point into the interpreter from the parser is 337--processInteractive. 338--the interactive coerce routines are in COERCE BOOT and COERCEFN BOOT. 339-- 340--Conventions: 341-- All spad values in the interpreter are passed around in triples. 342-- These are lists of three items: [value,mode,environment]. The value 343-- may be wrapped (this is a pair whose CAR is the atom WRAPPED and 344-- whose CDR is the value), which indicates that it is a real value, 345-- or unwrapped in which case it needs to be EVALed to produce the 346-- proper value. The mode is the type of value, and should always be 347-- completely specified (not contain $EmptyMode). The environment 348-- is always empty, and is included for historical reasons. 349-- 350--Modemaps: 351-- Modemaps are descriptions of compiled Spad function which the 352-- interpreter uses to perform type analysis. They consist of patterns 353-- of types for the arguments, and conditions the types must satisfy 354-- for the function to apply. For each function name there is a list 355-- of modemaps in file MODEMAP DATABASE for each distinct function with 356-- that name. The following is the list of the modemaps for "*" 357-- (multiplication. The first modemap (the one with the labels) is for 358-- module mltiplication which is multiplication of an element of a 359-- module by a member of its scalar domain. 360-- 361-- This is the signature pattern for the modemap, it is of the form: 362-- (DomainOfComputation TargetType <ArgumentType ...>) 363-- | 364-- | This is the predicate that needs to be 365-- | satisfied for the modemap to apply 366-- | | 367-- V | 368-- /-----------/ | 369-- ( ( (*1 *1 *2 *1) V 370-- /-----------------------------------------------------------/ 371-- ( (AND (ofCategory *1 (Module *2)) (ofCategory *2 (SimpleRing))) ) 372-- . CATDEF) <-- This is the file where the function was defined 373-- ( (*1 *1 *2 *1) 374-- ( (AND (isDomain *2 (Integer)) (ofCategory *1 (AbelianGroup))) ) 375-- . CATDEF) 376-- ( (*1 *1 *2 *1) 377-- ( (AND 378-- (isDomain *2 (NonNegativeInteger)) 379-- (ofCategory *1 (AbelianMonoid))) ) 380-- . CATDEF) 381-- ((*1 *1 *1 *1) ((ofCategory *1 (SemiGroup)) ) . CATDEF) 382-- ) 383-- 384--Environments: 385-- Environments associate properties with atoms. 386-- (see CUTIL BOOT for the exact structure of environments). 387-- Some common properties are: 388-- modeSet: 389-- During interpretation we build a modeSet property for each node in 390-- the expression. This is (in theory) a list of all the types 391-- possible for the node. In the current implementation these 392-- modeSets always contain a single type. 393-- value: 394-- Value properties are always triples. This is where the values of 395-- variables are stored. We also build value properties for internal 396-- nodes during the bottom up phase. 397-- mode: 398-- This is the declared type of an identifier. 399-- 400-- There are several different environments used in the interpreter: 401-- $InteractiveFrame : this is the environment where the user 402-- values are stored. Any side effects of evaluation of a top-level 403-- expression are stored in this environment. It is always used as 404-- the starting environment for interpretation. 405-- $e : This is the name used for $InteractiveFrame while interpreting. 406-- $env : This is local environment used by the interpreter. 407-- Only temporary information (such as types of local variables is 408-- stored in $env. 409-- It is thrown away after evaluation of each expression. 410-- 411--Frequently used global variables: 412-- $genValue : if true then evaluate generated code, otherwise leave 413-- code unevaluated. If $genValue is false then we are compiling. 414-- $op: name of the top level operator (unused except in map printing) 415-- $mapList: list of maps being type analyzed, used in recursive 416-- map type analysis. 417-- $compilingMap: true when compiling a map, used to detect where to 418-- THROW when interpret-only is invoked 419-- $compilingLoop: true when compiling a loop body, used to control 420-- nesting level of interp-only loop CATCH points 421-- $interpOnly: true when in interpret only mode, used to call 422-- alternate forms of COLLECT and REPEAT. 423-- $inCOLLECT: true when compiling a COLLECT, used only for hacked 424-- stream compiler. 425-- $declaredMode: Weak type propagation for symbols, set in upCOERCE 426-- and upLET. This variable is used to determine 427-- the alternate polynomial types of Symbols. 428-- $localVars: list of local variables in a map body 429-- $MapArgumentTypeList: hack for stream compilation 430