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