* interp/lisplib.boot (makePredicateBitVector): Take a DB argument.

	Set dbPredicates.
	(compConLib1): Set dbPredicates to nil.
	(compDefineLisplib): Likewise.
	(finalizeLisplib): Write dbPredicates.
	* boot/tokens.boot (copyTree): Do not translate.
	* boot/utility.boot (topyTree): Implement.  Export.

6 files changed, 24 insertions, 10 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 79e3e61c..2b3f8191 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,15 @@
 2011-10-29  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	* interp/lisplib.boot (makePredicateBitVector): Take a DB argument.
+	Set dbPredicates.
+	(compConLib1): Set dbPredicates to nil.
+	(compDefineLisplib): Likewise.
+	(finalizeLisplib): Write dbPredicates.
+	* boot/tokens.boot (copyTree): Do not translate.
+	* boot/utility.boot (topyTree): Implement.  Export.
+
+2011-10-29  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
 	* interp/define.boot (getInfovecCode): Take a DB argument.  Pass
 	it to callees.  Adjust caller.
 	* interp/database.boot (getConstructorPredicates): If contructor
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 02bf998e..4696f676 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -182,7 +182,7 @@
              (LIST '|charUpcase| 'CHAR-UPCASE) (LIST '|charString| 'STRING)
              (LIST '|char?| 'CHARACTERP) (LIST '|codePoint| 'CHAR-CODE)
              (LIST '|cons?| 'CONSP) (LIST '|copy| 'COPY)
-             (LIST '|copyString| 'COPY-SEQ) (LIST '|copyTree| 'COPY-TREE)
+             (LIST '|copyString| 'COPY-SEQ)
              (LIST '|copyVector| 'COPY-SEQ) (LIST '|croak| 'CROAK)
              (LIST '|digit?| 'DIGIT-CHAR-P) (LIST '|drop| 'DROP)
              (LIST '|exit| 'EXIT) (LIST '|false| 'NIL) (LIST '|fifth| 'FIFTH)
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index 7869bdb0..663f1301 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -253,7 +253,6 @@ for i in [ _
   ["cons?",      "CONSP"]  , _
   ["copy",        "COPY"]  , _
   ["copyString", "COPY-SEQ"] , _
-  ["copyTree", "COPY-TREE"] , _
   ["copyVector", "COPY-SEQ"] , _
   ["croak",      "CROAK"]  , _
   ["digit?",    "DIGIT-CHAR-P"]  , _
diff --git a/src/boot/utility.boot b/src/boot/utility.boot
index 70802e5a..139e98d0 100644
--- a/src/boot/utility.boot
+++ b/src/boot/utility.boot
@@ -48,7 +48,7 @@ module utility (objectMember?, symbolMember?, stringMember?,
   lastNode, append, append!, copyList, substitute, substitute!,
   setDifference, setUnion, setIntersection,
   symbolAssoc, applySubst, applySubst!, applySubstNQ, objectAssoc,
-  remove,removeSymbol,atomic?,finishLine) where
+  remove,removeSymbol,atomic?,copyTree,finishLine) where
     substitute: (%Thing,%Thing,%Thing) -> %Thing
     substitute!: (%Thing,%Thing,%Thing) -> %Thing
     append: (%List %Thing,%List %Thing) -> %List %Thing
@@ -63,6 +63,7 @@ module utility (objectMember?, symbolMember?, stringMember?,
     setUnion: (%List %Thing,%List %Thing) -> %List %Thing
     setIntersection: (%List %Thing,%List %Thing) -> %List %Thing
     atomic?: %Thing -> %Boolean
+    copyTree: %Thing -> %Thing
     finishLine: %Thing -> %Void
     --FIXME: Next signature commented out because of GCL bugs
     -- firstNonblankPosition: (%String,%Short) -> %Maybe %Short
@@ -76,6 +77,10 @@ module utility (objectMember?, symbolMember?, stringMember?,
 atomic? x ==
   x isnt [.,:.] or x.op is 'QUOTE
 
+copyTree t ==
+  t is [.,:.] => [copyTree first t,:copyTree rest t]
+  t
+
 --% membership operators
 
 objectMember?(x,l) ==
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index 639db319..8b76009d 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -97,7 +97,7 @@ makePrefixForm(u,op) ==
 --=======================================================================
 --               Generate Slot 3 Predicate Vector
 --=======================================================================
-makePredicateBitVector(pl,e) ==   --called by buildFunctor
+makePredicateBitVector(db,pl,e) ==   --called by buildFunctor
   if $insideCategoryPackageIfTrue then
     pl := union(pl,$categoryPredicateList)
   $predGensymAlist := nil --bound by buildFunctor, used by optHas
@@ -114,8 +114,8 @@ makePredicateBitVector(pl,e) ==   --called by buildFunctor
   firstCode:= 
     ['buildPredVector,0,0,mungeAddGensyms(firstPl,$predGensymAlist)]
   lastCode := augmentPredCode(# firstPl,lastPl)
-  $lisplibPredicates := [:firstPl,:lastPl] --what is stored under 'predicates
-  [$lisplibPredicates,firstCode,:lastCode]  --$pairlis set by compDefineFunctor1
+  dbPredicates(db) := [:firstPl,:lastPl] --what is stored under 'predicates
+  [dbPredicates db,firstCode,:lastCode]  --$pairlis set by compDefineFunctor1
 
 augmentPredCode(n,lastPl) ==
   ['%list,:pl] := mungeAddGensyms(lastPl,$predGensymAlist)
@@ -386,7 +386,7 @@ compileConstructorLib(l,op,editFlag,traceFlag) ==
  
 compConLib1(fun,infileOrNil,outfileOrNil,auxOp,editFlag,traceFlag) ==
   $PrettyPrint: local := 'T
-  $lisplibPredicates: local := nil
+  dbPredicates(constructorDB fun) := nil
   $lisplibOperationAlist: local := nil
   $libFile: local := nil
   if cons? fun and null rest fun then fun:= first fun -- unwrap nullary
@@ -405,7 +405,7 @@ compDefineLisplib(df:=["DEF",[op,:.],:.],m,e,prefix,fal,fn) ==
   --fn= compDefineCategory1 OR compDefineFunctor1
   sayMSG fillerSpaces(72,char "-")
   $op: local := op
-  $lisplibPredicates: local := nil -- set by makePredicateBitVector
+  dbPredicates(constructorDB op) := nil
   $lisplibOperationAlist: local := nil
   $libFile: local := nil
 --  $lisplibRelatedDomains: local := nil   --from ++ Related Domains: see c-doc
@@ -539,7 +539,7 @@ finalizeLisplib(ctor,libName) ==
   writeSuperDomain(ctor,dbSuperDomain db,$libFile)
   writeCapsuleLevelDefinitions(ctor,dbCapsuleDefinitions db,$libFile)
   writeAttributes(ctor,dbAttributes db,$libFile)
-  writePredicates(ctor,$lisplibPredicates,$libFile)
+  writePredicates(ctor,dbPredicates db,$libFile)
   writeAbbreviation(db,$libFile)
   writePrincipals(ctor,dbPrincipals db,$libFile)
   writeAncestors(ctor,dbAncestors db,$libFile)
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index f4ac82b6..7bd5e7de 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -513,7 +513,7 @@ buildFunctor(db,sig,code,$locals,$e) ==
   [$uncondAlist,:$condAlist] :=    --bound in compDefineFunctor1
       NRTsetVector4Part1(viewNames,catvecListMaker,condCats)
   [$NRTslot1PredicateList,predBitVectorCode1,:predBitVectorCode2] :=
-    makePredicateBitVector([:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList],$e)
+    makePredicateBitVector(db,[:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList],$e)
 
   storeOperationCode := DescendCode(db,code,true,nil)
   NRTaddDeltaCode()