diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 20 | ||||
| -rw-r--r-- | src/algebra/domain.spad.pamphlet | 8 | ||||
| -rw-r--r-- | src/interp/c-util.boot | 22 | ||||
| -rw-r--r-- | src/interp/category.boot | 35 | ||||
| -rw-r--r-- | src/interp/cattable.boot | 4 | ||||
| -rw-r--r-- | src/interp/database.boot | 16 | ||||
| -rw-r--r-- | src/interp/define.boot | 7 | ||||
| -rw-r--r-- | src/interp/functor.boot | 20 | ||||
| -rw-r--r-- | src/interp/modemap.boot | 11 | ||||
| -rw-r--r-- | src/interp/nruncomp.boot | 10 |
10 files changed, 83 insertions, 70 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 164311a1..93f7a46c 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,23 @@ +2011-08-18 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * interp/c-util.boot (categoryAssociatedTypes): Rename from + categoryHierarchy. Adjust callers. + (categoryPrincipals): New. + (categoryAncestors): Likewise. + (categoryLocals): Likewise. + (categoryParameters): Likewise. + (extendsCategoryForm): Use them. + * interp/category.boot: Likewise. + * interp/cattable.boot: Likewise. + * interp/define.boot: Likewise. + * interp/functor.boot: Likewise. + * interp/modemap.boot: Likewise. + * interp/nruncomp.boot: Likewise. + * interp/database.boot (getCategoryAttributes): Remove. + (getPrincipalAncestors): Likewise. + (getCategoryParents): Likewise. + * algebra/domain.spad.pamphlet (Category): Adjust. + 2011-08-16 Gabriel Dos Reis <gdr@cs.tamu.edu> * interp/c-util.boot (categoryPrincipals): New. diff --git a/src/algebra/domain.spad.pamphlet b/src/algebra/domain.spad.pamphlet index 456680dc..501d7b2a 100644 --- a/src/algebra/domain.spad.pamphlet +++ b/src/algebra/domain.spad.pamphlet @@ -399,18 +399,18 @@ Category(): Public == Private where ++ extended by the category `c'. Private == add constructor x == - %head(devaluate(x)$Lisp)$Foreign(Builtin) + %head(devaluate(x)$Foreign(Builtin))$Foreign(Builtin) exportedOperators c == [%head(x)$Foreign(Builtin)@OperatorSignature - for x in categoryExports(c)$Lisp@List(Syntax)] + for x in categoryExports(c)$Foreign(Builtin)@List(Syntax)] principalAncestors c == - getCategoryPrincipalAncestors(c)$Lisp + categoryPrincipals(c)$Foreign(Builtin) parents c == [%head(x)$Foreign(Builtin)@ConstructorCall(CategoryConstructor) - for x in getCategoryParents(c)$Lisp@List(Syntax)] + for x in categoryAncestors(c)$Foreign(Builtin)@List(Syntax)] coerce x == outputDomainConstructor(x)$Lisp diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 4ad94273..54000fad 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -86,16 +86,23 @@ macro categoryAttributes d == categoryRef(d,2) ++ Return a 3-list of data describing the hierarchy of category `c'. -macro categoryHierarchy c == +macro categoryAssociatedTypes c == categoryRef(c,4) ++ Return the list of principal ancestors of category `c'. macro categoryPrincipals c == - first categoryHierarchy c + first categoryAssociatedTypes c -++ Return the list of [ancestor,predicate,index] data of catagory `c'. +++ Return the list of [ancestor,predicate,index] data of catagory `c', +++ where `ancestor' is a fundamental ancestor, `index' its sequence number. macro categoryAncestors c == - second categoryHierarchy c + second categoryAssociatedTypes c + +macro categoryLocals c == + third categoryAssociatedTypes c + +macro categoryParameters c == + categoryRef(c,5) ++ Reference a 3-list ++ [lookupFunction,thisDomain,optable] @@ -1033,12 +1040,11 @@ extendsCategoryForm(domain,form,form') == 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') - catvlist:= formVec.4 - listMember?(form',first catvlist) or - listMember?(form',substitute(domain,"$",first catvlist)) or + listMember?(form',categoryPrincipals formVec) or + listMember?(form',substitute(domain,"$",categoryPrincipals formVec)) or (or/ [extendsCategoryForm(domain,substitute(domain,"$",cat),form') - for [cat,:.] in second catvlist]) + for [cat,:.] in categoryAncestors formVec]) nil getmode(x,e) == diff --git a/src/interp/category.boot b/src/interp/category.boot index 80d1fe86..c942e5c2 100644 --- a/src/interp/category.boot +++ b/src/interp/category.boot @@ -105,7 +105,7 @@ mkCategory(domainOrPackage,sigList,attList,domList,PrincipalAncestor) == OldLocals:= nil -- Remove possible duplicate local domain caches. if PrincipalAncestor then - for u in (OldLocals:= third PrincipalAncestor.4) repeat + for u in (OldLocals := categoryLocals PrincipalAncestor) repeat NewLocals := remove(NewLocals,first u) -- New local domains caches are hosted in slots at the end onward for u in NewLocals repeat @@ -120,10 +120,12 @@ mkCategory(domainOrPackage,sigList,attList,domList,PrincipalAncestor) == if PrincipalAncestor ~= nil then for x in 6..#PrincipalAncestor-1 repeat categoryRef(v,x) := PrincipalAncestor.x - categoryHierarchy(v) := - [first PrincipalAncestor.4,second PrincipalAncestor.4,OldLocals] + categoryAssociatedTypes(v) := + [categoryPrincipals PrincipalAncestor, + categoryAncestors PrincipalAncestor, + OldLocals] else - categoryHierarchy(v) := [nil,nil,OldLocals] + categoryAssociatedTypes(v) := [nil,nil,OldLocals] categoryRef(v,5) := domList for [nsig,:n] in NSigList repeat categoryRef(v,n) := nsig @@ -310,17 +312,17 @@ FindFundAncs l == canonicalForm f1 = nil => FindFundAncs rest l ans:= FindFundAncs rest l for u in FindFundAncs [[CatEval first x,mkAnd(CADAR l,second x)] - for x in second f1.4] repeat + for x in categoryAncestors f1] repeat x:= ASSQ(first u,ans) => ans:= [[first u,mkOr(second x,second u)],:remove(ans,x)] ans:= [u,:ans] --testing to see if first l is already there x:= ASSQ(CAAR l,ans) => [[CAAR l,mkOr(CADAR l,second x)],:remove(ans,x)] CADAR l=true => - for x in first f1.4 repeat + for x in categoryPrincipals f1 repeat if y:= ASSQ(CatEval x,ans) then ans := remove(ans,y) [first l,:ans] - for x in first f1.4 repeat + for x in categoryPrincipals f1 repeat if y:= ASSQ(CatEval x,ans) then ans:= [[first y,mkOr(CADAR l,second y)],:remove(ans,y)] [first l,:ans] @@ -341,7 +343,7 @@ AncestorP(xname,leaves) == -- checks for being a principal ancestor of one of the leaves listMember?(xname,leaves) => xname for y in leaves repeat - listMember?(xname,first CatEval(y).4) => return y + listMember?(xname,categoryPrincipals CatEval y) => return y CondAncestorP(xname,leaves,condition) == -- checks for being a principal ancestor of one of the leaves @@ -350,7 +352,7 @@ CondAncestorP(xname,leaves,condition) == ucond:= null rest u => true second u - xname = u' or listMember?(xname,first CatEval(u').4) => + xname = u' or listMember?(xname,categoryPrincipals CatEval u') => PredImplies(ucond,condition) => return u' @@ -364,8 +366,8 @@ DescendantP(a,b) == a:= CatEval a b is ["ATTRIBUTE",b'] => (l:=assoc(b',a.2)) => TruthP second l - listMember?(b,first a.4) => true - AncestorP(b,[first u for u in second a.4]) => true + listMember?(b,categoryPrincipals a) => true + AncestorP(b,[first u for u in categoryAncestors a]) => true false --% The implementation of Join @@ -403,7 +405,7 @@ JoinInner(l,$e) == sigl := categoryExports $NewCatVec attl:= $NewCatVec.2 globalDomains:= $NewCatVec.5 - FundamentalAncestors:= second $NewCatVec.4 + FundamentalAncestors := categoryAncestors $NewCatVec if $NewCatVec.0 then FundamentalAncestors:= [[$NewCatVec.0],:FundamentalAncestors] --principal ancestor . all those already included @@ -422,7 +424,7 @@ JoinInner(l,$e) == (f:=AncestorP(bname,[first u for u in FundamentalAncestors])) => [.,.,index]:=assoc(f,FundamentalAncestors) FundamentalAncestors:=[[bname,condition,index],:FundamentalAncestors] - PrinAncb:= first CatEval(bname).4 + PrinAncb := categoryPrincipals CatEval bname --Principal Ancestors of b reallynew:= true for anc in FundamentalAncestors repeat @@ -455,7 +457,7 @@ JoinInner(l,$e) == if originalVector and (condition=true) then $NewCatVec:= CatEval bname copied:= nil - FundamentalAncestors:= [[bname],:second $NewCatVec.4] + FundamentalAncestors:= [[bname],:categoryAncestors $NewCatVec] --bname is Principal, so comes first reallynew:= nil objectMember?(b,l) => @@ -529,10 +531,11 @@ JoinInner(l,$e) == [sig,mkpf([oldpred,newpred],"and"),:implem] FundamentalAncestors:= [x for x in FundamentalAncestors | rest x] --strip out the pointer to Principal Ancestor - c:= first $NewCatVec.4 + c := categoryPrincipals $NewCatVec pName:= $NewCatVec.0 if pName and not listMember?(pName,c) then c:= [pName,:c] - $NewCatVec.4:= [c,FundamentalAncestors,third $NewCatVec.4] + categoryAssociatedTypes($NewCatVec) := + [c,FundamentalAncestors,categoryLocals $NewCatVec] mkCategory("domain",sigl,attl,globalDomains,$NewCatVec) Join(:l) == diff --git a/src/interp/cattable.boot b/src/interp/cattable.boot index a4c1cdd9..298e6c56 100644 --- a/src/interp/cattable.boot +++ b/src/interp/cattable.boot @@ -296,8 +296,8 @@ mkCategoryExtensionAlistBasic cform == category := -- changed by RSS on 7/29/87 macrop cop => eval cform apply(cop, rest cform) - extendsList:= [[x,:'T] for x in category.4.0] - for [cat,pred,:.] in category.4.1 repeat + extendsList := [[x,:'T] for x in categoryPrincipals category] + for [cat,pred,:.] in categoryAncestors category repeat newList := getCategoryExtensionAlist0 cat finalList := pred is 'T => newList diff --git a/src/interp/database.boot b/src/interp/database.boot index be5479d8..72cb5fc7 100644 --- a/src/interp/database.boot +++ b/src/interp/database.boot @@ -775,22 +775,6 @@ displayHiddenConstructors() == else for c in $localExposureData.2 repeat centerAndHighlight c - - ---% - - -++ Return the list of category attribute info for the category object `c'. -++ A category attribute info is pair of attribute-predicate. -getCategoryAttributes: %Shell -> %List %Form -getCategoryAttributes c == c.2 - - -getCategoryPrincipalAncestors c == c.4.0 - -getCategoryParents c == c.4.1 - - --% squeezeAll: %List %Code -> %List %Code squeezeAll x == diff --git a/src/interp/define.boot b/src/interp/define.boot index 39c2abc1..59577423 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -327,7 +327,7 @@ extendsCategoryBasic(dom,u,v,env) == v is ['IF,p,['ATTRIBUTE,c],.] => uVec := compMakeCategoryObject(u,env).expr or return false cons? c and isCategoryForm(c,env) => - LASSOC(c,second categoryHierarchy uVec) is [=p,:.] + 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 = v => true @@ -348,8 +348,7 @@ extendsCategoryBasic(dom,u,v,env) == catExtendsCat?(u,v,env) == u = v => true uvec := compMakeCategoryObject(u,env).expr - slot4 := categoryHierarchy uvec - prinAncestorList := first slot4 + prinAncestorList := categoryPrincipals uvec listMember?(v,prinAncestorList) => true vOp := KAR v if similarForm := assoc(vOp,prinAncestorList) then @@ -358,7 +357,7 @@ catExtendsCat?(u,v,env) == PRINT similarForm sayBrightlyNT '" but not " PRINT v - or/[catExtendsCat?(x,v,env) for x in ASSOCLEFT second slot4] + or/[catExtendsCat?(x,v,env) for x in ASSOCLEFT categoryAncestors uvec] substSlotNumbers(form,template,domain) == form is [op,:.] and diff --git a/src/interp/functor.boot b/src/interp/functor.boot index fc44b8c8..d3c5823c 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -600,7 +600,7 @@ InvestigateConditions catvecListMaker == if $principal is [op,:.] then [principal',:.]:=compMakeCategoryObject($principal,$e) --Rather like eval, but quotes parameters first - for u in second principal'.4 repeat + for u in categoryAncestors principal' repeat if not TruthP(cond:=second u) then new:=['CATEGORY,'domain,['IF,cond,['ATTRIBUTE,first u], '%noBranch]] $principal is ['Join,:l] => @@ -620,14 +620,14 @@ InvestigateConditions catvecListMaker == null $Conditions => [true,:[true for u in secondaries]] PrincipalSecondaries:= getViewsConditions principal' MinimalPrimary:= first first PrincipalSecondaries - MaximalPrimary:= CAAR $domainShell.4 + MaximalPrimary := first categoryPrincipals $domainShell necessarySecondaries:= [first u for u in PrincipalSecondaries | rest u=true] and/[listMember?(u,necessarySecondaries) for u in secondaries] => [true,:[true for u in secondaries]] $HackSlot4:= MinimalPrimary=MaximalPrimary => nil - MaximalPrimaries:=[MaximalPrimary,:first CatEval(MaximalPrimary).4] - MinimalPrimaries:=[MinimalPrimary,:first CatEval(MinimalPrimary).4] + MaximalPrimaries:=[MaximalPrimary,:categoryPrincipals CatEval MaximalPrimary] + MinimalPrimaries:=[MinimalPrimary,:categoryPrincipals CatEval MinimalPrimary] MaximalPrimaries:=S_-(MaximalPrimaries,MinimalPrimaries) [[x] for x in MaximalPrimaries] ($Conditions:= Conds($principal,nil)) where @@ -657,7 +657,7 @@ InvestigateConditions catvecListMaker == # u=1 => first u ['AND,:u] for [v,:.] in newS repeat - for v' in [v,:first CatEval(v).4] repeat + for v' in [v,:categoryPrincipals CatEval v] repeat if (w:=assoc(v',$HackSlot4)) then w.rest := if rest w then mkOr(u,rest w) else u (list:= update(list,u,secondaries,newS)) where @@ -751,8 +751,8 @@ getPossibleViews u == --returns a list of all the categories that can be views of this one [vec,:.]:= compMakeCategoryObject(u,$e) or systemErrorHere ["getPossibleViews",u] - views:= [first u for u in second vec.4] - null vec.0 => [CAAR vec.4,:views] --* + views:= [first u for u in categoryAncestors vec] + null vec.0 => [first categoryPrincipals vec,:views] --* [vec.0,:views] --* --the two lines marked ensure that the principal view comes first --if you don't want it, rest it off @@ -763,10 +763,10 @@ getViewsConditions u == --paired with the condition under which they are such views [vec,:.]:= compMakeCategoryObject(u,$e) or systemErrorHere ["getViewsConditions",u] - views:= [[first u,:second u] for u in second vec.4] + views:= [[first u,:second u] for u in categoryAncestors vec] null vec.0 => - null first vec.4 => views - [[CAAR vec.4,:true],:views] --* + null categoryPrincipals vec => views + [[first categoryPrincipals vec,:true],:views] --* [[vec.0,:true],:views] --* --the two lines marked ensure that the principal view comes first --if you don't want it, rest it off diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot index c066b16e..cff85592 100644 --- a/src/interp/modemap.boot +++ b/src/interp/modemap.boot @@ -476,14 +476,13 @@ knownInfo pred == vmode is ["Join",:l] and listMember?(cat,l) => true [vv,.,.]:= compMakeCategoryObject(vmode,$e) or return stackAndThrow('"cannot find category %1pb",[vmode]) - catlist := vv.4 - listMember?(cat,first catlist) => true --checks princ. ancestors - (u:=assoc(cat,second catlist)) and knownInfo second u => true + listMember?(cat,categoryPrincipals vv) => true --checks princ. ancestors + (u:=assoc(cat,categoryAncestors vv)) and knownInfo second u => true -- previous line checks fundamental anscestors, we should check their -- principal anscestors but this requires instantiating categories or/[AncestorP(cat,[first u]) - for u in second catlist | knownInfo second u] => true + for u in categoryAncestors vv | knownInfo second u] => true false pred is ["SIGNATURE",name,op,sig,:.] => v:= get(op,"modemap",$e) @@ -547,8 +546,8 @@ actOnInfo(u,$e) == [ocatvec,.,$e]:= compMakeCategoryObject(vmode,$e) --we are adding a principal descendant of what was already known - listMember?(cat,first ocatvec.4) or - assoc(cat,second ocatvec.4) is [.,"T",.] => $e + listMember?(cat,categoryPrincipals ocatvec) or + assoc(cat,categoryAncestors ocatvec) is [.,"T",.] => $e --what was being asserted is an ancestor of what was known if name="$" then $e:= augModemapsFromCategory(name,name,name,cat,$e) diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index 0752edc4..d8703729 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -503,7 +503,8 @@ buildFunctor($definition is [name,:args],sig,code,$locals,$e) == --we will clobber elements; copy since $domainShell may be a cached vector $template := newShell($NRTbase + $NRTdeltaLength) $SetFunctions := newShell # domainShell - $catvecList := [domainShell,:[emptyVector for u in second domainShell.4]] + $catvecList := + [domainShell,:[emptyVector for u in categoryAncestors domainShell]] -- list of names n1..nn for each view viewNames := ['$,:[genvar() for u in rest catvecListMaker]] domname := 'dv_$ @@ -607,13 +608,14 @@ NRTsetVector4a(sig,form,cond) == sig is '$ => domainList := [simplifyVMForm COPY comp(d,$EmptyMode,$e).expr or d - for d in $domainShell.4.0] + for d in categoryPrincipals $domainShell] $uncondList := append(domainList,$uncondList) if isCategoryForm(form,$e) then $uncondList := [form,:$uncondList] $uncondList evalform := eval mkEvalableCategoryForm form - cond = true => $uncondList := [form,:append(evalform.4.0,$uncondList)] - $condList := [[cond,[form,:evalform.4.0]],:$condList] + cond = true => + $uncondList := [form,:append(categoryPrincipals evalform,$uncondList)] + $condList := [[cond,[form,:categoryPrincipals evalform]],:$condList] NRTmakeSlot1Info() == -- 4 cases: |