aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog14
-rw-r--r--src/interp/br-con.boot4
-rw-r--r--src/interp/br-data.boot13
-rw-r--r--src/interp/buildom.boot36
-rw-r--r--src/interp/category.boot2
-rw-r--r--src/interp/database.boot8
-rw-r--r--src/interp/define.boot2
-rw-r--r--src/interp/g-util.boot4
-rw-r--r--src/interp/i-coerce.boot6
9 files changed, 72 insertions, 17 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index c1833264..73deaa86 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,4 +1,16 @@
-2012-02-12 Gabriel Dos Reis <gdr@cse.tamu.edu>
+2012-02-13 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * interp/g-util.boot (stripTags): Rename from stripUnionTags.
+ Adjust callers.
+ * interp/database.boot (genericInstanceForm): New.
+ * interp/buildom.boot (parentsOfBuiltinInstance): New.
+ (builtinInstanceForm): Likewise.
+ * interp/br-data.boot (genericParentsOf): New.
+ (parentsOfForm): Use it,
+ (ancestorsRecur): Likewise.
+ * interp/br-con.boot (originInOrder): Use parentsOfForm.
+
+2012-02-12 Gabriel Dos Reis <gdr@cs.tamu.edu>
* interp/define.boot (getCatAncestors): Remove. Adjust caller.
(depthAssoc): Tidy.
diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot
index 61c27086..be5f8a94 100644
--- a/src/interp/br-con.boot
+++ b/src/interp/br-con.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -789,7 +789,7 @@ originsInOrder conform == --domain = nil or set to live domain
[con,:argl] := conform
getConstructorKindFromDB con = "category" =>
ASSOCLEFT ancestorsOf(conform,nil)
- acc := ASSOCLEFT parentsOf con
+ acc := ASSOCLEFT parentsOfForm conform
for x in acc repeat
for y in originsInOrder x repeat acc := insert(y,acc)
acc
diff --git a/src/interp/br-data.boot b/src/interp/br-data.boot
index 26ca4f08..7a6f1485 100644
--- a/src/interp/br-data.boot
+++ b/src/interp/br-data.boot
@@ -504,8 +504,13 @@ parentsOf con == --called by kcpPage, ancestorsRecur
tableValue($parentsCache,con) := parents
parents
-parentsOfForm [op,:argl] ==
- parents := parentsOf op
+++ Like `parentsOf', except that also handles builtin constructors.
+genericParentsOf form ==
+ builtinConstructor? form.op => parentsOfBuiltinInstance form
+ parentsOf form.op
+
+parentsOfForm(form is [op,:argl]) ==
+ parents := genericParentsOf form
argl = nil or argl = (newArgl := getConstructorFormFromDB(op).args) =>
parents
applySubst(pairList(newArgl,argl),parents)
@@ -563,8 +568,8 @@ ancestorsRecur(conform,domform,pred,firstTime?) == --called by ancestorsOf
pred = tableValue($done,conform) => nil --skip if already processed
parents :=
firstTime? => dbPrincipals constructorDB op
- parentsOf op
- originalConform := getConstructorForm op
+ genericParentsOf conform
+ originalConform := genericInstanceForm conform
if conform ~= originalConform then
parents := applySubst(pairList(originalConform.args,conform.args),parents)
for [newform,:p] in parents repeat
diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot
index 5d662bb7..1acc3560 100644
--- a/src/interp/buildom.boot
+++ b/src/interp/buildom.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -422,7 +422,7 @@ UnionEqual(x, y, dom) ==
["Union",:branches] := canonicalForm dom
predlist := mkPredList branches
same := false
- for b in stripUnionTags branches for p in predlist while not same repeat
+ for b in stripTags branches for p in predlist while not same repeat
typeFun := eval ['%lambda,'(_#1),p]
FUNCALL(typeFun,x) and FUNCALL(typeFun,y) =>
string? b => same := (x = y)
@@ -437,7 +437,7 @@ coerceUn2E(x,source) ==
["Union",:branches] := source
predlist := mkPredList branches
byGeorge := byJane := gensym()
- for b in stripUnionTags branches for p in predlist repeat
+ for b in stripTags branches for p in predlist repeat
typeFun := eval ['%lambda,'(_#1),p]
if FUNCALL(typeFun,x) then return
if p is ['%ieq,['%head,.],:.] then x := rest x
@@ -687,6 +687,36 @@ mkUnionFunList(op,form is ["Union",:listOfEntries],e) ==
[cList,e]
--%
+
+parentsOfBuiltinInstance form ==
+ [op,:args] := form
+ -- builtin categories
+ op in '(RecordCategory UnionCategory) =>
+ [[$SetCategory,:['AND,:[['has,t,$SetCategory] for t in stripTags args]]]]
+ op is 'MappingCategory => nil -- [[$Type,:true]]
+ op is 'EnumerationCategory => [[$SetCategory,:true]]
+ -- builtin domains
+ op is 'Mapping => [['MappingCategory,:args],:true]
+ op is 'Record => [['RecordCategory,:args],:true]
+ op is 'Union => [['UnionCategory,:args],:true]
+ op is 'Enumeration => [['EnumerationCategory,:args],:true]
+ nil
+
+$CapitalLetters ==
+ '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)
+
+builtinInstanceForm form ==
+ [op,:args] := form
+ op in '(Mapping MappingCategory Enumeration EnumerationCategory) =>
+ [op,:take(#args,$CapitalLetters)]
+ op in '(Record RecordCategory Union UnionCategory) =>
+ [op,:[T for a in args for t in $CapitalLetters]] where
+ T() ==
+ a is [":",x,.] => [":",x,t]
+ t
+ nil
+
+--%
for x in '((Record mkRecordFunList)
(Union mkUnionFunList)
(Mapping mkMappingFunList)
diff --git a/src/interp/category.boot b/src/interp/category.boot
index c5289d51..cdacc6b4 100644
--- a/src/interp/category.boot
+++ b/src/interp/category.boot
@@ -95,7 +95,7 @@ mkCategory(domainOrPackage,sigList,attList,domList,principal) ==
string? v => nil
v isnt [.,:.] => [v]
v.op is 'Union =>
- "union"/[Prepare2 x for x in stripUnionTags v.args]
+ "union"/[Prepare2 x for x in stripTags v.args]
v.op is 'Mapping => "union"/[Prepare2 x for x in v.args]
v.op is 'Record => "union"/[Prepare2 third x for x in v.args]
v.op is 'Enumeration => nil
diff --git a/src/interp/database.boot b/src/interp/database.boot
index 278630d9..943b635f 100644
--- a/src/interp/database.boot
+++ b/src/interp/database.boot
@@ -88,6 +88,14 @@ getConstructorFormFromDB: %Constructor -> %Form
getConstructorFormFromDB ctor ==
GETDATABASE(ctor,"CONSTRUCTORFORM")
+++ Return the generic instantiation form of a constructor,
+++ where the arguments are the parameters used in its
+++ original definition. Builtin constructors are also handled.
+genericInstanceForm form ==
+ [op,:args] := form
+ builtinConstructor? op => builtinInstanceForm form
+ getConstructorFormFromDB op
+
getConstructorSourceFileFromDB: %Constructor -> %Maybe %String
getConstructorSourceFileFromDB ctor ==
GETDATABASE(ctor,"SOURCEFILE")
diff --git a/src/interp/define.boot b/src/interp/define.boot
index c2264f37..495a9cc9 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -1953,7 +1953,7 @@ augModemapsFromDomain(name,functorForm,e) ==
listMember?(name,getDomainsInScope e) => e
if super := superType functorForm then
e := addNewDomain(super,e)
- if name is ["Union",:dl] then for d in stripUnionTags dl
+ if name is ["Union",:dl] then for d in stripTags dl
repeat e:= addDomain(d,e)
augModemapsFromDomain1(name,functorForm,e)
diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index bceb53b9..2d921148 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -545,7 +545,7 @@ TruthP x ==
--% Record and Union utils.
-stripUnionTags doms ==
+stripTags doms ==
[if dom is [":",.,dom'] then dom' else dom for dom in doms]
isTaggedUnion u ==
diff --git a/src/interp/i-coerce.boot b/src/interp/i-coerce.boot
index c668f46a..dc951db6 100644
--- a/src/interp/i-coerce.boot
+++ b/src/interp/i-coerce.boot
@@ -971,7 +971,7 @@ thisUnionBranch?(pred,val) ==
coerceUnion2Branch(object) ==
[.,:doms] := objMode object
predList:= mkPredList doms
- doms := stripUnionTags doms
+ doms := stripTags doms
val' := objValUnwrap object
predicate := nil
targetType:= nil
@@ -987,7 +987,7 @@ coerceBranch2Union(object,union) ==
-- assumes type is a member of doms
doms := rest union
predList:= mkPredList doms
- doms := stripUnionTags doms
+ doms := stripTags doms
p := position(objMode object,doms)
p = -1 => keyedSystemError("S2IC0014",[objMode object,union])
val := objVal object
@@ -998,7 +998,7 @@ coerceBranch2Union(object,union) ==
coerceInt2Union(object,union) ==
-- coerces to a Union type, adding numeric tags
-- first cut
- unionDoms := stripUnionTags rest union
+ unionDoms := stripTags rest union
t1 := objMode object
member(t1,unionDoms) => coerceBranch2Union(object,union)
val := objVal object