* 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.

8 files changed, 59 insertions, 16 deletions

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