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-- note domainObjects are now (dispatchVector hashCode . domainVector) 35-- lazy oldAxiomDomainObjects are (dispatchVector hashCode (Call form) . backptr), 36-- pre oldAxiomCategory is (dispatchVector . (cat form)) 37-- oldAxiomCategory objects are (dispatchVector . ( (cat form) hash defaultpack parentlist)) 38 39hashCode? x == INTEGERP x 40 41$domainTypeTokens := ['lazyOldAxiomDomain, 'oldAxiomDomain, 'oldAxiomPreCategory, 42 'oldAxiomCategory, 0] 43 44-- The name game. 45-- The compiler produces names that are of the form: 46-- a) cons(0, <string>) 47-- b) cons(1, type-name, arg-names...) 48-- c) cons(2, arg-names...) 49-- d) cons(3, value) 50-- NB: (c) is for tuple-ish constructors, 51-- and (d) is for dependent types. 52 53DNameStringID := 0 54DNameApplyID := 1 55DNameTupleID := 2 56DNameOtherID := 3 57 58DNameToSExpr1 dname == 59 NULL dname => error "unexpected domain name" 60 first dname = DNameStringID => 61 INTERN(CompStrToString rest dname) 62 name0 := DNameToSExpr1 first rest dname 63 args := rest rest dname 64 name0 = '_-_> => 65 froms := first args 66 froms := MAPCAR(function DNameToSExpr, rest froms) 67 ret := first rest args -- a tuple 68 ret := DNameToSExpr first rest ret -- contents 69 CONS('Mapping, CONS(ret, froms)) 70 name0 = 'Union or name0 = 'Record => 71 sxs := MAPCAR(function DNameToSExpr, rest first args) 72 CONS(name0, sxs) 73 name0 = 'Enumeration => 74 CONS(name0, MAPCAR(function DNameFixEnum, rest first args)) 75 CONS(name0, MAPCAR(function DNameToSExpr, args)) 76 77DNameToSExpr dname == 78 first dname = DNameOtherID => 79 rest dname 80 sx := DNameToSExpr1 dname 81 CONSP sx => sx 82 LIST sx 83 84DNameFixEnum arg == CompStrToString rest arg 85 86SExprToDName(sexpr, cosigVal) == 87 -- is it a non-type valued object? 88 NOT cosigVal => [DNameOtherID, :sexpr] 89 if first sexpr = '_: then sexpr := first rest rest sexpr 90 first sexpr = 'Mapping => 91 args := [SExprToDName(sx, 'T) for sx in rest sexpr] 92 [DNameApplyID, 93 [DNameStringID,: StringToCompStr '"->"], 94 [DNameTupleID, :rest args], 95 [DNameTupleID, first args]] 96 name0 := [DNameStringID, :StringToCompStr SYMBOL_-NAME first sexpr] 97 first sexpr = 'Union or first sexpr = 'Record => 98 [DNameApplyID, name0, 99 [DNameTupleID, :[ SExprToDName(sx, 'T) for sx in rest sexpr]]] 100 newCosig := rest GETDATABASE(first sexpr, QUOTE COSIG) 101 [DNameApplyID, name0, 102 :MAPCAR(function SExprToDName, rest sexpr, newCosig)] 103 104-- local garbage because Compiler strings are null terminated 105StringToCompStr(str) == 106 CONCATENATE(QUOTE STRING, str, STRING (CODE_-CHAR 0)) 107 108CompStrToString(str) == 109 SUBSTRING(str, 0, (LENGTH str - 1)) 110-- local garbage ends 111 112runOldAxiomFunctor(:allArgs) == 113 [:args,env] := allArgs 114 GETDATABASE(env, 'CONSTRUCTORKIND) = 'category => 115 [$oldAxiomPreCategoryDispatch,: [env, :args]] 116 dom:=APPLY(env, args) 117 makeOldAxiomDispatchDomain dom 118 119makeLazyOldAxiomDispatchDomain domform == 120 GETDATABASE(opOf domform, 'CONSTRUCTORKIND) = 'category => 121 [$oldAxiomPreCategoryDispatch,: domform] 122 dd := [$lazyOldAxiomDomainDispatch, hashTypeForm(domform,0), domform] 123 NCONC(dd,dd) -- installs back pointer to head of domain. 124 dd 125 126makeOldAxiomDispatchDomain dom == 127 PAIRP dom => dom 128 [$oldAxiomDomainDispatch,hashTypeForm(dom.0,0),:dom] 129 130closeOldAxiomFunctor(name) == 131 [function runOldAxiomFunctor,:SYMBOL_-FUNCTION name] 132 133lazyOldAxiomDomainLookupExport(domenv, self, op, sig, box, skipdefaults, env) == 134 dom := instantiate domenv 135 SPADCALL(rest dom, self, op, sig, box, skipdefaults, (first dom).3) 136 137lazyOldAxiomDomainHashCode(domenv, env) == first domenv 138 139lazyOldAxiomDomainDevaluate(domenv, env) == 140 dom := instantiate domenv 141 SPADCALL(rest dom, (first dom).1) 142 143lazyOldAxiomAddChild(domenv, kid, env) == 144 CONS($lazyOldAxiomDomainDispatch,domenv) 145 146$lazyOldAxiomDomainDispatch := 147 VECTOR('lazyOldAxiomDomain, 148 [function lazyOldAxiomDomainDevaluate], 149 [nil], 150 [function lazyOldAxiomDomainLookupExport], 151 [function lazyOldAxiomDomainHashCode], 152 [function lazyOldAxiomAddChild]) 153 154-- old Axiom pre category objects are just (dispatch . catform) 155-- where catform is ('categoryname,: evaluated args) 156-- old Axiom category objects are (dispatch . [catform, hashcode, defaulting package, parent vector, dom]) 157oldAxiomPreCategoryBuild(catform, dom, env) == 158 pack := oldAxiomCategoryDefaultPackage(catform, dom) 159 CONS($oldAxiomCategoryDispatch, 160 [catform, hashTypeForm(catform,0), pack, oldAxiomPreCategoryParents(catform,dom), dom]) 161oldAxiomPreCategoryHashCode(catform, env) == hashTypeForm(catform,0) 162oldAxiomCategoryDefaultPackage(catform, dom) == 163 hasDefaultPackage opOf catform 164 165oldAxiomPreCategoryDevaluate([op,:args], env) == 166 SExprToDName([op,:devaluateList args], T) 167 168oldAxiomCategoryDevaluate([[op,:args],:.], env) == 169 SExprToDName([op,:devaluateList args], T) 170 171$oldAxiomPreCategoryDispatch := 172 VECTOR('oldAxiomPreCategory, 173 [function oldAxiomPreCategoryDevaluate], 174 [nil], 175 [nil], 176 [function oldAxiomPreCategoryHashCode], 177 [function oldAxiomPreCategoryBuild], 178 [nil]) 179 180oldAxiomPreCategoryParents(catform,dom) == 181 vars := ["$",:rest GETDATABASE(opOf catform, 'CONSTRUCTORFORM)] 182 vals := [dom,:rest catform] 183 -- parents := GETDATABASE(opOf catform, 'PARENTS) 184 parents := parentsOf opOf catform 185 -- strip out forms listed both conditionally and unconditionally 186 unconditionalParents := [] 187 filteredParents := [] 188 for [cat, :pred] in parents repeat 189 if pred = true then 190 unconditionalParents := [cat,:unconditionalParents] 191 filteredParents := [[cat,:pred], :filteredParents] 192 for [cat, :pred] in parents repeat 193 if not pred = true and not member(cat, unconditionalParents) then 194 filteredParents=[[cat,:pred], :filteredParents] 195 PROGV(vars, vals, 196 LIST2VEC [EVAL quoteCatOp cat for [cat,:pred] in filteredParents | EVAL pred]) 197 198 199quoteCatOp cat == 200 atom cat => MKQ cat 201 ['LIST, MKQ first cat, :rest cat] 202 203 204oldAxiomCategoryLookupExport(catenv, self, op, sig, box, env) == 205 [catform,hash, pack,:.] := catenv 206 opIsHasCat op => if EQL(sig, hash) then [self] else nil 207 NULL(pack) => nil 208 if not VECP pack then 209 pack:=apply(pack, CONS(self, rest catform)) 210 RPLACA(CDDR catenv, pack) 211 fun := basicLookup(op, sig, pack, self) => [fun] 212 nil 213 214oldAxiomCategoryParentCount([.,.,.,parents,.], env) == LENGTH parents 215oldAxiomCategoryNthParent([.,.,.,parvec,dom], n, env) == 216 catform := ELT(parvec, n-1) 217 VECTORP IFCAR catform => catform 218 newcat := oldAxiomPreCategoryBuild(catform,dom,nil) 219 SETELT(parvec, n-1, newcat) 220 newcat 221 222oldAxiomCategoryBuild([catform,:.], dom, env) == 223 oldAxiomPreCategoryBuild(catform,dom, env) 224oldAxiomCategoryHashCode([.,hash,:.], env) == hash 225 226$oldAxiomCategoryDispatch := 227 VECTOR('oldAxiomCategory, 228 [function oldAxiomCategoryDevaluate], 229 [nil], 230 [function oldAxiomCategoryLookupExport], 231 [function oldAxiomCategoryHashCode], 232 [function oldAxiomCategoryBuild], -- builder ?? 233 [function oldAxiomCategoryParentCount], 234 [function oldAxiomCategoryNthParent]) -- 1 indexed 235 236instantiate domenv == 237 -- following is a patch for a bug in runtime.as 238 -- has a lazy dispatch vector with an instantiated domenv 239 VECTORP rest domenv => [$oldAxiomDomainDispatch, :domenv] 240 callForm := CADR domenv 241 oldDom := CDDR domenv 242 [functor,:args] := callForm 243-- if null(fn := GETL(functor,'instantiate)) then 244-- ofn := SYMBOL_-FUNCTION functor 245-- loadFunctor functor 246-- fn := SYMBOL_-FUNCTION functor 247-- SETF(SYMBOL_-FUNCTION functor, ofn) 248-- PUT(functor, 'instantiate, fn) 249-- domvec := APPLY(fn, args) 250 domvec := APPLY(functor, args) 251 RPLACA(oldDom, $oldAxiomDomainDispatch) 252 RPLACD(oldDom, [CADR oldDom,: domvec]) 253 oldDom 254 255hashTypeForm([fn,: args], percentHash) == 256 hashType([fn,:devaluateList args], percentHash) 257 258--------------------> NEW DEFINITION (override in i-util.boot) 259devaluate(d) == 260 isDomain d => 261 -- ?need a shortcut for old domains 262 -- ELT(first d, 0) = 'oldAxiomDomain => ... 263 -- FIXP(ELT(first d, 0)) => d 264 DNameToSExpr(SPADCALL(rest d, (first d).1)) 265 not REFVECP d => d 266 greater_SI(QVSIZE d, 5) and QREFELT(d, 3) is ['Category] => QREFELT(d, 0) 267 greater_SI(QVSIZE d, 0) => 268 d':=QREFELT(d,0) 269 isFunctor d' => d' 270 d 271 d 272 273devaluateList l == [devaluate d for d in l] 274 275$hashOp1 := hashString '"1" 276$hashOp0 := hashString '"0" 277$hashOpApply := hashString '"apply" 278$hashOpSet := hashString '"set!" 279$hashSeg := hashString '".." 280$hashPercent := hashString '"%" 281 282oldAxiomDomainLookupExport _ 283 (domenv, self, op, sig, box, skipdefaults, env) == 284 domainVec := rest domenv 285 if hashCode? op then 286 EQL(op, $hashOp1) => op := 'One 287 EQL(op, $hashOp0) => op := 'Zero 288 EQL(op, $hashOpApply) => op := 'elt 289 EQL(op, $hashOpSet) => op := "setelt!" 290 EQL(op, $hashSeg) => op := 'SEGMENT 291 constant := nil 292 if hashCode? sig and self and EQL(sig, getDomainHash self) then 293 sig := '($) 294 constant := true 295 val := 296 skipdefaults => 297 oldCompLookupNoDefaults(op, sig, domainVec, self) 298 oldCompLookup(op, sig, domainVec, self) 299 null val => val 300 if constant then val := SPADCALL val 301 RPLACA(box, val) 302 box 303 304oldAxiomDomainHashCode(domenv, env) == first domenv 305 306oldAxiomDomainDevaluate(domenv, env) == 307 SExprToDName((rest domenv).0, 'T) 308 309oldAxiomAddChild(domenv, child, env) == CONS($oldAxiomDomainDispatch, domenv) 310 311$oldAxiomDomainDispatch := 312 VECTOR('oldAxiomDomain, 313 [function oldAxiomDomainDevaluate], 314 [nil], 315 [function oldAxiomDomainLookupExport], 316 [function oldAxiomDomainHashCode], 317 [function oldAxiomAddChild]) 318 319--------------------> NEW DEFINITION (see g-util.boot) 320isDomain a == 321 PAIRP a and VECP(first a) and 322 member((first a).0, $domainTypeTokens) 323 324-- following is interpreter interface to function lookup 325-- perhaps it should always work with hashcodes for signature? 326--------------------> NEW DEFINITION (override in nrungo.boot) 327NRTcompiledLookup(op,sig,dom) == 328 if CONTAINED('_#,sig) then 329 sig := [NRTtypeHack t for t in sig] 330 hashCode? sig => compiledLookupCheck(op,sig,dom) 331 (fn := compiledLookup(op,sig,dom)) => fn 332 percentHash := 333 VECP dom => hashType(dom.0, 0) 334 getDomainHash dom 335 compiledLookupCheck(op, hashType(['Mapping,:sig], percentHash), dom) 336 337--------------------> NEW DEFINITION (override in nrungo.boot) 338compiledLookup(op, sig, dollar) == 339 if not isDomain dollar then dollar := NRTevalDomain dollar 340 basicLookup(op, sig, dollar, dollar) 341 342HasSignature(domain,[op,sig]) == 343 compiledLookup(op,sig,domain) 344 345--------------------> NEW DEFINITION (override in nrungo.boot) 346basicLookup(op,sig,domain,dollar) == 347 -- FIXME: We should use consistent representation, not hacks 348 -- like this one 349 if op = 0 then op := 'Zero 350 if op = ['Zero] then op := 'Zero 351 if op = 1 then op := 'One 352 if op = ['One] then op := 'One 353 -- Spad case 354 VECP domain => 355 isNewWorldDomain domain => -- getting ops from yourself (or for defaults) 356 oldCompLookup(op, sig, domain, dollar) 357 -- getting ops from Record or Union 358 lookupInDomainVector(op,sig,domain,dollar) 359 hashPercent := 360 VECP dollar => hashType(dollar.0,0) 361 hashType(dollar,0) 362 box := [nil] 363 not VECP(dispatch := first domain) => error "bad domain format" 364 lookupFun := dispatch.3 365 dispatch.0 = 0 => -- new compiler domain object 366 hashSig := 367 hashCode? sig => sig 368 opIsHasCat op => hashType(sig, hashPercent) 369 hashType(['Mapping,:sig], hashPercent) 370 371 if SYMBOLP op then 372 op = 'Zero => op := $hashOp0 373 op = 'One => op := $hashOp1 374 op = 'elt => op := $hashOpApply 375 op = "setelt!" => op := $hashOpSet 376 op := hashString SYMBOL_-NAME op 377 val := first SPADCALL(rest domain, dollar, op, hashSig, box, false, 378 lookupFun) => val 379 hashCode? sig => nil 380 #sig>1 or opIsHasCat op => nil 381 boxval := SPADCALL(rest dollar, dollar, op, 382 hashType(first sig, hashPercent), 383 box, false, lookupFun) => 384 [FUNCTION IDENTITY, :first boxval] 385 nil 386 opIsHasCat op => 387 HasCategory(domain, sig) 388 if hashCode? op then 389 EQL(op, $hashOp1) => op := 'One 390 EQL(op, $hashOp0) => op := 'Zero 391 EQL(op, $hashOpApply) => op := 'elt 392 EQL(op, $hashOpSet) => op := "setelt!" 393 EQL(op, $hashSeg) => op := 'SEGMENT 394 hashCode? sig and EQL(sig, hashPercent) => 395 SPADCALL first SPADCALL(rest dollar, dollar, op, '($), box, 396 false, lookupFun) 397 first SPADCALL(rest dollar, dollar, op, sig, box, false, lookupFun) 398 399basicLookupCheckDefaults(op,sig,domain,dollar) == 400 box := [nil] 401 not VECP(dispatch := first dollar) => error "bad domain format" 402 lookupFun := dispatch.3 403 dispatch.0 = 0 => -- new compiler domain object 404 hashPercent := 405 VECP dollar => hashType(dollar.0,0) 406 hashType(dollar,0) 407 408 hashSig := 409 hashCode? sig => sig 410 hashType( ['Mapping,:sig], hashPercent) 411 412 if SYMBOLP op then op := hashString SYMBOL_-NAME op 413 first SPADCALL(rest dollar, dollar, op, hashSig, box, 414 not $lookupDefaults, lookupFun) 415 first SPADCALL(rest dollar, dollar, op, sig, box, 416 not $lookupDefaults, lookupFun) 417 418$hasCatOpHash := hashString '"%%" 419opIsHasCat op == 420 hashCode? op => EQL(op, $hasCatOpHash) 421 EQ(op, "%%") 422 423-- has cat questions lookup up twice if false 424-- replace with following ? 425-- not(opIsHasCat op) and 426-- (u := lookupInDomainVector(op,sig,domvec,domvec)) => u 427 428oldCompLookup(op, sig, domvec, dollar) == 429 $lookupDefaults:local := nil 430 u := lookupInDomainVector(op,sig,domvec,dollar) => u 431 $lookupDefaults := true 432 lookupInDomainVector(op,sig,domvec,dollar) 433 434oldCompLookupNoDefaults(op, sig, domvec, dollar) == 435 $lookupDefaults:local := nil 436 lookupInDomainVector(op,sig,domvec,dollar) 437 438--------------------> NEW DEFINITION (override in nrungo.boot) 439lookupInDomainVector(op,sig,domain,dollar) == 440 PAIRP domain => basicLookupCheckDefaults(op,sig,domain,domain) 441 slot1 := domain.1 442 SPADCALL(op,sig,dollar,slot1) 443 444--------------------> NEW DEFINITION (override in nrunfast.boot) 445lookupComplete(op,sig,dollar,env) == 446 hashCode? sig => hashNewLookupInTable(op,sig,dollar,env,nil) 447 newLookupInTable(op,sig,dollar,env,nil) 448 449--------------------> NEW DEFINITION (override in nrunfast.boot) 450lookupIncomplete(op,sig,dollar,env) == 451 hashCode? sig => hashNewLookupInTable(op,sig,dollar,env,true) 452 newLookupInTable(op,sig,dollar,env,true) 453 454 455--------------------> NEW DEFINITION (override in nrunfast.boot) 456lazyMatchArg2(s,a,dollar,domain,typeFlag) == 457 if s = '$ then 458-- a = 0 => return true --needed only if extra call in newGoGet to basicLookup 459 s := devaluate dollar -- calls from HasCategory can have $s 460 INTEGERP a => 461 not typeFlag => s = domain.a 462 a = 6 and $isDefaultingPackage => s = devaluate dollar 463 VECP (d := domainVal(dollar,domain,a)) => 464 s = d.0 => true 465 domainArg := ($isDefaultingPackage => domain.6.0; domain.0) 466 IFCAR s = QCAR(d.0) and 467 lazyMatchArgDollarCheck(s, d.0, dollar.0, domainArg) 468 isDomain d => 469 dhash:=getDomainHash d 470 dhash = 471 (if hashCode? s then s else hashType(s, dhash)) 472 lazyMatch(s,d,dollar,domain) --new style 473 a = '$ => s = devaluate dollar 474 a = "$$" => s = devaluate domain 475 STRINGP a => 476 STRINGP s => a = s 477 s is ['QUOTE,y] and PNAME y = a 478 IDENTP s and PNAME s = a 479 atom a => a = s 480 op := opOf a 481 op = 'NRTEVAL => s = nrtEval(CADR a,domain) 482 op = 'QUOTE => s = CADR a 483 lazyMatch(s,a,dollar,domain) 484 --above line is temporarily necessary until system is compiled 8/15/90 485--s = a 486 487--------------------> NEW DEFINITION (override in nrunfast.boot) 488getOpCode(op,vec,max) == 489--search Op vector for "op" returning code if found, nil otherwise 490 res := nil 491 hashCode? op => 492 for i in 0..max by 2 repeat 493 EQL(hashString PNAME QVELT(vec, i), op) => return (res := inc_SI i) 494 res 495 for i in 0..max by 2 repeat 496 EQ(QVELT(vec, i), op) => return (res := inc_SI i) 497 res 498 499hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) == 500 opIsHasCat op => 501 HasCategory(domain, sig) 502 if hashCode? op and EQL(op, $hashOp1) then op := 'One 503 if hashCode? op and EQL(op, $hashOp0) then op := 'Zero 504 hashPercent := 505 VECP dollar => hashType(dollar.0,0) 506 hashType(dollar,0) 507 if hashCode? sig and EQL(sig, hashPercent) then 508 sig := hashType('(Mapping $), hashPercent) 509 dollar = nil => systemError() 510 $lookupDefaults = true => 511 -- lookup first in my cats 512 newLookupInCategories(op, sig, domain, dollar, false) 513 or newLookupInAddChain(op, sig, domain, dollar) 514 --fast path when called from newGoGet 515 success := false 516 if $monitorNewWorld then 517 sayLooking(concat('"---->",form2String devaluate domain, 518 '"----> searching op table for:","%l"," "),op,sig,dollar) 519 someMatch := false 520 numvec := getDomainByteVector domain 521 predvec := domain.3 522 max := MAXINDEX opvec 523 k := getOpCode(op,opvec,max) or return 524 flag => newLookupInAddChain(op,sig,domain,dollar) 525 nil 526 maxIndex := MAXINDEX numvec 527 start := ELT(opvec,k) 528 finish := 529 greater_SI(max, k) => opvec.(add_SI(k, 2)) 530 maxIndex 531 if greater_SI(finish, maxIndex) then systemError '"limit too large" 532 numArgs := if hashCode? sig then -1 else (#sig)-1 533 success := nil 534 $isDefaultingPackage: local := 535 -- use special defaulting handler when dollar non-trivial 536 dollar ~= domain and isDefaultPackageForm? devaluate domain 537 while finish > start repeat 538 PROGN 539 i := start 540 numTableArgs :=numvec.i 541 predIndex := numvec.(i := inc_SI i) 542 predIndex ~= 0 and null testBitVector(predvec, predIndex) => nil 543 exportSig := 544 [newExpandTypeSlot(numvec.(i + j + 1), 545 dollar,domain) for j in 0..numTableArgs] 546 sig ~= hashType(['Mapping,: exportSig],hashPercent) => nil --signifies no match 547 loc := numvec.(i + numTableArgs + 2) 548 loc = 1 => (someMatch := true) 549 loc = 0 => 550 start := add_SI(start, add_SI(numTableArgs, 4)) 551 i := start + 2 552 someMatch := true --mark so that if subsumption fails, look for original 553 subsumptionSig := 554 [newExpandTypeSlot(numvec.(add_SI(i, j)), 555 dollar,domain) for j in 0..numTableArgs] 556 if $monitorNewWorld then 557 sayBrightly [formatOpSignature(op,sig),'"--?-->", 558 formatOpSignature(op,subsumptionSig)] 559 nil 560 slot := domain.loc 561 null atom slot => 562 EQ(QCAR slot,FUNCTION newGoGet) => someMatch:=true 563 --treat as if operation were not there 564 --if EQ(QCAR slot, function newGoGet) then 565 -- UNWIND_-PROTECT --break infinite recursion 566 -- ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot QCDR slot), 567 -- if domain.loc = 'skip then domain.loc := slot) 568 return (success := slot) 569 slot = 'skip => --recursive call from above 'replaceGoGetSlot 570 return (success := newLookupInAddChain(op,sig,domain,dollar)) 571 systemError '"unexpected format" 572 start := add_SI(start, add_SI(numTableArgs, 4)) 573 success ~= 'failed and success => 574 if $monitorNewWorld then 575 if PAIRP success then 576 sayLooking1(concat('"<----", form2String(first success)), 577 rest success) 578 else sayLooking1('"<----XXXXX---", success) 579 success 580 subsumptionSig and (u:= basicLookup(op,subsumptionSig,domain,dollar)) => u 581 flag or someMatch => newLookupInAddChain(op,sig,domain,dollar) 582 nil 583 584--------------------> NEW DEFINITION (override in nrunfast.boot) 585replaceGoGetSlot env == 586 [thisDomain,index,:op] := env 587 thisDomainForm := devaluate thisDomain 588 bytevec := getDomainByteVector thisDomain 589 numOfArgs := bytevec.index 590 goGetDomainSlotIndex := bytevec.(index := inc_SI index) 591 goGetDomain := 592 goGetDomainSlotIndex = 0 => thisDomain 593 thisDomain.goGetDomainSlotIndex 594 if PAIRP goGetDomain and SYMBOLP first goGetDomain then 595 goGetDomain := lazyDomainSet(goGetDomain,thisDomain,goGetDomainSlotIndex) 596 sig := 597 [newExpandTypeSlot(bytevec.(index := inc_SI index), thisDomain, thisDomain) 598 for i in 0..numOfArgs] 599 thisSlot := bytevec.(inc_SI index) 600 if $monitorNewWorld then 601 sayLooking(concat('"%l","..",form2String thisDomainForm, 602 '" wants",'"%l",'" "),op,sig,goGetDomain) 603 slot := basicLookup(op,sig,goGetDomain,goGetDomain) 604 slot = nil => 605 $returnNowhereFromGoGet = true => 606 ['nowhere,:goGetDomain] --see newGetDomainOpTable 607 sayBrightly concat('"Function: ",formatOpSignature(op,sig), 608 '" is missing from domain: ",form2String goGetDomain.0) 609 keyedSystemError("S2NR0001",[op,sig,goGetDomain.0]) 610 if $monitorNewWorld then 611 sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain) 612 SETELT(thisDomain,thisSlot,slot) 613 if $monitorNewWorld then 614 sayLooking1(concat('"<------", form2String(first slot)), rest slot) 615 slot 616 617newHasCategory(domain,catform) == 618 catform = '(Type) => true 619 slot4 := domain.4 620 auxvec := first slot4 621 catvec := CADR slot4 622 $isDefaultingPackage: local := isDefaultPackageForm? devaluate domain 623 #catvec > 0 and INTEGERP IFCDR catvec.0 => --old style 624 BREAK() 625 lazyMatchAssocV(catform,auxvec,catvec,domain) --new style 626 627--------------------> NEW DEFINITION (override in nrunfast.boot) 628lazyMatchAssocV(x,auxvec,catvec,domain) == --new style slot4 629 -- Does not work (triggers type error due to initialization by NIL) 630 -- n : FIXNUM := MAXINDEX catvec 631 n := MAXINDEX catvec 632 -- following call to hashType was missing 2nd arg. 0 added on 3/31/94 by RSS 633 hashCode? x => 634 percentHash := 635 VECP domain => hashType(domain.0, 0) 636 getDomainHash domain 637 or/[ELT(auxvec,i) for i in 0..n | 638 x = hashType(newExpandLocalType(QVELT(catvec,i),domain,domain), percentHash)] 639 xop := first x 640 or/[ELT(auxvec,i) for i in 0..n | 641 --xop = first (lazyt := QVELT(catvec,i)) and lazyMatch(x,lazyt,domain,domain)] 642 xop = first (lazyt := getCatForm(catvec, i, domain)) and 643 lazyMatch(x, lazyt, domain, domain)] 644 645getCatForm(catvec, index, domain) == 646 NUMBERP(form := QVELT(catvec,index)) => domain.form 647 form 648 649has(domain,catform') == HasCategory(domain,catform') 650 651HasCategory(domain,catform') == 652 catform' is ['SIGNATURE,:f] => HasSignature(domain,f) 653 catform' is ['ATTRIBUTE,f] => 654 BREAK() 655 isDomain domain => 656 FIXP((first domain).0) => 657 catform' := devaluate catform' 658 basicLookup("%%",catform',domain,domain) 659 HasCategory(CDDR domain, catform') 660 catform:= devaluate catform' 661 isNewWorldDomain domain => newHasCategory(domain,catform) 662 domain0:=domain.0 -- handles old style domains, Record, Union etc. 663 slot4 := domain.4 664 catlist := slot4.1 665 member(catform,catlist) or 666 opOf(catform) = "Type" or --temporary hack 667 or/[compareSigEqual(catform,cat,domain0,domain) for cat in catlist] 668 669--------------------> NEW DEFINITION (override in nrunfast.boot) 670lazyDomainSet(form, thisDomain, slot) == 671 slotDomain := evalSlotDomain(form,thisDomain) 672 if $monitorNewWorld then 673 sayLooking1(concat(form2String devaluate thisDomain, 674 '" activating lazy slot ",slot,'": "),slotDomain) 675-- name := first form 676--getInfovec name 677 SETELT(thisDomain,slot,slotDomain) 678 679 680--------------------> NEW DEFINITION (override in template.boot) 681evalSlotDomain(u,dollar) == 682 $returnNowhereFromGoGet: local := false 683 $ : fluid := dollar 684 $lookupDefaults : local := nil -- new world 685 isDomain u => u 686 u = '$ => dollar 687 u = "$$" => dollar 688 FIXP u => 689 VECP (y := dollar.u) => y 690 isDomain y => y 691 y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous? 692 y is [v,:.] => 693 VECP v => BREAK() 694 constructor? v or MEMQ(v,'(Record Union Mapping)) => 695 lazyDomainSet(y,dollar,u) --new style has lazyt 696 v = 'QUOTE => first(rest(y)) 697 y 698 y 699 u is ['NRTEVAL, y] => eval y 700 u is ['QUOTE,y] => y 701 u is ['Record,:argl] => 702 FUNCALL('Record0,[[tag,:evalSlotDomain(dom,dollar)] 703 for [.,tag,dom] in argl]) 704 u is ['Union,:argl] and first argl is ['_:,.,.] => 705 APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)] 706 for [.,tag,dom] in argl]) 707 u is ['spadConstant,d,n] => 708 dom := evalSlotDomain(d,dollar) 709 SPADCALL(dom . n) 710 u is ['ELT,d,n] => 711 dom := evalSlotDomain(d,dollar) 712 slot := dom . n 713 slot is [=FUNCTION newGoGet,:env] => 714 replaceGoGetSlot env 715 slot 716 u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl]) 717 systemErrorHere '"evalSlotDomain" 718 719--------------------> NEW DEFINITION (override in i-util.boot) 720domainEqual(a,b) == 721 devaluate(a) = devaluate(b) 722 723 724--------------------> NEW DEFINITION (see i-funsel.boot) 725getFunctionFromDomain1(op, dc, target, args) == 726 -- finds the function op with argument types args in dc 727 -- complains, if no function or ambiguous 728 $reportBottomUpFlag:local:= NIL 729 member(first dc, $nonLisplibDomains) => 730 throwKeyedMsg("S2IF0002", [first dc]) 731 not constructor? first dc => 732 throwKeyedMsg("S2IF0003", [first dc]) 733 p:= findFunctionInDomain(op, dc, target, args, args, NIL, NIL) => 734--+ 735 --sig := [NIL,:args] 736 domain := evalDomain dc 737 for mm in nreverse p until b repeat 738 [[.,:osig],nsig,:.] := mm 739 b := compiledLookup(op,nsig,domain) 740 b or throwKeyedMsg("S2IS0023",[op,dc]) 741 throwKeyedMsg("S2IF0004",[op,dc]) 742 743getFunctionFromDomain(op, dc, args) == 744 getFunctionFromDomain1(op, dc, NIL, args) 745 746devaluateDeeply x == 747 VECP x => devaluate x 748 atom x => x 749 [devaluateDeeply y for y in x] 750 751lookupDisplay(op,sig,vectorOrForm,suffix) == 752 null $NRTmonitorIfTrue => nil 753 prefix := (suffix = '"" => ">"; "<") 754 sayBrightly 755 concat(prefix,formatOpSignature(op,sig), 756 '" from ", prefix2String devaluateDeeply vectorOrForm,suffix) 757 758isCategoryPackageName nam == 759 p := PNAME opOf nam 760 p.(MAXINDEX p) = char '_& 761