remove pamphlets - part 7

1 files changed, 670 insertions, 0 deletions

diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot
new file mode 100644
index 00000000..db9136af
--- /dev/null
+++ b/src/interp/nrunfast.boot
@@ -0,0 +1,670 @@
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- All rights reserved.
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+--     - Redistributions of source code must retain the above copyright
+--       notice, this list of conditions and the following disclaimer.
+--
+--     - Redistributions in binary form must reproduce the above copyright
+--       notice, this list of conditions and the following disclaimer in
+--       the documentation and/or other materials provided with the
+--       distribution.
+--
+--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+--       names of its contributors may be used to endorse or promote products
+--       derived from this software without specific prior written permission.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+--=======================================================================
+--                     Basic Functions
+--=======================================================================
+initNewWorld() ==
+  $NRTflag := true
+  $NRTvec := true
+  $NRTmakeCompactDirect := true
+  $NRTquick := true
+  $NRTmakeShortDirect := true
+  $newWorld := true
+  $monitorNewWorld := false
+  $consistencyCheck := false
+  $spadLibFT := 'NRLIB
+  $NRTmonitorIfTrue := false
+  $updateCatTableIfTrue := false
+  $doNotCompressHashTableIfTrue := true
+ 
+isNewWorldDomain domain == INTEGERP domain.3    --see HasCategory/Attribute
+ 
+getDomainByteVector dom == CDDR dom.4
+ 
+--------------------> NEW DEFINITION (see interop.boot.pamphlet)
+getOpCode(op,vec,max) ==
+--search Op vector for "op" returning code if found, nil otherwise
+  res := nil
+  for i in 0..max by 2 repeat
+    EQ(QVELT(vec,i),op) => return (res := QSADD1 i)
+  res
+ 
+--=======================================================
+--                 Lookup From Compiled Code
+--=======================================================
+newGoGet(:l) ==
+  [:arglist,env] := l
+  slot := replaceGoGetSlot env
+  APPLY(first slot,[:arglist,rest slot])  --SPADCALL it!
+ 
+--------------------> NEW DEFINITION (see interop.boot.pamphlet)
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+replaceGoGetSlot env ==
+  [thisDomain,index,:op] := env
+  thisDomainForm := devaluate thisDomain
+  bytevec := getDomainByteVector thisDomain
+  numOfArgs := bytevec.index
+  goGetDomainSlotIndex := bytevec.(index := QSADD1 index)
+  goGetDomain :=
+     goGetDomainSlotIndex = 0 => thisDomain
+     thisDomain.goGetDomainSlotIndex
+  if PAIRP goGetDomain then
+     goGetDomain := lazyDomainSet(goGetDomain,thisDomain,goGetDomainSlotIndex)
+  sig :=
+    [newExpandTypeSlot(bytevec.(index := QSADD1 index),thisDomain,thisDomain)
+      for i in 0..numOfArgs]
+  thisSlot := bytevec.(QSADD1 index)
+  if $monitorNewWorld then
+    sayLooking(concat('"%l","..",form2String thisDomainForm,
+      '" wants",'"%l",'"  "),op,sig,goGetDomain)
+  slot :=  .basicLookup(op,sig,goGetDomain,goGetDomain)
+  slot = nil =>
+    $returnNowhereFromGoGet = true =>
+      ['nowhere,:goGetDomain]  --see newGetDomainOpTable
+    sayBrightly concat('"Function: ",formatOpSignature(op,sig),
+      '" is missing from domain: ",form2String goGetDomain.0)
+    keyedSystemError("S2NR0001",[op,sig,goGetDomain.0])
+  if $monitorNewWorld then
+    sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain)
+  SETELT(thisDomain,thisSlot,slot)
+  if $monitorNewWorld then
+    sayLooking1('"<------",[CAR slot,:devaluate CDR slot])
+  slot
+ 
+--=======================================================
+--       Lookup Function in Slot 1 (via SPADCALL)
+--=======================================================
+lookupFF(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil)
+ 
+lookupUF(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true)
+ 
+--------------------> NEW DEFINITION (see interop.boot.pamphlet)
+lookupComplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil)
+ 
+--------------------> NEW DEFINITION (see interop.boot.pamphlet)
+lookupIncomplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true)
+ 
+--------------------> NEW DEFINITION (see interop.boot.pamphlet)
+lookupInCompactTable(op,sig,dollar,env) ==
+  newLookupInTable(op,sig,dollar,env,true)
+ 
+newLookupInTable(op,sig,dollar,[domain,opvec],flag) ==
+  dollar = nil => systemError()
+  $lookupDefaults = true =>
+    newLookupInCategories(op,sig,domain,dollar)      --lookup first in my cats
+      or newLookupInAddChain(op,sig,domain,dollar)
+  --fast path when called from newGoGet
+  success := false
+  if $monitorNewWorld then
+    sayLooking(concat('"---->",form2String devaluate domain,
+      '"----> searching op table for:","%l","  "),op,sig,dollar)
+  someMatch := false
+  numvec := getDomainByteVector domain
+  predvec := domain.3
+  max := MAXINDEX opvec
+  k := getOpCode(op,opvec,max) or return
+    flag => newLookupInAddChain(op,sig,domain,dollar)
+    nil
+  maxIndex := MAXINDEX numvec
+  start := ELT(opvec,k)
+  finish :=
+    QSGREATERP(max,k) => opvec.(QSPLUS(k,2))
+    maxIndex
+  if QSGREATERP(finish,maxIndex) then systemError '"limit too large"
+  numArgs := QSDIFFERENCE(#sig,1)
+  success := nil
+  $isDefaultingPackage: local :=
+    -- use special defaulting handler when dollar non-trivial
+    dollar ^= domain and isDefaultPackageForm? devaluate domain
+  while finish > start repeat
+    PROGN
+      i := start
+      numArgs ^= (numTableArgs :=numvec.i) => nil
+      predIndex := numvec.(i := QSADD1 i)
+      NE(predIndex,0) and null testBitVector(predvec,predIndex) => nil
+      loc := newCompareSig(sig,numvec,(i := QSADD1 i),dollar,domain)
+      null loc => nil  --signifies no match
+      loc = 1 => (someMatch := true)
+      loc = 0 =>
+        start := QSPLUS(start,QSPLUS(numTableArgs,4))
+        i := start + 2
+        someMatch := true --mark so that if subsumption fails, look for original
+        subsumptionSig :=
+          [newExpandTypeSlot(numvec.(QSPLUS(i,j)),
+            dollar,domain) for j in 0..numTableArgs]
+        if $monitorNewWorld then
+          sayBrightly [formatOpSignature(op,sig),'"--?-->",
+            formatOpSignature(op,subsumptionSig)]
+        nil
+      slot := domain.loc
+      null atom slot =>
+        EQ(QCAR slot,'newGoGet) => someMatch:=true
+                   --treat as if operation were not there
+        --if EQ(QCAR slot,'newGoGet) then
+        --  UNWIND_-PROTECT --break infinite recursion
+        --    ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot QCDR slot),
+        --      if domain.loc = 'skip then domain.loc := slot)
+        return (success := slot)
+      slot = 'skip =>       --recursive call from above 'replaceGoGetSlot
+        return (success := newLookupInAddChain(op,sig,domain,dollar))
+      systemError '"unexpected format"
+    start := QSPLUS(start,QSPLUS(numTableArgs,4))
+  NE(success,'failed) and success =>
+    if $monitorNewWorld then
+      sayLooking1('"<----",uu) where uu ==
+        PAIRP success => [first success,:devaluate rest success]
+        success
+    success
+  subsumptionSig and (u:= basicLookup(op,subsumptionSig,domain,dollar)) => u
+  flag or someMatch => newLookupInAddChain(op,sig,domain,dollar)
+  nil
+ 
+ 
+isDefaultPackageForm? x == x is [op,:.]
+  and IDENTP op and (s := PNAME op).(MAXINDEX s) = "&"
+ 
+ 
+--=======================================================
+--       Lookup Addlist (from lookupInDomainTable or lookupInDomain)
+--=======================================================
+newLookupInAddChain(op,sig,addFormDomain,dollar) ==
+  if $monitorNewWorld then sayLooking1('"looking up add-chain: ",addFormDomain)
+  addFunction:=newLookupInDomain(op,sig,addFormDomain,dollar,5)
+  addFunction =>
+    if $monitorNewWorld then
+      sayLooking1(concat('"<----add-chain function found for ",
+        form2String devaluate addFormDomain,'"<----"),CDR addFunction)
+    addFunction
+  nil
+ 
+--=======================================================
+--   Lookup In Domain (from lookupInAddChain)
+--=======================================================
+newLookupInDomain(op,sig,addFormDomain,dollar,index) ==
+  addFormCell := addFormDomain.index =>
+    INTEGERP KAR addFormCell =>
+      or/[newLookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell]
+    if null VECP addFormCell then lazyDomainSet(addFormCell,addFormDomain,index)
+    lookupInDomainVector(op,sig,addFormDomain.index,dollar)
+  nil
+ 
+--=======================================================
+--       Category Default Lookup (from goGet or lookupInAddChain)
+--=======================================================
+newLookupInCategories(op,sig,dom,dollar) ==
+  slot4 := dom.4
+  catVec := CADR slot4
+  SIZE catVec = 0 => nil                      --early exit if no categories
+  INTEGERP KDR catVec.0 =>
+    newLookupInCategories1(op,sig,dom,dollar) --old style
+  $lookupDefaults : local := nil
+  if $monitorNewWorld = true then sayBrightly concat('"----->",
+    form2String devaluate dom,'"-----> searching default packages for ",op)
+  predvec := dom.3
+  packageVec := QCAR slot4
+--the next three lines can go away with new category world
+  varList := ['$,:$FormalMapVariableList]
+  valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]]
+  valueList := [MKQ val for val in valueList]
+  nsig := MSUBST(dom.0,dollar.0,sig)
+  for i in 0..MAXINDEX packageVec |
+       (entry := packageVec.i) and entry ^= 'T repeat
+    package :=
+      VECP entry =>
+         if $monitorNewWorld then
+           sayLooking1('"already instantiated cat package",entry)
+         entry
+      IDENTP entry =>
+        cat := catVec.i
+        packageForm := nil
+        if not GETL(entry,'LOADED) then loadLib entry
+        infovec := GETL(entry,'infovec)
+        success :=
+          --VECP infovec =>  ----new world
+          true =>  ----new world
+            opvec := infovec.1
+            max := MAXINDEX opvec
+            code := getOpCode(op,opvec,max)
+            null code => nil
+            byteVector := CDDDR infovec.3
+            endPos :=
+              code+2 > max => SIZE byteVector
+              opvec.(code+2)
+            not nrunNumArgCheck(#(QCDR sig),byteVector,opvec.code,endPos) => nil
+            --numOfArgs := byteVector.(opvec.code)
+            --numOfArgs ^= #(QCDR sig) => nil
+            packageForm := [entry,'$,:CDR cat]
+            package := evalSlotDomain(packageForm,dom)
+            packageVec.i := package
+            package
+                           ----old world
+          table := HGET($Slot1DataBase,entry) or systemError nil
+          (u := LASSQ(op,table))
+            and (v := or/[rest x for x in u | #sig = #x.0]) =>
+              packageForm := [entry,'$,:CDR cat]
+              package := evalSlotDomain(packageForm,dom)
+              packageVec.i := package
+              package
+          nil
+        null success =>
+          if $monitorNewWorld = true then
+            sayBrightlyNT '"  not in: "
+            pp (packageForm and devaluate package or entry)
+          nil
+        if $monitorNewWorld then
+          sayLooking1('"candidate default package instantiated: ",success)
+        success
+      entry
+    null package => nil
+    if $monitorNewWorld then
+      sayLooking1('"Looking at instantiated package ",package)
+    res := basicLookup(op,sig,package,dollar) =>
+      if $monitorNewWorld = true then
+        sayBrightly '"candidate default package succeeds"
+      return res
+    if $monitorNewWorld = true then
+      sayBrightly '"candidate fails -- continuing to search categories"
+    nil
+ 
+nrunNumArgCheck(num,bytevec,start,finish) ==
+   args := bytevec.start
+   num = args => true
+   (start := start + args + 4) = finish => nil
+   nrunNumArgCheck(num,bytevec,start,finish)
+ 
+newLookupInCategories1(op,sig,dom,dollar) ==
+  $lookupDefaults : local := nil
+  if $monitorNewWorld = true then sayBrightly concat('"----->",
+    form2String devaluate dom,'"-----> searching default packages for ",op)
+  predvec := dom.3
+  slot4 := dom.4
+  packageVec := CAR slot4
+  catVec := CAR QCDR slot4
+--the next three lines can go away with new category world
+  varList := ['$,:$FormalMapVariableList]
+  valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]]
+  valueList := [MKQ val for val in valueList]
+  nsig := MSUBST(dom.0,dollar.0,sig)
+  for i in 0..MAXINDEX packageVec | (entry := ELT(packageVec,i))
+      and (VECP entry or (predIndex := CDR (node := ELT(catVec,i))) and
+          (EQ(predIndex,0) or testBitVector(predvec,predIndex))) repeat
+    package :=
+      VECP entry =>
+         if $monitorNewWorld then
+           sayLooking1('"already instantiated cat package",entry)
+         entry
+      IDENTP entry =>
+        cat := QCAR node
+        packageForm := nil
+        if not GETL(entry,'LOADED) then loadLib entry
+        infovec := GETL(entry,'infovec)
+        success :=
+          VECP infovec =>
+            opvec := infovec.1
+            max := MAXINDEX opvec
+            code := getOpCode(op,opvec,max)
+            null code => nil
+            byteVector := CDDR infovec.3
+            numOfArgs := byteVector.(opvec.code)
+            numOfArgs ^= #(QCDR sig) => nil
+            packageForm := [entry,'$,:CDR cat]
+            package := evalSlotDomain(packageForm,dom)
+            packageVec.i := package
+            package
+          table := HGET($Slot1DataBase,entry) or systemError nil
+          (u := LASSQ(op,table))
+            and (v := or/[rest x for x in u | #sig = #x.0]) =>
+              packageForm := [entry,'$,:CDR cat]
+              package := evalSlotDomain(packageForm,dom)
+              packageVec.i := package
+              package
+          nil
+        null success =>
+          if $monitorNewWorld = true then
+            sayBrightlyNT '"  not in: "
+            pp (packageForm and devaluate package or entry)
+          nil
+        if $monitorNewWorld then
+          sayLooking1('"candidate default package instantiated: ",success)
+        success
+      entry
+    null package => nil
+    if $monitorNewWorld then
+      sayLooking1('"Looking at instantiated package ",package)
+    res := lookupInDomainVector(op,sig,package,dollar) =>
+      if $monitorNewWorld = true then
+        sayBrightly '"candidate default package succeeds"
+      return res
+    if $monitorNewWorld = true then
+      sayBrightly '"candidate fails -- continuing to search categories"
+    nil
+ 
+--=======================================================
+--     Instantiate Default Package if Signature Matches
+--=======================================================
+ 
+getNewDefaultPackage(op,sig,infovec,dom,dollar) ==
+  hohohoho()
+  opvec := infovec . 1
+  numvec := CDDR infovec . 3
+  max := MAXINDEX opvec
+  k := getOpCode(op,opvec,max) or return nil
+  maxIndex := MAXINDEX numvec
+  start := ELT(opvec,k)
+  finish :=
+    QSGREATERP(max,k) => opvec.(QSPLUS(k,2))
+    maxIndex
+  if QSGREATERP(finish,maxIndex) then systemError '"limit too large"
+  numArgs := QSDIFFERENCE(#sig,1)
+  success := nil
+  while finish > start repeat
+    PROGN
+      i := start
+      numArgs ^= (numTableArgs :=numvec.i) => nil
+      newCompareSigCheaply(sig,numvec,(i := QSPLUS(i,2))) =>
+        return (success := true)
+    start := QSPLUS(start,QSPLUS(numTableArgs,4))
+  null success => nil
+  defaultPackage := cacheCategoryPackage(packageVec,catVec,i)
+ 
+--=======================================================
+--         Compare Signature to One Derived from Table
+--=======================================================
+newCompareSig(sig, numvec, index, dollar, domain) ==
+  k := index
+  null (target := first sig)
+   or lazyMatchArg(target,numvec.k,dollar,domain) =>
+     and/[lazyMatchArg(s,numvec.(k := i),dollar,domain)
+              for s in rest sig for i in (index+1)..] => numvec.(QSINC1 k)
+     nil
+  nil
+ 
+--=======================================================
+--     Compare Signature to One Derived from Table
+--=======================================================
+lazyMatchArg(s,a,dollar,domain) == lazyMatchArg2(s,a,dollar,domain,true)
+ 
+--------------------> NEW DEFINITION (see interop.boot.pamphlet)
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+lazyMatchArg2(s,a,dollar,domain,typeFlag) ==
+  if s = '$ then
+--  a = 0 => return true  --needed only if extra call in newGoGet to basicLookup
+    s := devaluate dollar -- calls from HasCategory can have $s
+  INTEGERP a =>
+    not typeFlag => s = domain.a
+    a = 6 and $isDefaultingPackage => s = devaluate dollar
+    VECP (d := domainVal(dollar,domain,a)) =>
+      s = d.0 => true
+      domainArg := ($isDefaultingPackage => domain.6.0; domain.0)
+      KAR s = QCAR d.0 and lazyMatchArgDollarCheck(s,d.0,dollar.0,domainArg)
+    --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain)      --old style (erase)
+    lazyMatch(s,d,dollar,domain)                         --new style
+  a = '$ => s = devaluate dollar
+  STRINGP a =>
+    s is ['QUOTE,y] and PNAME y = a
+    IDENTP s and PNAME s = a
+  atom a =>  a = s
+  op := opOf a
+  op  = 'NRTEVAL => s = nrtEval(CADR a,domain)
+  op = 'QUOTE => s = CADR a
+  lazyMatch(s,a,dollar,domain)
+  --above line is temporarily necessary until system is compiled 8/15/90
+--s = a
+ 
+lazyMatch(source,lazyt,dollar,domain) ==
+  lazyt is [op,:argl] and null atom source and op=CAR source
+    and #(sargl := CDR source) = #argl =>
+      MEMQ(op,'(Record Union)) and first argl is [":",:.] =>
+        and/[stag = atag and lazyMatchArg(s,a,dollar,domain)
+              for [.,stag,s] in sargl for [.,atag,a] in argl]
+      MEMQ(op,'(Union Mapping QUOTE)) =>
+         and/[lazyMatchArg(s,a,dollar,domain) for s in sargl for a in argl]
+      coSig := GETDATABASE(op,'COSIG)
+      NULL coSig => error ["bad Constructor op", op]
+      and/[lazyMatchArg2(s,a,dollar,domain,flag)
+           for s in sargl for a in argl for flag in rest coSig]
+  STRINGP source and lazyt is ['QUOTE,=source] => true
+  NUMBERP source =>
+      lazyt is ['_#, slotNum] => source = #(domain.slotNum)
+      lazyt is ['call,'LENGTH, slotNum] => source = #(domain.slotNum)
+      nil
+  source is ['construct,:l] => l = lazyt
+  -- A hideous hack on the same lines as the previous four lines JHD/MCD
+  nil
+
+ 
+lazyMatchArgDollarCheck(s,d,dollarName,domainName) ==
+  #s ^= #d => nil
+  scoSig := GETDATABASE(opOf s,'COSIG) or return nil
+  if MEMQ(opOf s, '(Union Mapping Record)) then 
+     scoSig := [true for x in s]
+  and/[fn for x in rest s for arg in rest d for xt in rest scoSig] where
+   fn ==
+    x = arg => true
+    x is ['elt,someDomain,opname] => lookupInDomainByName(opname,evalDomain someDomain,arg)
+    x = '$ and (arg = dollarName or arg = domainName) => true
+    x = dollarName and arg = domainName => true
+    ATOM x or ATOM arg => false
+    xt and CAR x = CAR arg =>
+      lazyMatchArgDollarCheck(x,arg,dollarName,domainName)
+    false
+
+lookupInDomainByName(op,domain,arg) ==
+  atom arg => nil
+  opvec := domain . 1 . 2
+  numvec := getDomainByteVector domain
+  predvec := domain.3
+  max := MAXINDEX opvec
+  k := getOpCode(op,opvec,max) or return nil
+  maxIndex := MAXINDEX numvec
+  start := ELT(opvec,k)
+  finish :=
+    QSGREATERP(max,k) => opvec.(QSPLUS(k,2))
+    maxIndex
+  if QSGREATERP(finish,maxIndex) then systemError '"limit too large"
+  success := false
+  while finish > start repeat
+    i := start
+    numberOfArgs :=numvec.i
+    predIndex := numvec.(i := QSADD1 i)
+    NE(predIndex,0) and null testBitVector(predvec,predIndex) => nil
+    slotIndex := numvec.(i + 2 + numberOfArgs)
+    newStart := QSPLUS(start,QSPLUS(numberOfArgs,4))
+    slot := domain.slotIndex
+    null atom slot and EQ(CAR slot,CAR arg) and EQ(CDR slot,CDR arg) => return (success := true)
+    start := QSPLUS(start,QSPLUS(numberOfArgs,4))
+  success
+ 
+--=======================================================
+--        Expand Signature from Encoded Slot Form
+--=======================================================
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+newExpandGoGetTypeSlot(slot,dollar,domain) ==
+  newExpandTypeSlot(slot,domain,domain)
+ 
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+newExpandTypeSlot(slot, dollar, domain) ==
+--> returns domain form for dollar.slot
+   newExpandLocalType(domainVal(dollar, domain, slot), dollar,domain)
+ 
+ 
+--------------------> NEW DEFINITION (see interop.boot.pamphlet)
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+newExpandLocalType(lazyt,dollar,domain) ==
+  VECP lazyt => lazyt.0
+  lazyt is [vec,.,:lazyForm] and VECP vec =>              --old style
+    newExpandLocalTypeForm(lazyForm,dollar,domain)
+  newExpandLocalTypeForm(lazyt,dollar,domain)             --new style
+ 
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+newExpandLocalTypeForm([functorName,:argl],dollar,domain) ==
+  MEMQ(functorName, '(Record Union)) and first argl is [":",:.] =>
+    [functorName,:[['_:,tag,newExpandLocalTypeArgs(dom,dollar,domain,true)]
+                                 for [.,tag,dom] in argl]]
+  MEMQ(functorName, '(Union Mapping)) =>
+          [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,true) for a in argl]]
+  functorName = 'QUOTE => [functorName,:argl]
+  coSig := GETDATABASE(functorName,'COSIG)
+  NULL coSig => error ["bad functorName", functorName]
+  [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,flag)
+        for a in argl for flag in rest coSig]]
+ 
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+newExpandLocalTypeArgs(u,dollar,domain,typeFlag) ==
+  u = '$ => dollar.0      -------eliminate this as $ is rep by 0
+  INTEGERP u =>
+     typeFlag => newExpandTypeSlot(u, dollar,domain)
+     domain.u
+  u is ['NRTEVAL,y] => nrtEval(y,domain)
+  u is ['QUOTE,y] => y
+  atom u => u   --can be first, rest, etc.
+  newExpandLocalTypeForm(u,dollar,domain)
+ 
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+nrtEval(expr,dom) ==
+  $:fluid := dom
+  eval expr
+ 
+domainVal(dollar,domain,index) ==
+--returns a domain or a lazy slot
+  index = 0 => dollar
+  index = 2 => domain
+  domain.index
+ 
+ 
+--=======================================================
+--          Convert Lazy Domain to Domain Form
+--=======================================================
+ 
+--------------------> NEW DEFINITION (see interop.boot.pamphlet)
+lazyDomainSet(lazyForm,thisDomain,slot) ==
+  form :=
+    lazyForm is [vec,.,:u] and VECP vec => u        --old style
+    lazyForm                                        --new style
+  slotDomain := evalSlotDomain(form,thisDomain)
+  if $monitorNewWorld then
+    sayLooking1(concat(form2String devaluate thisDomain,
+      '" activating lazy slot ",slot,'": "),slotDomain)
+  name := CAR form
+  SETELT(thisDomain,slot,slotDomain)
+ 
+--=======================================================
+--                   HasCategory/Attribute
+--=======================================================
+-- PLEASE NOTE: This function has the rather charming side-effect that
+-- e.g. it works if domform is an Aldor Category.  This is being used
+-- by extendscategoryForm in c-util to allow Aldor domains to be used
+-- in spad code.  Please do not break this!  An example is the use of
+-- Interval (an Aldor domain) by SIGNEF in limitps.spad.  MCD.
+newHasTest(domform,catOrAtt) ==
+  domform is [dom,:.] and dom in '(Union Record Mapping Enumeration) =>
+    ofCategory(domform, catOrAtt)
+  catOrAtt = '(Type) => true
+  GETDATABASE(opOf domform, 'ASHARP?) => fn(domform,catOrAtt) where
+  -- atom (infovec := getInfovec opOf domform) => fn(domform,catOrAtt) where
+    fn(a,b) ==
+      categoryForm?(a) => assoc(b, ancestorsOf(a, nil))
+      isPartialMode a => throwKeyedMsg("S2IS0025",NIL)
+      b is ["SIGNATURE",:opSig] =>
+        HasSignature(evalDomain a,opSig)
+      b is ["ATTRIBUTE",attr] => HasAttribute(evalDomain a,attr)
+      hasCaty(a,b,NIL) ^= 'failed
+      HasCategory(evalDomain a,b) => true -- for asharp domains: must return Boolean
+  op := opOf catOrAtt
+  isAtom := atom catOrAtt
+  null isAtom and op = 'Join =>
+    and/[newHasTest(domform,x) for x in rest catOrAtt]
+-- we will refuse to say yes for 'Cat has Cat'
+--GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => throwKeyedMsg("S2IS0025",NIL)
+-- on second thoughts we won't!
+  GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category =>
+      domform = catOrAtt => 'T
+      for [aCat,:cond] in [:ancestorsOf(domform,NIL),:SUBLISLIS (rest domform,$FormalMapVariableList,GETDATABASE(opOf domform,'ATTRIBUTES))] |  aCat = catOrAtt  repeat
+         return evalCond cond where
+           evalCond x ==
+             ATOM x => x
+             [pred,:l] := x
+             pred = 'has => 
+                  l is [ w1,['ATTRIBUTE,w2]] => newHasTest(w1,w2) 
+                  l is [ w1,['SIGNATURE,:w2]] => compiledLookup(CAR w2,CADR w2, eval mkEvalable w1)
+                  newHasTest(first  l ,first rest l) 
+             pred = 'OR => or/[evalCond i for i in l]
+             pred = 'AND => and/[evalCond i for i in l]
+             x  
+  null isAtom and constructor? op  =>
+    domain := eval mkEvalable domform
+    newHasCategory(domain,catOrAtt)
+  newHasAttribute(eval mkEvalable domform,catOrAtt)
+ 
+lazyMatchAssocV(x,auxvec,catvec,domain) ==      --new style slot4
+  n : FIXNUM := MAXINDEX catvec
+  xop := CAR x
+  or/[ELT(auxvec,i) for i in 0..n |
+    xop = CAR (lazyt := QVELT(catvec,i)) and lazyMatch(x,lazyt,domain,domain)]
+ 
+lazyMatchAssocV1(x,vec,domain) ==               --old style slot4
+  n : FIXNUM := MAXINDEX vec
+  xop := CAR x
+  or/[QCDR QVELT(vec,i) for i in 0..n |
+    xop = CAR (lazyt := CAR QVELT(vec,i)) and lazyMatch(x,lazyt,domain,domain)]
+ 
+--newHasAttribute(domain,attrib) ==
+--  predIndex := LASSOC(attrib,domain.2) =>
+--    EQ(predIndex,0) => true
+--    predvec := domain.3
+--    testBitVector(predvec,predIndex)
+--  false
+ 
+--=======================================================
+--                   Utility Functions
+--=======================================================
+ 
+sayLooking(prefix,op,sig,dom) ==
+  $monitorNewWorld := false
+  dollar := devaluate dom
+  atom dollar or VECP dollar or or/[VECP x for x in dollar] => systemError nil
+  sayBrightly
+    concat(prefix,formatOpSignature(op,sig),bright '"from ",form2String dollar)
+  $monitorNewWorld := true
+ 
+sayLooking1(prefix,dom) ==
+  $monitorNewWorld := false
+  dollar :=
+    VECP dom => devaluate dom
+    devaluateList dom
+  sayBrightly concat(prefix,form2String dollar)
+  $monitorNewWorld := true
+ 
+cc() == -- don't remove this function
+  clearConstructorCaches()
+  clearClams()