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-- Functions which require special handlers (also see end of file) 35DEFPARAMETER($specialOps, [ _ 36 "ADEF", "AlgExtension", "and", "case", "COERCE", "COLLECT", "construct", "Declare", "DEF", "Dollar", _ 37 "equation", "error", "free", "has", "IF", "is", "isnt", "iterate", "break", "LET", "local", "MDEF", "or", _ 38 "pretend", "QUOTE", "REDUCE", "REPEAT", "return", "SEQ", "TARGET", "Tuple", "typeOf", "where" ]) 39 40--% Handlers for map definitions 41 42upDEF t == 43 -- performs map definitions. value is thrown away 44 t isnt [op,def,pred,.] => nil 45 v:=addDefMap(['DEF,:def],pred) 46 null(LISTP(def)) or null(def) => 47 keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) 48 mapOp := first def 49 if LISTP(mapOp) then 50 null mapOp => 51 keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) 52 mapOp := first mapOp 53 put(mapOp,'value,v,$e) 54 putValue(op,objNew(voidValue(), $Void)) 55 putModeSet(op,[$Void]) 56 57--% Handler for package calling and $ constants 58 59upDollar t == 60 -- Puts "dollar" property in atree node, and calls bottom up 61 t isnt [op,D,form] => nil 62 t2 := t 63 (not $genValue) and or/[CONTAINED(var,D) for var in $localVars] => 64 keyedMsgCompFailure("S2IS0032",NIL) 65 EQ(D,'Lisp) => upLispCall(op,form) 66 if VECP D and (SIZE(D) > 0) then D := D.0 67 t := evaluateType unabbrev D 68 categoryForm? t => 69 throwKeyedMsg("S2IE0012", [t]) 70 f := getUnname form 71 if f = $immediateDataSymbol then 72 f := objValUnwrap coerceInteractive(getValue form,$OutputForm) 73 if f = '(construct) then f := "nil" 74 ATOM(form) and (f ~= $immediateDataSymbol) and 75 (u := findUniqueOpInDomain(op,f,t)) => u 76 f in '(One Zero true false nil) and constantInDomain?([f],t) => 77 isPartialMode t => throwKeyedMsg("S2IS0020",NIL) 78 if $genValue then 79 val := wrap getConstantFromDomain([f],t) 80 else val := ['getConstantFromDomain,['LIST,MKQ f],MKQ t] 81 putValue(op,objNew(val,t)) 82 putModeSet(op,[t]) 83 84 nargs := #rest form 85 86 (ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms 87 88 f ~= 'construct and null isOpInDomain(f,t,nargs) => 89 throwKeyedMsg("S2IS0023",[f,t]) 90 if (sig := findCommonSigInDomain(f,t,nargs)) then 91 for x in sig for y in form repeat 92 if x then putTarget(y,x) 93 putAtree(first form,'dollar,t) 94 ms := bottomUp form 95 f in '(One Zero) and PAIRP(ms) and first(ms) = $OutputForm => 96 throwKeyedMsg("S2IS0021",[f,t]) 97 putValue(op,getValue first form) 98 putModeSet(op,ms) 99 100 101upDollarTuple(op, f, t, t2, args, nargs) == 102 -- this function tries to find a tuple function to use 103 nargs = 1 and getUnname first args = "Tuple" => NIL 104 nargs = 1 and (ms := bottomUp first args) and ms is [["Tuple",.]] => NIL 105 null (singles := isOpInDomain(f,t,1)) => NIL 106 tuple := NIL 107 for [[.,arg], :.] in singles while null tuple repeat 108 if arg is ['Tuple,.] then tuple := arg 109 null tuple => NIL 110 [.,D,form] := t2 111 newArg := [mkAtreeNode "Tuple",:args] 112 putTarget(newArg, tuple) 113 ms := bottomUp newArg 114 first ms ~= tuple => NIL 115 form := [first form, newArg] 116 putAtree(first form,'dollar,t) 117 ms := bottomUp form 118 putValue(op,getValue first form) 119 putModeSet(op,ms) 120 121upLispCall(op,t) == 122 -- process $Lisp calls 123 if atom t then code:=getUnname t else 124 [lispOp,:argl]:= t 125 not(functionp(lispOp.0) or macrop(lispOp.0)) => 126 throwKeyedMsg("S2IS0024",[lispOp.0]) 127 for arg in argl repeat bottomUp arg 128 code:=[getUnname lispOp, 129 :[getArgValue(arg,computedMode arg) for arg in argl]] 130 code := 131 $genValue => wrap timedEVALFUN code 132 code 133 rt := '(SExpression) 134 putValue(op,objNew(code,rt)) 135 putModeSet(op,[rt]) 136 137--% Handlers for equation 138 139upequation tree == 140 -- only handle this if there is a target of Boolean 141 -- this should speed things up a bit 142 tree isnt [op,lhs,rhs] => NIL 143 $Boolean ~= getTarget(op) => NIL 144 null VECP op => NIL 145 -- change equation into '=' 146 op.0 := "=" 147 bottomUp tree 148 149--% Handler for error 150 151uperror t == 152 -- when compiling a function, this merely inserts another argument 153 -- which is the name of the function. 154 not $compilingMap => NIL 155 t isnt [op,msg] => NIL 156 msgMs := bottomUp msg 157 msgMs isnt [=$String] => NIL 158 RPLACD(t,[mkAtree object2String $mapName,msg]) 159 bottomUp t 160 161--% Handlers for free and local 162 163upfree t == 164 putValue(t,objNew('(voidValue),$Void)) 165 putModeSet(t,[$Void]) 166 167uplocal t == 168 putValue(t,objNew('(voidValue),$Void)) 169 putModeSet(t,[$Void]) 170 171upfreeWithType(var,type) == 172 sayKeyedMsg("S2IS0055",['"free",var]) 173 var 174 175uplocalWithType(var,type) == 176 sayKeyedMsg("S2IS0055",['"local",var]) 177 var 178 179--% Handlers for has 180 181uphas t == 182 t isnt [op,type,prop] => nil 183 -- handler for category and attribute queries 184 type := 185 isLocalVar(type) => ['unabbrev, type] 186 MKQ unabbrev type 187 catCode := 188 prop := unabbrev SUBST('$, '%, prop) 189 prop is [":", :.] => MKQ prop 190 ['evaluateType, MKQ prop] 191 code:=['newHasTest,['evaluateType, type], catCode] 192 if $genValue then code := wrap timedEVALFUN code 193 putValue(op,objNew(code,$Boolean)) 194 putModeSet(op,[$Boolean]) 195 196--% Handlers for IF 197 198upIF t == 199 t isnt [op,cond,a,b] => nil 200 bottomUpPredicate(cond,'"if/when") 201 $genValue => interpIF(op,cond,a,b) 202 compileIF(op,cond,a,b,t) 203 204compileIF(op,cond,a,b,t) == 205 -- type analyzer for compiled case where types of both branches of 206 -- IF are resolved. 207 ms1 := bottomUp a 208 [m1] := ms1 209 b = 'noBranch => 210 evalIF(op,rest t,$Void) 211 putModeSet(op,[$Void]) 212 b = 'noMapVal => 213 -- if this was a return statement, we take the mode to be that 214 -- of what is being returned. 215 if getUnname a = "return" then 216 ms1 := bottomUp CADR a 217 [m1] := ms1 218 evalIF(op,rest t,m1) 219 putModeSet(op,ms1) 220 ms2 := bottomUp b 221 [m2] := ms2 222 m:= 223 m2=m1 => m1 224 m2 = $Exit => m1 225 m1 = $Exit => m2 226 if EQCAR(m1,'Symbol) then 227 m1:=getMinimalVarMode(getUnname a,$declaredMode) 228 if EQCAR(m2,'Symbol) then 229 m2:=getMinimalVarMode(getUnname b,$declaredMode) 230 (r := resolveTTAny(m2,m1)) => r 231 rempropI($mapName,'localModemap) 232 rempropI($mapName,'localVars) 233 rempropI($mapName,'mapBody) 234 throwKeyedMsg("S2IS0026",[m2,m1]) 235 evalIF(op,rest t,m) 236 putModeSet(op,[m]) 237 238evalIF(op,[cond,a,b],m) == 239 -- generate code form compiled IF 240 elseCode:= 241 b='noMapVal => 242 [[MKQ true, ['throwKeyedMsg,MKQ "S2IM0018", 243 ['CONS,MKQ object2Identifier $mapName,NIL]]]] 244 b = 'noBranch => [[MKQ true, ['voidValue]]] 245 [[MKQ true,genIFvalCode(b,m)]] 246 code:=['COND,[getArgValue(cond,$Boolean), 247 genIFvalCode(a,m)],:elseCode] 248 triple:= objNew(code,m) 249 putValue(op,triple) 250 251genIFvalCode(t,m) == 252 -- passes type information down braches of IF statement 253 -- So that coercions can be performed on data at branches of IF. 254 m1 := computedMode t 255 m1=m => getArgValue(t,m) 256 code:=objVal getValue t 257 IFcodeTran(code,m,m1) 258 259IFcodeTran(code,m,m1) == 260 -- coerces values at branches of IF 261 null code => code 262 code is ['spadThrowBrightly,:.] => code 263 m1 = $Exit => code 264 code isnt ['COND,[p1,a1],[''T,a2]] => 265 m = $Void => code 266 code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) => 267 wrapped2Quote objVal code' 268 throwKeyedMsgCannotCoerceWithValue(quote2Wrapped code,m1,m) 269 a1:=IFcodeTran(a1,m,m1) 270 a2:=IFcodeTran(a2,m,m1) 271 ['COND,[p1,a1],[''T,a2]] 272 273interpIF(op,cond,a,b) == 274 -- non-compiled version of IF type analyzer. Doesn't resolve across 275 -- branches of the IF. 276 val:= getValue cond 277 val:= coerceInteractive(val,$Boolean) => 278 objValUnwrap(val) => upIFgenValue(op,a) 279 EQ(b,'noBranch) => 280 putValue(op,objNew(voidValue(), $Void)) 281 putModeSet(op,[$Void]) 282 upIFgenValue(op,b) 283 throwKeyedMsg("S2IS0031",NIL) 284 285upIFgenValue(op,tree) == 286 -- evaluates tree and transfers the results to op 287 ms:=bottomUp tree 288 val:= getValue tree 289 putValue(op,val) 290 putModeSet(op,ms) 291 292--% Handlers for is 293 294upis t == 295 t isnt [op,a,pattern] => nil 296 $opIsIs : local := true 297 upisAndIsnt t 298 299upisnt t == 300 t isnt [op,a,pattern] => nil 301 $opIsIs : local := nil 302 upisAndIsnt t 303 304upisAndIsnt(t:=[op,a,pattern]) == 305 -- handler for "is" pattern matching 306 mS:= bottomUp a 307 mS isnt [m] => 308 keyedSystemError("S2GE0016",['"upisAndIsnt",'"non-unique modeset"]) 309 putPvarModes(removeConstruct pattern,m) 310 evalis(op,rest t,m) 311 putModeSet(op,[$Boolean]) 312 313putPvarModes(pattern,m) == 314 -- Puts the modes for the pattern variables into $env 315 m isnt ['List,um] => throwKeyedMsg("S2IS0030",NIL) 316 for pvar in pattern repeat 317 IDENTP pvar => put(pvar, 'mode, um, $env) 318 pvar is ['_:, var] => put(var, 'mode, m, $env) 319 pvar is ['_=, var] => put(var, 'mode, um, $env) 320 putPvarModes(pvar, um) 321 322evalis(op,[a,pattern],mode) == 323 -- actually handles is and isnt 324 if $opIsIs 325 then fun := 'evalIsPredicate 326 else fun := 'evalIsntPredicate 327 if isLocalPred pattern then 328 code:= compileIs(a,pattern) 329 else code:=[fun,getArgValue(a,mode), 330 MKQ pattern,MKQ mode] 331 triple:= 332 $genValue => objNewWrap(timedEVALFUN code,$Boolean) 333 objNew(code,$Boolean) 334 putValue(op,triple) 335 336isLocalPred pattern == 337 -- returns true if the is predicate is to be compiled 338 for pat in pattern repeat 339 IDENTP pat and isLocalVar(pat) => return true 340 pat is ['_:,var] and isLocalVar(var) => return true 341 pat is ['_=,var] and isLocalVar(var) => return true 342 343compileIs(val,pattern) == 344 -- produce code for compiled "is" predicate. makes pattern variables 345 -- into local variables of the function 346 vars:= NIL 347 for pat in rest pattern repeat 348 IDENTP(pat) and isLocalVar(pat) => vars:=[pat,:vars] 349 pat is ['_:,var] => vars:= [var,:vars] 350 pat is ['_=,var] => vars:= [var,:vars] 351 predCode:=['LET,g:=GENSYM(),['isPatternMatch, 352 getArgValue(val,computedMode val),MKQ removeConstruct pattern]] 353 for var in REMDUP vars repeat 354 assignCode:=[['LET,var,['CDR,['ASSQ,MKQ var,g]]],:assignCode] 355 null $opIsIs => 356 ['COND,[['EQ,predCode,MKQ 'failed],['SEQ,:assignCode,MKQ 'T]]] 357 ['COND,[['NOT,['EQ,predCode,MKQ 'failed]],['SEQ,:assignCode,MKQ 'T]]] 358 359evalIsPredicate(value,pattern,mode) == 360 --This function pattern matches value to pattern, and returns 361 --true if it matches, and false otherwise. As a side effect 362 --if the pattern matches then the bindings given in the pattern 363 --are made 364 pattern:= removeConstruct pattern 365 not ((valueAlist:=isPatternMatch(value,pattern))='failed) => 366 for [id,:value] in valueAlist repeat 367 evalLETchangeValue(id,objNewWrap(value,get(id,'mode,$env))) 368 true 369 false 370 371evalIsntPredicate(value,pattern,mode) == 372 evalIsPredicate(value,pattern,mode) => NIL 373 'TRUE 374 375removeConstruct pat == 376 -- removes the "construct" from the beginning of patterns 377 if pat is ['construct,:p] then pat:=p 378 if pat is ['cons, a, b] then pat := [a, ['_:, b]] 379 atom pat => pat 380 RPLACA(pat, removeConstruct first pat) 381 RPLACD(pat, removeConstruct rest pat) 382 pat 383 384isPatternMatch(l,pats) == 385 -- perform the actual pattern match 386 $subs: local := NIL 387 isPatMatch(l,pats) 388 $subs 389 390isPatMatch(l,pats) == 391 null pats => 392 null l => $subs 393 $subs:='failed 394 null l => 395 null pats => $subs 396 pats is [['_:,var]] => 397 $subs := [[var],:$subs] 398 $subs:='failed 399 pats is [pat,:restPats] => 400 IDENTP pat => 401 $subs:=[[pat,:first l],:$subs] 402 isPatMatch(rest l,restPats) 403 pat is ['_=,var] => 404 p:=ASSQ(var,$subs) => 405 first l = rest p => isPatMatch(rest l, restPats) 406 $subs:='failed 407 $subs:='failed 408 pat is ['_:,var] => 409 n:=#restPats 410 m:=#l-n 411 m<0 => $subs:='failed 412 ZEROP n => $subs:=[[var,:l],:$subs] 413 $subs:=[[var,:[x for x in l for i in 1..m]],:$subs] 414 isPatMatch(DROP(m,l),restPats) 415 isPatMatch(first l,pat) = 'failed => 'failed 416 isPatMatch(rest l,restPats) 417 keyedSystemError("S2GE0016",['"isPatMatch", 418 '"unknown form of is predicate"]) 419 420--% Handler for iterate 421 422upiterate t == 423 null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"]) 424 $iterateCount := $iterateCount + 1 425 code := ['THROW,$repeatBodyLabel,'(voidValue)] 426 $genValue => THROW(eval $repeatBodyLabel,voidValue()) 427 putValue(t,objNew(code,$Void)) 428 putModeSet(t,[$Void]) 429 430--% Handler for break 431 432upbreak t == 433 t isnt [op,.] => nil 434 null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"]) 435 $breakCount := $breakCount + 1 436 code := ['THROW,$repeatLabel,'(voidValue)] 437 $genValue => THROW(eval $repeatLabel,voidValue()) 438 putValue(op,objNew(code,$Void)) 439 putModeSet(op,[$Void]) 440 441--% Handlers for LET 442 443upLET t == 444 -- analyzes and evaluates the righthand side, and does the variable 445 -- binding 446 t isnt [op,lhs,rhs] => nil 447 $declaredMode: local := NIL 448 PAIRP lhs => 449 var:= getUnname first lhs 450 var = 'construct => upLETWithPatternOnLhs t 451 var = 'QUOTE => throwKeyedMsg("S2IS0027",['"A quoted form"]) 452 upLETWithFormOnLhs(op,lhs,rhs) 453 var:= getUnname lhs 454 var = $immediateDataSymbol => 455 -- following will be immediate data, so probably ok to not 456 -- specially format it 457 obj := objValUnwrap coerceInteractive(getValue lhs,$OutputForm) 458 throwKeyedMsg("S2IS0027",[obj]) 459 var in '(% %%) => -- for history 460 throwKeyedMsg("S2IS0027",[var]) 461 (IDENTP var) and not (var in '(true false elt QUOTE)) => 462 var ~= (var' := unabbrev(var)) => -- constructor abbreviation 463 throwKeyedMsg("S2IS0028",[var,var']) 464 if get(var,'isInterpreterFunction,$e) then 465 putHist(var,'isInterpreterFunction,false,$e) 466 sayKeyedMsg("S2IS0049",['"Function",var]) 467 else if get(var,'isInterpreterRule,$e) then 468 putHist(var,'isInterpreterRule,false,$e) 469 sayKeyedMsg("S2IS0049",['"Rule",var]) 470 not isTupleForm(rhs) and (m := isType rhs) => upLETtype(op,lhs,m) 471 transferPropsToNode(var,lhs) 472 if ( m:= getMode(lhs) ) then 473 $declaredMode := m 474 putTarget(rhs,m) 475 if (val := getValue lhs) and (objMode val = $Boolean) and 476 getUnname(rhs) = 'equation then putTarget(rhs,$Boolean) 477 (rhsMs:= bottomUp rhs) = [$Void] => 478 throwKeyedMsg("S2IS0034",[var]) 479 val:=evalLET(lhs,rhs) 480 putValue(op,val) 481 putModeSet(op,[objMode(val)]) 482 throwKeyedMsg("S2IS0027",[var]) 483 484isTupleForm f == 485 -- have to do following since "Tuple" is an internal form name 486 getUnname f ~= "Tuple" => false 487 f is [op,:args] and VECP(op) and getUnname(op) = "Tuple" => 488 #args ~= 1 => true 489 isTupleForm first args => true 490 isType first args => false 491 true 492 false 493 494evalLET(lhs,rhs) == 495 -- lhs is a vector for a variable, and rhs is the evaluated atree 496 -- for the value which is coerced to the mode of lhs 497 $useConvertForCoercions: local := true 498 v' := (v:= getValue rhs) 499 ((not getMode lhs) and (getModeSet rhs is [.])) or 500 get(getUnname lhs,'autoDeclare,$env) => 501 v:= 502 $genValue => v 503 objNew(wrapped2Quote objVal v,objMode v) 504 evalLETput(lhs,v) 505 t1:= objMode v 506 t2' := (t2 := getMode lhs) 507 value:= 508 t1 = t2 => 509 $genValue => v 510 objNew(wrapped2Quote objVal v,objMode v) 511 if isPartialMode t2 then 512 if EQCAR(t1,'Symbol) and $declaredMode then 513 t1:= getMinimalVarMode(objValUnwrap v,$declaredMode) 514 t' := t2 515 null (t2 := resolveTM(t1,t2)) => 516 if not t2 then t2 := t' 517 throwKeyedMsg("S2IS0035",[t1,t2]) 518 null (v := getArgValue(rhs,t2)) => 519 isWrapped(objVal v') and (v2:=coerceInteractive(v',$OutputForm)) => 520 throwKeyedMsg("S2IS0036",[objValUnwrap v2,t2]) 521 throwKeyedMsg("S2IS0037",[t2]) 522 t2 and objNew(($genValue => wrap timedEVALFUN v ; v),t2) 523 value => evalLETput(lhs,value) 524 throwKeyedMsgCannotCoerceWithValue(objVal v,t1,getMode lhs) 525 526evalLETput(lhs,value) == 527 -- put value into the cell for lhs 528 name:= getUnname lhs 529 if not $genValue then 530 code:= 531 isLocalVar(name) => 532 om := objMode(value) 533 dm := get(name,'mode,$env) 534 dm and not ((om = dm) or isSubDomain(om,dm) or 535 isSubDomain(dm,om)) => 536 compFailure ['" The type of the local variable", 537 :bright name,'"has changed in the computation."] 538 if dm and isSubDomain(dm,om) then put(name,'mode,om,$env) 539 ['LET,name,objVal value,$mapName] 540 -- $mapName is set in analyzeMap 541 om := objMode value 542 dm := get(name, 'mode, $env) or objMode(get(name, 'value, $e)) 543 dm and (null $compilingMap) and not(om = dm) and not(isSubDomain(om, dm)) => 544 THROW('loopCompiler,'tryInterpOnly) 545 ['unwrap,['evalLETchangeValue,MKQ name, 546 objNewCode(['wrap,objVal value],objMode value)]] 547 value:= objNew(code,objMode value) 548 isLocalVar(name) => 549 if not get(name,'mode,$env) then put(name,'autoDeclare,'T,$env) 550 put(name,'mode,objMode(value),$env) 551 put(name,'automode,objMode(value),$env) 552 $genValue and evalLETchangeValue(name,value) 553 putValue(lhs,value) 554 555upLETWithPatternOnLhs(t := [op,pattern,a]) == 556 $opIsIs : local := true 557 [m] := bottomUp a 558 putPvarModes(pattern,m) 559 object := evalis(op,[a,pattern],m) 560 -- have to change code to return value of a 561 failCode := 562 ['spadThrowBrightly,['concat, 563 '" Pattern",['QUOTE,bright form2String pattern], 564 '"is not matched in assignment to right-hand side."]] 565 if $genValue 566 then 567 null objValUnwrap object => eval failCode 568 putValue(op,getValue a) 569 else 570 code := ['COND,[objVal object,objVal getValue a],[''T,failCode]] 571 putValue(op,objNew(code,m)) 572 putModeSet(op,[m]) 573 574evalLETchangeValue(name,value) == 575 -- write the value of name into the environment, clearing dependent 576 -- maps if its type changes from its last value 577 localEnv := PAIRP $env 578 clearCompilationsFlag := 579 val:= (localEnv and get(name,'value,$env)) or get(name,'value,$e) 580 null val => 581 not ((localEnv and get(name,'mode,$env)) or get(name,'mode,$e)) 582 objMode val ~= objMode(value) 583 if clearCompilationsFlag then 584 clearDependencies(name) 585 if localEnv and isLocalVar(name) 586 then $env:= putHist(name,'value,value,$env) 587 else putIntSymTab(name,'value,value,$e) 588 objVal value 589 590upLETWithFormOnLhs(op,lhs,rhs) == 591 -- bottomUp for assignment to forms (setelt, table or tuple) 592 lhs' := getUnnameIfCan lhs 593 rhs' := getUnnameIfCan rhs 594 lhs' = 'Tuple => 595 rhs' ~= 'Tuple => throwKeyedMsg("S2IS0039",NIL) 596 #(lhs) ~= #(rhs) => throwKeyedMsg("S2IS0038",NIL) 597 -- generate a sequence of assignments, using local variables 598 -- to first hold the assignments so that things like 599 -- (t1,t2) := (t2,t1) will work. 600 seq := [] 601 temps := [GENSYM() for l in rest lhs] 602 for lvar in temps repeat mkLocalVar($mapName,lvar) 603 for l in reverse rest lhs for t in temps repeat 604 transferPropsToNode(getUnname l,l) 605 let := mkAtreeNode 'LET 606 t' := mkAtreeNode t 607 if m := getMode(l) then putMode(t',m) 608 seq := cons([let,l,t'],seq) 609 for t in temps for r in reverse rest rhs 610 for l in reverse rest lhs repeat 611 let := mkAtreeNode 'LET 612 t' := mkAtreeNode t 613 if m := getMode(l) then putMode(t',m) 614 seq := cons([let,t',r],seq) 615 seq := cons(mkAtreeNode 'SEQ,seq) 616 ms := bottomUp seq 617 putValue(op,getValue seq) 618 putModeSet(op,ms) 619 rhs' = 'Tuple => throwKeyedMsg("S2IS0039",NIL) 620 tree:= seteltable(lhs,rhs) => upSetelt(op,lhs,tree) 621 throwKeyedMsg("S2IS0060", NIL) 622-- upTableSetelt(op,lhs,rhs) 623 624get_opname_if_can(f) == 625 VECP(f) => f.0 626 nil 627 628seteltable(lhs is [f,:argl],rhs) == 629 -- produces the setelt form for trees such as "l.2:= 3" 630 g := get_opname_if_can f 631 EQ(g,'elt) => altSeteltable [:argl, rhs] 632 altSeteltable [:lhs,rhs] 633 634altSeteltable args == 635 for x in args repeat bottomUp x 636 newOps := [mkAtreeNode "setelt!", mkAtreeNode "set!"] 637 form := NIL 638 639 -- first look for exact matches for any of the possibilities 640 while not form for newOp in newOps repeat 641 if selectMms(newOp, args, NIL) then form := [newOp, :args] 642 643 -- now try retracting arguments after the first 644 while not form and ( "and"/[retractAtree(a) for a in rest args] ) repeat 645 while not form for newOp in newOps repeat 646 if selectMms(newOp, args, NIL) then form := [newOp, :args] 647 648 form 649 650 651upSetelt(op,lhs,tree) == 652 -- type analyzes implicit setelt forms 653 var:=opOf lhs 654 transferPropsToNode(getUnname var,var) 655 if (m1:=getMode var) then $declaredMode:= m1 656 if m1 or ((v1 := getValue var) and (m1 := objMode v1)) then 657 putModeSet(var,[m1]) 658 ms := bottomUp tree 659 putValue(op,getValue tree) 660 putModeSet(op,ms) 661 662upTableSetelt(op,lhs is [htOp,:args],rhs) == 663 -- called only for undeclared, uninitialized table setelts 664 ("*" = (PNAME getUnname htOp).0) and (1 ~= # args) => 665 throwKeyedMsg("S2IS0040",NIL) 666 # args ~= 1 => 667 throwKeyedMsg("S2IS0041",[[getUnname htOp,'".[", 668 getUnname first args, 669 ['",",getUnname arg for arg in rest args],'"]"]]) 670 keyMode := '(Any) 671 putMode (htOp,['Table,keyMode,'(Any)]) 672 -- if we are to use a new table, we must call the "table" 673 -- function to give it an initial value. 674 bottomUp [mkAtreeNode 'LET,htOp,[mkAtreeNode 'table]] 675 tableCode := objVal getValue htOp 676 r := upSetelt(op, lhs, [mkAtreeNode "setelt!", :lhs, rhs]) 677 $genValue => r 678 -- construct code 679 t := getValue op 680 putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t)) 681 r 682 683isType t == 684 -- Returns the evaluated type if t is a tree representing a type, 685 -- and NIL otherwise 686 op:=opOf t 687 VECP op => 688 isMap(op:= getUnname op) => NIL 689 op = 'Mapping => 690 argTypes := [isType type for type in rest t] 691 "or"/[null type for type in argTypes] => nil 692 ['Mapping, :argTypes] 693 isLocalVar(op) => NIL 694 d := isDomainValuedVariable op => d 695 type:= 696 -- next line handles subscripted vars 697 (abbreviation?(op) or (op = 'typeOf) or 698 constructor?(op) or (op in '(Record Union Enumeration))) and 699 unabbrev unVectorize t 700 type and evaluateType type 701 d := isDomainValuedVariable op => d 702 NIL 703 704upLETtype(op,lhs,type) == 705 -- performs type assignment 706 opName:= getUnname lhs 707 (not $genValue) and or/[CONTAINED(var,type) for var in $localVars] => 708 compFailure ['" Cannot compile type assignment to",:bright opName] 709 mode := 710 if isPartialMode type then '(Mode) 711 else if categoryForm?(type) then '(Category) 712 else '(Type) 713 val:= objNew(type,mode) 714 if isLocalVar(opName) then put(opName,'value,val,$env) 715 else putHist(opName,'value,val,$e) 716 putValue(op,val) 717 -- have to fix the following 718 putModeSet(op,[mode]) 719 720assignSymbol(symbol, value, domain) == 721-- Special function for binding an interpreter variable from within algebra 722-- code. Does not do the assignment and returns nil, if the variable is 723-- already assigned 724 val := get(symbol, 'value, $e) => nil 725 obj := objNew(wrap value, devaluate domain) 726 put(symbol, 'value, obj, $e) 727 true 728 729--% Handler for Interpreter Macros 730 731getInterpMacroNames() == 732 names := [n for [n,:.] in $InterpreterMacroAlist] 733 if (e := CAAR $InteractiveFrame) and (m := assoc("--macros--",e)) then 734 names := append(names, [n for [n, :.] in rest m]) 735 MSORT names 736 737isInterpMacro name == 738 -- look in local and then global environment for a macro 739 null IDENTP name => NIL 740 name in $specialOps => NIL 741 (m := get("--macros--",name,$env)) => m 742 (m := get("--macros--",name,$e)) => m 743 (m := get("--macros--",name,$InteractiveFrame)) => m 744 -- $InterpreterMacroAlist will probably be phased out soon 745 (sv := assoc(name, $InterpreterMacroAlist)) => CONS(NIL, rest sv) 746 NIL 747 748--% Handlers for prefix QUOTE 749 750upQUOTE t == 751 t isnt [op,expr] => NIL 752 ms:= list 753 m:= getBasicMode expr => m 754 IDENTP expr => 755-- $useSymbolNotVariable => $Symbol 756 ['Variable,expr] 757 $OutputForm 758 evalQUOTE(op,[expr],ms) 759 putModeSet(op,ms) 760 761evalQUOTE(op,[expr],[m]) == 762 triple:= 763 $genValue => objNewWrap(expr,m) 764 objNew(['QUOTE,expr],m) 765 putValue(op,triple) 766 767--% Handler for pretend 768 769uppretend t == 770 t isnt [op,expr,type] => NIL 771 mode := evaluateType unabbrev type 772 not isValidType(mode) => throwKeyedMsg("S2IE0004",[mode]) 773 bottomUp expr 774 putValue(op,objNew(objVal getValue expr,mode)) 775 putModeSet(op,[mode]) 776 777--% Handlers for REDUCE 778 779getReduceFunction(op,type,result, locale) == 780 -- return the function cell for operation with the signature 781 -- (type,type) -> type, possible from locale 782 if type is ['Variable,var] then 783 args := [arg := mkAtreeNode var,arg] 784 putValue(arg,objNewWrap(var,type)) 785 else 786 args := [arg := mkAtreeNode "%1",arg] 787 if type=$Symbol then putValue(arg,objNewWrap("%1",$Symbol)) 788 putModeSet(arg,[type]) 789 vecOp:=mkAtreeNode op 790 transferPropsToNode(op,vecOp) 791 if locale then putAtree(vecOp,'dollar,locale) 792 mmS:= selectMms(vecOp,args,result) 793 mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS | 794 (isHomogeneousArgs sig) and and/[null c for c in cond]] 795 null mm => 'failed 796 [[dc,:sig],fun,:.]:=mm 797 dc = 'local => [MKQ [fun, :'local], :first sig] 798 dcVector := evalDomain dc 799 $compilingMap => 800 k := NRTgetMinivectorIndex( 801 NRTcompiledLookup(op,sig,dcVector),op,sig,dcVector) 802 ['ELT,"$$$",k] --$$$ denotes minivector 803 env:= 804 NRTcompiledLookup(op,sig,dcVector) 805 MKQ env 806 807isHomogeneous sig == 808 --return true if sig describes a homogeneous binary operation 809 sig.0=sig.1 and sig.1=sig.2 810 811isHomogeneousArgs sig == 812 --return true if sig describes a homogeneous binary operation 813 sig.1=sig.2 814 815--% Handlers for REPEAT 816 817transformREPEAT [:itrl,body] == 818 -- syntactic transformation of repeat iterators, called from mkAtree2 819 iterList:=[:iterTran1 for it in itrl] where iterTran1 == 820 it is ['STEP,index,lower,step,:upperList] => 821 [['STEP,index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper 822 for upper in upperList]]] 823 it is ['IN,index,s] => 824 [['IN,index,mkAtree1 s]] 825 it is ['ON,index,s] => 826 [['IN,index,mkAtree1 ['tails,s]]] 827 it is ['WHILE,b] => 828 [['WHILE,mkAtree1 b]] 829 it is ['_|,pred] => 830 [['SUCHTHAT,mkAtree1 pred]] 831 it is [op,:.] and (op in '(VALUE UNTIL)) => nil 832 bodyTree:=mkAtree1 body 833 iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2 == 834 it is ['STEP,:.] => nil 835 it is ['IN,:.] => nil 836 it is ['ON,:.] => nil 837 it is ['WHILE,:.] => nil 838 it is [op,b] and (op in '(UNTIL VALUE)) => 839 [[op,mkAtree1 b]] 840 it is ['_|,pred] => nil 841 keyedSystemError("S2GE0016", 842 ['"transformREPEAT",'"Unknown type of iterator"]) 843 [:iterList,bodyTree] 844 845upREPEAT t == 846 -- REPEATS always return void() of Void 847 -- assures throw to interpret-code mode goes to outermost loop 848 $repeatLabel : local := MKQ GENSYM() 849 $breakCount : local := 0 850 $repeatBodyLabel : local := MKQ GENSYM() 851 $iterateCount : local := 0 852 $compilingLoop => upREPEAT1 t 853 upREPEAT0 t 854 855upREPEAT0 t == 856 -- sets up catch point for interp-only mode 857 $compilingLoop: local := true 858 ms := CATCH('loopCompiler,upREPEAT1 t) 859 ms = 'tryInterpOnly => interpOnlyREPEAT t 860 ms 861 862upREPEAT1 t == 863 -- repeat loop handler with compiled body 864 -- see if it has the expected form 865 t isnt [op,:itrl,body] => NIL 866 -- determine the mode of the repeat loop. At the moment, if there 867 -- there are no iterators and there are no "break" statements, then 868 -- the return type is Exit, otherwise Void. 869 repeatMode := 870 null(itrl) and ($breakCount=0) => $Void 871 $Void 872 873 -- if interpreting, go do that 874 $interpOnly => interpREPEAT(op,itrl,body,repeatMode) 875 876 -- analyze iterators and loop body 877 upLoopIters itrl 878 bottomUpCompile body 879 880 -- now that the body is analyzed, we should know everything that 881 -- is in the UNTIL clause 882 for itr in itrl repeat 883 itr is ['UNTIL, pred] => bottomUpCompilePredicate(pred,'"until") 884 885 -- now go do it 886 evalREPEAT(op,rest t,repeatMode) 887 putModeSet(op,[repeatMode]) 888 889evalREPEAT(op,[:itrl,body],repeatMode) == 890 -- generate code for loop 891 bodyMode := computedMode body 892 bodyCode := getArgValue(body,bodyMode) 893 if $iterateCount > 0 then 894 bodyCode := ['CATCH,$repeatBodyLabel,bodyCode] 895 code := ['REPEAT,:[evalLoopIter itr for itr in itrl], bodyCode] 896 if repeatMode = $Void then code := ['OR,code,'(voidValue)] 897 code := timedOptimization code 898 if $breakCount > 0 then code := ['CATCH,$repeatLabel,code] 899 val:= 900 $genValue => 901 timedEVALFUN code 902 objNewWrap(voidValue(),repeatMode) 903 objNew(code,repeatMode) 904 putValue(op,val) 905 906interpOnlyREPEAT t == 907 -- interpret-code mode call to upREPEAT 908 $genValue: local := true 909 $interpOnly: local := true 910 upREPEAT1 t 911 912interpREPEAT(op,itrl,body,repeatMode) == 913 -- performs interpret-code repeat 914 $indexVars: local := NIL 915 $indexTypes: local := NIL 916 code := 917 -- we must insert a CATCH for the iterate clause 918 ['REPEAT,:[interpIter itr for itr in itrl], 919 ['CATCH,$repeatBodyLabel,interpLoop(body,$indexVars, 920 $indexTypes,nil)]] 921 CATCH($repeatLabel,timedEVALFUN code) 922 val:= objNewWrap(voidValue(),repeatMode) 923 putValue(op,val) 924 putModeSet(op,[repeatMode]) 925 926interpLoop(expr,indexList,indexTypes,requiredType) == 927 -- generates code for interp-only repeat body 928 ['interpLoopIter,MKQ expr,MKQ indexList,['LIST,:indexList], 929 MKQ indexTypes, MKQ requiredType] 930 931interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) == 932 -- call interpreter on exp with loop vars in indexList with given 933 -- values and types, requiredType is used from interpCOLLECT 934 -- to indicate the required type of the result 935 emptyAtree exp 936 for i in indexList for val in indexVals for type in indexTypes repeat 937 put(i,'value,objNewWrap(val,type),$env) 938 bottomUp exp 939 v:= getValue exp 940 val := 941 null requiredType => v 942 coerceInteractive(v,requiredType) 943 null val => 944 throwKeyedMsgCannotCoerceWithValue(objVal v,objMode v,requiredType) 945 objValUnwrap val 946 947--% Handler for return 948 949upreturn t == 950 -- make sure we are in a user function 951 t isnt [op,val] => NIL 952 (null $compilingMap) and (null $interpOnly) => 953 throwKeyedMsg("S2IS0047",NIL) 954 if $mapTarget then putTarget(val,$mapTarget) 955 bottomUp val 956 if $mapTarget 957 then 958 val' := getArgValue(val, $mapTarget) 959 m := $mapTarget 960 else 961 val' := wrapped2Quote objVal getValue val 962 m := computedMode val 963 cn := mapCatchName $mapName 964 $mapReturnTypes := insert(m, $mapReturnTypes) 965 $mapThrowCount := $mapThrowCount + 1 966 -- if $genValue then we are interpreting the map 967 $genValue => THROW(cn,objNewWrap(removeQuote val',m)) 968 putValue(op,objNew(['THROW,MKQ cn,val'],m)) 969 putModeSet(op,[$Exit]) 970 971--% Handler for SEQ 972 973upSEQ u == 974 -- assumes that exits were translated into if-then-elses 975 -- handles flat SEQs and embedded returns 976 u isnt [op,:args] => NIL 977 if (target := getTarget(op)) then putTarget(last args, target) 978 for x in args repeat bottomUp x 979 null (m := computedMode last args) => 980 keyedSystemError("S2GE0016",['"upSEQ", 981 '"last line of SEQ has no mode"]) 982 evalSEQ(op,args,m) 983 putModeSet(op,[m]) 984 985evalSEQ(op,args,m) == 986 -- generate code for SEQ 987 [:argl,last] := args 988 val:= 989 $genValue => getValue last 990 bodyCode := nil 991 for x in args repeat 992 (m1 := computedMode x) => 993 (av := getArgValue(x,m1)) ~= voidValue() => 994 bodyCode := [av,:bodyCode] 995 code:= 996 bodyCode is [c] => c 997 ['PROGN,:reverse bodyCode] 998 objNew(code,m) 999 putValue(op,val) 1000 1001--% Handlers for Tuple 1002 1003upTuple t == 1004 --Computes the common mode set of the construct by resolving across 1005 --the argument list, and evaluating 1006 t isnt [op,:l] => nil 1007 dol := getAtree(op,'dollar) 1008 tar := getTarget(op) or dol 1009 null l => upNullTuple(op,l,tar) 1010 isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar) 1011 aggs := '(List) 1012 if tar and PAIRP(tar) and not isPartialMode(tar) then 1013 first(tar) in aggs => 1014 ud := CADR tar 1015 for x in l repeat if not getTarget(x) then putTarget(x,ud) 1016 first(tar) in '(Matrix SquareMatrix RectangularMatrix) => 1017 vec := ['List,underDomainOf tar] 1018 for x in l repeat if not getTarget(x) then putTarget(x,vec) 1019 argModeSetList:= [bottomUp x for x in l] 1020 eltTypes := replaceSymbols([first x for x in argModeSetList],l) 1021 if not isPartialMode(tar) and tar is ['Tuple,ud] then 1022 mode := ['Tuple, resolveTypeListAny cons(ud,eltTypes)] 1023 else mode := ['Tuple, resolveTypeListAny eltTypes] 1024 if isPartialMode tar then tar:=resolveTM(mode,tar) 1025 evalTuple(op,l,mode,tar) 1026 1027evalTuple(op,l,m,tar) == 1028 [agg,:.,underMode]:= m 1029 code := asTupleNewCode(#l, 1030 [(getArgValue(x,underMode) or throwKeyedMsg("S2IC0007",[underMode])) for x in l]) 1031 val := 1032 $genValue => objNewWrap(timedEVALFUN code,m) 1033 objNew(code,m) 1034 if tar then val1 := coerceInteractive(val,tar) else val1 := val 1035 1036 val1 => 1037 putValue(op,val1) 1038 putModeSet(op,[tar or m]) 1039 putValue(op,val) 1040 putModeSet(op,[m]) 1041 1042upNullTuple(op,l,tar) == 1043 -- handler for the empty tuple 1044 defMode := 1045 tar and tar is [a,b] and (a in '(Stream Vector List)) and 1046 not isPartialMode(b) => ['Tuple,b] 1047 '(Tuple (None)) 1048 val := objNewWrap(asTupleNew(0,NIL), defMode) 1049 tar and not isPartialMode(tar) => 1050 null (val' := coerceInteractive(val,tar)) => 1051 throwKeyedMsg("S2IS0013",[tar]) 1052 putValue(op,val') 1053 putModeSet(op,[tar]) 1054 putValue(op,val) 1055 putModeSet(op,[defMode]) 1056 1057--% Handler for typeOf 1058 1059uptypeOf form == 1060 form isnt [op, arg] => NIL 1061 if VECP arg then transferPropsToNode(getUnname arg,arg) 1062 if m := isType(arg) then 1063 m := 1064 categoryForm?(m) => '(Category) 1065 isPartialMode m => '(Mode) 1066 '(Type) 1067 else if not (m := getMode arg) then [m] := bottomUp arg 1068 t := typeOfType m 1069 putValue(op, objNew(m,t)) 1070 putModeSet(op,[t]) 1071 1072typeOfType type == 1073 type in '((Mode) (Type)) => '(Category) 1074 '(Type) 1075 1076--% Handler for where 1077 1078upwhere t == 1079 -- upwhere does the puts in where into a local environment 1080 t isnt [op,tree,clause] => NIL 1081 -- since the "clause" might be a local macro, we now call mkAtree 1082 -- on the "tree" part (it is not yet a vat) 1083 not $genValue => 1084 compFailure [:bright '" where", 1085 '"for compiled code is not yet implemented."] 1086 $whereCacheList : local := nil 1087 [env,:e] := upwhereClause(clause,$env,$e) 1088 tree := upwhereMkAtree(tree,env,e) 1089 if x := getAtree(op,'dollar) then 1090 atom tree => throwKeyedMsg("S2IS0048",NIL) 1091 putAtree(first tree, 'dollar, x) 1092 upwhereMain(tree,env,e) 1093 val := getValue tree 1094 putValue(op,val) 1095 result := putModeSet(op,getModeSet tree) 1096 wcl := [op for op in $whereCacheList] 1097 for op in wcl repeat clearDependencies(op) 1098 result 1099 1100upwhereClause(tree,env,e) == 1101 -- uses the variable bindings from env and e and returns an environment 1102 -- of its own bindings 1103 $env: local := copyHack env 1104 $e: local := copyHack e 1105 bottomUp tree 1106 [$env,:$e] 1107 1108upwhereMkAtree(tree,$env,$e) == mkAtree tree 1109 1110upwhereMain(tree,$env,$e) == 1111 -- uses local copies of $env and $e while evaluating tree 1112 bottomUp tree 1113 1114copyHack(env) == 1115 -- makes a copy of an environment with the exception of pairs 1116 -- (localModemap . something) 1117 c:= CAAR env 1118 d:= [fn p for p in c] where fn(p) == 1119 CONS(first p, [(EQCAR(q, 'localModemap) => q; copy q) for q in rest p]) 1120 [[d]] 1121 1122-- Creates the function names of the special function handlers and puts 1123-- them on the property list of the function name 1124 1125 1126for name in $specialOps repeat 1127 ( 1128 functionName := INTERNL1('up, name) ; 1129 MAKEPROP(name,'up,functionName) ; 1130 functionName 1131 ) 1132