Revert commits to the wrong tree.

1 files changed, 769 insertions, 0 deletions

diff --git a/src/interp/nruncomp.boot.pamphlet b/src/interp/nruncomp.boot.pamphlet
new file mode 100644
index 00000000..fbc94289
--- /dev/null
+++ b/src/interp/nruncomp.boot.pamphlet
@@ -0,0 +1,769 @@
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\$SPAD/src/interp nruncomp.boot}
+\author{The Axiom Team}
+
+\begin{document}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+
+\section{License}
+
+<<license>>=
+-- 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.
+
+@
+<<*>>=
+<<license>>
+
+-----------------------------NEW buildFunctor CODE-----------------------------
+NRTaddDeltaCode() ==
+--NOTES: This function is called from NRTbuildFunctor to initially
+--  fill slots in $template. The $template so created is stored in the
+--  NRLIB. On load, makeDomainTemplate is called on this $template to
+--  create a template which becomes slot 0 of the infovec for the constructor.
+--The template has 6 kinds of entries:
+--  (1) formal arguments and local variables, represented by (QUOTE <entry>)
+--      this conflicts by (5) but is ok since each is explicitly set by
+--      instantiator code;
+--  (2) domains, represented by lazy forms, e.g. (Foo 12 17 6)
+--  (3) latch slots, represented SPADCALLable forms which goGet an operation
+--      from a domain then cache the operation in the same slot
+--  (4) functions, represented by identifiers which are names of functions
+--  (5) identifiers/strings, parts of signatures (now parts of signatures
+--      now must all have slot numbers, represented by (QUOTE <entry>)
+--  (6) constants, like 0 and 1, represented by (CONS .. ) form
+  kvec := first $catvecList
+  for i in $NRTbase.. for item in REVERSE $NRTdeltaList
+    for compItem in REVERSE $NRTdeltaListComp
+      |null (s:=kvec.i) repeat
+        $template.i:= deltaTran(item,compItem)
+  $template.5 :=
+    $NRTaddForm =>
+      $NRTaddForm is ['Tuple,:y] => NREVERSE y
+      NRTencode($NRTaddForm,$addForm)
+    nil
+
+deltaTran(item,compItem) ==
+  item is ['domain,lhs,:.] => NRTencode(lhs,compItem)
+  --NOTE: all items but signatures are wrapped with domain forms
+  [op,:modemap] := item
+  [dcSig,[.,[kind,:.]]] := modemap
+  [dc,:sig] := dcSig
+  sig := substitute('$,dc,substitute("$$",'$,sig))
+  dcCode :=
+    dc = '$ =>
+      --$NRTaddForm => -5
+      0
+    NRTassocIndexAdd dc or keyedSystemError("S2NR0004",[dc])
+  formalSig:= SUBLISLIS($FormalMapVariableList,$formalArgList,sig)
+  kindFlag:= (kind = 'CONST => 'CONST; nil)
+  newSig := [NRTassocIndex x or x for x in formalSig]
+  [newSig,dcCode,op,:kindFlag]
+
+--NRTencodeSig x == [NRTencode y for y in x]
+
+NRTreplaceAllLocalReferences(form) ==
+  $devaluateList :local := []
+  NRTputInLocalReferences form
+
+--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet)
+NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) ==
+  --converts a domain form to a lazy domain form; everything other than
+  --the operation name should be assigned a slot
+  null firstTime and (k:= NRTassocIndex x) => k
+  VECP x => systemErrorHere '"NRTencode"
+  PAIRP x =>
+    QCAR x='Record or x is ['Union,['_:,a,b],:.] =>
+      [QCAR x,:[['_:,a,encode(b,c,false)]
+        for [.,a,b] in QCDR x for [.,=a,c] in CDR compForm]]
+    constructor? QCAR x or MEMQ(QCAR x,'(Union Mapping)) =>
+      [QCAR x,:[encode(y,z,false) for y in QCDR x for z in CDR compForm]]
+    ['NRTEVAL,NRTreplaceAllLocalReferences COPY_-TREE lispize compForm]
+  MEMQ(x,$formalArgList) =>
+    v := $FormalMapVariableList.(POSN1(x,$formalArgList))
+    firstTime => ['local,v]
+    v
+  x = '$ => x
+  ['QUOTE,x]
+
+--------------FUNCTIONS CALLED DURING CAPSULE FUNCTION COMPILATION-------------
+listOfBoundVars form ==
+-- Only called from the function genDeltaEntry below
+  form = '$ => []
+  IDENTP form and (u:=get(form,'value,$e)) =>
+    u:=u.expr
+    MEMQ(KAR u,'(Union Record)) => listOfBoundVars u
+    [form]
+  atom form => []
+  CAR form = 'QUOTE => []
+  EQ(CAR form,":") => listOfBoundVars CADDR form
+  -- We don't want to pick up the tag, only the domain
+  "union"/[listOfBoundVars x for x in CDR form]
+
+optDeltaEntry(op,sig,dc,eltOrConst) ==
+  $killOptimizeIfTrue = true => nil
+  ndc :=
+    dc = '$ => $functorForm
+    atom dc and (dcval := get(dc,'value,$e)) => dcval.expr
+    dc
+--if (atom dc) and (dcval := get(dc,'value,$e))
+--   then ndc := dcval.expr
+--   else ndc := dc
+  sig := SUBST(ndc,dc,sig)
+  not MEMQ(KAR ndc,$optimizableConstructorNames) => nil
+  dcval := optCallEval ndc
+  -- MSUBST guarantees to use EQUAL testing
+  sig := MSUBST(devaluate dcval, ndc, sig)
+  if rest ndc then
+     for new in rest devaluate dcval for old in rest ndc repeat
+       sig := MSUBST(new,old,sig)
+     -- optCallEval sends (List X) to (LIst (Integer)) etc,
+     -- so we should make the same transformation
+  fn := compiledLookup(op,sig,dcval)
+  if null fn then
+    -- following code is to handle selectors like first, rest
+     nsig := [quoteSelector tt for tt in sig] where
+       quoteSelector(x) ==
+         not(IDENTP x) => x
+         get(x,'value,$e) => x
+         x='$ => x
+	 MKQ x
+     fn := compiledLookup(op,nsig,dcval)
+     if null fn then return nil
+  eltOrConst="CONST" => ['XLAM,'ignore,MKQ SPADCALL fn]
+  GETL(compileTimeBindingOf first fn,'SPADreplace)
+
+--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet)
+genDeltaEntry opMmPair ==
+--called from compApplyModemap
+--$NRTdeltaLength=0.. always equals length of $NRTdeltaList
+  [.,[odc,:.],.] := opMmPair
+  --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair)
+  [op,[dc,:sig],[.,cform:=[eltOrConst,:.]]] := opMmPair
+  if $profileCompiler = true then profileRecord(dc,op,sig)
+  eltOrConst = 'XLAM => cform
+  if eltOrConst = 'Subsumed then eltOrConst := 'ELT
+    -- following hack needed to invert Rep to $ substitution
+  if odc = 'Rep and cform is [.,.,osig] then sig:=osig
+  newimp := optDeltaEntry(op,sig,dc,eltOrConst) => newimp
+  setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] =>
+    ['applyFun,['compiledLookupCheck,MKQ op,
+         mkList consSig(sig,dc),consDomainForm(dc,nil)]]
+ --if null atom dc then
+ --   sig := substitute('$,dc,sig)
+ --   cform := substitute('$,dc,cform)
+  opModemapPair :=
+    [op,[dc,:[genDeltaSig x for x in sig]],['T,cform]] -- force pred to T
+  if null NRTassocIndex dc and dc ^= $NRTaddForm and
+    (member(dc,$functorLocalParameters) or null atom dc) then
+    --create "domain" entry to $NRTdeltaList
+      $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList]
+      saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
+      $NRTdeltaLength := $NRTdeltaLength+1
+      compEntry:= compOrCroak(dc,$EmptyMode,$e).expr
+--      dc
+      RPLACA(saveNRTdeltaListComp,compEntry)
+  u :=
+    [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index ==
+      (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1
+        --n + 1 since $NRTdeltaLength is 1 too large
+      $NRTdeltaList:= [opModemapPair,:$NRTdeltaList]
+      $NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
+      $NRTdeltaLength := $NRTdeltaLength+1
+      0
+  u
+
+genDeltaSig x ==
+  NRTgetLocalIndex x
+
+genDeltaSpecialSig x ==
+  x is [":",y,z] => [":",y,genDeltaSig z]
+  genDeltaSig x
+
+NRTassocIndexAdd x ==
+  x = $NRTaddForm => 5
+  NRTassocIndex x
+
+NRTassocIndex x == --returns index of "domain" entry x in al
+  NULL x => x
+  x = $NRTaddForm => 5
+  k := or/[i for i in 1.. for y in $NRTdeltaList
+            | y.0 = 'domain and y.1 = x and ($found := y)] =>
+    $NRTbase + $NRTdeltaLength - k
+  nil
+
+NRTgetLocalIndexClear item == NRTgetLocalIndex1(item,true)
+
+NRTgetLocalIndex item == NRTgetLocalIndex1(item,false)
+
+NRTgetLocalIndex1(item,killBindingIfTrue) ==
+  k := NRTassocIndex item => k
+  item = $NRTaddForm => 5
+  item = '$ => 0
+  item = '_$_$ => 2
+  value:=
+    MEMQ(item,$formalArgList) => item
+    nil
+  atom item and null MEMQ(item,'($ _$_$))
+   and null value =>  --give slots to atoms
+    $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList]
+    $NRTdeltaListComp:=[item,:$NRTdeltaListComp]
+    $NRTdeltaLength := $NRTdeltaLength+1
+    $NRTbase + $NRTdeltaLength - 1
+  $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList]
+  saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
+  saveIndex := $NRTbase + $NRTdeltaLength
+  $NRTdeltaLength := $NRTdeltaLength+1
+  compEntry:= compOrCroak(item,$EmptyMode,$e).expr
+--    item
+  RPLACA(saveNRTdeltaListComp,compEntry)
+  saveIndex
+
+NRTgetAddForm domain ==
+  u := HGET($Slot1DataBase,first domain) =>
+    EQSUBSTLIST(rest domain,$FormalMapVariableList,first u)
+  systemErrorHere '"NRTgetAddForm"
+
+--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet)
+NRTassignCapsuleFunctionSlot(op,sig) ==
+--called from compDefineCapsuleFunction
+  opSig := [op,sig]
+  [.,.,implementation] := NRTisExported? opSig or return nil
+    --if opSig is not exported, it is local and need not be assigned
+  sig := [genDeltaSig x for x in sig]
+  opModemapPair := [op,['_$,:sig],['T,implementation]]
+  POSN1(opModemapPair,$NRTdeltaList) => nil   --already there
+  $NRTdeltaList:= [opModemapPair,:$NRTdeltaList]
+  $NRTdeltaListComp := [nil,:$NRTdeltaListComp]
+  $NRTdeltaLength := $NRTdeltaLength+1
+
+NRTisExported? opSig ==
+  or/[u for u in $domainShell.1 | u.0 = opSig]
+
+consOpSig(op,sig,dc) ==
+  if null atom op then
+    keyedSystemError("S2GE0016",['"consOpSig",'"bad operator in table"])
+  mkList [MKQ op,mkList consSig(sig,dc)]
+
+consSig(sig,dc) == [consDomainName(sigpart,dc) for sigpart in sig]
+
+--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet)
+consDomainName(x,dc) ==
+  x = dc => ''$
+  x = '$ => ['devaluate,'$]
+  x is [op,:argl] =>
+    (op = 'Record) or (op = 'Union and argl is [[":",:.],:.])  =>
+       mkList [MKQ op,
+         :[['LIST,MKQ '_:,MKQ tag,consDomainName(dom,dc)]
+                   for [.,tag,dom] in argl]]
+    isFunctor op or op = 'Mapping or constructor? op =>
+         -- call to constructor? needed if op was compiled in $bootStrapMode
+        mkList [MKQ op,:[consDomainName(y,dc) for y in argl]]
+    x
+  x = [] => x
+  (y := LASSOC(x,$devaluateList)) => y
+  k:=NRTassocIndex x =>
+    ['devaluate,['ELT,'$,k]]
+  get(x,'value,$e) or get(x,'mode,$e) =>
+    isDomainForm(x,$e) => ['devaluate,x]
+    x
+  MKQ x
+
+consDomainForm(x,dc) ==
+  x = '$ => '$
+  x is [op,:argl] =>
+     op = ":" and argl is [tag, value] => [op, tag, consDomainForm(value,dc)]
+     [op,:[consDomainForm(y,dc) for y in argl]]
+  x = [] => x
+  (y := LASSOC(x,$devaluateList)) => y
+  k:=NRTassocIndex x => ['ELT,'$,k]
+  get(x,'value,$e) or get(x,'mode,$e) => x
+  MKQ x
+
+buildFunctor($definition is [name,:args],sig,code,$locals,$e) ==
+--PARAMETERS
+--  $definition: constructor form, e.g. (SquareMatrix 10 (RationalNumber))
+--  sig: signature of constructor form
+--  code: result of "doIt", converting body of capsule to CodeDefine forms, e.g.
+--       (PROGN (LET Rep ...)
+--              (: (ListOf x y) $)
+--              (CodeDefine (<op> <signature> <functionName>))
+--              (COND ((HasCategory $ ...) (PROGN ...))) ..)
+--  $locals: list of variables to go into slot 5, e.g. (R Rep R,1 R,2 R,3 R,4)
+--           same as $functorLocalParameters
+--           this list is not augmented by this function
+--  $e: environment
+--GLOBAL VARIABLES REFERENCED:
+--  $domainShell: passed in from compDefineFunctor1
+--  $QuickCode: compilation flag
+
+  if code is ['add,.,newstuff] then code := newstuff
+
+  changeDirectoryInSlot1()  --this extends $NRTslot1PredicateList
+
+  --pp '"=================="
+  --for item in $NRTdeltaList repeat pp item
+
+--LOCAL BOUND FLUID VARIABLES:
+  $GENNO: local:= 0     --bound in compDefineFunctor1, then as parameter here
+--$frontier: local      --index of first local slot=#(cat part of princ view)
+  $catvecList: local    --list of vectors v1..vn for each view
+  $hasCategoryAlist: local  --list of GENSYMs bound to (HasCategory ..) items
+  $catNames: local      --list of names n1..nn for each view
+  $maximalViews: local  --list of maximal categories for domain (???)
+  $catsig: local        --target category (used in ProcessCond)
+  $SetFunctions: local  --copy of p view with preds telling when fnct defined
+  $MissingFunctionInfo: local --now useless
+     --vector marking which functions are assigned
+  $ConstantAssignments: local --code for creation of constants
+  $epilogue: local := nil     --code to set slot 5, things to be done last
+  $HackSlot4: local  --Invention of JHD 13/July/86-set in InvestigateConditions
+  $extraParms:local  --Set in DomainSubstitutionFunction, used in setVector12
+  $devaluateList: local --Bound to ((#1 . dv$1)..) where &1 := devaluate #1 later
+  $devaluateList:= [[arg,:b] for arg in args for b in $ModeVariableList]
+  $supplementaries: local
+   --set in InvestigateConditions to represent any additional
+   --category membership tests that may be needed(see buildFunctor for details)
+------------------------
+  $maximalViews: local
+  oldtime:= TEMPUS_-FUGIT()
+  [$catsig,:argsig]:= sig
+  catvecListMaker:=REMDUP
+    [(comp($catsig,$EmptyMode,$e)).expr,
+      :[compCategories first u for u in CADR $domainShell.4]]
+  condCats:= InvestigateConditions [$catsig,:rest catvecListMaker]
+  -- a list, one %for each element of catvecListMaker
+  -- indicating under what conditions this
+  -- category should be present.  true => always
+  makeCatvecCode:= first catvecListMaker
+  emptyVector := VECTOR()
+--if $NRTaddForm and null NRTassocIndex $NRTaddForm then
+--  --create "domain" entry to $NRTdeltaList
+--    $NRTdeltaList:=
+--      [['domain,NRTaddInner $NRTaddForm,:$NRTaddForm],:$NRTdeltaList]
+--    $NRTdeltaLength := $NRTdeltaLength+1
+--NRTgetLocalIndex $NRTaddForm
+  domainShell := GETREFV (6 + $NRTdeltaLength)
+  for i in 0..4 repeat domainShell.i := $domainShell.i
+    --we will clobber elements; copy since $domainShell may be a cached vector
+  $template :=
+    $NRTvec = true => GETREFV (6 + $NRTdeltaLength)
+    nil
+  $catvecList:= [domainShell,:[emptyVector for u in CADR domainShell.4]]
+  $catNames := ['$] -- for DescendCode -- to be changed below for slot 4
+  $maximalViews:= nil
+  $SetFunctions:= GETREFV SIZE domainShell
+  $MissingFunctionInfo:= GETREFV SIZE domainShell
+  $catNames:= ['$,:[GENVAR() for u in rest catvecListMaker]]
+  domname:='dv_$
+
+-->  Do this now to create predicate vector; then DescendCode can refer
+-->  to predicate vector if it can
+  [$uncondAlist,:$condAlist] :=    --bound in compDefineFunctor1
+      NRTsetVector4Part1($catNames,catvecListMaker,condCats)
+  [$NRTslot1PredicateList,predBitVectorCode1,:predBitVectorCode2] :=
+      makePredicateBitVector [:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList]
+
+  storeOperationCode:= DescendCode(code,true,nil,first $catNames)
+  outsideFunctionCode:= NRTaddDeltaCode()
+  storeOperationCode:= NRTputInLocalReferences storeOperationCode
+  if $NRTvec = true then
+    NRTdescendCodeTran(storeOperationCode,nil) --side effects storeOperationCode
+  codePart2:=
+    $NRTvec = true =>
+      argStuffCode :=
+        [[$setelt,'$,i,v] for i in 6.. for v in $FormalMapVariableList
+          for arg in rest $definition]
+      if MEMQ($NRTaddForm,$locals) then
+         addargname := $FormalMapVariableList.(POSN1($NRTaddForm,$locals))
+         argStuffCode := [[$setelt,'$,5,addargname],:argStuffCode]
+      [['stuffDomainSlots,'$],:argStuffCode,
+         :predBitVectorCode2,storeOperationCode]
+    [:outsideFunctionCode,storeOperationCode]
+
+  $CheckVectorList := NRTcheckVector domainShell
+--CODE: part 1
+  codePart1:= [:devaluateCode,:domainFormCode,createDomainCode,
+                createViewCode,setVector0Code, slot3Code,:slamCode] where
+    devaluateCode:= [['LET,b,['devaluate,a]] for [a,:b] in $devaluateList]
+    domainFormCode := [['LET,a,b] for [a,:b] in NREVERSE $NRTdomainFormList]
+      --$NRTdomainFormList is unused now
+    createDomainCode:=
+      ['LET,domname,['LIST,MKQ CAR $definition,:ASSOCRIGHT $devaluateList]]
+    createViewCode:= ['LET,'$,['GETREFV, 6+$NRTdeltaLength]]
+    setVector0Code:=[$setelt,'$,0,'dv_$]
+    slot3Code := ['QSETREFV,'$,3,['LET,'pv_$,predBitVectorCode1]]
+    slamCode:=
+      isCategoryPackageName opOf $definition => nil
+      [NRTaddToSlam($definition,'$)]
+
+--CODE: part 3
+  $ConstantAssignments :=
+      [NRTputInLocalReferences code for code in $ConstantAssignments]
+  codePart3:= [:constantCode1,
+                :constantCode2,:epilogue] where
+    constantCode1:=
+      name='Integer => $ConstantAssignments
+      nil
+                      -- The above line is needed to get the recursion
+                      -- Integer => FontTable => NonNegativeInteger  => Integer
+                      -- right.  Otherwise NNI has 'unset' for 0 and 1
+--  setVector4c:= setVector4part3($catNames,$catvecList)
+                      -- In particular, setVector4part3 and setVector5,
+                      -- which generate calls to local domain-instantiators,
+                      -- must come after operations are set in the vector.
+                      -- The symptoms of getting this wrong are that
+                      -- operations are not set which should be
+    constantCode2:= --matches previous test on Integer
+      name='Integer => nil
+      $ConstantAssignments
+    epilogue:= $epilogue
+  ans :=
+    ['PROGN,:optFunctorPROGN [:codePart1,:codePart2,:codePart3], '$]
+  $getDomainCode:= nil
+    --if we didn't kill this, DEFINE would insert it in the wrong place
+  ans:= minimalise ans
+  SAY ['"time taken in buildFunctor: ",TEMPUS_-FUGIT()-oldtime]
+  --sayBrightly '"------------------functor code: -------------------"
+  --pp ans
+  ans
+
+NRTcheckVector domainShell ==
+--RETURNS: an alist (((op,sig),:pred) ...) of missing functions
+  alist := nil
+  for i in 6..MAXINDEX domainShell repeat
+--Vector elements can be one of
+-- (a) T           -- item was marked
+-- (b) NIL         -- item is a domain; will be filled in by setVector4part3
+-- (c) categoryForm-- it was a domain view; now irrelevant
+-- (d) op-signature-- store missing function info in $CheckVectorList
+    v:= domainShell.i
+    v=true => nil  --item is marked; ignore
+    null v => nil  --a domain, which setVector4part3 will fill in
+    atom first v => nil  --category form; ignore
+    atom v => systemErrorHere '"CheckVector"
+    ASSOC(first v,alist) => nil
+    alist:=
+      [[first v,:$SetFunctions.i],:alist]
+  alist
+
+-- Obsolete once we have moved to JHD's world
+NRTvectorCopy(cacheName,domName,deltaLength) == GETREFV (6 + deltaLength)
+
+mkDomainCatName id == INTERN STRCONC(id,";CAT")
+
+NRTsetVector4(siglist,formlist,condlist) ==
+  $uncondList: local := nil
+  $condList: local := nil
+  $count: local := 0
+  for sig in reverse siglist for form in reverse formlist
+         for cond in reverse condlist repeat
+                  NRTsetVector4a(sig,form,cond)
+  --NRTsetVector4a(first siglist,first formlist,first condlist)
+
+  $lisplibCategoriesExtended:= [$uncondList,:$condList]
+  code := ['mapConsDB,MKQ REVERSE REMDUP $uncondList]
+  if $condList then
+    localVariable := GENSYM()
+    code := [['LET,localVariable,code]]
+    for [pred,list] in $condList repeat
+      code :=
+        [['COND,[pred,['LET,localVariable,
+          ['mergeAppend,['mapConsDB,MKQ list],localVariable]]]],
+            :code]
+    code := ['PROGN,:NREVERSE [['NREVERSE,localVariable],:code]]
+  g := GENSYM()
+  [$setelt,'$,4,['PROG2,['LET,g,code],
+    ['VECTOR,['catList2catPackageList,g],g]]]
+
+NRTsetVector4Part1(siglist,formlist,condlist) ==
+  $uncondList: local := nil
+  $condList: local := nil
+  $count: local := 0
+  for sig in reverse siglist for form in reverse formlist
+         for cond in reverse condlist repeat
+                  NRTsetVector4a(sig,form,cond)
+  reducedUncondlist := REMDUP $uncondList
+  reducedConlist :=
+    [[x,:y] for [x,z] in $condList| y := SETDIFFERENCE(z,reducedUncondlist)]
+  revCondlist := reverseCondlist reducedConlist
+  orCondlist := [[x,:MKPF(y,'OR)] for [x,:y] in revCondlist]
+  [reducedUncondlist,:orCondlist]
+  --NRTsetVector4a(first siglist,first formlist,first condlist)
+
+reverseCondlist cl ==
+  alist := nil
+  for [x,:y] in cl repeat
+    for z in y repeat
+      u := ASSOC(z,alist)
+      null u => alist := [[z,x],:alist]
+      member(x,CDR u) => nil
+      RPLACD(u,[x,:CDR u])
+  alist
+
+NRTsetVector4Part2(uncondList,condList) ==
+  $lisplibCategoriesExtended:= [uncondList,:condList]
+  code := ['mapConsDB,MKQ REVERSE REMDUP uncondList]
+  if condList then
+    localVariable := GENSYM()
+    code := [['LET,localVariable,code]]
+    for [pred,list] in condList repeat
+      code :=
+        [['COND,[predicateBitRef SUBLIS($pairlis,pred),['LET,localVariable,
+          ['mergeAppend,['mapConsDB,MKQ list],localVariable]]]],
+            :code]
+    code := ['PROGN,:NREVERSE [['NREVERSE,localVariable],:code]]
+  g := GENSYM()
+  [$setelt,'$,4,['PROG2,['LET,g,code],
+    ['VECTOR,['catList2catPackageList,g],g]]]
+
+mergeAppend(l1,l2) ==
+  ATOM l1 => l2
+  member(QCAR l1,l2) => mergeAppend(QCDR l1, l2)
+  CONS(QCAR l1, mergeAppend(QCDR l1, l2))
+
+--genLoadTimeValue u ==
+--  name :=
+--    INTERN STRCONC(PNAME first $definition,'";",STRINGIZE($count:=$count+1))
+--  $NRTloadTimeAlist := [[name,:['addConsDB,MKQ u]],:$NRTloadTimeAlist]
+--  --see compDefineFunctor1
+--  name
+
+catList2catPackageList u ==
+--converts ((Set) (Module R) ...) to ((Set& $) (Module& $ R)...)
+  [fn x for x in u] where
+    fn [op,:argl] ==
+      newOp := INTERN(STRCONC(PNAME op,"&"))
+      addConsDB [newOp,"$",:argl]
+
+NRTsetVector4a(sig,form,cond) ==
+  sig = '$ =>
+     domainList :=
+       [optimize COPY KAR comp(d,$EmptyMode,$e) or d for d in $domainShell.4.0]
+     $uncondList := APPEND(domainList,$uncondList)
+     if isCategoryForm(form,$e) then $uncondList := [form,:$uncondList]
+     $uncondList
+  evalform := eval mkEvalableCategoryForm form
+  cond = true => $uncondList := [form,:APPEND(evalform.4.0,$uncondList)]
+  $condList := [[cond,[form,:evalform.4.0]],:$condList]
+
+NRTmakeSlot1 domainShell ==
+  opDirectName := INTERN STRCONC(PNAME first $definition,'";opDirect")
+  fun :=
+    $NRTmakeCompactDirect => '(function lookupInCompactTable)
+    '(function lookupInTable)
+  [($QuickCode=>'QSETREFV;'SETELT), '$,1, ['LIST,fun,'$,opDirectName]]
+
+NRTmakeSlot1Info() ==
+-- 4 cases:
+-- a:T == b add c  --- slot1 directory has #s for entries defined in c
+-- a:T == b        --- slot1 has all slot #s = NIL (see compFunctorBody)
+-- a == b add c    --- not allowed (line 7 of getTargetFromRhs)
+-- a == b          --- $NRTderivedTargetIfTrue = true; set directory to NIL
+  pairlis :=
+    $insideCategoryPackageIfTrue = true =>
+      [:argl,dollarName] := rest $form
+      [[dollarName,:'_$],:mkSlot1sublis argl]
+    mkSlot1sublis rest $form
+  $lisplibOpAlist := transformOperationAlist SUBLIS(pairlis,$domainShell.1)
+  opList :=
+    $NRTderivedTargetIfTrue => 'derived
+    $insideCategoryPackageIfTrue = true => slot1Filter $lisplibOpAlist
+    $lisplibOpAlist
+  addList := SUBLIS(pairlis,$NRTaddForm)
+  [first $form,[addList,:opList]]
+
+mkSlot1sublis argl ==
+  [[a,:b] for a in argl for b in $FormalMapVariableList]
+
+slot1Filter opList ==
+--include only those ops which are defined within the capsule
+  [u for x in opList | u := fn x] where
+    fn [op,:l] ==
+      u := [entry for entry in l | INTEGERP CADR entry] => [op,:u]
+      nil
+
+NRToptimizeHas u ==
+--u is a list ((pred cond)...) -- see optFunctorBody
+--produces an alist: (((HasCategory a b) . GENSYM)...)
+  u is [a,:b] =>
+    a='HasCategory => LASSOC(u,$hasCategoryAlist) or
+      $hasCategoryAlist := [[u,:(y:=GENSYM())],:$hasCategoryAlist]
+      y
+    a='has => NRToptimizeHas ['HasCategory,first b,MKQ first rest b]
+    a = 'QUOTE => u
+    [NRToptimizeHas a,:NRToptimizeHas b]
+  u
+
+NRTaddToSlam([name,:argnames],shell) ==
+  $mutableDomain => return nil
+  null argnames => addToConstructorCache(name,nil,shell)
+  args:= ['LIST,:ASSOCRIGHT $devaluateList]
+  addToConstructorCache(name,args,shell)
+
+--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet)
+changeDirectoryInSlot1() ==  --called by NRTbuildFunctor
+  --3 cases:
+  --  if called inside NRTbuildFunctor, $NRTdeltaLength gives different locs
+  --  otherwise called from compFunctorBody (all lookups are forwarded):
+  --    $NRTdeltaList = nil  ===> all slot numbers become nil
+  $lisplibOperationAlist := [sigloc entry for entry in $domainShell.1] where
+    sigloc [opsig,pred,fnsel] ==
+        if pred ^= 'T then
+          pred := simpBool pred
+          $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList)
+        fnsel is [op,a,:.] and (op = 'ELT or op = 'CONST) =>
+          [opsig,pred,[op,a,vectorLocation(first opsig,CADR opsig)]]
+        [opsig,pred,fnsel]
+  sortedOplist := listSort(function GLESSEQP,
+                           COPY_-LIST $lisplibOperationAlist,function CADR)
+  $lastPred :local := nil
+  $newEnv :local := $e
+  $domainShell.1 := [fn entry for entry in sortedOplist] where
+    fn [[op,sig],pred,fnsel] ==
+       if $lastPred ^= pred then
+            $newEnv := deepChaseInferences(pred,$e)
+            $lastPred := pred
+       newfnsel :=
+         fnsel is ['Subsumed,op1,sig1] =>
+           ['Subsumed,op1,genSlotSig(sig1,'T,$newEnv)]
+         fnsel
+       [[op, genSlotSig(sig,pred,$newEnv)] ,pred,newfnsel]
+
+genSlotSig(sig,pred,$e) ==
+   [genDeltaSig t for t in sig]
+
+deepChaseInferences(pred,$e) ==
+    pred is ['AND,:preds] or pred is ['and,:preds] =>
+        for p in preds repeat $e := deepChaseInferences(p,$e)
+        $e
+    pred is ['OR,pred1,:.] or pred is ['or,pred1,:.] =>
+        deepChaseInferences(pred1,$e)
+    pred is 'T or pred is ['NOT,:.] or pred is ['not,:.] => $e
+    chaseInferences(pred,$e)
+
+vectorLocation(op,sig) ==
+  u := or/[i for i in 1.. for u in $NRTdeltaList
+        | u is [=op,[='$,: xsig],:.] and sig=NRTsubstDelta(xsig) ]
+  u => $NRTdeltaLength - u + 6
+  nil    -- this signals that calls should be forwarded
+
+NRTsubstDelta(initSig) ==
+  sig := [replaceSlotTypes s for s in initSig] where
+     replaceSlotTypes(t) ==
+        atom t =>
+          not INTEGERP t => t
+          t = 0 => '$
+          t = 2 => '_$_$
+          t = 5 => $NRTaddForm
+          u:= $NRTdeltaList.($NRTdeltaLength+5-t)
+          CAR u = 'domain => CADR u
+          error "bad $NRTdeltaList entry"
+        MEMQ(CAR t,'(Mapping Union Record _:)) =>
+           [CAR t,:[replaceSlotTypes(x) for x in rest t]]
+        t
+-----------------------------SLOT1 DATABASE------------------------------------
+
+updateSlot1DataBase [name,info] == HPUT($Slot1DataBase,name,info)
+
+NRTputInLocalReferences bod ==
+  $elt: local := ($QuickCode => 'QREFELT; 'ELT)
+  NRTputInHead bod
+
+NRTputInHead bod ==
+  atom bod => bod
+--  LASSOC(bod,$devaluateList) => nil
+--  k:= NRTassocIndex bod => [$elt,'_$,k]
+--  systemError '"unexpected position of domain reference"
+--  bod
+--bod is ['LET,var,val,:extra] and IDENTP var =>
+--  NRTputInTail extra
+--  k:= NRTassocIndex var => RPLAC(CADDR bod,[$elt,'$,k])
+--  NRTputInHead val
+--  bod
+  bod is ['SPADCALL,:args,fn] =>
+    NRTputInTail rest bod --NOTE: args = COPY of rest bod
+    -- The following test allows function-returning expressions
+    fn is [elt,dom,ind] and not (dom='$) and MEMQ(elt,'(ELT QREFELT CONST)) =>
+      k:= NRTassocIndex dom => RPLACA(LASTNODE bod,[$elt,'_$,k])
+--    sayBrightlyNT '"unexpected SPADCALL:"
+--    pp fn
+--    nil
+--    keyedSystemError("S2GE0016",['"NRTputInHead",
+--       '"unexpected SPADCALL form"])
+      nil
+    NRTputInHead fn
+    bod
+  bod is ["COND",:clauses] =>
+    for cc in clauses repeat NRTputInTail cc
+    bod
+  bod is ["QUOTE",:.] => bod
+  bod is ["CLOSEDFN",:.] => bod
+  bod is ["SPADCONST",dom,ind] =>
+    RPLACA(bod,$elt)
+    dom = '_$ => nil
+    k:= NRTassocIndex dom =>
+      RPLACA(LASTNODE bod,[$elt,'_$,k])
+      bod
+    keyedSystemError("S2GE0016",['"NRTputInHead",
+       '"unexpected SPADCONST form"])
+  NRTputInHead first bod
+  NRTputInTail rest bod
+  bod
+
+NRTputInTail x ==
+  for y in tails x repeat
+    atom (u := first y) =>
+      EQ(u,'$) or LASSOC(u,$devaluateList) => nil
+      k:= NRTassocIndex u =>
+        atom u => RPLACA(y,[$elt,'_$,k])
+        -- u atomic means that the slot will always contain a vector
+        RPLACA(y,['SPADCHECKELT,'_$,k])
+      --this reference must check that slot is a vector
+      nil
+    NRTputInHead u
+  x
+
+
+
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}