From 722618d8f5ca5ba86289bb0e1a6e3b427ab0262f Mon Sep 17 00:00:00 2001 From: dos-reis Date: Mon, 13 Feb 2012 06:26:42 +0000 Subject: * 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. --- src/ChangeLog | 14 +++++++++++++- src/interp/br-con.boot | 4 ++-- src/interp/br-data.boot | 13 +++++++++---- src/interp/buildom.boot | 36 +++++++++++++++++++++++++++++++++--- src/interp/category.boot | 2 +- src/interp/database.boot | 8 ++++++++ src/interp/define.boot | 2 +- src/interp/g-util.boot | 4 ++-- src/interp/i-coerce.boot | 6 +++--- 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 +2012-02-13 Gabriel Dos Reis + + * 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 * 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 @@ -686,6 +686,36 @@ mkUnionFunList(op,form is ["Union",:listOfEntries],e) == cList:= substitute(dollarIfRepHack op,g,cList) [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) 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 -- cgit v1.2.3