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 34DEFPARAMETER($currentFunctionLevel, 0) 35DEFPARAMETER($tryRecompileArguments, true) 36DEFPARAMETER($locVarsTypes, nil) 37 38initEnvHashTable(l) == 39 for u in first(first(l)) repeat 40 for v in rest(u) repeat 41 HPUT($envHashTable, [first u, first v], true) 42 43compTopLevel(x,m,e) == 44 $killOptimizeIfTrue: local:= false 45 $forceAdd: local:= false 46 $compTimeSum: local := 0 47 $resolveTimeSum: local := 0 48 $envHashTable : local := MAKE_HASHTABLE('EQUAL) 49 initEnvHashTable(e) 50 initEnvHashTable($CategoryFrame) 51 -- The next line allows the new compiler to be tested interactively. 52 compFun := 'compOrCroak 53 x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => 54 ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e]) 55 --keep old environment after top level function defs 56 FUNCALL(compFun,x,m,e) 57 58compUniquely(x,m,e) == 59 $compUniquelyIfTrue: local:= true 60 CATCH("compUniquely",comp(x,m,e)) 61 62compOrCroak(x,m,e) == compOrCroak1(x,m,e,'comp) 63 64compOrCroak1(x,m,e,compFn) == 65 fn(x,m,e,nil,nil,compFn) where 66 fn(x,m,e,$compStack,$compErrorMessageStack,compFn) == 67 T:= CATCH("compOrCroak",FUNCALL(compFn,x,m,e)) => T 68 -- stackAndThrow does the appropriate THROW 69 $compStack:= [[x,m,e,$exitModeStack],:$compStack] 70 $s:= 71 compactify $compStack where 72 compactify al == 73 null al => nil 74 LASSOC(first first al,rest al) => compactify rest al 75 [first al,:compactify rest al] 76 $level:= #$s 77 errorMessage:= 78 if $compErrorMessageStack 79 then first $compErrorMessageStack 80 else "unspecified error" 81 $scanIfTrue => 82 stackSemanticError(errorMessage,mkErrorExpr $level) 83 ["failedCompilation",m,e] 84 displaySemanticErrors() 85 SAY("****** comp fails at level ",$level," with expression: ******") 86 displayComp $level 87 userError errorMessage 88 89comp(x,m,e) == 90 T:= compNoStacking(x,m,e) => ($compStack:= nil; T) 91 $compStack:= [[x,m,e,$exitModeStack],:$compStack] 92 nil 93 94compNoStacking(x,m,e) == 95 T:= comp2(x,m,e) => 96 (m=$EmptyMode and T.mode=$Representation => [T.expr,"$",T.env]; T) 97 --$Representation is bound in compDefineFunctor, set by doIt 98 --this hack says that when something is undeclared, $ is 99 --preferred to the underlying representation -- RDJ 9/12/83 100 compNoStacking1(x,m,e,$compStack) 101 102compNoStacking1(x,m,e,$compStack) == 103 u:= get(if m="$" then "Rep" else m,"value",e) => 104 (T:= comp2(x,u.expr,e) => [T.expr,m,T.env]; nil) 105 nil 106 107comp2(x,m,e) == 108 [y,m',e]:= comp3(x,m,e) or return nil 109 --if null atom y and isDomainForm(y,e) then e := addDomain(x,e) 110 --line commented out to prevent adding derived domain forms 111 m ~= m' and isDomainForm(m',e) => [y, m', addDomain(m', e)] 112 --isDomainForm test needed to prevent error while compiling Ring 113 [y,m',e] 114 115comp3(x, m, e) == 116 --returns a Triple or else nil to signal can't do 117 e := addDomain(m, e) 118 m is ["Mapping",:.] => compWithMappingMode(x,m,e) 119 m is ["QUOTE",a] => (x=a => [x, m, e]; nil) 120 STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) 121 not x or atom x => compAtom(x,m,e) 122 op:= first x 123 op=":" => compColon(x,m,e) 124 op="::" => compCoerce(x,m,e) 125 t:= compExpression(x,m,e) 126 t is [x',m',e'] and not member(m',getDomainsInScope e') => 127 [x',m',addDomain(m',e')] 128 t 129 130hasFormalMapVariable(x, vl) == 131 $formalMapVariables: local := vl 132 null vl => false 133 ScanOrPairVec(function hasone?, x) where 134 hasone? x == MEMQ(x,$formalMapVariables) 135 136argsToSig(args) == 137 args is [":", v, t] => [[v], [t]] 138 sig1 := [] 139 arg1 := [] 140 bad := false 141 for arg in args repeat 142 arg is [":", v, t] => 143 sig1 := [t, :sig1] 144 arg1 := [v, :arg1] 145 bad := true 146 bad => [nil, nil] 147 [REVERSE(arg1), REVERSE(sig1)] 148 149compLambda(x is ["+->", vl, body], m, e) == 150 vl is [":", args, target] => 151 args := 152 args is ["@Tuple", :a1] => a1 153 args 154 LISTP(args) => 155 [arg1, sig1] := argsToSig(args) 156 sig1 or NULL(args) => 157 ress := compAtSign(["@", ["+->", arg1, body], 158 ["Mapping", target, :sig1]], m, e) 159 ress 160 stackAndThrow ["compLambda: malformed argument list", x] 161 stackAndThrow ["compLambda: malformed argument list", x] 162 nil 163 164getFreeList(u, bound, free, e) == 165 atom u => 166 not IDENTP u => free 167 MEMQ(u,bound) => free 168 v := ASSQ(u, free) => 169 RPLACD(v, 1 + CDR v) 170 free 171 not getmode(u, e) => free 172 [[u, :1], :free] 173 op := first u 174 MEMQ(op, '(QUOTE GO function)) => free 175 EQ(op, 'LAMBDA) => 176 lvl := CADR u 177 avl := [] 178 for evl in lvl repeat 179 el := 180 ATOM(evl) => evl 181 first(evl) 182 avl := [el, :avl] 183 bound := UNIONQ(bound, avl) 184 for v in CDDR u repeat 185 free := getFreeList(v, bound, free, e) 186 free 187 EQ(op, 'PROG) => 188 bound := UNIONQ(bound, CADR u) 189 for v in CDDR u | NOT ATOM v repeat 190 free := getFreeList(v, bound, free, e) 191 free 192 EQ(op, 'SPROG) => 193 bound := UNIONQ(bound, [first uu for uu in CADR u]) 194 for v in CDDR u | NOT ATOM v repeat 195 free := getFreeList(v, bound, free, e) 196 free 197 EQ(op, 'SEQ) => 198 for v in rest u | NOT ATOM v repeat 199 free := getFreeList(v, bound, free, e) 200 free 201 EQ(op, 'COND) => 202 for v in rest u repeat 203 for vv in v repeat 204 free := getFreeList(vv, bound, free, e) 205 free 206 if ATOM op then u := rest u --Atomic functions aren't descended 207 for v in u repeat 208 free := getFreeList(v, bound, free, e) 209 free 210 211compWithMappingMode(x, m, oldE) == 212 compWithMappingMode1(x, m, oldE, $formalArgList) 213 214compWithMappingMode1(x, m is ["Mapping", m', :sl], oldE, $formalArgList) == 215 $killOptimizeIfTrue: local:= true 216 e:= oldE 217 isFunctor x => 218 if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and 219 (and/[extendsCategoryForm("$", s, mode, e) for mode in argModeList 220 for s in sl] 221 ) and extendsCategoryForm("$", target, m', e) then return [x, m, e] 222 if STRINGP x then x:= INTERN x 223 ress := nil 224 old_style := true 225 if x is ["+->", vl, nx] then 226 old_style := false 227 vl is [":", :.] => 228 ress := compLambda(x,m,oldE) 229 -- In case Boot gets fixed 230 ress 231 vl := 232 vl is ["@Tuple", :vl1] => vl1 233 vl 234 vl := 235 IDENTP(vl) => [vl] 236 LISTP(vl) and (and/[SYMBOLP(v) for v in vl])=> vl 237 stackAndThrow ["bad +-> arguments:", vl] 238 $formalArgList := [:vl, :$formalArgList] 239 #sl ~= #vl => 240 stackAndThrow [_ 241 "number of arguments to +-> does not match, expected:", #sl] 242 x := nx 243 else 244 vl:= take(#sl,$FormalMapVariableList) 245 ress => ress 246 $returnMode : local := m' 247 $currentFunctionLevel : local := #$exitModeStack 248 old_style and not null vl and not hasFormalMapVariable(x, vl) => 249 vln := [GENSYM() for v in vl] 250 $formalArgList := [:vln, :$formalArgList] 251 for m in sl for v in vln repeat 252 [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) 253 [u,.,.] := comp([x,:vln],m',e) or return nil 254 extractCodeAndConstructTriple(u, m, oldE) 255 null vl and (t := comp([x], m', e)) => 256 [u,.,.] := t 257 extractCodeAndConstructTriple(u, m, oldE) 258 for m in sl for v in vl repeat 259 [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) 260 [u,.,.]:= comp(x,m',e) or return nil 261 (uu := simpleCall(u, vl, m, oldE)) => uu 262 catchTag:= MKQ GENSYM() 263 u := replaceExitEtc(u, catchTag, "TAGGEDreturn", $returnMode) 264 u := ["CATCH", catchTag, u] 265 uu := optimizeFunctionDef [nil, ['LAMBDA, vl, u]] 266 -- At this point, we have a function that we would like to pass. 267 -- Unfortunately, it makes various free variable references outside 268 -- itself. So we build a mini-vector that contains them all, and 269 -- pass this as the environment to our inner function. 270 expandedFunction := compTranDryRun CADR uu 271 frees := getFreeList(expandedFunction, vl, nil, e) 272 expandedFunction := 273 --One free can go by itself, more than one needs a vector 274 --An A-list name . number of times used 275 #frees = 0 => 276 ['LAMBDA, addNilTypesToArgs [:vl, "$$"], :CDDR expandedFunction] 277 #frees = 1 => 278 vec:=first first frees 279 ['LAMBDA, addNilTypesToArgs [:vl, vec], :CDDR expandedFunction] 280 scode:=nil 281 vec:=nil 282 locals:=nil 283 i:=-1 284 for v in frees repeat 285 i:=i+1 286 vec:=[first v,:vec] 287 scode:=[['SETQ, first v, [($QuickCode => 'QREFELT;'ELT),"$$",i]], :scode] 288 locals:=[first v, :locals] 289 body:= CDDR expandedFunction 290 if locals then 291 if body is [['DECLARE,:.],:.] then 292 body := [first body, ['PROG, locals, :scode, 293 ['RETURN, ['PROGN, :rest body]]]] 294 else body:=[['PROG,locals,:scode,['RETURN,['PROGN,:body]]]] 295 vec:=['VECTOR,:NREVERSE vec] 296 ['LAMBDA, addNilTypesToArgs [:vl, "$$"], :body] 297 fname:=['CLOSEDFN,expandedFunction] 298 --Like QUOTE, but gets compiled 299 uu:= 300 frees => ['CONS,fname,vec] 301 ['LIST,fname] 302 [uu,m,oldE] 303 304simpleCall(u, vl, m, oldE) == 305 u is ["call", fn, :avl] and avl = vl => 306 if fn is ["applyFun", a] then fn := a 307 fn = "mkRecord" => nil 308 [fn,m,oldE] 309 nil 310 311extractCodeAndConstructTriple(u, m, oldE) == 312 u is ["call",fn,:.] => 313 if fn is ["applyFun",a] then fn := a 314 [fn,m,oldE] 315 [op,:.,env] := u 316 [["CONS",["function",op],env],m,oldE] 317 318compExpression(x,m,e) == 319 op := first x 320 SYMBOLP(op) and (fn := GET(op, "SPECIAL")) => 321 FUNCALL(fn,x,m,e) 322 getmode(op, e) is ["Mapping", :ml] and (u := applyMapping(x, m, e, ml)) => u 323 compForm(x,m,e) 324 325compAtom(x, m, e) == 326 res := compAtom1(x, m, e) => res 327 -- Needed at least for bootstrap of FFIELDC.spad 328 compAtomWithModemap(x, m, e, get(x, "modemap", e)) 329 330compAtom1(x, m, e) == 331 t:= 332 isSymbol x => 333 compSymbol(x,m,e) or return nil 334 STRINGP x => [x,x,e] 335 [x,primitiveType x or return nil,e] 336 convert(t,m) 337 338primitiveType x == 339 x is nil => $EmptyMode 340 STRINGP x => BREAK() -- handled in compAtom1 341 INTEGERP x => 342 x=0 => $NonNegativeInteger 343 x>0 => $PositiveInteger 344 $Integer 345 FLOATP x => BREAK() -- no longer used 346 nil 347 348DEFPARAMETER($compForModeIfTrue, false) 349 350compSymbol(s,m,e) == 351 s="$NoValue" => ["$NoValue",$NoValueMode,e] 352 isFluid s => [s,getmode(s,e) or return nil,e] 353 s="true" => ['(QUOTE T),$Boolean,e] 354 s="false" => [false,$Boolean,e] 355 s = m => [["QUOTE", s], s, e] 356 v:= get(s,"value",e) => 357--+ 358 MEMQ(s,$functorLocalParameters) => 359 NRTgetLocalIndex(s, e) 360 [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile 361 [s,v.mode,e] --s has been SETQd 362 m':= getmode(s,e) => 363 if not member(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and 364 not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s 365 [s,m',e] --s is a declared argument 366 MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s] 367 not isFunction(s,e) => errorRef s 368 369convertOrCroak(T,m) == 370 u:= convert(T,m) => u 371 userError ["CANNOT CONVERT: ",T.expr,"%l"," OF MODE: ",T.mode,"%l", 372 " TO MODE: ",m,"%l"] 373 374convert(T,m) == 375 coerce(T,resolve(T.mode,m) or return nil) 376 377maxSuperType(m,e) == 378 typ:= get(m,"SuperDomain",e) => maxSuperType(typ,e) 379 m 380 381hasType(x,e) == 382 fn get(x,"condition",e) where 383 fn x == 384 null x => nil 385 x is [["case",.,y],:.] => y 386 fn rest x 387 388compForm(form,m,e) == 389 T:= 390 compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return 391 stackMessageIfNone ["cannot compile","%b",form,"%d"] 392 T 393 394compArgumentsAndTryAgain(form is [.,:argl],m,e) == 395 not($tryRecompileArguments) or null(argl) => nil 396 -- used in case: f(g(x)) where f is in domain introduced by 397 -- comping g, e.g. for (ELT (ELT x a) b), environment can have no 398 -- modemap with selector b 399 form is ["Sel", a, .] => nil 400 u:= for x in argl repeat [.,.,e]:= comp(x,$EmptyMode,e) or return "failed" 401 u="failed" => nil 402 compForm1(form,m,e) 403 404-- FIXME: we should check the argument. 405outputComp(x,e) == 406 u:=comp(['_:_:, x, $OutputForm], $OutputForm, e) => u 407 x is ['construct,:argl] => 408 [['LIST, ['QUOTE, 'CONCAT], :[([.,.,e] := outputComp(x, e)).expr 409 for x in argl]], $OutputForm, e] 410 (v:= get(x,"value",e)) and (v.mode is ['Union,:l]) => 411 [['coerceUn2E, x, v.mode], $OutputForm, e] 412 SAY ["outputComp strange x ", x] 413 nil 414 415compSel1(domain, op, argl, m, e) == 416 domain="Lisp" => 417 [[op, :[([., ., e] := compOrCroak(x, $EmptyMode, e)).expr 418 for x in argl]], m, e] 419 (op = "COLLECT") and coerceable(domain, m, e) => 420 (T := comp([op, :argl], domain, e) or return nil; coerce(T, m)) 421 -- FIXME: we should handle 0 and 1 in systematic way, instead 422 -- of renaming hacks like below 423 if op = 0 then 424 op := "Zero" 425 else if op = 1 then 426 op := "One" 427 -- Next clause added JHD 8/Feb/94: the clause after doesn't work 428 -- since addDomain refuses to add modemaps from Mapping 429 domain=$Float and op="float" and m=$DoubleFloat => 430 argl is [mant, exp, 10] => try_constant_DF(mant, exp, m, e) 431 nil 432 e := 433 domain is ['Mapping, :.] => 434 augModemapsFromDomain1(domain, domain, e) 435 addDomain(domain, e) 436 mml := [x for x in getFormModemaps([op, :argl], e) 437 | x is [[ =domain, :.], :.]] 438 (ans := compForm2([op, :argl], m, e, mml)) => ans 439 op = "construct" and coerceable(domain, m, e) => 440 (T := comp_construct1(argl, domain, e)) or return nil 441 coerce(T, m) 442 nil 443 444try_constant_DF(mant, exp, m, e) == 445 if mant = ["Zero"] then mant := 0 446 if mant = ["One"] then mant := 1 447 if exp = ["Zero"] then exp := 0 448 if exp = ["One"] then exp := 1 449 INTEGERP(mant) and INTEGERP(exp) => [["mk_DF", mant, exp], m, e] 450 nil 451 452compForm1(form is [op,:argl],m,e) == 453 op="error" => 454 #argl = 1 => 455 arg := first(argl) 456 u := comp(arg, $String, e) => 457 [[op, u.expr], m, e] 458 SAY ["compiling call to error ", argl] 459 u := outputComp(arg, e) => 460 [[op, ['LIST, ['QUOTE, 'mathprint], u.expr]], m, e] 461 nil 462 SAY ["compiling call to error ", argl] 463 nil 464 op is ["Sel", domain, op'] => compSel1(domain, op', argl, m, e) 465 466 e:= addDomain(m,e) --???unnecessary because of comp2's call??? 467 (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T 468 compToApply(op,argl,m,e) 469 470compForm2(form is [op,:argl],m,e,modemapList) == 471 sargl:= TAKE(# argl, $TriangleVariableList) 472 aList:= [[sa,:a] for a in argl for sa in sargl] 473 modemapList:= SUBLIS(aList,modemapList) 474 Tl:= 475 [[.,.,e]:= T 476 for x in argl while (isSimple x and (T:= compUniquely(x,$EmptyMode,e)))] 477 or/[x for x in Tl] => 478 partialModeList:= [(x => x.mode; nil) for x in Tl] 479 compFormPartiallyBottomUp(form,m,e,modemapList,partialModeList) or 480 compForm3(form,m,e,modemapList) 481 compForm3(form,m,e,modemapList) 482 483compFormPartiallyBottomUp(form,m,e,modemapList,partialModeList) == 484 mmList:= [mm for mm in modemapList | compFormMatch(mm,partialModeList)] => 485 compForm3(form,m,e,mmList) 486 487compFormMatch(mm,partialModeList) == 488 mm is [[.,.,:argModeList],:.] and match(argModeList,partialModeList) where 489 match(a,b) == 490 null b => true 491 null first b => match(rest a,rest b) 492 first a=first b and match(rest a,rest b) 493 494compForm3(form is [op,:argl],m,e,modemapList) == 495 T:= 496 or/ 497 [compFormWithModemap(form,m,e,first (mml:= ml)) 498 for ml in tails modemapList] 499 $compUniquelyIfTrue => 500 or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] => 501 THROW("compUniquely",nil) 502 T 503 T 504 505getFormModemaps(form is [op,:argl],e) == 506 op is ["Sel", domain, op1] => 507 [x for x in getFormModemaps([op1,:argl],e) | x is [[ =domain,:.],:.]] 508 null atom op => nil 509 modemapList:= get(op,"modemap",e) 510 if $insideCategoryPackageIfTrue then 511 modemapList := [x for x in modemapList | x is [[dom,:.],:.] and dom ~= '$] 512 if op = "elt" and #argl = 2 or op = "setelt!" and #argl = 3 then 513 modemapList := eltModemapFilter(argl.1, modemapList, e) or return nil 514 nargs:= #argl 515 finalModemapList:= [mm for (mm:= [[.,.,:sig],:.]) in modemapList | #sig=nargs] 516 modemapList and null finalModemapList => 517 stackMessage ["no modemap for","%b",op,"%d","with ",nargs," arguments"] 518 finalModemapList 519 520eltModemapFilter(name,mmList,e) == 521 isConstantId(name,e) => 522 l:= [mm for mm in mmList | mm is [[.,.,.,sel,:.],:.] and sel=name] => l 523 -- setelt! has extra parameter 524 stackMessage ["selector variable: ",name," is undeclared and unbound"] 525 nil 526 mmList 527 528substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) == 529 #dc~=#sig => 530 keyedSystemError("S2GE0016",['"substituteIntoFunctorModemap", 531 '"Incompatible maps"]) 532 #argl=#rest sig => 533 --here, we actually have a functor form 534 sig:= EQSUBSTLIST(argl,rest dc,sig) 535 --make new modemap, subst. actual for formal parametersinto modemap 536 Tl:= [[.,.,e]:= compOrCroak(a,m,e) for a in argl for m in rest sig] 537 substitutionList:= [[x,:T.expr] for x in rest dc for T in Tl] 538 [SUBLIS(substitutionList,modemap),e] 539 nil 540 541--% SPECIAL EVALUATION FUNCTIONS 542 543--% SETQ 544 545compSetq([":=", form, val], m, E) == compSetq1(form, val, m, E) 546 547compSetq1(form,val,m,E) == 548 IDENTP form => setqSingle(form,val,m,E) 549 form is [":",x,y] => 550 [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E) 551 compSetq([":=", x, val], m, E') 552 form is [op,:l] => 553 op="CONS" => setqMultiple(uncons form,val,m,E) 554 op = "@Tuple" => setqMultiple(l, val, m, E) 555 setqSetelt(form,val,m,E) 556 557compMakeDeclaration(x,m,e) == 558 compColon(x,m,e) 559 560setqSetelt([v,:s],val,m,E) == 561 comp(["setelt!", v, :s, val], m, E) 562 563setqSingle(id,val,m,E) == 564 $insideSetqSingleIfTrue: local:= true 565 --used for comping domain forms within functions 566 currentProplist:= getProplist(id,E) 567 m'':= 568 get(id,'mode,E) or getmode(id,E) or 569 (if m=$NoValueMode then $EmptyMode else m) 570-- m'':= LASSOC("mode",currentProplist) or $EmptyMode 571 --for above line to work, line 3 of compNoStackingis required 572 T:= 573 eval or return nil where 574 eval() == 575 T:= comp(val,m'',E) => T 576 not get(id,"mode",E) and m'' ~= (maxm'':=maxSuperType(m'',E)) and 577 (T:=comp(val,maxm'',E)) => T 578 (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => 579 assignError(val,T.mode,id,m'') 580 m'' = $EmptyMode and T.mode = $EmptyMode => 581 stackMessage ["No mode in assignment to: ", id] 582 finish_setq_single(T, m, id, val, currentProplist) 583 584finish_setq_single(T, m, id, val, currentProplist) == 585 T' := [x, m', e'] := convert(T, m) or return nil 586 newProplist:= consProplistOf(id,currentProplist,"value",removeEnv [val,:rest T]) 587 e':= (PAIRP id => e'; addBinding(id,newProplist,e')) 588 if isDomainForm(val,e') then 589 if isDomainInScope(id,e') then 590 stackWarning ["domain valued variable","%b",id,"%d", 591 "has been reassigned within its scope"] 592 e':= augModemapsFromDomain1(id,val,e') 593 --all we do now is to allocate a slot number for lhs 594 --e.g. the LET form below will be changed by putInLocalDomainReferences 595--+ 596 saveLocVarsTypeDecl(x, id, e') 597 598 if (k:=NRTassocIndex(id)) 599 then form:=['SETELT,"$",k,x] 600 else form:= 601 $QuickLet => ["LET",id,x] 602 ["LET",id,x, 603 (isDomainForm(x, e') => ['ELT, id, 0]; first outputComp(id, e'))] 604 [form,m',e'] 605 606saveLocVarsTypeDecl(x, id, e) == 607 t := getmode(id, e) => 608 t := (t = '$EmptyMode => nil; ATOM(t) => [t]; t) 609 typeDecl := ASSOC(id, $locVarsTypes) 610 null typeDecl => 611 if null t then 612 SAY("Local variable ", id, " lacks type.") 613 else $locVarsTypes := ACONS(id, t, $locVarsTypes) 614 t' := CDR(typeDecl) 615 not EQUAL(t, t') => 616 if not null t' then 617 SAY("Local variable ", id, " type redefined: ", t, " to ", t') 618 RPLACD(typeDecl, t) 619 620assignError(val,m',form,m) == 621 message:= 622 val => 623 ["CANNOT ASSIGN: ",val,"%l"," OF MODE: ",m',"%l"," TO: ",form,"%l", 624 " OF MODE: ",m] 625 ["CANNOT ASSIGN: ",val,"%l"," TO: ",form,"%l"," OF MODE: ",m] 626 stackMessage message 627 628MKPROGN(l) == MKPF(l, "PROGN") 629 630setqMultiple(nameList,val,m,e) == 631 val is ["CONS",:.] and m=$NoValueMode => 632 setqMultipleExplicit(nameList,uncons val,m,e) 633 val is ["@Tuple", :l] and m = $NoValueMode => 634 setqMultipleExplicit(nameList,l,m,e) 635 -- 1 create a gensym, add to local environment, compile and assign rhs 636 g:= genVariable() 637 e:= addBinding(g,nil,e) 638 T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil 639 e:= put(g,"mode",m1,e) 640 [x,m',e]:= convert(T,m) or return nil 641 -- 1.1 exit if result is a list 642 m1 is ["List",D] => 643 g2 := genVariable() 644 e := addBinding(g2, nil, e) 645 e := put(g2, "mode", m1, e) 646 T := compSetq1(g2, g, m1, e) or return nil 647 [x2, ., e] := convert(T, m1) or return nil 648 ass_list := [] 649 for y in nameList repeat 650 e := put(y, "value", [genSomeVariable(), D, $noEnv], e) 651 ass_list := cons(["LET", y, ["SPADfirst", g2]], ass_list) 652 ass_list := cons(["LET", g2, ["CDR", g2]], ass_list) 653 ass_list := nreverse(rest(ass_list)) 654 convert([["PROGN",x, x2, :ass_list, g], m', e], m) 655 -- 2 verify that the #nameList = number of parts of right-hand-side 656 selectorModePairs:= 657 --list of modes 658 decompose(m1,#nameList,e) or return nil where 659 decompose(t,length,e) == 660 t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l] 661 comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] => 662 [[name,:mode] for [":",name,mode] in l] 663 stackMessage ["no multiple assigns to mode: ",t] 664 #nameList~=#selectorModePairs => 665 stackMessage [val," must decompose into ",#nameList," components"] 666 -- 3 generate code; return 667 assignList:= 668 [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr 669 for x in nameList for [y,:z] in selectorModePairs] 670 if assignList="failed" then NIL 671 else [MKPROGN [x,:assignList,g],m',e] 672 673setqMultipleExplicit(nameList,valList,m,e) == 674 #nameList~=#valList => 675 stackMessage ["Multiple assignment error; # of items in: ",nameList, 676 "must = # in: ",valList] 677 gensymList:= [genVariable() for name in nameList] 678 assignList:= 679 --should be fixed to declare genVar when possible 680 [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed" 681 for g in gensymList for val in valList] 682 assignList="failed" => nil 683 reAssignList:= 684 [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed" 685 for g in gensymList for name in nameList] 686 reAssignList="failed" => nil 687 [["PROGN",:[T.expr for T in assignList],:[T.expr for T in reAssignList]], 688 $NoValueMode, (last reAssignList).env] 689 690--% WHERE 691compWhere([.,form,:exprList],m,eInit) == 692 $insideWhereIfTrue: local:= true 693 e:= eInit 694 u:= 695 for item in exprList repeat 696 [.,.,e]:= comp(item,$EmptyMode,e) or return "failed" 697 u="failed" => return nil 698 $insideWhereIfTrue:= false 699 [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil 700 eFinal:= 701 del:= deltaContour(eAfter,eBefore) => addContour(del,eInit) 702 eInit 703 [x,m,eFinal] 704 705comp_construct1(l, m, e) == 706 (y := modeIsAggregateOf("List", m, e)) => 707 compList(l, ["List", CADR y], e) 708 (y := modeIsAggregateOf("Vector", m, e)) => 709 compVector(l,["Vector",CADR y],e) 710 711compConstruct(form is ["construct", :l], m, e) == 712 (T := comp_construct1(l, m, e)) and (T' := convert(T,m)) => T' 713 T := compForm(form, m, e) => T 714 for D in getDomainsInScope e repeat 715 (T := comp_construct1(l, D, e)) and (T' := convert(T, m)) => 716 return T' 717 718compQuote(expr is [QUOTE, e1], m, e) == 719 SYMBOLP(e1) => [expr, ["Symbol"], e] 720 stackAndThrow ["Strange argument to QUOTE", expr] 721 -- [expr,m,e] 722 723compList(l,m is ["List",mUnder],e) == 724 null l => [NIL,m,e] 725 Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] 726 Tl="failed" => nil 727 T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] 728 729compVector(l,m is ["Vector",mUnder],e) == 730 null l => [$EmptyVector,m,e] 731 Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] 732 Tl="failed" => nil 733 [["VECTOR",:[T.expr for T in Tl]],m,e] 734 735--% MACROS 736compMacro(form,m,e) == 737 ["MDEF",lhs,signature,specialCases,rhs]:= form 738 prhs := 739 rhs is ['CATEGORY,:.] => ['"-- the constructor category"] 740 rhs is ['Join,:.] => ['"-- the constructor category"] 741 rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] 742 rhs is ['add,:.] => ['"-- the constructor capsule"] 743 formatUnabbreviated rhs 744 sayBrightly ['" processing macro definition",'%b, 745 :formatUnabbreviated lhs,'" ==> ",:prhs,'%d] 746 ATOM(lhs) => userError("Malformed macro definition") 747 nrhs := 748 (margs := rest(lhs)) => [rhs, :margs] 749 [rhs] 750 m=$EmptyMode or m=$NoValueMode => 751 ["/throwAway", $NoValueMode, put(first lhs, "macro", nrhs, e)] 752 753--% SEQ 754 755compSeq(["SEQ",:l],m,e) == compSeq1(l,[m,:$exitModeStack],e) 756 757compSeq1(l,$exitModeStack,e) == 758 $finalEnv: local := false 759 --used in replaceExitEtc. 760 c:= 761 [([.,.,e]:= 762 763 764 --this used to be compOrCroak-- but changed so we can back out 765 766 (compSeqItem(x, $NoValueMode, e) or return "failed")).expr for x in l] 767 if c="failed" then return nil 768 catchTag:= MKQ GENSYM() 769 form:= ["SEQ",:replaceExitEtc(c,catchTag,"TAGGEDexit",$exitModeStack.(0))] 770 [["CATCH",catchTag,form],$exitModeStack.(0),$finalEnv] 771 772compSeqItem(x,m,e) == comp(macroExpand(x,e),m,e) 773 774replaceExitEtc(x,tag,opFlag,opMode) == 775 (fn(x,tag,opFlag,opMode); x) where 776 fn(x,tag,opFlag,opMode) == 777 atom x => nil 778 x is ["QUOTE",:.] => nil 779 x is [ =opFlag,n,t] => 780 rplac(first t,replaceExitEtc(first t, tag, opFlag, opMode)) 781 n = 0 => 782 $finalEnv:= 783 --bound in compSeq1 and compDefineCapsuleFunction 784 $finalEnv => intersectionEnvironment($finalEnv,t.env) 785 t.env 786 rplac(first x,"THROW") 787 rplac(CADR x,tag) 788 rplac(CADDR x,(convertOrCroak(t,opMode)).expr) 789 true => rplac(CADR x,CADR x-1) 790 x is [key,n,t] and MEMQ(key,'(TAGGEDreturn TAGGEDexit)) => 791 rplac(first t,replaceExitEtc(first t,tag,opFlag,opMode)) 792 replaceExitEtc(first x,tag,opFlag,opMode) 793 replaceExitEtc(rest x,tag,opFlag,opMode) 794 795 796--% try 797 798comp_try(["try", expr, catcher, finallizer], m, e) == 799 $exitModeStack : local := [m, :$exitModeStack] 800 if catcher then 801 stackAndThrow ["comp_try: catch unimplemented"] 802 ([c1, m1, .] := comp(expr, m, e)) or return nil 803 ([c2, ., .] := comp(finallizer, $EmptyMode, e)) or return nil 804 [["finally", c1, c2], m1, e] 805 806--% SUCHTHAT 807compSuchthat([.,x,p],m,e) == 808 [x',m',e]:= comp(x,m,e) or return nil 809 [p',.,e]:= comp(p,$Boolean,e) or return nil 810 e:= put(x',"condition",p',e) 811 [x',m',e] 812 813--% exit 814 815compExit(["exit",level,x],m,e) == 816 index:= level-1 817 $exitModeStack = [] => comp(x,m,e) 818 m1:= $exitModeStack.index 819 [x',m',e']:= 820 u:= 821 comp(x,m1,e) or return 822 stackMessageIfNone ["cannot compile exit expression",x,"in mode",m1] 823 modifyModeStack(m',index) 824 [["TAGGEDexit",index,u],m,e] 825 826modifyModeStack(m,index) == 827 $reportExitModeStack => 828 SAY("exitModeStack: ",COPY $exitModeStack," ====> ", 829 ($exitModeStack.index:= resolve(m,$exitModeStack.index); $exitModeStack)) 830 $exitModeStack.index:= resolve(m,$exitModeStack.index) 831 832compLeave(["leave",level,x],m,e) == 833 index:= #$exitModeStack-1-$leaveLevelStack.(level-1) 834 [x',m',e']:= u:= comp(x,$exitModeStack.index,e) or return nil 835 modifyModeStack(m',index) 836 [["TAGGEDexit",index,u],m,e] 837 838--% return 839 840compReturn(["return", x], m, e) == 841 ns := #$exitModeStack 842 ns = $currentFunctionLevel => 843 stackSemanticError(["the return before","%b",x,"%d","is unnecessary"],nil) 844 nil 845 index := MAX(0, ns - $currentFunctionLevel - 1) 846 $returnMode:= resolve($exitModeStack.index,$returnMode) 847 [x',m',e']:= u:= comp(x,$returnMode,e) or return nil 848 $returnMode:= resolve(m',$returnMode) 849 modifyModeStack(m',index) 850 [["TAGGEDreturn",0,u],m,e'] 851 852--% ELT 853 854compSel(form is ["Sel", aDomain, anOp], m, E) == 855 aDomain="Lisp" => 856 [anOp',m,E] where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) 857 anOp := (anOp = $Zero => "Zero"; anOp = $One => "One"; anOp) 858 compSel1(aDomain, anOp, [], m, E) 859 860--% HAS 861 862compHas(pred is ["has", a, b], m, e) == 863 --b is (":",:.) => (.,.,E):= comp(b,$EmptyMode,E) 864 e := chaseInferences(pred, e) 865 --pred':= ("has",a',b') := formatHas(pred) 866 predCode := compHasFormat1(pred, e) 867 coerce([predCode, $Boolean, e], m) 868 869compHasFormat1(pred is ["has", a, b], e) == 870 [a, :.] := comp(a, $EmptyMode, e) or return nil 871 b is ["ATTRIBUTE", c] => BREAK() 872 b is ["SIGNATURE", op, sig] => 873 ["HasSignature", a, 874 mkList [MKQ op, mkList [mkDomainConstructor type for type in sig]]] 875 isDomainForm(b, $EmptyEnvironment) => ["EQUAL", a, b] 876 ["HasCategory", a, mkDomainConstructor b] 877 878--used in various other places to make the discrimination 879compHasFormat (pred is ["has",olda,b], e) == 880 argl := rest($functorForm) 881 formals := TAKE(#argl,$FormalMapVariableList) 882 a := SUBLISLIS(argl,formals,olda) 883 [a,:.] := comp(a, $EmptyMode, e) or return nil 884 a := SUBLISLIS(formals,argl,a) 885 b is ["ATTRIBUTE",c] => BREAK() 886 b is ["SIGNATURE",op,sig] => 887 ["HasSignature",a, 888 mkList [MKQ op,mkList [mkDomainConstructor type for type in sig]]] 889 isDomainForm(b,$EmptyEnvironment) => ["EQUAL",a,b] 890 ["HasCategory",a,mkDomainConstructor b] 891 892--% IF 893 894compIf(["IF",a,b,c],m,E) == 895 [xa,ma,Ea,Einv]:= compBoolean(a,$Boolean,E) or return nil 896 [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil 897 [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil 898 xb':= coerce(Tb,mc) or return nil 899 x:= ["IF", xa, xb'.expr, xc] 900 (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where 901 Env(bEnv,cEnv,b,c,E) == 902 canReturn(b,0,0,true) => 903 (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv) 904 canReturn(c,0,0,true) => cEnv 905 E 906 [x,mc,returnEnv] 907 908canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends 909 atom expr => ValueFlag and level=exitCount 910 (op:= first expr)="QUOTE" => ValueFlag and level=exitCount 911 op="TAGGEDexit" => 912 expr is [.,count,data] => canReturn(data.expr,level,count,count=level) 913 level=exitCount and not ValueFlag => nil 914 op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] 915 op = "error" => nil 916 op="TAGGEDreturn" => nil 917 op="CATCH" => 918 [.,gs,data]:= expr 919 (findThrow(gs,data,level,exitCount,ValueFlag) => true) where 920 findThrow(gs,expr,level,exitCount,ValueFlag) == 921 atom expr => nil 922 expr is ["THROW", =gs,data] => true 923 --this is pessimistic, but I know of no more accurate idea 924 expr is ["SEQ",:l] => 925 or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] 926 or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr] 927 canReturn(data,level,exitCount,ValueFlag) 928 op = "COND" => 929 level = exitCount => 930 or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr] 931 or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v] 932 for v in rest expr] 933 op="IF" => 934 expr is [.,a,b,c] 935 if not canReturn(a,0,0,true) then 936 SAY "IF statement can not cause consequents to be executed" 937 pp expr 938 canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag) 939 or canReturn(c,level,exitCount,ValueFlag) 940 op = "SPROG" => 941 expr is [., defs, body] 942 canReturn(body, level, exitCount, ValueFlag) 943 op = "LAMBDA" => 944 expr is [., args, :body] 945 and/[canReturn(u, level, exitCount, ValueFlag) for u in body] 946 --now we have an ordinary form 947 atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] 948 op is ["XLAM",args,bods] => 949 and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] 950 systemErrorHere '"canReturn" --for the time being 951 952compBoolean(p,m,E) == 953 [p',m,E]:= comp(p,m,E) or return nil 954 [p',m,getSuccessEnvironment(p,E),getInverseEnvironment(p,E)] 955 956getSuccessEnvironment(a,e) == 957 -- the next four lines try to ensure that explicit special-case tests 958 -- prevent implicit ones from being generated 959 a is ["has",x,m] => 960 e 961 a is ["is",id,m] => 962 IDENTP id and isDomainForm(m,$EmptyEnvironment) => 963 currentProplist:= getProplist(id,e) 964 [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs 965 newProplist:= consProplistOf(id,currentProplist,"value",[m,:rest removeEnv T]) 966 addBinding(id,newProplist,e) 967 e 968 a is ["case",x,m] and IDENTP x => 969 put(x,"condition",[a,:get(x,"condition",e)],e) 970 e 971 972getInverseEnvironment(a,E) == 973 atom a => E 974 [op,:argl]:= a 975-- the next five lines try to ensure that explicit special-case tests 976-- prevent implicit ones from being generated 977 op="has" => 978 [x,m]:= argl 979 E 980 a is ["case",x,m] and IDENTP x => 981 --the next two lines are necessary to get 3-branched Unions to work 982 -- old-style unions, that is 983 (get(x,"condition",E) is [["OR",:oldpred]]) and member(a,oldpred) => 984 put(x,"condition",LIST MKPF(delete(a,oldpred),"OR"),E) 985 getUnionMode(x,E) is ["Union",:l] 986 l':= delete(m,l) 987 for u in l' repeat 988 if u is ['_:,=m,:.] then l':=delete(u,l') 989 newpred:= MKPF([["case",x,m'] for m' in l'],"OR") 990 put(x,"condition",[newpred,:get(x,"condition",E)],E) 991 E 992 993getUnionMode(x,e) == 994 m:= 995 atom x => getmode(x,e) 996 return nil 997 isUnionMode(m,e) 998 999isUnionMode(m,e) == 1000 m is ["Union",:.] => m 1001 (m':= getmode(m,e)) is ["Mapping",["UnionCategory",:.]] => CADR m' 1002 v:= get(if m="$" then "Rep" else m,"value",e) => 1003 (v.expr is ["Union",:.] => v.expr; nil) 1004 nil 1005 1006compFromIf(a,m,E) == 1007 a="noBranch" => ["noBranch",m,E] 1008 true => comp(a,m,E) 1009 1010compImport(["import",:doms],m,e) == 1011 for dom in doms repeat e:=addDomain(dom,e) 1012 ["/throwAway",$NoValueMode,e] 1013 1014--Will the jerk who commented out these two functions please NOT do so 1015--again. These functions ARE needed, and case can NOT be done by 1016--modemap alone. The reason is that A case B requires to take A 1017--evaluated, but B unevaluated. Therefore a special function is 1018--required. You may have thought that you had tested this on "failed" 1019--etc., but "failed" evaluates to it's own mode. Try it on x case $ 1020--next time. 1021-- An angry JHD - August 15th., 1984 1022 1023compCase(["case",x,m'],m,e) == 1024 e:= addDomain(m',e) 1025 T:= compCase1(x,m',e) => coerce(T,m) 1026 nil 1027 1028compCase1(x,m,e) == 1029 [x',m',e']:= comp(x,$EmptyMode,e) or return nil 1030 u:= 1031 [cexpr 1032 for (modemap:= [map,cexpr]) in getModemapList("case",2,e') | map is [.,.,s, 1033 t] and modeEqual(t,m) and modeEqual(s,m')] or return nil 1034 fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil 1035 [["call",fn,x'],$Boolean,e'] 1036 1037compColon([":",f,t],m,e) == 1038 t:= 1039 atom t and (t':= assoc(t,getDomainsInScope e)) => t' 1040 isDomainForm(t,e) and not $insideCategoryIfTrue => 1041 (if not member(t,getDomainsInScope e) then e:= addDomain(t,e); t) 1042 isDomainForm(t, e) or isCategoryForm(t) => t 1043 t is ["Mapping",m',:r] => t 1044 unknownTypeError t 1045 t 1046 f is ["LISTOF",:l] => 1047 (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) 1048 e:= 1049 f is [op,:argl] => 1050 --for MPOLY--replace parameters by formal arguments: RDJ 3/83 1051 newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), 1052 [(x is [":",a,m] => a; x) for x in argl],t) 1053 signature:= 1054 ["Mapping",newTarget,: 1055 [(x is [":",a,m] => m; 1056 getmode(x,e) or systemErrorHere '"compColon") for x in argl]] 1057 put(op,"mode",signature,e) 1058 put(f,"mode",t,e) 1059 if not $bootStrapMode and $insideFunctorIfTrue and 1060 makeCategoryForm(t,e) is [catform,e] then 1061 e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) 1062 ["/throwAway",getmode(f,e),e] 1063 1064unknownTypeError name == 1065 name:= 1066 name is [op,:.] => op 1067 name 1068 stackSemanticError(["%b",name,"%d","is not a known type"],nil) 1069 1070compPretend(["pretend",x,t],m,e) == 1071 e:= addDomain(t,e) 1072 T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil 1073 if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"] 1074 if opOf(T.mode) = 'Union and opOf(m) ~= 'Union then 1075 stackWarning(["cannot pretend ",x," of mode ",T.mode," to mode ",m]) 1076 T:= [T.expr,t,T.env] 1077 T':= coerce(T,m) => (if warningMessage then stackWarning warningMessage; T') 1078 1079compIs(["is",a,b],m,e) == 1080 [aval,am,e] := comp(a,$EmptyMode,e) or return nil 1081 [bval,bm,e] := comp(b,$EmptyMode,e) or return nil 1082 T:= [["domainEqual",aval,bval],$Boolean,e] 1083 coerce(T,m) 1084 1085--% Functions for coercion by the compiler 1086 1087-- The function coerce is used by the old compiler for coercions. 1088-- The function coerceInteractive is used by the interpreter. 1089-- One should always call the correct function, since the represent- 1090-- ation of basic objects may not be the same. 1091-- 1092-- Type in returned triple is m when m is not $EmptyMode, 1093-- otherwise it is type from T 1094coerce(T,m) == 1095 $InteractiveMode => 1096 keyedSystemError("S2GE0016",['"coerce", 1097 '"function coerce called from the interpreter."]) 1098 rplac(CADR T,substitute("$",$Rep,CADR T)) 1099 T':= coerceEasy(T,m) => T' 1100 T' := constant_coerce(T, m) => T' 1101 T':= coerceSubset(T,m) => T' 1102 T':= coerceHard(T,m) => T' 1103 T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil 1104 -- if from coerceable, this coerce was just a trial coercion 1105 -- from compFormWithModemap to filter through the modemaps 1106 stackMessage fn(T.expr,T.mode,m) where 1107 fn(x,m1,m2) == 1108 ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l", 1109 " to mode","%b",m2,"%d"] 1110 1111coerceEasy(T,m) == 1112 m=$EmptyMode => T 1113 m=$NoValueMode or m=$Void => [T.expr,m,T.env] 1114 T.mode =m => T 1115 T.mode =$Exit => 1116 [["PROGN", T.expr, ["userError", '"Did not really exit."]], 1117 m,T.env] 1118 T.mode=$EmptyMode or modeEqualSubst(T.mode,m,T.env) => 1119 [T.expr,m,T.env] 1120 1121coerceSubset([x,m,e],m') == 1122 isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] 1123 m is ['SubDomain,=m',:.] => [x,m',e] 1124 INTEGERP x and (pred:= isSubset(m',maxSuperType(m,e),e)) -- again temporary 1125 and eval substitute(x,"*",pred) => 1126 [x,m',e] 1127 nil 1128 1129check_prop(pl, m) == 1130 (QLASSQ("value", pl) is [m'', :.] or 1131 QLASSQ("mode", pl) is ["Mapping", m'']) and modeEqual(m'', m) 1132 1133coerceHard(T,m) == 1134 e := T.env 1135 m':= T.mode 1136 STRINGP m' and modeEqual(m, $String) => [T.expr, m, e] 1137 STRINGP T.expr and modeEqual(m', $String) and modeEqual(m, $Symbol) => 1138 [["QUOTE", INTERN(T.expr, "BOOT")], m, e] 1139 modeEqual(m', m) => [T.expr, m, e] 1140 STRINGP T.expr and T.expr = m => [T.expr, m, e] 1141 pl' := getProplist(m', e) 1142 check_prop(pl', m) => [T.expr, m, e] 1143 pl := getProplist(m, e) 1144 check_prop(pl, m') => [T.expr, m, e] 1145 isCategoryForm(m) => 1146 $bootStrapMode = true => [T.expr, m, e] 1147 extendsCategoryForm(T.expr, T.mode, m, e) => [T.expr, m, e] 1148 coerceExtraHard(T, m, pl, pl') 1149 coerceExtraHard(T, m, pl, pl') 1150 1151getmode_pl(x, pl) == 1152 u := QLASSQ("value", pl) => u.mode 1153 QLASSQ("mode", pl) 1154 1155isUnionMode2(m, e, pl) == 1156 m is ["Union",:.] => m 1157 (m' := getmode_pl(m, pl)) is ["Mapping", ["UnionCategory", :.]] => CADR m' 1158 -- FIXME: Hardcoded assumprion about Rep 1159 v := 1160 m = "$" => get("Rep", "value", e) 1161 QLASSQ("value", pl) 1162 v => (v.expr is ["Union",:.] => v.expr; nil) 1163 nil 1164 1165coerceExtraHard(T is [x, m', e], m, pl, pl') == 1166 T':= autoCoerceByModemap(T,m) => T' 1167 isUnionMode2(m', e, pl') is ["Union",:l] and (t:= hasType(x,e)) and 1168 member(t,l) and (T':= autoCoerceByModemap(T,t)) and 1169 (T'':= coerce(T',m)) => T'' 1170 m' is ['Record, :.] and m = $OutputForm => 1171 [['coerceRe2E,x,['ELT,COPY m',0]],m,e] 1172 nil 1173 1174coerceable(m,m',e) == 1175 m=m' => m 1176 -- must find any free parameters in m 1177 sl:= pmatch(m',m) => SUBLIS(sl,m') 1178 coerce(["$fromCoerceable$",m,e],m') => m' 1179 nil 1180 1181coerceExit([x,m,e],m') == 1182 m':= resolve(m,m') 1183 x':= replaceExitEtc(x,catchTag:= MKQ GENSYM(),"TAGGEDexit",$exitMode) 1184 coerce([["CATCH",catchTag,x'],m,e],m') 1185 1186compAtSign(["@",x,m'],m,e) == 1187 e:= addDomain(m',e) 1188 T:= comp(x,m',e) or return nil 1189 coerce(T,m) 1190 1191compCoerce(["::",x,m'],m,e) == 1192 e:= addDomain(m',e) 1193 T:= compCoerce1(x,m',e) => coerce(T,m) 1194 1195compCoerce1(x,m',e) == 1196 T:= comp(x,m',e) or comp(x,$EmptyMode,e) or return nil 1197 m1:= 1198 STRINGP T.mode => $String 1199 T.mode 1200 T1 := constant_coerce(T, m') => T1 1201 m':=resolve(m1,m') 1202 T:=[T.expr,m1,T.env] 1203 T':= coerce(T,m') => T' 1204 T':= coerceByModemap(T,m') => T' 1205 pred:=isSubset(m',T.mode,e) => 1206 gg:=GENSYM() 1207 pred:= substitute(gg,"*",pred) 1208 code := ['PROG1, ['LET, gg, T.expr], 1209 ['check_subtype2, pred, MKQ m', MKQ T.mode, gg]] 1210 [code,m',T.env] 1211 1212constant_coerce([x, m, e], m') == 1213 m' = $SingleInteger => 1214 if x = ["Zero"] then x = 0 1215 if x = ["One"] then x = 1 1216 not(INTEGERP(x)) => nil 1217 -- Check if in range of FIXNUM on all supported implementations 1218 x > 8000000 or x < -8000000 => nil 1219 m = $Integer or m = $PositiveInteger or $NonNegativeInteger => 1220 [x, m', e] 1221 nil 1222 m' = $DoubleFloat and m = $Float => 1223 x is [["Sel", ["Float"], "float"], mant, exp, 10] => 1224 try_constant_DF(mant, exp, m, e) 1225 nil 1226 nil 1227 1228coerceByModemap([x,m,e],m') == 1229--+ modified 6/27 for new runtime system 1230 u:= 1231 [modemap 1232 for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t, 1233 s] and (modeEqual(t,m') or isSubset(t,m',e)) 1234 and (modeEqual(s,m) or isSubset(m,s,e))] or return nil 1235 1236 --mm:= (or/[mm for (mm:=[.,[cond,.]]) in u | cond=true]) or return nil 1237 mm:=first u -- patch for non-trival conditions 1238 fn := 1239 genDeltaEntry(['coerce, :mm], e) 1240 [["call",fn,x],m',e] 1241 1242autoCoerceByModemap([x,source,e],target) == 1243 u:= 1244 [cexpr 1245 for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ 1246 .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil 1247 fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil 1248 source is ["Union",:l] and member(target,l) => 1249 (y:= get(x,"condition",e)) and (or/[u is ["case",., =target] for u in y]) 1250 => [["call",fn,x],target,e] 1251 x="$fromCoerceable$" => nil 1252 stackMessage ["cannot coerce: ",x,"%l"," of mode: ",source,"%l", 1253 " to: ",target," without a case statement"] 1254 [["call",fn,x],target,e] 1255 1256--% Very old resolve 1257-- should only be used in the old (preWATT) compiler 1258 1259resolve(din,dout) == 1260 din=$NoValueMode or dout=$NoValueMode => $NoValueMode 1261 dout=$EmptyMode => din 1262 din ~= dout and STRINGP dout and modeEqual(din, $String) => nil 1263 dout 1264 1265modeEqual(x,y) == 1266 EQ(x, y) => true 1267 -- FIXME: we should eliminate confusion due to 0 and 1 instead 1268 -- of hacks like below 1269 atom x => 1270 x = y => true 1271 x = 0 => y = ["Zero"] 1272 x = 1 => y = ["One"] 1273 false 1274 atom y => 1275 x = y => true 1276 y = 0 => x = ["Zero"] 1277 y = 1 => x = ["One"] 1278 false 1279 #x ~=#y => nil 1280 (and/[modeEqual(u,v) for u in x for v in y]) 1281 1282modeEqualSubst(m1,m,e) == 1283 atom m1 and EQ(m1, m) => true 1284 if atom m1 then 1285 m1 := 1286 get(m1,"value",e) is [m0,:.] => m0 1287 m1 1288 if atom m then 1289 m := 1290 get(m,"value",e) is [m2,:.] => m2 1291 m 1292 atom m1 or atom m => m1 = m 1293 modeEqual(m1, m) => true 1294 -- atom m1 => get(m1,"value",e) is [m',:.] and modeEqual(m',m) 1295 m1 is [op,:l1] and m is [=op,:l2] and # l1 = # l2 => 1296-- Above length test inserted JHD 4:47 on 15/8/86 1297-- Otherwise Records can get fouled up - consider expressIdealElt 1298-- in the DEFAULTS package 1299 and/[modeEqualSubst(xm1,xm2,e) for xm1 in l1 for xm2 in l2] 1300 nil 1301 1302--% Things to support )compile 1303 1304compileSpad2Cmd args == 1305 -- This is the old compiler 1306 -- Assume we entered from the "compiler" function, so args ~= nil 1307 -- and is a file with file extension .spad. 1308 1309 path := pathname args 1310 pathnameType path ~= '"spad" => throwKeyedMsg("S2IZ0082", nil) 1311 not PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) 1312 1313 $edit_file := path 1314 sayKeyedMsg("S2IZ0038",[namestring args]) 1315 1316 optList := '( _ 1317 break _ 1318 constructor _ 1319 functions _ 1320 library _ 1321 lisp _ 1322 new _ 1323 old _ 1324 nobreak _ 1325 nolibrary _ 1326 noquiet _ 1327 vartrace _ 1328 quiet _ 1329 ) 1330 1331 -- next three are for the OLD NEW compiler 1332 -- should be unhooked 1333 1334 $scanIfTrue : local := nil 1335 $f : local := nil -- compiler 1336 $m : local := nil -- variables 1337 1338 -- following are for )quick option for code generation 1339 $QuickLet : local := true 1340 $QuickCode : local := true 1341 1342 fun := ['rq, 'lib] 1343 constructor := nil 1344 1345 for opt in $options repeat 1346 [optname,:optargs] := opt 1347 fullopt := selectOptionLC(optname,optList,nil) 1348 1349 fullopt = 'new => error "Internal error: compileSpad2Cmd got )new" 1350 fullopt = 'old => NIL -- no opt 1351 1352 fullopt = 'library => fun.1 := 'lib 1353 fullopt = 'nolibrary => fun.1 := 'nolib 1354 1355 -- Ignore quiet/nonquiet if "constructor" is given. 1356 fullopt = 'quiet => if fun.0 ~= 'c then fun.0 := 'rq 1357 fullopt = 'noquiet => if fun.0 ~= 'c then fun.0 := 'rf 1358 fullopt = 'nobreak => $scanIfTrue := true 1359 fullopt = 'break => $scanIfTrue := nil 1360 fullopt = 'vartrace => 1361 $QuickLet := false 1362 fullopt = 'lisp => 1363 throwKeyedMsg("S2IZ0036",['")lisp"]) 1364 fullopt = 'functions => 1365 null optargs => 1366 throwKeyedMsg("S2IZ0037",['")functions"]) 1367 throwKeyedMsg(")functions unsupported", []) 1368 fullopt = 'constructor => 1369 null optargs => 1370 throwKeyedMsg("S2IZ0037",['")constructor"]) 1371 fun.0 := 'c 1372 constructor := [unabbrev o for o in optargs] 1373 throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)]) 1374 1375 $InteractiveMode : local := nil 1376 compilerDoit(constructor, fun) 1377 extendLocalLibdb $newConlist 1378 terminateSystemCommand() 1379 spadPrompt() 1380 1381compilerDoit(constructor, fun) == 1382 $byConstructors : local := [] 1383 $constructorsSeen : local := [] 1384 fun = ['rf, 'lib] => read_or_compile(true, true) -- Ignore "noquiet". 1385 fun = ['rf, 'nolib] => read_or_compile(false, false) 1386 fun = ['rq, 'lib] => read_or_compile(true, true) 1387 fun = ['rq, 'nolib] => read_or_compile(true, false) 1388 fun = ['c, 'lib] => 1389 $byConstructors := [opOf x for x in constructor] 1390 read_or_compile(true, true) 1391 for ii in $byConstructors repeat 1392 null member(ii,$constructorsSeen) => 1393 sayBrightly ['">>> Warning ",'%b,ii,'%d,'" was not found"] 1394 1395