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)if false 35Internal Interpreter Facilities 36 37Vectorized Attributed Trees 38 39The interpreter translates parse forms into vats for analysis. 40These contain a number of slots in each node for information. 41The leaves are now all vectors, though the leaves for basic types 42such as integers and strings used to just be the objects themselves. 43The vectors for the leaves with such constants now have the value 44of $immediateDataSymbol as their name. Their are undoubtably still 45some functions that still check whether a leaf is a constant. Note 46that if it is not a vector it is a subtree. 47 48attributed tree nodes have the following form: 49slot description 50---- ----------------------------------------------------- 51 0 operation name or literal 52 1 declared mode of variable 53 2 computed value of subtree from this node 54 3 modeset: list of single computed mode of subtree 55 4 prop list for extra things 56)endif 57 58DEFPARAMETER($useParserSrcPos, NIL) 59DEFPARAMETER($transferParserSrcPos, NIL) 60 61DEFCONST($failure, GENSYM()) 62 63-- Making Trees 64 65mkAtreeNode x == 66 -- maker of attrib tree node 67 v := MAKE_VEC(5) 68 v.0 := x 69 v 70 71mkAtree x == 72 -- maker of attrib tree from parser form 73 mkAtree1 mkAtreeExpandMacros x 74 75mkAtreeWithSrcPos(form, posnForm) == 76 posnForm and $useParserSrcPos => pf2Atree(posnForm) 77 transferSrcPosInfo(posnForm, mkAtree form) 78 79mkAtree1WithSrcPos(form, posnForm) == 80 transferSrcPosInfo(posnForm, mkAtree1 form) 81 82mkAtreeNodeWithSrcPos(form, posnForm) == 83 transferSrcPosInfo(posnForm, mkAtreeNode form) 84 85transferSrcPosInfo(pf, atree) == 86 not (pf and $transferParserSrcPos) => atree 87 pos := pfPosOrNopos(pf) 88 pfNoPosition?(pos) => atree 89 90 -- following is a hack because parser code for getting filename 91 -- seems wrong. 92 fn := lnPlaceOfOrigin poGetLineObject(pos) 93 if NULL fn or fn = '"strings" then fn := '"console" 94 95 putSrcPos(atree, fn, pfSourceText(pf), pfLinePosn(pos), pfCharPosn(pos)) 96 atree 97 98mkAtreeExpandMacros x == 99 -- handle macro expansion. if the macros have args we require that 100 -- we match the correct number of args 101 if x isnt ['MDEF,:.] and x isnt ['DEF,['macro,:.],:.] then 102 atom x and (m := isInterpMacro x) => 103 [args,:body] := m 104 args => 'doNothing 105 x := body 106 x is [op,:argl] => 107 op = 'QUOTE => 'doNothing 108 op = "where" and argl is [before, after] => 109 -- in a where clause, what follows "where" (the "after" parm 110 -- above) might be a local macro, so do not expand the "before" 111 -- part yet 112 x := [op,before,mkAtreeExpandMacros after] 113 argl := [mkAtreeExpandMacros a for a in argl] 114 (m := isInterpMacro op) => 115 [args,:body] := m 116 #args = #argl => 117 sl := [[a,:s] for a in args for s in argl] 118 x := sublisNQ(sl, body) 119 null args => x := [body,:argl] 120 x := [op,:argl] 121 x := [mkAtreeExpandMacros op,:argl] 122 x 123 124mkAtree1 x == 125 -- first special handler for making attrib tree 126 null x => throwKeyedMsg("S2IP0005",['"NIL"]) 127 VECP x => x 128 atom x => 129 x in '(noBranch noMapVal) => x 130 x in '(nil true false) => mkAtree2([x],x,NIL) 131 x = "/throwAway" => 132 -- don't want to actually compute this 133 tree := mkAtree1 '(void) 134 putValue(tree,objNewWrap(voidValue(),$Void)) 135 putModeSet(tree,[$Void]) 136 tree 137 getBasicMode x => 138 v := mkAtreeNode $immediateDataSymbol 139 putValue(v,getBasicObject x) 140 v 141 IDENTP x => mkAtreeNode x 142 keyedSystemError("S2II0002",[x]) 143 x is [op,:argl] => mkAtree2(x,op,argl) 144 systemErrorHere '"mkAtree1" 145 146-- mkAtree2 and mkAtree3 were created because mkAtree1 got so big 147 148mkAtree2(x,op,argl) == 149 nargl := #argl 150 (op= '_-) and (nargl = 1) and (INTEGERP first argl) => 151 mkAtree1(- first argl) 152 op='_: and argl is [y,z] => [mkAtreeNode 'Declare,:argl] 153 op='COLLECT => [mkAtreeNode op,:transformCollect argl] 154 op= 'break => 155 argl is [.,val] => 156 if val = '$NoValue then val := '(void) 157 [mkAtreeNode op,mkAtree1 val] 158 [mkAtreeNode op,mkAtree1 '(void)] 159 op= "return" => 160 argl is [val] => 161 if val = '$NoValue then val := '(void) 162 [mkAtreeNode op,mkAtree1 val] 163 [mkAtreeNode op,mkAtree1 '(void)] 164 op='exit => mkAtree1 CADR argl 165 op = 'QUOTE => [mkAtreeNode op,:argl] 166 op='SEGMENT => 167 argl is [a] => [mkAtreeNode op, mkAtree1 a] 168 z := 169 null argl.1 => nil 170 mkAtree1 argl.1 171 [mkAtreeNode op, mkAtree1 argl.0,z] 172 op in '(pretend is isnt) => 173 [mkAtreeNode op,mkAtree1 first argl,:rest argl] 174 op = '_:_: => 175 [mkAtreeNode 'COERCE,mkAtree1 first argl,CADR argl] 176 x is ['_@, expr, type] => 177 t := evaluateType unabbrev type 178 t = '(DoubleFloat) and expr is [['_$elt, '(Float), 'float], :args] => 179 mkAtree1 [['_$elt, '(DoubleFloat), 'float], :args] 180 t = '(DoubleFloat) and INTEGERP expr => 181 v := mkAtreeNode $immediateDataSymbol 182 putValue(v,getBasicObject float expr) 183 v 184 t = '(Float) and INTEGERP expr => 185 mkAtree1 ["::", expr, t] 186 typeIsASmallInteger(t) and INTEGERP expr => 187 mkAtree1 ["::", expr, t] 188 [mkAtreeNode 'TARGET,mkAtree1 expr, type] 189 (op = "case") and (nargl = 2) => 190 [mkAtreeNode "case", mkAtree1 first argl, unabbrev CADR argl] 191 op='REPEAT => [mkAtreeNode op,:transformREPEAT argl] 192 op='LET and argl is [['construct,:.],rhs] => 193 [mkAtreeNode 'LET,first argl,mkAtree1 rhs] 194 op='LET and argl is [['_:,a,.],rhs] => 195 mkAtree1 ['SEQ,first argl,['LET,a,rhs]] 196 op is ['_$elt,D,op1] => 197 op1 is '_= => 198 a' := [mkAtreeNode '_=,:[mkAtree1 arg for arg in argl]] 199 [mkAtreeNode 'Dollar,D,a'] 200 [mkAtreeNode 'Dollar,D,mkAtree1 [op1,:argl]] 201 op='_$elt => 202 argl is [D,a] => 203 INTEGERP a => 204 a = 0 => mkAtree1 [['_$elt,D,'Zero]] 205 a = 1 => mkAtree1 [['_$elt,D,'One]] 206 t := evaluateType unabbrev [D] 207 typeIsASmallInteger(t) and SINTP a => 208 v := mkAtreeNode $immediateDataSymbol 209 putValue(v,mkObjWrap(a, t)) 210 v 211 mkAtree1 ["*",a,[['_$elt,D,'One]]] 212 [mkAtreeNode 'Dollar,D,mkAtree1 a] 213 keyedSystemError("S2II0003",['"$",argl, 214 '"not qualifying an operator"]) 215 mkAtree3(x,op,argl) 216 217mkAtree3fn(a, b) == 218 a and b => 219 if a = b then a 220 else throwMessage '" double declaration of parameter" 221 a or b 222 223mkAtree3(x,op,argl) == 224 op='REDUCE and argl is [op1,axis,body] => 225 [mkAtreeNode op,axis,mkAtree1 op1,mkAtree1 body] 226 op='has => [mkAtreeNode op, :argl] 227 op='_| => [mkAtreeNode 'AlgExtension,:[mkAtree1 arg for arg in argl]] 228 op='_= => [mkAtreeNode 'equation,:[mkAtree1 arg for arg in argl]] 229 op='not and argl is [["=",lhs,rhs]] => 230 [mkAtreeNode 'not,[mkAtreeNode "=",mkAtree1 lhs,mkAtree1 rhs]] 231 op = "in" and argl is [var, ['SEGMENT, lb, ul]] => 232 upTest:= 233 null ul => NIL 234 mkLessOrEqual(var,ul) 235 lowTest:=mkLessOrEqual(lb,var) 236 z := 237 ul => ['and,lowTest,upTest] 238 lowTest 239 mkAtree1 z 240 x is ['IF,p,'noBranch,a] => mkAtree1 ['IF,['not,p],a,'noBranch] 241 x is ['MDEF,sym,junk1,junk2,val] => 242 -- new macros look like macro f == or macro f(x) === 243 -- so transform into that format 244 mkAtree1 ['DEF,['macro,sym],junk1,junk2,val] 245 x is ["+->",funargs,funbody] => 246 if funbody is [":",body,type] then 247 types := [type] 248 funbody := body 249 else types := [NIL] 250 v := collectDefTypesAndPreds funargs 251 types := [:types,:v.1] 252 [mkAtreeNode 'ADEF,[v.0,types,[NIL for a in types],funbody], 253 if v.2 then v.2 else true, false] 254 x is ['ADEF,arg,:r] => 255 r := mkAtreeValueOf r 256 v := 257 null arg => VECTOR(NIL,NIL,NIL) 258 PAIRP arg and rest arg and first arg~= "|" => 259 collectDefTypesAndPreds ['Tuple,:arg] 260 null rest arg => collectDefTypesAndPreds first arg 261 collectDefTypesAndPreds arg 262 [types,:r'] := r 263 at := [mkAtree3fn(x, y) for x in rest types for y in v.1] 264 r := [[first types,:at],:r'] 265 [mkAtreeNode 'ADEF,[v.0,:r],if v.2 then v.2 else true,false] 266 x is ["where", before, after] => 267 [mkAtreeNode "where", before, mkAtree1 after] 268 x is ['DEF,['macro,form],.,.,body] => 269 [mkAtreeNode 'MDEF,form,body] 270 x is ['DEF,a,:r] => 271 r := mkAtreeValueOf r 272 a is [op,:arg] => 273 v := 274 null arg => VECTOR(NIL,NIL,NIL) 275 PAIRP arg and rest arg and first arg~= "|" => 276 collectDefTypesAndPreds ['Tuple,:arg] 277 null rest arg => collectDefTypesAndPreds first arg 278 collectDefTypesAndPreds arg 279 [types,:r'] := r 280 at := [mkAtree3fn(x, y) for x in rest types for y in v.1] 281 r := [[first types,:at],:r'] 282 [mkAtreeNode 'DEF,[[op,:v.0],:r],if v.2 then v.2 else true,false] 283 [mkAtreeNode 'DEF,[a,:r],true,false] 284--x is ['when,y,pred] => 285-- y isnt ['DEF,a,:r] => 286-- keyedSystemError("S2II0003",['"when",y,'"improper argument form"]) 287-- a is [op,p1,:pr] => 288-- null pr => mkAtree1 ['DEF,[op,["|",p1,pred]],:r] 289-- mkAtree1 ['DEF,[op,["|",['Tuple,p1,:pr],pred]],:r] 290-- [mkAtreeNode 'DEF, rest y, pred, false] 291--x is ['otherwise,u] => 292-- throwMessage '" otherwise is no longer supported." 293 z := 294 getBasicMode op => 295 v := mkAtreeNode $immediateDataSymbol 296 putValue(v,getBasicObject op) 297 v 298 atom op => mkAtreeNode op 299 mkAtree1 op 300 [z,:[mkAtree1 y for y in argl]] 301 302addPred(old, new) == 303 null new => old 304 null old => new 305 ['and, old, new] 306 307collectDefTypesAndPreds args == 308 -- given an arglist to a DEF-like form, this function returns 309 -- a vector of three things: 310 -- slot 0: just the variables 311 -- slot 1: the type declarations on the variables 312 -- slot 2: a predicate for all arguments 313 pred := types := vars := NIL 314 junk := 315 IDENTP args => 316 types := [NIL] 317 vars := [args] 318 args is [":",var,type] => 319 types := [type] 320 var is ["|",var',p] => 321 vars := [var'] 322 pred := addPred(pred, p) 323 vars := [var] 324 args is ["|",var,p] => 325 pred := addPred(pred,p) 326 var is [":",var',type] => 327 types := [type] 328 vars := [var'] 329 var is ['Tuple,:.] or var is ["|",:.] => 330 v := collectDefTypesAndPreds var 331 vars := [:vars,:v.0] 332 types := [:types,:v.1] 333 pred := addPred(pred,v.2) 334 vars := [var] 335 types := [NIL] 336 args is ['Tuple,:args'] => 337 for a in args' repeat 338 v := collectDefTypesAndPreds a 339 vars := [:vars,first v.0] 340 types := [:types,first v.1] 341 pred := addPred(pred,v.2) 342 types := [NIL] 343 vars := [args] 344 VECTOR(vars,types,pred) 345 346mkAtreeValueOf l == 347 -- scans for ['valueOf,atom] 348 not CONTAINED('valueOf,l) => l 349 mkAtreeValueOf1 l 350 351mkAtreeValueOf1 l == 352 null l or atom l or null rest l => l 353 l is ['valueOf,u] and IDENTP u => 354 v := mkAtreeNode $immediateDataSymbol 355 putValue(v,get(u,'value,$InteractiveFrame) or 356 objNewWrap(u,['Variable,u])) 357 v 358 [mkAtreeValueOf1 x for x in l] 359 360mkLessOrEqual(lhs,rhs) == ['not,['_<,rhs,lhs]] 361 362emptyAtree expr == 363 -- remove mode, value, and misc. info from attrib tree 364 VECP expr => 365 $immediateDataSymbol = expr.0 => nil 366 expr.1:= NIL 367 expr.2:= NIL 368 expr.3:= NIL 369 -- kill proplist too? 370 atom expr => nil 371 for e in expr repeat emptyAtree e 372 373unVectorize body == 374 -- transforms from an atree back into a tree 375 VECP body => 376 name := getUnname body 377 name ~= $immediateDataSymbol => name 378 objValUnwrap getValue body 379 atom body => body 380 body is [op,:argl] => 381 newOp:=unVectorize op 382 if newOp = 'SUCHTHAT then newOp := '_| 383 if newOp = 'COERCE then newOp := '_:_: 384 if newOp = 'Dollar then newOp := "$elt" 385 [newOp,:unVectorize argl] 386 systemErrorHere '"unVectorize" 387 388 389-- Stuffing and Getting Info 390 391putAtree(x,prop,val) == 392 x is [op,:.] => 393 -- only willing to add property if op is a vector 394 -- otherwise will be pushing to deeply into calling structure 395 if VECP op then putAtree(op,prop,val) 396 x 397 null VECP x => x -- just ignore it 398 n := QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) 399 => x.n := val 400 x.4 := insertShortAlist(prop,val,x.4) 401 x 402 403getAtree(x,prop) == 404 x is [op,:.] => 405 -- only willing to get property if op is a vector 406 -- otherwise will be pushing to deeply into calling structure 407 VECP op => getAtree(op,prop) 408 NIL 409 null VECP x => NIL -- just ignore it 410 n:= QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) 411 => x.n 412 QLASSQ(prop,x.4) 413 414putTarget(x, targ) == 415 -- want to put nil modes perhaps to clear old target 416 if targ = $EmptyMode then targ := nil 417 putAtree(x,'target,targ) 418 419getTarget(x) == getAtree(x,'target) 420 421insertShortAlist(prop,val,al) == 422 pair := ASSQ(prop,al) => 423 RPLACD(pair,val) 424 al 425 [[prop,:val],:al] 426 427transferPropsToNode(x,t) == 428 propList := getProplist(x,$env) 429 QLASSQ('Led,propList) or QLASSQ('Nud,propList) => nil 430 node := 431 VECP t => t 432 first t 433 for prop in '(mode localModemap value name generatedCode) 434 repeat transfer(x,node,prop) 435 where 436 transfer(x,node,prop) == 437 u := get(x,prop,$env) => putAtree(node,prop,u) 438 (not (x in $localVars)) and (u := get(x,prop,$e)) => 439 putAtree(node,prop,u) 440 if not getMode(t) and (am := get(x,'automode,$env)) then 441 putModeSet(t,[am]) 442 putMode(t,am) 443 t 444 445isLeaf x == atom x --may be a number or a vector 446 447getMode x == 448 x is [op,:.] => getMode op 449 VECP x => x.1 450 m := getBasicMode x => m 451 keyedSystemError("S2II0001",[x]) 452 453putMode(x,y) == 454 x is [op,:.] => putMode(op,y) 455 null VECP x => keyedSystemError("S2II0001",[x]) 456 x.1 := y 457 458getValue x == 459 VECP x => x.2 460 atom x => 461 t := getBasicObject x => t 462 keyedSystemError("S2II0001",[x]) 463 getValue first x 464 465putValue(x,y) == 466 x is [op,:.] => putValue(op,y) 467 null VECP x => keyedSystemError("S2II0001",[x]) 468 x.2 := y 469 470putValueValue(vec,val) == 471 putValue(vec,val) 472 vec 473 474getUnnameIfCan x == 475 VECP x => x.0 476 x is [op,:.] => getUnnameIfCan op 477 atom x => x 478 nil 479 480getUnname x == 481 x is [op,:.] => getUnname op 482 getUnname1 x 483 484getUnname1 x == 485 VECP x => x.0 486 null atom x => keyedSystemError("S2II0001",[x]) 487 x 488 489computedMode t == 490 getModeSet t is [m] => m 491 keyedSystemError("S2GE0016",['"computedMode",'"non-singleton modeset"]) 492 493putModeSet(x,y) == 494 x is [op,:.] => putModeSet(op,y) 495 not VECP x => keyedSystemError("S2II0001",[x]) 496 x.3 := y 497 y 498 499getModeOrFirstModeSetIfThere x == 500 x is [op,:.] => getModeOrFirstModeSetIfThere op 501 VECP x => 502 m := x.1 => m 503 val := x.2 => objMode val 504 y := x.aModeSet => 505 (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => m 506 first y 507 NIL 508 m := getBasicMode x => m 509 NIL 510 511getModeSet x == 512 x and PAIRP x => getModeSet first x 513 VECP x => 514 y:= x.aModeSet => 515 (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => 516 [m] 517 y 518 keyedSystemError("S2GE0016",['"getModeSet",'"no mode set"]) 519 m:= getBasicMode x => [m] 520 null atom x => getModeSet first x 521 keyedSystemError("S2GE0016",['"getModeSet", 522 '"not an attributed tree"]) 523 524getModeSetUseSubdomain x == 525 x and PAIRP x => getModeSetUseSubdomain first x 526 VECP(x) => 527 -- don't play subdomain games with retracted args 528 getAtree(x,'retracted) => getModeSet x 529 y := x.aModeSet => 530 (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => 531 [m] 532 val := getValue x 533 (x.0 = $immediateDataSymbol) and (y = [$Integer]) => 534 val := objValUnwrap val 535 m := getBasicMode0(val,true) 536 x.2 := objNewWrap(val,m) 537 x.aModeSet := [m] 538 [m] 539 null val => y 540 isEqualOrSubDomain(objMode(val),$Integer) and 541 INTEGERP(f := objValUnwrap val) => 542 [getBasicMode0(f,true)] 543 y 544 keyedSystemError("S2GE0016", 545 ['"getModeSetUseSubomain",'"no mode set"]) 546 m := getBasicMode0(x,true) => [m] 547 null atom x => getModeSetUseSubdomain first x 548 keyedSystemError("S2GE0016", 549 ['"getModeSetUseSubomain",'"not an attributed tree"]) 550 551 552--% Environment Utilities 553 554-- getValueFromEnvironment(x,mode) == 555-- $failure ~= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v 556-- $failure ~= (v := getValueFromSpecificEnvironment(x,mode,$e)) => v 557-- throwKeyedMsg("S2IE0001",[x]) 558getValueFromEnvironment(x,mode) == 559 $failure ~= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v 560 $failure ~= (v := getValueFromSpecificEnvironment(x,mode,$e)) => v 561 null(v := coerceInt(objNew(x, ['Variable, x]), mode)) => 562 throwKeyedMsg("S2IE0001",[x]) 563 objValUnwrap v 564 565getValueFromSpecificEnvironment(id,mode,e) == 566 PAIRP e => 567 u := get(id,'value,e) => 568 objMode(u) = $EmptyMode => 569 systemErrorHere '"getValueFromSpecificEnvironment" 570 v := objValUnwrap u 571 mode isnt ['Mapping,:mapSig] => v 572 v isnt ['SPADMAP, :.] => v 573 v' := coerceInt(u,mode) 574 null v' => throwKeyedMsg("S2IC0002",[objMode u,mode]) 575 objValUnwrap v' 576 577 m := get(id,'mode,e) => 578 -- See if we can make it into declared mode from symbolic form 579 -- For example, (x : P[x] I; x + 1) 580 if isPartialMode(m) then m' := resolveTM(['Variable,id],m) 581 else m' := m 582 m' and 583 (u := coerceInteractive(objNewWrap(id,['Variable,id]),m')) => 584 objValUnwrap u 585 586 throwKeyedMsg("S2IE0002",[id,m]) 587 $failure 588 $failure 589 590addBindingInteractive(var,proplist,e is [[curContour,:.],:.]) == 591 -- change proplist of var in e destructively 592 u := ASSQ(var,curContour) => 593 RPLACD(u,proplist) 594 e 595 rplac(CAAR e, [[var, :proplist], :curContour]) 596 e 597 598augProplistInteractive(proplist,prop,val) == 599 u := ASSQ(prop,proplist) => 600 RPLACD(u,val) 601 proplist 602 [[prop,:val],:proplist] 603 604getFlag x == get("--flags--",x,$e) 605 606putFlag(flag,value) == 607 $e := put ("--flags--", flag, value, $e) 608 609get(x,prop,e) == 610 $InteractiveMode => get0(x,prop,e) 611 get1(x,prop,e) 612 613get0(x,prop,e) == 614 null atom x => get(QCAR x,prop,e) 615 (pl := getProplist(x, e)) => QLASSQ(prop, pl) 616 nil 617 618get1(x,prop,e) == 619 --this is the old get 620 negHash := nil 621 null atom x => get(QCAR x,prop,e) 622 if $envHashTable and (not(EQ($CategoryFrame, e))) and (not(EQ(prop, "modemap"))) then 623 null (HGET($envHashTable, [x, prop])) => return nil 624 negHash := null (HGET($envHashTable, [x, prop])) 625 prop="modemap" and $insideCapsuleFunctionIfTrue=true => 626 ress := LASSOC("modemap",getProplist(x,$CapsuleModemapFrame)) 627 or get2(x,prop,e) 628 -- SAY ["get1", x, prop, ress and true] 629 ress 630 ress := LASSOC(prop,getProplist(x,e)) or get2(x,prop,e) 631 if ress and negHash then 632 SAY ["get1", x, prop, ress and true] 633 ress 634 635get2(x,prop,e) == 636 prop="modemap" and constructor? x => 637 (u := getConstructorModemap(x)) => [u] 638 nil 639 nil 640 641getI(x,prop) == get(x,prop,$InteractiveFrame) 642 643putI(x,prop,val) == ($InteractiveFrame := put(x,prop,val,$InteractiveFrame)) 644 645getIProplist x == getProplist(x,$InteractiveFrame) 646 647rempropI(x,prop) == 648 id:= 649 atom x => x 650 first x 651 getI(id,prop) => 652 recordNewValue(id,prop,NIL) 653 recordOldValue(id,prop,getI(id,prop)) 654 $InteractiveFrame:= remprop(id,prop,$InteractiveFrame) 655 656remprop(x,prop,e) == 657 u:= assoc(prop,pl:= getProplist(x,e)) => 658 e:= addBinding(x,DELASC(first u,pl),e) 659 e 660 e 661 662fastSearchCurrentEnv(x,currentEnv) == 663 u := QLASSQ(x, first currentEnv) => u 664 while (currentEnv:= QCDR currentEnv) repeat 665 u := QLASSQ(x, first currentEnv) => u 666 667put(x,prop,val,e) == 668 $InteractiveMode and not EQ(e,$CategoryFrame) => 669 putIntSymTab(x,prop,val,e) 670 --e must never be $CapsuleModemapFrame 671 null atom x => put(first x,prop,val,e) 672 newProplist:= augProplistOf(x,prop,val,e) 673 prop="modemap" and $insideCapsuleFunctionIfTrue=true => 674 SAY ["**** modemap PUT on CapsuleModemapFrame: ",val] 675 $CapsuleModemapFrame:= 676 addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame), 677 $CapsuleModemapFrame) 678 e 679 addBinding(x,newProplist,e) 680 681putIntSymTab(x,prop,val,e) == 682 null atom x => putIntSymTab(first x,prop,val,e) 683 pl0 := pl := search(x,e) 684 pl := 685 null pl => [[prop,:val]] 686 u := ASSQ(prop,pl) => 687 RPLACD(u,val) 688 pl 689 lp := LASTNODE pl 690 u := [[prop,:val]] 691 RPLACD(lp,u) 692 pl 693 EQ(pl0,pl) => e 694 addIntSymTabBinding(x,pl,e) 695 696addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) == 697 -- change proplist of var in e destructively 698 u := ASSQ(var,curContour) => 699 RPLACD(u,proplist) 700 e 701 rplac(CAAR e, [[var, :proplist], :curContour]) 702 e 703 704 705--% Source and position information 706 707-- In the following, src is a string containing an original input line, 708-- line is the line number of the string within the source file, 709-- and col is the index within src of the start of the form represented 710-- by x. x is a VAT. 711 712putSrcPos(x, file, src, line, col) == 713 putAtree(x, 'srcAndPos, srcPos_New(file, src, line, col)) 714 715getSrcPos(x) == getAtree(x, 'srcAndPos) 716 717srcPosNew(file, src, line, col) == LIST2VEC [file, src, line, col] 718 719srcPosFile(sp) == 720 if sp then sp.0 else nil 721 722srcPosSource(sp) == 723 if sp then sp.1 else nil 724 725srcPosLine(sp) == 726 if sp then sp.2 else nil 727 728srcPosColumn(sp) == 729 if sp then sp.3 else nil 730 731srcPosDisplay(sp) == 732 null sp => nil 733 s := STRCONC('"_"", srcPosFile sp, '"_", line ", 734 STRINGIMAGE srcPosLine sp, '": ") 735 sayBrightly [s, srcPosSource sp] 736 col := srcPosColumn sp 737 dots := 738 col = 0 => '"" 739 fillerSpaces(col, '".") 740 sayBrightly [fillerSpaces(#s, '" "), dots, '"^"] 741 true 742 743--% Functions on interpreter objects 744 745-- Interpreter objects used to be called triples because they had the 746-- structure [value, type, environment]. For many years, the environment 747-- was not used, so finally in January, 1990, the structure of objects 748-- was changed to be (type . value). This was chosen because it was the 749-- structure of objects of type Any. Sometimes the values are wrapped 750-- (see the function isWrapped to see what this means physically). 751-- Wrapped values are not actual values belonging to their types. An 752-- unwrapped value must be evaluated to get an actual value. A wrapped 753-- value must be unwrapped before being passed to a library function. 754-- Typically, an unwrapped value in the interpreter consists of LISP 755-- code, e.g., parts of a function that is being constructed. 756-- RSS 1/14/90 757 758-- These are the new structure functions. 759 760mkObj(val, mode) == CONS(mode,val) -- old names 761mkObjWrap(val, mode) == CONS(mode,wrap val) 762mkObjCode(val, mode) == ['CONS, MKQ mode,val ] 763 764objNew(val, mode) == CONS(mode,val) -- new names as of 10/14/93 765objNewWrap(val, mode) == CONS(mode,wrap val) 766objNewCode(val, mode) == ['CONS, MKQ mode,val ] 767objSetVal(obj,val) == RPLACD(obj,val) 768objSetMode(obj,mode) == RPLACA(obj,mode) 769 770objVal obj == rest obj 771objValUnwrap obj == unwrap rest obj 772objMode obj == first obj 773 774objCodeVal obj == CADDR obj 775objCodeMode obj == CADR obj 776 777 778 779 780--% Library compiler structures needed by the interpreter 781 782-- Tuples and Crosses 783 784asTupleNew(size, listOfElts) == CONS(size, LIST2VEC listOfElts) 785asTupleNew0(listOfElts) == CONS(#listOfElts, LIST2VEC listOfElts) 786 787asTupleNewCode(size, listOfElts) == ["asTupleNew", size, ['LIST, :listOfElts]] 788asTupleNewCode0(listForm) == ["asTupleNew0", listForm] 789 790asTupleSize(at) == first at 791asTupleAsVector(at) == rest at 792asTupleAsList(at) == VEC2LIST asTupleAsVector at 793