* interp/Makefile.pamphlet (template.$(FASLEXT)): Remove.

	* interp/template.boot: Move non-dead code where appropriate.
	Remove file.
	* boot/ast.boot (bfQ): Improve.

15 files changed, 176 insertions, 397 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 815f7ec0..8f226992 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,12 @@
 2008-11-02  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	* interp/Makefile.pamphlet (template.$(FASLEXT)): Remove.
+	* interp/template.boot: Move non-dead code where appropriate.
+	Remove file.
+	* boot/ast.boot (bfQ): Improve.
+
+2008-11-02  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
 	* lisp/core.lisp.in (|$ExtraRuntimeLibraries|): Listify.
 	(extra-runtime-libs): Tidy.
 	* lisp/Makefile.in (edit): stringify $(oa_c_runtime_extra) elements.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index f9246218..da023938 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -784,16 +784,12 @@ bfSmintable x==
       first x in '(SIZE LENGTH char)
  
 bfQ(l,r)==
-       if bfSmintable l or bfSmintable r
-       then  ["EQL",l,r]
-       else if defQuoteId l or defQuoteId r
-            then  ["EQ",l,r]
-            else
-              if null l
-              then ["NULL",r]
-              else if null r
-                   then ["NULL",l]
-                   else ["EQUAL",l,r]
+  bfSmintable l or bfSmintable r => ["EQL",l,r]
+  defQuoteId l or defQuoteId r => ["EQ",l,r]
+  null l => ["NULL",r]
+  null r => ["NULL",l]
+  EQ(l,true) or EQ(r,true) => ["EQ",l,r]
+  ["EQUAL",l,r]
  
 bfLessp(l,r)==
       if r=0
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 8cff46d0..44f1e0f2 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -84,7 +84,7 @@ OBJS=   boot-pkg.$(FASLEXT)	types.$(FASLEXT)	 \
 	preparse.$(FASLEXT)	bootlex.$(FASLEXT)	\
 	spad.$(FASLEXT)	\
 	spaderror.$(FASLEXT)				\
-	template.$(FASLEXT)	termrw.$(FASLEXT)	\
+	                       	termrw.$(FASLEXT)	\
 	trace.$(FASLEXT)	daase.$(FASLEXT)  	\
 	fortcall.$(FASLEXT) 	i-parser.$(FASLEXT) 	\
 	$(OCOBJS) $(BROBJS) $(ASCOMP) $(INOBJS)
@@ -309,7 +309,6 @@ nrunopt.$(FASLEXT): c-util.$(FASLEXT)
 nrunfast.$(FASLEXT): c-util.$(FASLEXT)
 nruncomp.$(FASLEXT): c-util.$(FASLEXT)
 nrungo.$(FASLEXT): c-util.$(FASLEXT)
-template.$(FASLEXT): c-util.$(FASLEXT)
 iterator.$(FASLEXT): g-util.$(FASLEXT)
 define.$(FASLEXT): cattable.$(FASLEXT) category.$(FASLEXT) c-util.$(FASLEXT)
 package.$(FASLEXT): clam.$(FASLEXT)
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index af5850ae..67c3671b 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -163,7 +163,7 @@ OBJS=   boot-pkg.$(FASLEXT)	types.$(FASLEXT)	 \
 	preparse.$(FASLEXT)	bootlex.$(FASLEXT)	\
 	spad.$(FASLEXT)	\
 	spaderror.$(FASLEXT)				\
-	template.$(FASLEXT)	termrw.$(FASLEXT)	\
+	                       	termrw.$(FASLEXT)	\
 	trace.$(FASLEXT)	daase.$(FASLEXT)  	\
 	fortcall.$(FASLEXT) 	i-parser.$(FASLEXT) 	\
 	$(OCOBJS) $(BROBJS) $(ASCOMP) $(INOBJS)
@@ -558,7 +558,6 @@ nrunopt.$(FASLEXT): c-util.$(FASLEXT)
 nrunfast.$(FASLEXT): c-util.$(FASLEXT)
 nruncomp.$(FASLEXT): c-util.$(FASLEXT)
 nrungo.$(FASLEXT): c-util.$(FASLEXT)
-template.$(FASLEXT): c-util.$(FASLEXT)
 iterator.$(FASLEXT): g-util.$(FASLEXT)
 define.$(FASLEXT): cattable.$(FASLEXT) category.$(FASLEXT) c-util.$(FASLEXT)
 package.$(FASLEXT): clam.$(FASLEXT)
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 7fd58b82..f40155ce 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -75,6 +75,7 @@ compApplication: (%Form,%List,%Mode,%Env,%Triple) -> %Maybe %Triple
 compApplyModemap: (%Form,%Modemap,%Env,%List) -> %Maybe %Triple
 
 primitiveType: %Thing -> %Mode
+modeEqual: (%Form,%Form) -> %Boolean
 hasUniqueCaseView: (%Form,%Mode,%Env) -> %Boolean
 convertOrCroak: (%Triple,%Mode) -> %Maybe %Triple
 getFormModemaps: (%Form,%Env) -> %List
diff --git a/src/interp/database.boot b/src/interp/database.boot
index 06422176..011f15c5 100644
--- a/src/interp/database.boot
+++ b/src/interp/database.boot
@@ -57,7 +57,7 @@ pathToDatabase name ==
 
 --%
 
-getConstructorAbbreviationFromDB: %Symbol -> %Maybe %Symbol
+getConstructorAbbreviationFromDB: %Symbol -> %Symbol
 getConstructorAbbreviationFromDB ctor ==
   GETDATABASE(ctor,"ABBREVIATION")
 
@@ -75,7 +75,7 @@ getConstructorAncestorsFromDB ctor ==
 
 ++ return the modemap of the constructor or the instantiation
 ++ of the constructor `form'. 
-getConstructorModemapFromDB: %Symbol -> %Maybe %Symbol
+getConstructorModemapFromDB: %Symbol -> %Mode
 getConstructorModemapFromDB form ==
   GETDATABASE(opOf form, 'CONSTRUCTORMODEMAP)
  
@@ -271,17 +271,6 @@ getDependentsOfConstructor(con) ==
   RSHUT stream
   val
 
-putModemapIntoDatabase(name,modemap,fileName) ==
-  $forceAdd: local:= nil
-  mml:= ASSOC(name,$databaseQueue)
-  if mml = [] then
-    $databaseQueue:=[[name, modemap],:$databaseQueue]
-  else
-    or/[modemap=map' for map' in CDR mml] => "already there"
-    newEntry:= [modemap,:CDR mml]
-    RPLACD(mml,newEntry)
-  newEntry
-
 orderPredicateItems(pred1,sig,skip) ==
   pred:= signatureTran pred1
   pred is ["AND",:l] => orderPredTran(l,sig,skip)
@@ -645,23 +634,6 @@ updateDatabase(fname,cname,systemdir?) ==
     clearClams()
     clearAllSlams []
 
-removeCoreModemaps(modemapList,c) ==
-  newUserModemaps:= nil
-  c := opOf unabbrev c
-  for [op,mmList] in modemapList repeat
-    temp:= nil
-    for mm in mmList repeat
-      cname := getDomainFromMm mm
-      if cname ^= c then temp:= [:temp,mm]
-    if temp then newUserModemaps:= [:newUserModemaps,[op,temp]]
-  newUserModemaps
-
-addCoreModemap(modemapList,op,modemap,cname) ==
-  entry:= ASSQ(op,modemapList) =>
-    RPLAC(CADR entry,[modemap,:CADR entry])
-    modemapList
-  modeMapList:= [:modemapList,[op,[ modemap]]]
-
 REMOVER(lst,item) ==
   --destructively removes item from lst
   not PAIRP lst =>
@@ -685,6 +657,30 @@ loadDependents fn ==
 
 --% Miscellaneous Stuff
 
+markUnique x ==
+  u := first x
+  RPLACA(x,'(_$unique))
+  RPLACD(x,[u,:rest x])
+  rest x
+
+getOperationAlistFromLisplib x ==
+  u := getConstructorOperationsFromDB x
+--  u := removeZeroOneDestructively u
+  null u => u          -- this can happen for Object
+  CAAR u = '_$unique => rest u
+  f:= addConsDB '(NIL T ELT)
+  for [op,:sigList] in u repeat
+    for items in tails sigList repeat
+      [sig,:r] := first items
+      if r is [.,:s] then
+        if s is [.,:t] then
+          if t is [.] then nil
+          else RPLACD(s,QCDDR f)
+        else RPLACD(r,QCDR f)
+      else RPLACD(first items,f)
+      RPLACA(items,addConsDB CAR items)
+  u and markUnique u
+
 getOplistForConstructorForm (form := [op,:argl]) ==
   --  The new form is an op-Alist which has entries (<op> . signature-Alist)
   --    where signature-Alist has entries (<signature> . item)
diff --git a/src/interp/define.boot b/src/interp/define.boot
index aec9d7ef..4166b0f9 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -294,7 +294,7 @@ compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) ==
     nil
   [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal)
   if categoryCapsule and not $bootStrapMode then [.,.,e] :=
-    $insideCategoryPackageIfTrue: local := true  --see NRTmakeSlot1
+    $insideCategoryPackageIfTrue: local := true
     $categoryPredicateList: local :=
         makeCategoryPredicates(form,$lisplibCategory)
     compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e)
@@ -335,8 +335,6 @@ mkCategoryPackage(form is [op,:argl],cat,def) ==
   catvec := eval mkEvalableCategoryForm form
   fullCatOpList:=(JoinInner([catvec],$e)).1
   catOpList :=
-    --note: this gets too many modemaps in general
-    --   this is cut down in NRTmakeSlot1
     [['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList
          --above line calls the category constructor just compiled
         | assoc(op1,capsuleDefAlist)]
@@ -403,8 +401,9 @@ compDefineCategory2(form,signature,specialCases,body,m,e,
         ['sublisV,['PAIR,['QUOTE,sargl],['LIST,:
           [['devaluate,u] for u in sargl]]],body]
     body:=
-      ['PROG1,["%LET",g:= GENSYM(),body],['SETELT,g,0,mkConstructor $form]]
-    fun:= compile [op',['LAM,sargl,body]]
+      ["PROG1",["%LET",g:= GENSYM(),body],
+         ["setShellEntry",g,0,mkConstructor $form]]
+    fun:= compile [op',["LAM",sargl,body]]
  
 --  5. give operator a 'modemap property
     pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList]
@@ -537,9 +536,9 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
       REMDUP [CADR x for x in attributeList]
 -->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT)
     $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList
-    $NRTslot1Info: local := nil  --set in NRTmakeSlot1 called by NRTbuildFunctor
+    $NRTslot1Info: local := nil  --set in NRTmakeSlot1Info
        --this is used below to set $lisplibSlot1 global
-    $NRTaddForm: local := nil   -- see compAdd; NRTmakeSlot1
+    $NRTaddForm: local := nil   -- see compAdd
     $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts
     $NRTdeltaListComp: local := nil --list of compiled forms for $NRTdeltaList
     $NRTaddList: local := nil --list of fncts not defined in capsule (added)
@@ -640,7 +639,7 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
           [simpBool x for x in $NRTslot1PredicateList]
         rwriteLispForm('loadTimeStuff,
           ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()])
-      $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1
+      $lisplibSlot1 := $NRTslot1Info
       $lisplibOperationAlist:= operationAlist
       $lisplibMissingFunctions:= $CheckVectorList
     lisplibWrite('"compilerInfo",
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index db4bd860..9dd8bff1 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -290,6 +290,38 @@ NRTassignCapsuleFunctionSlot(op,sig) ==
   $NRTdeltaListComp := [nil,:$NRTdeltaListComp]
   $NRTdeltaLength := $NRTdeltaLength+1
 
+
+++ NRTaddInner should call following function instead of NRTgetLocalIndex
+++ This would prevent putting spurious items in $NRTdeltaList
+NRTinnerGetLocalIndex x ==
+  atom x => x
+  -- following test should skip Unions, Records, Mapping
+  op := first x
+  op in '(Union Record Mapping Enumeration _[_|_|_]) => NRTgetLocalIndex x
+  constructor? op => NRTgetLocalIndex x
+  NRTaddInner x
+
+
+NRTaddInner x ==
+--called by genDeltaEntry and others that affect $NRTdeltaList
+  PROGN
+    atom x => nil
+    x is ['Record,:l] =>
+      for [.,.,y] in l repeat NRTinnerGetLocalIndex y
+    first x in '(Union Mapping _[_|_|_]) =>
+      for y in rest x repeat
+         y is [":",.,z] => NRTinnerGetLocalIndex z
+         NRTinnerGetLocalIndex y
+    x is ['SubDomain,y,:.] => NRTinnerGetLocalIndex y
+    getConstructorSignature first x is [.,:ml] =>
+      for y in rest x for m in ml | not (y = '$) repeat
+        isCategoryForm(m,$CategoryFrame) => NRTinnerGetLocalIndex y
+    x is ["Enumeration",:.] =>
+      for y in rest x repeat NRTinnerGetLocalIndex y
+    keyedSystemError("S2NR0003",[x])
+  x
+
+
 NRTisExported? opSig ==
   or/[u for u in $domainShell.1 | u.0 = opSig]
 
@@ -333,6 +365,27 @@ consDomainForm(x,dc) ==
   get(x,'value,$e) or get(x,'mode,$e) => x
   MKQ x
 
+
+++ Called by buildFunctor fill $template slots with names 
+++ of compiled functions
+NRTdescendCodeTran(u,condList) ==
+  null u => nil
+  u is ['LIST] => nil
+  u is [op,.,i,a] and MEMQ(op,'(setShellEntry SETELT QSETREFV)) =>
+    null condList and a is ['CONS,fn,:.] =>
+      RPLACA(u,'LIST)
+      RPLACD(u,nil)
+      $template.i :=
+        fn = 'IDENTITY => a
+        fn is ['dispatchFunction,fn'] => fn'
+        fn
+    nil   --code for this will be generated by the instantiator
+  u is ['COND,:c] =>
+    for [pred,:y] in c|y repeat NRTdescendCodeTran(first y,[pred,:condList])
+  u is ['PROGN,:c] => for x in c repeat NRTdescendCodeTran(x,condList)
+  nil
+
+
 buildFunctor($definition is [name,:args],sig,code,$locals,$e) ==
 --PARAMETERS
 --  $definition: constructor form, e.g. (SquareMatrix 10 (RationalNumber))
@@ -488,9 +541,6 @@ NRTcheckVector domainShell ==
       [[first v,:$SetFunctions.i],:alist]
   alist
 
--- Obsolete once we have moved to JHD's world
-NRTvectorCopy(cacheName,domName,deltaLength) == GETREFV ($NRTbase + deltaLength)
-
 mkDomainCatName id == INTERN STRCONC(id,";CAT")
 
 NRTsetVector4(siglist,formlist,condlist) ==
@@ -579,11 +629,6 @@ NRTsetVector4a(sig,form,cond) ==
   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 := '(function lookupInCompactTable)
-  ["setShellEntry", '$,1, ['LIST,fun,'$,opDirectName]]
-
 NRTmakeSlot1Info() ==
 -- 4 cases:
 -- a:T == b add c  --- slot1 directory has #s for entries defined in c
@@ -657,11 +702,11 @@ changeDirectoryInSlot1() ==  --called by NRTbuildFunctor
             $lastPred := pred
        newfnsel :=
          fnsel is ['Subsumed,op1,sig1] =>
-           ['Subsumed,op1,genSlotSig(sig1,"T",$newEnv)]
+           ['Subsumed,op1,genSlotSig(sig1,$newEnv)]
          fnsel
-       [[op, genSlotSig(sig,pred,$newEnv)] ,pred,newfnsel]
+       [[op, genSlotSig(sig,$newEnv)] ,pred,newfnsel]
 
-genSlotSig(sig,pred,$e) ==
+genSlotSig(sig,$e) ==
    [NRTgetLocalIndex t for t in sig]
 
 deepChaseInferences(pred,$e) ==
@@ -693,6 +738,33 @@ NRTsubstDelta(initSig) ==
         MEMQ(CAR t,'(Mapping Union Record _:)) =>
            [CAR t,:[replaceSlotTypes(x) for x in rest t]]
         t
+
+mapConsDB x == 
+  [addConsDB y for y in x]
+
+addConsDB x ==
+  min x where
+    min x ==
+      y:=HGET($consDB,x)
+      y => y
+      PAIRP x =>
+        for z in tails x repeat
+          u:=min CAR z
+          if not EQ(u,CAR z) then RPLACA(z,u)
+        HashCheck x
+      REFVECP x =>
+        for i in 0..MAXINDEX x repeat
+          x.i:=min (x.i)
+        HashCheck x
+      STRINGP x => HashCheck x
+      x
+    HashCheck x ==
+      y:=HGET($consDB,x)
+      y => y
+      HPUT($consDB,x,x)
+      x
+  x
+
 -----------------------------SLOT1 DATABASE------------------------------------
 
 updateSlot1DataBase [name,info] == HPUT($Slot1DataBase,name,info)
diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot
index 2b5f55b8..2f419f37 100644
--- a/src/interp/nrunfast.boot
+++ b/src/interp/nrunfast.boot
@@ -65,14 +65,41 @@ 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
- 
+
+evalSlotDomain(u,dollar) ==
+  $returnNowhereFromGoGet: local := false
+  $ : fluid := dollar                      -- ??? substitute
+  $lookupDefaults : local := nil -- new world
+  u = '$ => dollar
+  u = "$$" => dollar
+  FIXP u =>
+    VECP (y := dollar.u) => y
+    y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous?
+    y is [v,:.] =>
+      VECP v => lazyDomainSet(y,dollar,u)   --old style has [$,code,:lazyt]
+      IDENTP v and constructor? v 
+        or MEMQ(v,'(Record Union Mapping Enumeration)) =>
+           lazyDomainSet(y,dollar,u)        --new style has lazyt
+      y
+    y
+  u is ['NRTEVAL,y] => eval  y
+  u is ['QUOTE,y] => y
+  u is ['Record,:argl] =>
+     apply('Record,[[":",tag,evalSlotDomain(dom,dollar)]
+                                 for [.,tag,dom] in argl])
+  u is ['Union,:argl] and first argl is ['_:,.,.] =>
+     APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)]
+                                 for [.,tag,dom] in argl])
+  u is ["Enumeration",:.] => eval u
+  u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl])
+  systemErrorHere '"evalSlotDomain"
+
 --=======================================================
 --                 Lookup From Compiled Code
 --=======================================================
@@ -127,10 +154,6 @@ 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 =>
diff --git a/src/interp/nrunopt.boot b/src/interp/nrunopt.boot
index 124497ed..a4d10e00 100644
--- a/src/interp/nrunopt.boot
+++ b/src/interp/nrunopt.boot
@@ -142,7 +142,8 @@ makeCompactSigCode(sig,$isOpPackageName) == [fn for x in sig] where
   fn() == 
     x = '_$_$ => 2
     x = '$ => 0
-    not INTEGERP x => systemError ['"code vector slot is ",x,"; must be number"]
+    not INTEGERP x => 
+      systemError ['"code vector slot is ",x,'"; must be number"]
 --  x = 6 and $isOpPackageName => 0  --treat slot 6 as $ for default packages
     x
   
@@ -177,6 +178,13 @@ getLookupFun infovec ==
   MAXINDEX infovec = 4 => infovec.4
   'lookupIncomplete
 
+makeSpadConstant [fn,dollar,slot] ==
+  val := FUNCALL(fn,dollar)
+  u:= dollar.slot
+  RPLACA(u,function IDENTITY)
+  RPLACD(u,val)
+  val
+
 stuffSlot(dollar,i,item) ==
   dollar.i :=
     atom item => [SYMBOL_-FUNCTION item,:dollar]
diff --git a/src/interp/preparse.lisp b/src/interp/preparse.lisp
index de612cfd..2b92469e 100644
--- a/src/interp/preparse.lisp
+++ b/src/interp/preparse.lisp
@@ -94,7 +94,6 @@
 
 
 (defvar $skipme)
-(defvar $COMBLOCKLIST)
  
 (defun PREPARSE (Strm &aux (stack ()))
   (SETQ $COMBLOCKLIST NIL $skipme NIL)
diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot
index 977859a3..073bc1c8 100644
--- a/src/interp/sys-utility.boot
+++ b/src/interp/sys-utility.boot
@@ -37,6 +37,9 @@ import sys_-os
 import vmlisp
 namespace BOOT
 
+--%
+$COMBLOCKLIST := nil
+
 
 --%
 
diff --git a/src/interp/template.boot b/src/interp/template.boot
deleted file mode 100644
index d5c4c816..00000000
--- a/src/interp/template.boot
+++ /dev/null
@@ -1,323 +0,0 @@
--- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
--- All rights reserved.
--- Copyright (C) 2007-2008, Gabriel Dos Reis.
--- 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.
-
-import c_-util
-namespace BOOT
-
-getOperationAlistFromLisplib x ==
-  -- used to be in clammed.boot. Moved on 1/24/94
---+
---  newType? x => getConstructorOperationsFromDB x
-  NRTgetOperationAlistFromLisplib x
-
-NRTgetOperationAlistFromLisplib x ==
-  u := getConstructorOperationsFromDB x
---  u := removeZeroOneDestructively u
-  null u => u          -- this can happen for Object
-  CAAR u = '_$unique => rest u
-  f:= addConsDB '(NIL T ELT)
-  for [op,:sigList] in u repeat
-    for items in tails sigList repeat
-      [sig,:r] := first items
-      if r is [.,:s] then
-        if s is [.,:t] then
-          if t is [.] then nil
-          else RPLACD(s,QCDDR f)
-        else RPLACD(r,QCDR f)
-      else RPLACD(first items,f)
-      RPLACA(items,addConsDB CAR items)
-  u and markUnique u
-
-markUnique x ==
-  u := first x
-  RPLACA(x,'(_$unique))
-  RPLACD(x,[u,:rest x])
-  rest x
-
---=======================================================================
---                  Instantiation/Run-Time Operations
---=======================================================================
-
-stuffSlots(dollar,template) ==
-  _$: fluid := dollar               --??? substitute
-  dollarTail := [dollar]
-  for i in 5..MAXINDEX template | item := template.i repeat
-    dollar.i :=
-      atom item => [SYMBOL_-FUNCTION item,:dollar]
-      item is ['QUOTE,x] =>
-        x is [.,.,:n] and FIXP n => ['goGet,item,:dollarTail]
-        ['SETELT,dollar,i,['evalSlotDomain,item,dollar]]
-      item is ['CONS,:.] =>
-        item is [.,'IDENTITY,['FUNCALL,a,b]] =>
-          b = '$ => ['makeSpadConstant,eval a,dollar,i]
-          sayBrightlyNT '"Unexpected constant environment!!"
-          pp devaluate b
-          nil
-        sayBrightlyNT '"Unexpected constant format!!"
-        pp devaluate item
-        nil
-      sayBrightlyNT '"Unidentified stuff:"
-      pp item
-
---------------------> NEW DEFINITION (see interop.boot.pamphlet)
-evalSlotDomain(u,dollar) ==
-  $returnNowhereFromGoGet: local := false
-  $ : fluid := dollar                      -- ??? substitute
-  $lookupDefaults : local := nil -- new world
-  u = '$ => dollar
-  u = "$$" => dollar
-  FIXP u =>
-    VECP (y := dollar.u) => y
-    y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous?
-    y is [v,:.] =>
-      VECP v => lazyDomainSet(y,dollar,u)   --old style has [$,code,:lazyt]
-      IDENTP v and constructor? v 
-        or MEMQ(v,'(Record Union Mapping Enumeration)) =>
-           lazyDomainSet(y,dollar,u)        --new style has lazyt
-      y
-    y
-  u is ['NRTEVAL,y] => eval  y
-  u is ['QUOTE,y] => y
-  u is ['Record,:argl] =>
-     apply('Record,[[":",tag,evalSlotDomain(dom,dollar)]
-                                 for [.,tag,dom] in argl])
-  u is ['Union,:argl] and first argl is ['_:,.,.] =>
-     APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)]
-                                 for [.,tag,dom] in argl])
-  u is ["Enumeration",:.] => eval u
-  u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl])
-  systemErrorHere '"evalSlotDomain"
-
-
---=======================================================================
---                       Loadtime Operations
---=======================================================================
-setLoadTime alist ==
-  for [nam,:val] in alist repeat setDynamicBinding(nam,eval val)
-
-setLoadTimeQ alist ==
-  for [nam,:val] in alist repeat setDynamicBinding(nam,val)
-
-makeTemplate vec ==
---called at instantiation time by setLoadTime
---the form ['makeTemplate,MKQ $template] is recorded by compDefineFunctor1
---  $template is set below in NRTdescendCodeTran and NRTaddDeltaOpt
-  newVec := newShell SIZE vec
-  for index in 0..MAXINDEX vec repeat
-    item := vec.index
-    null item => nil
-    item is ['local,:.] => nil --this information used to for display of domains
-    newVec.index :=
-      atom item => item
-      null atom first item =>
-        [sig,dcIndex,op,:flag] := item
-        code := 4*index
-        if dcIndex > 0 then
-          code := code + 2   --means "bind"
-          else dcIndex := -dcIndex
-        if flag = 'CONST then code := code + 1 --means "constant"
-        sourceIndex := 8192*dcIndex + code
-        uniqueSig:= addConsDB sig
-        MKQ [op,uniqueSig,:sourceIndex]
-      item is ['CONS,:.] =>  item --constant case
-      MKQ item
-  newVec
-
-makeOpDirect u ==
-  [nam,[addForm,:opList]] := u
-  opList = 'derived => 'derived
-  [[op,:[fn y for y in items]] for [op,:items] in opList] where fn y ==
-        [sig,:r] := y
-        uniqueSig := addConsDB sig
-        predCode := 0
-        isConstant := false
-        r is [subSig,pred,'Subsumed] => [uniqueSig,'subsumed,addConsDB subSig]
-        if r is [n,:s] then
-          slot :=
-            n is [p,:.] => p  --the CDR is linenumber of function definition
-            n
-          if s is [pred,:t] then
-            predCode := (pred = 'T => 0; mkUniquePred pred)
-            if t is [='CONST,:.] then isConstant := true
-        index:= 8192*predCode
-        if NUMBERP slot and slot ^= 0 then index := index + 2*slot
-        if isConstant then index := index + 1
-        [uniqueSig,:index]
-
---=======================================================================
---          Creation of System Sig/Pred Vectors & Hash Tables
---=======================================================================
-
-mkUniquePred pred == putPredHash addConsDB pred
-
-putPredHash pred == --pred MUST have had addConsDB applied to it
-  if pred is [op,:u] and MEMQ(op,'(AND OR NOT)) then
-    for x in u repeat putPredHash x
-  k := HGET($predHash,pred) => k
-  HPUT($predHash,pred,$predVectorFrontier)
-  if $predVectorFrontier > MAXINDEX $predVector
-    then $predVector := extendVectorSize $predVector
-  $predVector.$predVectorFrontier := pred
-  $predVectorFrontier := $predVectorFrontier + 1
-  $predVectorFrontier - 1
-
-extendVectorSize v ==
-  n:= MAXINDEX v
-  m:= (7*n)/5   -- make 40% longer
-  newVec := newShell m
-  for i in 0..n repeat newVec.i := v.i
-  newVec
-
-mkSigPredVectors() ==
-  $predHash:= MAKE_-HASHTABLE 'UEQUAL
-  $consDB:= MAKE_-HASHTABLE 'UEQUAL
-  $predVectorFrontier:= 1   --slot 0 in vector will be vacant
-  $predVector:= newShell 100
-  for nam in allConstructors() |
-          getConstuctorKindFromDB nam ^= "package" repeat
-    for [op,:sigList] in getConstructorOperationsFromDB nam repeat
-      for [sig,:r] in sigList repeat
-        addConsDB sig
-        r is [.,pred,:.] => putPredHash addConsDB pred
-  'done
-
-list2LongerVec(u,n) ==
-  vec := newShell ((7*n)/5) -- make 40% longer
-  for i in 0.. for x in u repeat vec.i := x
-  vec
-
-squeezeConsDB u ==
-  fn u where fn u ==
-    VECP u => for i in 0..MAXINDEX u repeat fn u.i
-    PAIRP u =>
-      EQ(x := QCAR u,'QUOTE) => RPLAC(CADR u,addConsDB CADR u)
-      squeezeConsDB x
-      squeezeConsDB QCDR u
-    nil
-  u
-
-mapConsDB x == [addConsDB y for y in x]
-addConsDB x ==
-  min x where
-    min x ==
-      y:=HGET($consDB,x)
-      y => y
-      PAIRP x =>
-        for z in tails x repeat
-          u:=min CAR z
-          if not EQ(u,CAR z) then RPLACA(z,u)
-        HashCheck x
-      REFVECP x =>
-        for i in 0..MAXINDEX x repeat
-          x.i:=min (x.i)
-        HashCheck x
-      STRINGP x => HashCheck x
-      x
-    HashCheck x ==
-      y:=HGET($consDB,x)
-      y => y
-      HPUT($consDB,x,x)
-      x
-  x
-
---=======================================================================
---               Functions Creating Lisplib Information
---=======================================================================
-NRTdescendCodeTran(u,condList) ==
---NRTbuildFunctor calls to fill $template slots with names of compiled functions
-  null u => nil
-  u is ['LIST] => nil
-  u is [op,.,i,a] and MEMQ(op,'(setShellEntry SETELT QSETREFV)) =>
-    null condList and a is ['CONS,fn,:.] =>
-      RPLACA(u,'LIST)
-      RPLACD(u,nil)
-      $template.i :=
-        fn = 'IDENTITY => a
-        fn is ['dispatchFunction,fn'] => fn'
-        fn
-    nil   --code for this will be generated by the instantiator
-  u is ['COND,:c] =>
-    for [pred,:y] in c|y repeat NRTdescendCodeTran(first y,[pred,:condList])
-  u is ['PROGN,:c] => for x in c repeat NRTdescendCodeTran(x,condList)
-  nil
-
---=======================================================================
---                  Miscellaneous Functions
---=======================================================================
-NRTaddInner x ==
---called by genDeltaEntry and others that affect $NRTdeltaList
-  PROGN
-    atom x => nil
-    x is ['Record,:l] =>
-      for [.,.,y] in l repeat NRTinnerGetLocalIndex y
-    first x in '(Union Mapping _[_|_|_]) =>
-      for y in rest x repeat
-         y is [":",.,z] => NRTinnerGetLocalIndex z
-         NRTinnerGetLocalIndex y
-    x is ['SubDomain,y,:.] => NRTinnerGetLocalIndex y
-    getConstructorSignature first x is [.,:ml] =>
-      for y in rest x for m in ml | not (y = '$) repeat
-        isCategoryForm(m,$CategoryFrame) => NRTinnerGetLocalIndex y
-    x is ["Enumeration",:.] =>
-      for y in rest x repeat NRTinnerGetLocalIndex y
-    keyedSystemError("S2NR0003",[x])
-  x
-
--- NRTaddInner should call following function instead of NRTgetLocalIndex
--- This would prevent putting spurious items in $NRTdeltaList
-NRTinnerGetLocalIndex x ==
-  atom x => x
-  -- following test should skip Unions, Records, Mapping
-  op := first x
-  MEMQ(op,'(Union Record Mapping Enumeration _[_|_|_])) => NRTgetLocalIndex x
-  constructor? op => NRTgetLocalIndex x
-  NRTaddInner x
-
-assignSlotToPred cond ==
---called by ProcessCond
-  cond is ['AND,:u] => ['AND,:[assignSlotToPred x for x in u]]
-  cond is ['OR,:u] => ['OR,:[assignSlotToPred x for x in u]]
-  cond is ['NOT,u] => ['NOT,assignSlotToPred u]
-  thisNeedsTOBeFilledIn()
-
-makeSpadConstant [fn,dollar,slot] ==
-  val := FUNCALL(fn,dollar)
-  u:= dollar.slot
-  RPLACA(u,function IDENTITY)
-  RPLACD(u,val)
-  val
-
-
-
-
-
diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot
index 0293178c..29ea264e 100644
--- a/src/interp/wi1.boot
+++ b/src/interp/wi1.boot
@@ -1148,7 +1148,7 @@ compDefineCategory1(df,m,e,prefix,fal) ==
 --  else
   if categoryCapsule and not $bootStrapMode then
     [.,.,e] :=
-      $insideCategoryPackageIfTrue: local := true  --see NRTmakeSlot1
+      $insideCategoryPackageIfTrue: local := true
       $categoryPredicateList: local :=
           makeCategoryPredicates(form,$lisplibCategory)
       defform := mkCategoryPackage(form,cat,categoryCapsule)
diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot
index cb2d24c3..38ab1339 100644
--- a/src/interp/wi2.boot
+++ b/src/interp/wi2.boot
@@ -120,9 +120,9 @@ compDefineFunctor1(df, m,$e,$prefix,$formalArgList) ==
       REMDUP [CADR x for x in attributeList]
 -->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT)
     $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList
-    $NRTslot1Info: local := nil --set in NRTmakeSlot1 called by NRTbuildFunctor
+    $NRTslot1Info: local := nil --set in NRTmakeSlot1Info
        --this is used below to set $lisplibSlot1 global
-    $NRTaddForm: local := nil   -- see compAdd; NRTmakeSlot1
+    $NRTaddForm: local := nil   -- see compAdd
     $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts
     $NRTdeltaListComp: local := nil --list of compiled forms for $NRTdeltaList
     $NRTaddList: local := nil --list of fncts not defined in capsule (added)