diff options
| -rw-r--r-- | src/ChangeLog | 7 | ||||
| -rw-r--r-- | src/interp/c-util.boot | 30 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 7 | ||||
| -rw-r--r-- | src/interp/define.boot | 1 |
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 |