Add DB parameter to extendsCategoryForm.

4 files changed, 27 insertions, 18 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 81154b2f..4ff70a94 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,12 @@
 2013-06-14  Gabriel Dos Reis  <gdr@integrable-solutions.net>
 
+	* interp/c-util.boot (extendsCategoryForm): Take a DB parameter.
+	Avoid special variables for current constructor form. Adjust callers.
+	* interp/define.boot (compDefineCategory2): Register current
+	constructor in environment.
+
+2013-06-14  Gabriel Dos Reis  <gdr@integrable-solutions.net>
+
 	* interp/lisplib.boot (writeSourceFile): Always write source file.
 
 2013-06-14  Gabriel Dos Reis  <gdr@integrable-solutions.net>
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 27c12319..d9663fae 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -1100,19 +1100,21 @@ printStats [byteCount,elapsedSeconds] ==
   finishLine $OutputStream
   nil
  
-extendsCategoryForm(domain,form,form') ==
-  --is domain of category form also of category form'?
-  --domain is only used for SubsetCategory resolution.
-  --and ensuring that X being a Ring means that it
-  --satisfies (Algebra X)
+++is domain of category form also of category form'?
+++domain is only used for SubsetCategory resolution.
+++ `db', if non-nil, is the DB for the constructor being compiled.
+++Ensuring that X being a Ring means that it satisfies (Algebra X)
+extendsCategoryForm(db,domain,form,form') ==
   form=form' => true
   form=$Category => nil
-  form' is ["Join",:l] => and/[extendsCategoryForm(domain,form,x) for x in l]
+  form' is ["Join",:l] =>
+    and/[extendsCategoryForm(db,domain,form,x) for x in l]
   form' is ["CATEGORY",.,:l] =>
-    and/[extendsCategoryForm(domain,form,x) for x in l]
+    and/[extendsCategoryForm(db,domain,form,x) for x in l]
   form' is ["SubsetCategory",cat,dom] =>
-    extendsCategoryForm(domain,form,cat) and isSubset(domain,dom,$e)
-  form is ["Join",:l] => or/[extendsCategoryForm(domain,x,form') for x in l]
+    extendsCategoryForm(db,domain,form,cat) and isSubset(domain,dom,$e)
+  form is ["Join",:l] =>
+    or/[extendsCategoryForm(db,domain,x,form') for x in l]
   form is ["CATEGORY",.,:l] =>
     listMember?(form',l) or
       stackWarning('"not known that %1 is of mode %2p",[form',form]) or true
@@ -1121,15 +1123,15 @@ extendsCategoryForm(domain,form,form') ==
   -- possibly compiled previously that may have changed.
   -- FIXME: should not we go all the way down and implement
   --        polynormic recursion?
-  domain = "$" and form = $definition => 
-    extendsCategoryForm(domain, $currentCategoryBody, form')
+  domain = "$" and form = dbConstructorForm db => 
+    extendsCategoryForm(db,domain, $currentCategoryBody, form')
   isCategoryForm(form,$EmptyEnvironment) =>
     -- -- If we have an existing definition for this category, use it.
     -- (db := constructorDB form.op) and loadDB db =>
     --   form' is ['SIGNATURE,op,types,:.] => assoc([op,args],dbOperations db)
     --   form' is ['ATTRIBUTE,a] => assoc(a,dbAttributes db)
     --   subst := pairList(dbConstructorForm(db).args,form.args)
-    --   or/[extendsCategoryForm(domain,applySubst(subst,cat),form')
+    --   or/[extendsCategoryForm(db,domain,applySubst(subst,cat),form')
     --        for [cat,:.] in dbAncestors db]
     -- Otherwise constructs the associated domain shell
     formVec:=(compMakeCategoryObject(form,$e)).expr
@@ -1142,12 +1144,10 @@ extendsCategoryForm(domain,form,form') ==
          assoc(at,categoryAttributes formVec) or
             assoc(substitute(domain,"$",at),substitute(domain,"$",categoryAttributes formVec))
     form' is ["IF",:.] => true --temporary hack so comp won't fail
-    -- Are we dealing with an Aldor category?  If so use the "has" function ...
-    # formVec = 1 => newHasTest(form,form')
     listMember?(form',categoryPrincipals formVec) or
      listMember?(form',substitute(domain,"$",categoryPrincipals formVec)) or
       (or/
-        [extendsCategoryForm(domain,substitute(domain,"$",cat),form')
+        [extendsCategoryForm(db,domain,substitute(domain,"$",cat),form')
           for [cat,:.] in categoryAncestors formVec])
   nil
  
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 60f2fc50..1d2921eb 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -327,9 +327,10 @@ finishLambdaExpression(expr is ['%lambda,vars,.],env) ==
 compWithMappingMode(x,m is ["Mapping",m',:sl],oldE) ==
   e := oldE
   isFunctor x =>
+    db := currentDB e
     if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and
-      (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl]
-        ) and extendsCategoryForm("$",target,m') then
+      (and/[extendsCategoryForm(db,"$",s,mode) for mode in argModeList for s in sl]
+        ) and extendsCategoryForm(db,"$",target,m') then
             return [['%function,x],m,e]
   x is ["+->",:.] => compLambda(x,m,oldE)
   if string? x then x := makeSymbol x
@@ -1843,7 +1844,7 @@ coerceHard(T,m) ==
   string? T.expr and T.expr=m => [T.expr,m,$e]
   isCategoryForm(m,$e) =>
       $bootStrapMode => [T.expr,m,$e]
-      extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e]
+      extendsCategoryForm(currentDB $e,T.expr,T.mode,m) => [T.expr,m,$e]
       coerceExtraHard(T,m)
   (m' is "$" and m = $functorForm) or (m' = $functorForm and m = "$") =>
     [T.expr,m,$e]
diff --git a/src/interp/define.boot b/src/interp/define.boot
index ff65b86d..a17f8aa8 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -1119,6 +1119,7 @@ compDefineCategory2(db,form,signature,body,m,e,$formalArgList) ==
     $definition: local := form   --used by DomainSubstitutionFunction
     $form: local := nil
     $extraParms: local := nil
+    e := registerConstructor($op,e)
     -- Remember the body for checking the current instantiation.
     $currentCategoryBody : local := body
          --Set in DomainSubstitutionFunction, used further down