diff options
| -rw-r--r-- | src/ChangeLog | 12 | ||||
| -rw-r--r-- | src/interp/define.boot | 73 | ||||
| -rw-r--r-- | src/interp/lisplib.boot | 17 |
3 files changed, 55 insertions, 47 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index af4680fb..dec986fa 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,17 @@ 2013-06-01 Gabriel Dos Reis <gdr@integrable-solutions.net> + * interp/define.boot (NRTgetLookupFunction): Take a cache table. + Adjust caller. + (NRTextendsCategory1): Likewise. + (extendsCategory): Likewise. + (extendsCategoryBasic): Likewise. + (catExtendsCat?): Likewise. + (getCategoryObjectIfCan): New. + (getCategoryObject): Use it. + * interp/lisplib.boot (getSlot1): Remove as unused. + +2013-06-01 Gabriel Dos Reis <gdr@integrable-solutions.net> + * interp/category.boot (SigListUnion): Take a cache table. Adjust callers. (mkOr): Likewise. diff --git a/src/interp/define.boot b/src/interp/define.boot index a3c893d1..d15c4682 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -46,6 +46,7 @@ module define where compAdd: (%Form, %Mode, %Env) -> %Maybe %Triple compCategory: (%Form,%Mode,%Env) -> %Maybe %Triple evalCategoryForm: (%Form,%Env) -> %Maybe %Shell + getCategoryObjectIfCan: (%Table,%Form,%Env) -> %Maybe %Shell getCategoryObject: (%Table,%Form,%Env) -> %Shell @@ -259,7 +260,9 @@ GetValue name == actOnInfo(u,$e) == null u => $e - u is ["PROGN",:l] => (for v in l repeat $e:= actOnInfo(v,$e); $e) + u is ["PROGN",:l] => + for v in l repeat $e := actOnInfo(v,$e) + $e db := currentDB $e $e:= put("$Information","special",Info:= [u,:get("$Information","special",$e)],$e @@ -268,7 +271,7 @@ actOnInfo(u,$e) == --there is nowhere %else that this sort of thing exists for [ante,:conseq] in l repeat if listMember?(hasToInfo ante,Info) then for v in conseq repeat - $e:= actOnInfo(v,$e) + $e := actOnInfo(v,$e) $e u is ["ATTRIBUTE",name,att] => [vval,vmode,.]:= GetValue name @@ -336,7 +339,7 @@ chaseInferences(pred,$e) == foo hasToInfo pred where foo pred == knownInfo(pred,$e) => nil - $e:= actOnInfo(pred,$e) + $e := actOnInfo(pred,$e) pred:= infoToHas pred for u in get("$Information","special",$e) repeat u is ['%when,:l] => @@ -528,18 +531,18 @@ getXmode(x,e) == --======================================================================= -- Compute the lookup function (complete or incomplete) --======================================================================= -NRTgetLookupFunction(db,addForm,env) == +NRTgetLookupFunction(db,addForm,tbl,env) == $why: local := nil domform := dbSubstituteFormals(db,dbConstructorForm db) cat := dbCategory db addForm isnt [.,:.] => ident? addForm and (m := getmode(addForm,env)) ~= nil and isCategoryForm(m,env) and - extendsCategory(db,domform,cat,dbSubstituteFormals(db,m),env) => + extendsCategory(db,domform,cat,dbSubstituteFormals(db,m),tbl,env) => 'lookupIncomplete 'lookupComplete addForm := dbSubstituteFormals(db,addForm) - NRTextendsCategory1(db,domform,cat,getBaseExports(db,addForm),env) => + NRTextendsCategory1(db,domform,cat,getBaseExports(db,addForm),tbl,env) => 'lookupIncomplete [u,msg,:v] := $why SAY '"--------------non extending category----------------------" @@ -563,55 +566,58 @@ getBaseExports(db,form) == [[.,target,:tl],:.] := getConstructorModemap op applySubst(pairList($FormalMapVariableList,argl),target) -NRTextendsCategory1(db,domform,exCategory,addForm,env) == +NRTextendsCategory1(db,domform,exCategory,addForm,tbl,env) == addForm is ["%Comma",:r] => - and/[extendsCategory(db,domform,exCategory,x,env) for x in r] - extendsCategory(db,domform,exCategory,addForm,env) + and/[extendsCategory(db,domform,exCategory,x,tbl,env) for x in r] + extendsCategory(db,domform,exCategory,addForm,tbl,env) --======================================================================= -- Compute if a domain constructor is forgetful functor --======================================================================= -extendsCategory(db,dom,u,v,env) == +extendsCategory(db,dom,u,v,tbl,env) == --does category u extend category v (yes iff u contains everything in v) --is dom of category u also of category v? u=v => true - v is ["Join",:l] => and/[extendsCategory(db,dom,u,x,env) for x in l] - v is ["CATEGORY",.,:l] => and/[extendsCategory(db,dom,u,x,env) for x in l] + v is ["Join",:l] => and/[extendsCategory(db,dom,u,x,tbl,env) for x in l] + v is ["CATEGORY",.,:l] => + and/[extendsCategory(db,dom,u,x,tbl,env) for x in l] v is ["SubsetCategory",cat,d] => - extendsCategory(db,dom,u,cat,env) and isSubset(dom,d,env) + extendsCategory(db,dom,u,cat,tbl,env) and isSubset(dom,d,env) v := substSlotNumbers(v,dbTemplate db,dbConstructorForm db) - extendsCategoryBasic(dom,u,v,env) => true + extendsCategoryBasic(dom,u,v,tbl,env) => true $why := v is ['SIGNATURE,op,sig,:.] => [u,['" has no ",:formatOpSignature(op,sig)]] [u,'" has no",v] nil -extendsCategoryBasic(dom,u,v,env) == +extendsCategoryBasic(dom,u,v,tbl,env) == v is ['IF,p,['ATTRIBUTE,c],.] => - uVec := compMakeCategoryObject(u,env).expr or return false + uVec := getCategoryObjectIfCan(tbl,u,env) or return false cons? c and isCategoryForm(c,env) => LASSOC(c,categoryAncestors uVec) is [=p,:.] LASSOC(c,categoryAttributes uVec) is [=p,:.] - u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v,env) for x in l] + u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v,tbl,env) for x in l] u = v => true v is ['ATTRIBUTE,c] => - cons? c and isCategoryForm(c,env) => extendsCategoryBasic(dom,u,c,env) - u is ['CATEGORY,.,:l] => or/[extendsCategoryBasic(dom,x,v,env) for x in l] - uVec := compMakeCategoryObject(u,env).expr or return false + cons? c and isCategoryForm(c,env) => + extendsCategoryBasic(dom,u,c,tbl,env) + u is ['CATEGORY,.,:l] => + or/[extendsCategoryBasic(dom,x,v,tbl,env) for x in l] + uVec := getCategoryObjectIfCan(tbl,u,env) or return false LASSOC(c,categoryAttributes uVec) is [=true] - isCategoryForm(v,env) => catExtendsCat?(u,v,env) + isCategoryForm(v,env) => catExtendsCat?(u,v,tbl,env) v is ['SIGNATURE,op,sig,:.] => - uVec := compMakeCategoryObject(u,env).expr or return false + uVec := getCategoryObjectIfCan(tbl,u,env) or return false or/[categoryRef(uVec,i) is [[=op,=sig],:.] for i in 6..maxIndex uVec] u is ['CATEGORY,.,:l] => v is ['IF,:.] => listMember?(v,l) false false -catExtendsCat?(u,v,env) == +catExtendsCat?(u,v,tbl,env) == u = v => true - uvec := compMakeCategoryObject(u,env).expr + uvec := getCategoryObject(tbl,u,env) prinAncestorList := categoryPrincipals uvec listMember?(v,prinAncestorList) => true vOp := KAR v @@ -621,7 +627,7 @@ catExtendsCat?(u,v,env) == PRINT similarForm sayBrightlyNT '" but not " PRINT v - or/[catExtendsCat?(x,v,env) for x in ASSOCLEFT categoryAncestors uvec] + or/[catExtendsCat?(x,v,tbl,env) for x in ASSOCLEFT categoryAncestors uvec] substSlotNumbers(form,template,domain) == form is [op,:.] and @@ -1219,10 +1225,14 @@ compMakeCategoryObject(c,$e) == u := evalCategoryForm(c,$e) => [u,$Category,$e] nil -getCategoryObject(tbl,x,env) == +getCategoryObjectIfCan(tbl,x,env) == obj := tableValue(tbl,x) => obj T := compMakeCategoryObject(x,env) => tableValue(tbl,x) := T.expr - systemErrorHere ['getCategoryObject] + nil + +getCategoryObject(tbl,x,env) == + getCategoryObjectIfCan(tbl,x,env) + or systemErrorHere ['getCategoryObject] predicatesFromAttributes: %List %Form -> %List %Form predicatesFromAttributes attrList == @@ -1350,7 +1360,9 @@ getOperationAlist(db,name,functorForm,form) == $insideFunctorIfTrue and name is "$" => dbDomainShell db = nil => systemError '"$ has no shell now" categoryExports dbDomainShell db - T:= compMakeCategoryObject(form,$e) => ([.,.,$e]:= T; categoryExports T.expr) + T := compMakeCategoryObject(form,$e) => + [.,.,$e] := T + categoryExports T.expr stackMessage('"not a category form: %1bp",[form]) substNames(domainName,functorForm,opalist) == @@ -1510,7 +1522,8 @@ compDefineFunctor1(db,df is ['DEF,form,signature,body],m,$e,$formalArgList) == $functorTarget := target := signature'.target $e := giveFormalParametersValues(form.args,$e) - [ds,.,$e] := compMakeCategoryObject(target,$e) or return + tbl := makeTable function valueEq? -- category-form/object table + ds := getCategoryObjectIfCan(tbl,target,$e) or return stackAndThrow('" cannot produce category object: %1pb",[target]) dbDomainShell(db) := copyVector ds attributeList := categoryAttributes ds --see below under "loadTimeAlist" @@ -1570,7 +1583,7 @@ compDefineFunctor1(db,df is ['DEF,form,signature,body],m,$e,$formalArgList) == dbAncestors(db) := computeAncestorsOf($form,nil) $insideFunctorIfTrue:= false if not $bootStrapMode then - dbLookupFunction(db) := NRTgetLookupFunction(db,$NRTaddForm,$e) + dbLookupFunction(db) := NRTgetLookupFunction(db,$NRTaddForm,tbl,$e) --either lookupComplete (for forgetful guys) or lookupIncomplete $NRTslot1PredicateList := [simpBool x for x in $NRTslot1PredicateList] diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index 8dceae5d..9bb304aa 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -616,23 +616,6 @@ getSlotFromFunctor(target) == systemErrorHere "getSlotFromFunctor" categoryRef(t.expr,2) -getSlot1 domainName == - $e: local:= $CategoryFrame - fn:= getLisplibName domainName - p := pathname [fn,$spadLibFT,'"*"] - not isExistingFile(p) => - sayKeyedMsg("S2IL0003",[namestring p]) - nil - (sig := getConstructorSignature domainName) => - [.,target,:argMml] := sig - for a in $FormalMapVariableList for m in argMml repeat - $e:= put(a,'mode,m,$e) - t := compMakeCategoryObject(target,$e) or - systemErrorHere ["getSlot1",domainName] - categoryExports t.expr - sayKeyedMsg("S2IL0022",[namestring p,'"constructor modemap"]) - nil - transformOperationAlist operationAlist == -- this transforms the operationAlist which is written out onto LISPLIBs. -- The original form of this list is a list of items of the form: |