* interp/nruncomp.boot (NRTsetVector4Part1): Add environment parameter.

	Adjust caller.
	(NRTsetVector4a): Likewise.  Avoid special variable for environment.
	* boot/utility.boot: Add and export substSource, substTarget.
	* interp/define.boot: Use them.

8 files changed, 86 insertions, 34 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 98e0770e..9b8adf19 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,13 @@
 2013-06-14  Gabriel Dos Reis  <gdr@integrable-solutions.net>
 
+	* interp/nruncomp.boot (NRTsetVector4Part1): Add environment parameter.
+	Adjust caller.
+	(NRTsetVector4a): Likewise.  Avoid special variable for environment.
+	* boot/utility.boot: Add and export substSource, substTarget.
+	* interp/define.boot: Use them.
+
+2013-06-14  Gabriel Dos Reis  <gdr@integrable-solutions.net>
+
 	* interp/compiler.boot (categoryInstance?): New.
 	(compColon): Use it for category definitions.
 	* interp/c-util.boot: Add accessors for infovec parts.
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index 985611d3..fcb8a2ef 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -388,7 +388,7 @@
       (COND (|done| (RETURN NIL))
             (T
              (SETQ |found|
-                     (LET ((#1=#:G720
+                     (LET ((#1=#:G727
                             (CATCH :OPEN-AXIOM-CATCH-POINT
                               (APPLY |f| |ps| NIL))))
                        (COND
@@ -1371,7 +1371,7 @@
      (SETQ |op| (|enclosingFunction| (|parserLoadUnit| |ps|)))
      (SETQ |varno| (|parserGensymSequenceNumber| |ps|))
      (UNWIND-PROTECT
-         (LET ((#1=#:G721
+         (LET ((#1=#:G728
                 (CATCH :OPEN-AXIOM-CATCH-POINT
                   (PROGN
                    (SETF (|enclosingFunction| (|parserLoadUnit| |ps|)) NIL)
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index afd689ad..55653a76 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -84,10 +84,10 @@
   (LET* (|s|)
     (COND
      ((SETQ |s|
-              (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|)
+              (WITH-HASH-TABLE-ITERATOR (#1=#:G726 |shoeKeyTable|)
                 (LET ((|bfVar#1| NIL))
                   (LOOP
-                   (MULTIPLE-VALUE-BIND (#2=#:G720 |k| |v|)
+                   (MULTIPLE-VALUE-BIND (#2=#:G727 |k| |v|)
                        (#1#)
                      (COND ((NOT #2#) (RETURN |bfVar#1|))
                            (T
@@ -138,9 +138,9 @@
                  (COND ((> |i| 255) (RETURN NIL)) (T (SETF (ELT |a| |i|) |b|)))
                  (SETQ |i| (+ |i| 1))))
               |a|))
-     (WITH-HASH-TABLE-ITERATOR (#1=#:G721 |shoeKeyTable|)
+     (WITH-HASH-TABLE-ITERATOR (#1=#:G728 |shoeKeyTable|)
        (LOOP
-        (MULTIPLE-VALUE-BIND (#2=#:G722 |s| #:G723)
+        (MULTIPLE-VALUE-BIND (#2=#:G729 |s| #:G730)
             (#1#)
           (COND ((NOT #2#) (RETURN NIL)) (T (|shoeInsert| |s| |d|))))))
      |d|)))
@@ -154,9 +154,9 @@
      (LET ((|i| 0))
        (LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0)))
              (SETQ |i| (+ |i| 1))))
-     (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
+     (WITH-HASH-TABLE-ITERATOR (#1=#:G731 |shoeKeyTable|)
        (LOOP
-        (MULTIPLE-VALUE-BIND (#2=#:G725 |k| #:G726)
+        (MULTIPLE-VALUE-BIND (#2=#:G732 |k| #:G733)
             (#1#)
           (COND ((NOT #2#) (RETURN NIL)) ((|shoeStartsId| (SCHAR |k| 0)) NIL)
                 (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1))))))
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index d3f85676..99d7f82a 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -416,7 +416,7 @@
      (SETQ |ps| (|makeParserState| |toks|))
      (|bpFirstTok| |ps|)
      (SETQ |found|
-             (LET ((#1=#:G729
+             (LET ((#1=#:G736
                     (CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem| |ps|))))
                (COND
                 ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT))
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index 2e303001..1a288c10 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -20,10 +20,10 @@
                      |lastNode| |append| |append!| |copyList| |substitute|
                      |substitute!| |setDifference| |setUnion| |setIntersection|
                      |symbolAssoc| |applySubst| |applySubst!| |applySubstNQ|
-                     |objectAssoc| |remove| |removeSymbol| |atomic?| |every?|
-                     |any?| |take| |takeWhile| |drop| |copyTree| |finishLine|
-                     |stringPrefix?| |stringSuffix?| |findChar|
-                     |charPosition|)))
+                     |objectAssoc| |invertSubst| |substTarget| |substSource|
+                     |remove| |removeSymbol| |atomic?| |every?| |any?| |take|
+                     |takeWhile| |drop| |copyTree| |finishLine| |stringPrefix?|
+                     |stringSuffix?| |findChar| |charPosition|)))
 
 (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|))
 
@@ -338,6 +338,40 @@
           ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|))
           (T |t|))))
 
+(DEFUN |invertSubst| (|sl|)
+  (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |sl|) (|x| NIL))
+    (LOOP
+     (COND
+      ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+       (RETURN |bfVar#2|))
+      ((NULL |bfVar#2|)
+       (SETQ |bfVar#2| #1=(CONS (CONS (CDR |x|) (CAR |x|)) NIL))
+       (SETQ |bfVar#3| |bfVar#2|))
+      (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+     (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
+(DEFUN |substSource| (|sl|)
+  (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |sl|) (|x| NIL))
+    (LOOP
+     (COND
+      ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+       (RETURN |bfVar#2|))
+      ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS (CAR |x|) NIL))
+       (SETQ |bfVar#3| |bfVar#2|))
+      (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+     (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
+(DEFUN |substTarget| (|sl|)
+  (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |sl|) (|x| NIL))
+    (LOOP
+     (COND
+      ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+       (RETURN |bfVar#2|))
+      ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS (CDR |x|) NIL))
+       (SETQ |bfVar#3| |bfVar#2|))
+      (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+     (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
 (DEFUN |setDifference| (|x| |y|)
   (LET* (|a| |l| |p|)
     (COND ((NULL |x|) NIL) ((NULL |y|) |x|)
diff --git a/src/boot/utility.boot b/src/boot/utility.boot
index 839e9b1a..d3f999ad 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,
-  invertSubst,
+  invertSubst, substTarget, substSource,
   remove, removeSymbol, atomic?, every?, any?, take, takeWhile, drop,
   copyTree, finishLine, stringPrefix?, stringSuffix?,
   findChar, charPosition) where
@@ -285,6 +285,14 @@ applySubstNQ(sl,t) ==
 invertSubst sl ==
   [[rest x,:first x] for x in sl]
 
+++ Return the list of source values of a map given by a alist.
+substSource sl ==
+  [first x for x in sl]
+
+++ Return the list of target values of a map given by a alist.
+substTarget sl ==
+  [rest x for x in sl]
+
 --% set operations
 
 setDifference(x,y) ==
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 10403767..0195e4e2 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -479,7 +479,7 @@ depthAssocList(u,cache) ==
  
 depthAssoc(x,cache) ==
   y := tableValue(cache,x) => y
-  x is ['Join,:u] or (u := ASSOCLEFT parentsOfForm x) =>
+  x is ['Join,:u] or (u := substSource parentsOfForm x) =>
     v := depthAssocList(u,cache)
     tableValue(cache,x) := [[x,:n],:v]
       where n() == 1 + "MAX"/[rest y for y in v]
@@ -487,20 +487,20 @@ depthAssoc(x,cache) ==
  
 NRTmakeCategoryAlist(db,e) ==
   pcAlist := [:[[x,:true] for x in $uncondAlist],:$condAlist]
-  levelAlist := depthAssocList(ASSOCLEFT pcAlist,hashTable 'EQUAL)
+  levelAlist := depthAssocList(substSource pcAlist,hashTable 'EQUAL)
   opcAlist := sortBy(function(x +-> LASSOC(first x,levelAlist)),pcAlist)
-  newPairlis := [[5 + i,:b] for [.,:b] in dbFormalSubst db for i in 1..]
+  newPairlis := [[i,:b] for [.,:b] in dbFormalSubst db for i in 6..]
   slot1 := [[a,:k] for [a,:b] in dbSubstituteAllQuantified(db,opcAlist)
                    | (k := predicateBitIndex(b,e)) ~= -1]
-  slot0 := [hasDefaultPackage a.op for [a,:b] in slot1]
+  slot0 := [hasDefaultPackage a.op for [a,:.] in slot1]
   sixEtc := [5 + i for i in 1..dbArity db]
-  formals := ASSOCRIGHT dbFormalSubst db
+  formals := substTarget dbFormalSubst db
   for x in slot1 repeat
     x.first := applySubst(pairList(['$,:formals],["$$",:sixEtc]),first x)
   -----------code to make a new style slot4 -----------------
-  predList := ASSOCRIGHT slot1  --is list of predicate indices
+  predList := substTarget slot1  --is list of predicate indices
   maxPredList := "MAX"/predList
-  catformvec := ASSOCLEFT slot1
+  catformvec := substSource slot1
   maxElement := "MAX"/dbByteList db
   ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList],
     ['CONS, MKQ vector slot0,
@@ -625,7 +625,7 @@ catExtendsCat?(u,v,tbl,env) ==
     PRINT similarForm
     sayBrightlyNT '"   but not "
     PRINT v
-  or/[catExtendsCat?(x,v,tbl,env) for x in ASSOCLEFT categoryAncestors uvec]
+  or/[catExtendsCat?(x,v,tbl,env) for x in substSource categoryAncestors uvec]
  
 substSlotNumbers(form,template,domain) ==
   form is ['SIGNATURE,op,sig,:q] =>
@@ -1098,7 +1098,7 @@ deduceImplicitParameters(db,e) ==
     
 buildConstructorCondition db ==
   dbImplicitData db is [subst,cond] =>
-    ['%exist,ASSOCRIGHT subst,mkpf(applySubst(subst,cond),'AND)]
+    ['%exist,substTarget subst,mkpf(applySubst(subst,cond),'AND)]
   true
 
 getArgumentMode: (%Form,%Env) -> %Maybe %Mode 
@@ -1763,7 +1763,7 @@ compDefWhereClause(['DEF,form,signature,body],m,e) ==
   -- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that
   --       the type of xi is independent of xj if i < j
   varList :=
-    orderByDependency(ASSOCLEFT argDepAlist,ASSOCRIGHT argDepAlist) where
+    orderByDependency(substSource argDepAlist,substTarget argDepAlist) where
       argDepAlist :=
         [[x,:dependencies] for [x,:y] in argSigAlist] where
           dependencies() ==
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index bd6424fd..0271c9a4 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -1,6 +1,6 @@
 -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
 -- All rights reserved.
--- Copyright (C) 2007-2012, Gabriel Dos Reis.
+-- Copyright (C) 2007-2013, Gabriel Dos Reis.
 -- All rights reserved.
 --
 -- Redistribution and use in source and binary forms, with or without
@@ -480,7 +480,7 @@ buildFunctor(db,sig,code,$locals,$e) ==
   -- Do this now to create predicate vector; then DescendCode can refer
   -- to predicate vector if it can
   [$uncondAlist,:$condAlist] :=    --bound in compDefineFunctor1
-      NRTsetVector4Part1(db,viewNames,catvecListMaker,condCats)
+      NRTsetVector4Part1(db,viewNames,catvecListMaker,condCats,$e)
   [$NRTslot1PredicateList,predBitVectorCode1,:predBitVectorCode2] :=
     makePredicateBitVector(db,[:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList],$e)
 
@@ -527,13 +527,13 @@ buildFunctor(db,sig,code,$locals,$e) ==
   SAY ['"time taken in buildFunctor: ",TEMPUS_-FUGIT()-oldtime]
   ans
 
-NRTsetVector4Part1(db,siglist,formlist,condlist) ==
+NRTsetVector4Part1(db,siglist,formlist,condlist,e) ==
   $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(db,sig,form,cond)
+                  NRTsetVector4a(db,sig,form,cond,e)
   reducedUncondlist := removeDuplicates $uncondList
   reducedConlist :=
     [[x,:y] for [x,z] in $condList| y := SETDIFFERENCE(z,reducedUncondlist)]
@@ -551,15 +551,17 @@ reverseCondlist cl ==
       u.rest := [x,:rest u]
   alist
 
-NRTsetVector4a(db,sig,form,cond) ==
+NRTsetVector4a(db,sig,form,cond,e) ==
   sig is '$ =>
      domainList :=
-       [optimize comp(d,$EmptyMode,$e).expr or d
-         for d in categoryPrincipals dbDomainShell db]
-     $uncondList := append(domainList,$uncondList)
-     if isCategoryForm(form,$e) then $uncondList := [form,:$uncondList]
+       [domForm for d in categoryPrincipals dbDomainShell db] where
+          domForm() == optimize
+            T := comp(d,$EmptyMode,e) => T.expr
+            d
+     $uncondList := append!(domainList,$uncondList)
+     if isCategoryForm(form,e) then $uncondList := [form,:$uncondList]
      $uncondList
-  evalform := evalCategoryForm(form,$e)
+  evalform := evalCategoryForm(form,e)
   cond is true =>
     $uncondList := [form,:append(categoryPrincipals evalform,$uncondList)]
   $condList := [[cond,[form,:categoryPrincipals evalform]],:$condList]