aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog20
-rw-r--r--src/algebra/domain.spad.pamphlet8
-rw-r--r--src/interp/c-util.boot22
-rw-r--r--src/interp/category.boot35
-rw-r--r--src/interp/cattable.boot4
-rw-r--r--src/interp/database.boot16
-rw-r--r--src/interp/define.boot7
-rw-r--r--src/interp/functor.boot20
-rw-r--r--src/interp/modemap.boot11
-rw-r--r--src/interp/nruncomp.boot10
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: