- Only the SimpleChair test-case fails
- fixed ROOT.ML for PolyML.make - reflexive associations git-svn-id: https://projects.brucker.ch/su4sml/svn/su4sml/trunk@6954 3260e6d1-4efc-4170-b0a7-36055960796d
This commit is contained in:
Martin Bill
parent
cdebaa07a5
commit
0441c6a197
|
|
@ -40,7 +40,7 @@
|
|||
(* $Id$ *)
|
||||
|
||||
use "library.sml";
|
||||
|
||||
use "stringHandling.sml";
|
||||
|
||||
(* ****************************************************** *)
|
||||
(* Load the (foreign) fxp-module providing
|
||||
|
|
@ -53,9 +53,9 @@ OS.FileSys.chDir "compiler";
|
|||
|
||||
use "compiler_ext.sig";
|
||||
|
||||
val ml_system = getOpt (OS.Process.getEnv "ML_SYSTEM", "polyml")
|
||||
val ml_system = getOpt (OS.Process.getEnv "ML_SYSTEM", "poly")
|
||||
|
||||
val use_wrapper = if (String.isSubstring "polyml" ml_system)
|
||||
val use_wrapper = if (String.isSubstring "poly" ml_system)
|
||||
then (use "../contrib/HashTable.sml"; "polyml.sml")
|
||||
else "smlnj.sml";
|
||||
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@
|
|||
(* $Id$ *)
|
||||
|
||||
use "gcg_helper.sml";
|
||||
use "stringHandling.sml";
|
||||
use "../stringHandling.sml";
|
||||
|
||||
use "tpl_parser.sml";
|
||||
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ fun (x |> f) = f x;
|
|||
|
||||
|
||||
(* minimal tracing support (modifed version of ocl_parser tracing *)
|
||||
val log_level = ref 5
|
||||
val log_level = ref 6
|
||||
fun trace lev s = if (lev <= !log_level ) then print(s) else ()
|
||||
|
||||
(* debugging-levels *)
|
||||
|
|
|
|||
|
|
@ -93,6 +93,7 @@ sig
|
|||
val trace : int -> string -> unit
|
||||
val log_level : int ref
|
||||
val function_calls : int
|
||||
val function_arguments : int
|
||||
val zero : int
|
||||
val high : int
|
||||
val medium : int
|
||||
|
|
@ -131,10 +132,11 @@ exception NoSuchOperationError of string
|
|||
|
||||
(* Error logging *)
|
||||
(* default value *)
|
||||
val log_level = ref 200
|
||||
val log_level = ref 6
|
||||
|
||||
(* debugging-levels *)
|
||||
val function_calls = 5
|
||||
val function_arguments = 6
|
||||
val zero = 0
|
||||
val high = 10
|
||||
val medium = 20
|
||||
|
|
@ -188,6 +190,7 @@ fun find_operation op_name [] = raise NoSuchOperationError ("no such operation")
|
|||
(* RETURN: attribute *)
|
||||
fun find_attribute attr_name [] =
|
||||
let
|
||||
val _ = trace function_calls "find_attribute\n"
|
||||
val _ = trace low ("Error ... " ^ "\n")
|
||||
in
|
||||
raise (NoSuchAttributeError ("Error: no attribute '"^attr_name^" found"))
|
||||
|
|
@ -195,12 +198,14 @@ fun find_attribute attr_name [] =
|
|||
| find_attribute attr_name ((a:attribute)::attribute_list) =
|
||||
if (attr_name = #name a) then
|
||||
let
|
||||
val _ = trace function_calls "find_attribute\n"
|
||||
val _ = trace low ("Attribute found ... " ^ "\n")
|
||||
in
|
||||
(a)
|
||||
end
|
||||
else
|
||||
let
|
||||
val _ = trace function_calls "find_attribute\n"
|
||||
val _ = trace low ("Attribute not found ... " ^ "\n")
|
||||
in
|
||||
(find_attribute attr_name attribute_list)
|
||||
|
|
@ -945,21 +950,40 @@ fun get_overloaded_methods class op_name ([],_) = raise NoModelReferenced ("in '
|
|||
fun get_overloaded_attrs_or_assocends class attr_name ([],_) = raise NoModelReferenced ("in 'get_overloaded_attrs' ... \n")
|
||||
| get_overloaded_attrs_or_assocends class attr_name (model as (classifiers,associations)) =
|
||||
let
|
||||
val _ = trace function_calls ("get_overloaded_attrs_or_assocends\n")
|
||||
val _ = trace low ("attrs\n")
|
||||
val _ = trace function_calls ("\nget_overloaded_attrs_or_assocends\n")
|
||||
val _ = trace function_arguments ("class: "^(string_of_path (name_of class))^"\n")
|
||||
val _ = trace function_arguments ("attr_name: "^attr_name^"\n")
|
||||
val _ = trace function_arguments ("class's associations:\n")
|
||||
val _ = map (trace function_arguments o
|
||||
(fn name => string_of_path name ^ "\n")) (associations_of class)
|
||||
val _ = trace function_arguments ("class's attributes:\n")
|
||||
val _ = map (trace function_arguments o
|
||||
(fn {name,...} => name ^ "\n")) (attributes_of class)
|
||||
val _ = trace function_arguments ("class's operations:\n")
|
||||
val _ = map (trace function_arguments o
|
||||
(fn {name,...} => name ^ "\n")) (operations_of class)
|
||||
val _ = trace function_arguments ("associations:\n")
|
||||
val _ = map (trace function_arguments o
|
||||
(fn {name,...} => string_of_path name ^"\n")) associations
|
||||
val attrs = attributes_of class
|
||||
val _ = trace low ("assocends\n")
|
||||
val _ = trace low ("sizes: "^(Int.toString (List.length classifiers))^", "^
|
||||
(Int.toString( List.length associations))^"\n")
|
||||
val _ = print "attrs: \n"
|
||||
val _ = map (print o (fn {name,...} => name^"\n")) attrs
|
||||
val assocends = associationends_of associations class
|
||||
val _ = trace low ("assocends:\n")
|
||||
val _ = trace low ("sizes: "^(Int.toString (List.length attrs))^", "^
|
||||
(Int.toString( List.length assocends))^"\n")
|
||||
val _ = trace low ("Look for attributes/assocends : Class: " ^ string_of_OclType (type_of class) ^ " \n")
|
||||
val attrs2 = List.filter (fn a => (if ((#name a) = attr_name) then true else false)) attrs
|
||||
val assocends2 = List.filter (fn {name,...} => (List.last name)=attr_name) assocends
|
||||
val _ = trace low ("Name of attr/assocend : " ^ attr_name ^ " Found " ^ Int.toString (List.length attrs2) ^ " attribute(s), " ^ Int.toString (List.length assocends2) ^ " assocend(s) \n")
|
||||
val _ = trace low ("Name of attr/assocend : " ^ attr_name ^ " Found " ^ Int.toString (List.length attrs2) ^
|
||||
" attribute(s), " ^ Int.toString (List.length assocends2) ^ " assocend(s) \n")
|
||||
val parent = class_of_parent class classifiers
|
||||
val _ = trace low ("Parent class : " ^ string_of_OclType(type_of parent) ^ "\n\n")
|
||||
val _ = trace low ("Size of attrs2: "^(Int.toString (List.length attrs2))^"\n")
|
||||
val _ = trace low ("Size of assocends2: "^(Int.toString (List.length assocends2))^"\n")
|
||||
val cl_at = List.map (fn a => (class,SOME(a),NONE)) attrs2
|
||||
val cl_as = List.map (fn a => (class,NONE,SOME(a))) assocends2
|
||||
val _ = trace low ("search done\n")
|
||||
in
|
||||
if (class = class_of_type OclAny classifiers) then
|
||||
(* end of hierarchie *)
|
||||
|
|
|
|||
|
|
@ -166,8 +166,7 @@ val parent_interfaces_of : Classifier -> Rep_OclType.OclType list
|
|||
val thy_name_of : Classifier -> string
|
||||
val attributes_of : Classifier -> attribute list
|
||||
val associationends_of: association list -> Classifier -> associationend list
|
||||
(* FIXME: dummy workaround for ocl_parser compile error *)
|
||||
(*val associationends_of_old: Classifier -> associationend list *)
|
||||
val associations_of : Classifier -> Rep_OclType.Path list
|
||||
|
||||
val operations_of : Classifier -> operation list
|
||||
val invariant_of : Classifier -> (string option * Rep_OclTerm.OclTerm) list
|
||||
|
|
@ -189,8 +188,6 @@ val parents_of : Classifier -> Classifier list -> Rep_OclType.Path list
|
|||
val operation_of : Classifier list -> Rep_OclType.Path -> operation option
|
||||
val topsort_cl : Classifier list -> Classifier list
|
||||
val connected_classifiers_of : association list -> Classifier -> Classifier list -> Classifier list
|
||||
(* FIXME: dummy workaround for compile error *)
|
||||
val connected_classifiers_of_old : Classifier -> Classifier list -> Classifier list
|
||||
|
||||
(* billk_tag *)
|
||||
(* changed assoc to aend, since associations are now part of the model *)
|
||||
|
|
@ -339,13 +336,8 @@ fun assoc_to_attr (assoc:associationend) = {name = #name assoc,
|
|||
init = #init assoc}
|
||||
*)
|
||||
|
||||
(** dummy *)
|
||||
fun associationends_of_old cls:associationend list = []
|
||||
fun connected_classifiers_of_old cls cls_list:Classifier list = cls_list
|
||||
|
||||
|
||||
fun aend_to_attr (cls_name:string) (aend:associationend):attribute =
|
||||
{name = cls_name ^ List.last (#name aend),
|
||||
{name = List.last (#name aend),
|
||||
attr_type = aend_to_attr_type aend,
|
||||
visibility = #visibility aend,
|
||||
scope = XMI.InstanceScope,
|
||||
|
|
@ -353,7 +345,6 @@ fun aend_to_attr (cls_name:string) (aend:associationend):attribute =
|
|||
init = #init aend}
|
||||
|
||||
|
||||
|
||||
(* convert a multiplicity range into an invariant of the form *)
|
||||
(* size > lowerBound and size < upperBound ) *)
|
||||
fun range_to_inv cls_name aend (a,b) =
|
||||
|
|
@ -423,31 +414,40 @@ fun aend_to_inv cls_name (aend:associationend) =
|
|||
else (SOME inv_name, foldr1 ocl_or range_constraints)
|
||||
end
|
||||
|
||||
fun associations_of (Class{name,associations,...}) = associations
|
||||
| associations_of (AssociationClass{name,associations,association,...}) = associations
|
||||
| associations_of (Primitive{name,associations,...}) = associations
|
||||
|
||||
(* find all association ends, excluding of self_type *)
|
||||
fun association_to_associationends (associations:association list) (self_type:OclType) (assoc:Path):associationend list=
|
||||
let
|
||||
val _ = trace function_calls "association_to_associationends\n"
|
||||
val association = filter (fn {name,...} => name=assoc ) associations
|
||||
val aends = if (List.length association) > 1
|
||||
val _ = trace function_arguments ("assoc: "^(string_of_path assoc)^"\n")
|
||||
val (association::rest) = filter (fn {name,...} => name=assoc ) associations
|
||||
val aends = if rest <> []
|
||||
then
|
||||
error ("in association_to_associationends: non-unique association name: "^
|
||||
(string_of_path assoc))
|
||||
else
|
||||
#aends (hd association)
|
||||
val aends_filtered = List.filter (fn {aend_type,...} => aend_type <> self_type) aends
|
||||
val _ = if (List.length aends_filtered) >1
|
||||
#aends association
|
||||
val (aendsFiltered,aendsSelf) = List.partition (fn {aend_type,...} =>
|
||||
aend_type <> self_type) aends
|
||||
val aendsFiltered = if List.length aendsSelf > 1 then aendsFiltered@aendsSelf (* reflexiv *)
|
||||
else aendsFiltered
|
||||
val _ = if (List.length aendsFiltered) >1
|
||||
then
|
||||
print "association_to_associationends: aends found\n"
|
||||
else
|
||||
print "association_to_associationends: no aends found\n"
|
||||
in
|
||||
aends_filtered
|
||||
aendsFiltered
|
||||
end
|
||||
|
||||
(** find the associationends belonging to a classifier.
|
||||
* This mean all other associationends from all associations the
|
||||
* classifer is part of.
|
||||
* classifer is part of. For association classes, the belonging
|
||||
* association also needs to be checked.
|
||||
* If the association is reflexiv, all aends will be returned.
|
||||
*)
|
||||
fun associationends_of (all_associations:association list) (Class{name,associations,...}):associationend list =
|
||||
List.concat (map (association_to_associationends all_associations name) associations)
|
||||
|
|
@ -459,52 +459,67 @@ fun associationends_of (all_associations:association list) (Class{name,associati
|
|||
| associationends_of _ _ = error ("in associationends_of: This classifier has no associationends") (*FIXME: or rather []? *)
|
||||
|
||||
|
||||
(** convert association ends into attributes + invariants *)
|
||||
(** convert association ends into attributes + invariants
|
||||
* Associations belonging to an association class have not been modified to
|
||||
* include an additional aend to the association class.
|
||||
*)
|
||||
fun normalize (all_associations:association list) (C as (Class {name,parent,attributes,operations,associations,invariant,
|
||||
stereotypes,interfaces,thyname,activity_graphs})):Classifier=
|
||||
Class {name = name,
|
||||
parent = parent,
|
||||
attributes = (append (map (aend_to_attr (string_of_path (path_of_OclType name)))
|
||||
(associationends_of all_associations C)) attributes),
|
||||
operations = operations,
|
||||
associations = nil,
|
||||
invariant = append (map (aend_to_inv (path_of_OclType name)) (associationends_of all_associations C))
|
||||
invariant,
|
||||
stereotypes = stereotypes,
|
||||
interfaces = interfaces,
|
||||
thyname = thyname,
|
||||
activity_graphs=activity_graphs}
|
||||
stereotypes,interfaces,thyname,activity_graphs})):Classifier =
|
||||
let
|
||||
val _ = trace function_calls "normalize: class\n"
|
||||
val _ = trace function_arguments ("number of associations: " ^ (Int.toString (List.length associations )) ^ "\n")
|
||||
in
|
||||
Class {name = name,
|
||||
parent = parent (*,
|
||||
attributes = (append (map (aend_to_attr (string_of_path (path_of_OclType name)))
|
||||
(associationends_of all_associations C)) attributes)*),
|
||||
attributes = (append (map (aend_to_attr (List.last (path_of_OclType name)))
|
||||
(associationends_of all_associations C)) attributes),
|
||||
operations = operations,
|
||||
associations = nil,
|
||||
invariant = append (map (aend_to_inv (path_of_OclType name)) (associationends_of all_associations C))
|
||||
invariant,
|
||||
stereotypes = stereotypes,
|
||||
interfaces = interfaces,
|
||||
thyname = thyname,
|
||||
activity_graphs = activity_graphs}
|
||||
end
|
||||
| normalize all_associations (AC as (AssociationClass {name,parent,attributes,association,associations,operations,invariant,
|
||||
stereotypes,interfaces,thyname,activity_graphs})) =
|
||||
stereotypes,interfaces,thyname,activity_graphs})) =
|
||||
(* FIXME: how to handle AssociationClass.association? *)
|
||||
AssociationClass {name = name,
|
||||
parent = parent,
|
||||
attributes = append (map (aend_to_attr (string_of_path (path_of_OclType name)))
|
||||
(associationends_of all_associations AC)) attributes,
|
||||
operations = operations,
|
||||
invariant = append (map (aend_to_inv (path_of_OclType name)) (associationends_of all_associations AC))
|
||||
invariant,
|
||||
stereotypes = stereotypes,
|
||||
interfaces = interfaces,
|
||||
thyname = thyname,
|
||||
activity_graphs = activity_graphs,
|
||||
associations = [],
|
||||
association = association (* FIXME? *)}
|
||||
let
|
||||
val _ = trace function_calls "normalize: associationclass\n"
|
||||
val _ = trace function_arguments ("number of associations: " ^ (Int.toString (List.length associations )) ^ "\n")
|
||||
in
|
||||
AssociationClass {name = name,
|
||||
parent = parent,
|
||||
attributes = append (map (aend_to_attr (List.last (path_of_OclType name)))
|
||||
(associationends_of all_associations AC)) attributes,
|
||||
operations = operations,
|
||||
invariant = append (map (aend_to_inv (path_of_OclType name)) (associationends_of all_associations AC))
|
||||
invariant,
|
||||
stereotypes = stereotypes,
|
||||
interfaces = interfaces,
|
||||
thyname = thyname,
|
||||
activity_graphs = activity_graphs,
|
||||
associations = [],
|
||||
association = [] (* FIXME? *)}
|
||||
end
|
||||
| normalize all_associations (Primitive p) =
|
||||
(* Primitive's do not have attributes, so we have to convert *)
|
||||
(* them into Classes... *)
|
||||
if (#associations p) = []
|
||||
then Primitive p
|
||||
else normalize all_associations (Class {name = #name p, parent = #parent p, attributes=[],
|
||||
operations = #operations p, invariant = #invariant p,
|
||||
operations = #operations p, invariant = #invariant p,
|
||||
associations = #associations p,
|
||||
stereotypes = #stereotypes p,
|
||||
interfaces = #interfaces p,
|
||||
thyname = #thyname p,
|
||||
activity_graphs=nil})
|
||||
stereotypes = #stereotypes p,
|
||||
interfaces = #interfaces p,
|
||||
thyname = #thyname p,
|
||||
activity_graphs=nil})
|
||||
| normalize all_associations c = c
|
||||
|
||||
|
||||
|
||||
|
||||
fun rm_init_attr (attr:attribute) = {
|
||||
name = #name attr,
|
||||
attr_type = #attr_type attr,
|
||||
|
|
@ -570,8 +585,8 @@ fun normalize_init (Class {name,parent,attributes,operations,associations,invari
|
|||
activity_graphs=activity_graphs}
|
||||
| normalize_init c = c
|
||||
|
||||
fun normalize_ext ((all_classifiers,all_associations):transform_model):transform_model =
|
||||
(map (normalize all_associations) all_classifiers, all_associations)
|
||||
fun normalize_ext ((classifiers,associations):transform_model):transform_model =
|
||||
(map (normalize associations) classifiers, associations)
|
||||
|
||||
val OclAnyC = Class{name=Rep_OclType.OclAny,parent=NONE,attributes=[],
|
||||
operations=[], interfaces=[],
|
||||
|
|
@ -817,16 +832,6 @@ fun attributes_of (Class{attributes,...}) = attributes
|
|||
(* error "attributes_of <Primitive> not supported" *)
|
||||
| attributes_of (Template{parameter,classifier}) = attributes_of classifier
|
||||
|
||||
(* needed further up -> moved to the beginning
|
||||
fun associationends_of (Class{associations,...}):associationend list=
|
||||
map association_to_associationend associations
|
||||
| associationends_of (AssociationClass{associations,association,...}) =
|
||||
(* association only contains endpoints to the other, pure clases *)
|
||||
map association_to_associationend (association::associations)
|
||||
| associationends_of (Primitive{associations,...}) =
|
||||
map association_to_associationend associations
|
||||
*)
|
||||
|
||||
fun operations_of (Class{operations,...}) = operations
|
||||
| operations_of (AssociationClass{operations,...}) = operations
|
||||
| operations_of (Interface{operations,...}) = operations
|
||||
|
|
@ -899,11 +904,6 @@ fun thy_name_of (C as Class{thyname,...}) =
|
|||
\unsupported argument type Template"
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
fun class_of (name:Path) (cl:Classifier list):Classifier = hd (filter (fn a => if ((name_of a) = name)
|
||||
then true else false ) cl )
|
||||
handle _ => error ("class_of: class "^(string_of_path name)^" not found!\n")
|
||||
|
|
|
|||
|
|
@ -273,7 +273,7 @@ fun transform_attribute t ({xmiid,name,type_id,changeability,visibility,ordering
|
|||
"', defaulting to OclVoid");
|
||||
Rep_OclType.OclVoid)
|
||||
in
|
||||
{name= name,
|
||||
{name = name,
|
||||
attr_type = if multiplicity = [(1,1)]
|
||||
then cls_type
|
||||
else if ordering = XMI.Ordered then Rep_OclType.Sequence cls_type
|
||||
|
|
@ -405,7 +405,9 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
|
|||
state_machines}) =
|
||||
let
|
||||
val _ = trace function_calls "transform_classifier: Class\n"
|
||||
val _ = trace function_arguments ("class name: "^ name ^"\n")
|
||||
val assocs = find_classifier_associations t xmiid
|
||||
val _ = trace high ("number of associations added: "^(Int.toString (List.length assocs))^"\n")
|
||||
val parents = map ((find_classifier_type t) o (find_parent t))
|
||||
generalizations
|
||||
val filtered_parents = filter (fn x => x <> Rep_OclType.OclAny) parents
|
||||
|
|
@ -444,7 +446,10 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
|
|||
supplierDependency,taggedValue}) =
|
||||
let
|
||||
val _ = trace function_calls "transform_classifier: AssociationClass\n"
|
||||
val _ = trace function_arguments ("associationclass name: "^ name ^"\n")
|
||||
val (_,assocs,assoc,_,_) = find_classifier_entries t xmiid
|
||||
val _ = trace high ("number of associations added: "^(Int.toString (List.length assocs))^"\n")
|
||||
val _ = trace high ("ac association found: "^(Bool.toString (assoc <> []))^"\n")
|
||||
val _ = print "associations retrieved\n"
|
||||
val parents = map ((find_classifier_type t) o (find_parent t))
|
||||
generalizations
|
||||
|
|
@ -475,7 +480,9 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
|
|||
| transform_classifier t (XMI.Primitive {xmiid,name,generalizations,operations,invariant,taggedValue}) =
|
||||
let
|
||||
val _ = trace function_calls "transform_classifier: Primitive\n"
|
||||
val (_,assocs,assoc,_,_) = find_classifier_entries t xmiid
|
||||
val _ = trace function_arguments ("primitive name: "^ name ^"\n")
|
||||
val (_,assocs,_,_,_) = find_classifier_entries t xmiid
|
||||
val _ = trace high ("number of associations added: "^(Int.toString (List.length assocs))^"\n")
|
||||
val checked_invariants = filter_exists t invariant
|
||||
in
|
||||
Rep.Primitive {name = (* case *) find_classifier_type t xmiid (*of Rep_OclType.Classifier x => x
|
||||
|
|
@ -549,8 +556,8 @@ fun transformAssociationFromAssociationClass t (XMI.AssociationClass ac) =
|
|||
val connection = #connection ac
|
||||
val id = xmiid^"_association"
|
||||
val association_path = find_association_path t id
|
||||
val _ = print ("transform_association path: "^(string_of_path association_path) ^"\n")
|
||||
val _ = print ("transform_association path length: "^(Int.toString (List.length association_path)) ^"\n")
|
||||
val _ = trace low ("transform_association path: "^(string_of_path association_path) ^"\n")
|
||||
val _ = trace low ("transform_association path length: "^(Int.toString (List.length association_path)) ^"\n")
|
||||
val association_ends = map (transform_aend t association_path) connection
|
||||
val aClass = SOME (path_of_OclType (find_classifier_type t xmiid))
|
||||
in
|
||||
|
|
@ -783,17 +790,31 @@ fun transformXMI_ext ({classifiers,constraints,packages,
|
|||
val _ = map (print o (fn x => x^"\n") o string_of_path o name_of) classifiers
|
||||
val _ = print "associations\n"
|
||||
val _ = map (print o (fn x => x^"\n") o string_of_path o (fn {name,aends,aclass} => name)) associations
|
||||
val _ = print "operations\n"
|
||||
fun printClassifier cls =
|
||||
let
|
||||
val _ = print ("output of transformXMI_ext:\n")
|
||||
val _ = print ("classifier: "^ (string_of_path (name_of cls)) ^"\n")
|
||||
|
||||
val _ = print ("associations: \n")
|
||||
val _ = map (print o(fn x => x ^ "\n") o string_of_path ) (associations_of cls)
|
||||
|
||||
val _ = print ("operations: \n")
|
||||
val _ = map (print o (fn {name,...} => name)) (operations_of cls)
|
||||
in
|
||||
print "\n"
|
||||
end
|
||||
val _ = map printClassifier classifiers
|
||||
in
|
||||
trace function_calls "\n### transformXMI_ext done\n\n";
|
||||
(classifiers,associations)
|
||||
end
|
||||
|
||||
|
||||
in
|
||||
print "### transformXMI: populate hash table\n";
|
||||
trace function_calls "### transformXMI: populate hash table\n";
|
||||
insert_model xmiid_table model (* fill xmi.id table *);
|
||||
print "### transformXMI: fix associations\n";
|
||||
trace function_calls "### transformXMI: fix associations\n";
|
||||
fix_associations xmiid_table model (* handle associations *);
|
||||
print "### transformXMI: transform XMI into Rep";
|
||||
trace function_calls "### transformXMI: transform XMI into Rep\n";
|
||||
test2 (transform_package xmiid_table model) (* transform classifiers *)
|
||||
end
|
||||
|
||||
|
|
|
|||
|
|
@ -172,8 +172,8 @@ fun mkRole (C as Rep.Class c) = Rep.string_of_path (Rep.name_of C)
|
|||
(* FIXME: handle groups also *)
|
||||
fun mkSubject (C as Rep.Class c) = User (Rep.string_of_path (Rep.name_of C))
|
||||
| mkSubject _ = error ("in mkSubject: argument is not a class")
|
||||
fun mkPermission cs (c as Rep.Class _) =
|
||||
let val classifiers = (Rep.connected_classifiers_of_old c cs)
|
||||
fun mkPermission (cs,ascs) (c as Rep.Class _) =
|
||||
let val classifiers = (Rep.connected_classifiers_of ascs c cs)
|
||||
val role_classes = List.filter (classifier_has_stereotype "secuml.role")
|
||||
classifiers
|
||||
val root_classes = List.filter (fn x => ListEq.overlaps
|
||||
|
|
@ -201,12 +201,12 @@ fun mkPermission cs (c as Rep.Class _) =
|
|||
| mkPermission _ _ = error "in mkPermission: argument is not a class"
|
||||
|
||||
|
||||
fun mkSubjectAssignment cs (c as (Rep.Class _)) =
|
||||
fun mkSubjectAssignment (cs,ascs) (c as (Rep.Class _)) =
|
||||
let (* FIXME: we just take all roles that are connected to the subject. *)
|
||||
(* in principle, we should check the stereotype of the association, *)
|
||||
(* but that does not exist in the rep datastructure... *)
|
||||
val classifiers = List.filter (classifier_has_stereotype "secuml.role")
|
||||
(Rep.connected_classifiers_of_old c cs)
|
||||
(Rep.connected_classifiers_of ascs c cs)
|
||||
in
|
||||
(mkSubject c, map mkRole classifiers)
|
||||
end
|
||||
|
|
@ -369,13 +369,13 @@ fun parse (model as (cs,assocs):Rep.Model) =
|
|||
cs),
|
||||
*) (modified_classifiers,modified_assocs),
|
||||
{ config_type = "SecureUML",
|
||||
permissions = map (mkPermission cs) (filter_permission cs),
|
||||
permissions = map (mkPermission model) (filter_permission cs),
|
||||
subjects = map mkSubject (filter_subject cs),
|
||||
roles = map mkRole (filter_role cs),
|
||||
rh = map (fn x => (Rep.string_of_path (Rep.name_of x),
|
||||
Rep.string_of_path (Rep.parent_name_of x)))
|
||||
(List.filter classifier_has_parent (filter_role cs)),
|
||||
sa = map (mkSubjectAssignment cs) (filter_subject cs)})
|
||||
sa = map (mkSubjectAssignment model) (filter_subject cs)})
|
||||
end
|
||||
handle ex => (error_msg "in SecureUML.parse: security configuration \
|
||||
\could not be parsed";
|
||||
|
|
|
|||
|
|
@ -60,6 +60,7 @@ type testcase = {
|
|||
result : result
|
||||
}
|
||||
|
||||
exception TestSuiteException of string
|
||||
|
||||
val initResult = {
|
||||
parse = false,
|
||||
|
|
@ -146,26 +147,26 @@ fun test (tc:testcase) =
|
|||
handle _ => []
|
||||
val OclParse = if ocl = [] then false else true
|
||||
val (xmi,ocl) = ModelImport.removePackages (xmi,ocl) []
|
||||
handle _ => (([],[]),[])
|
||||
handle _ => (([],[]),[])
|
||||
|
||||
val _ = print "### Preprocess Context List ###\n"
|
||||
val fixed_ocl = Preprocessor.preprocess_context_list
|
||||
ocl ((OclLibrary.oclLib)@(#1 xmi))
|
||||
handle _ => []
|
||||
handle _ => []
|
||||
val OclPreprocess = if fixed_ocl = [] then false else true
|
||||
val _ = print "### Finished Preprocess Context List ###\n\n"
|
||||
|
||||
val _ = print "### Type Checking ###\n"
|
||||
val typed_cl = TypeChecker.check_context_list
|
||||
fixed_ocl (((OclLibrary.oclLib)@(#1 xmi)),#2 xmi)
|
||||
handle _ => []
|
||||
handle _ => []
|
||||
val OclTC = if typed_cl = [] then false else true
|
||||
val _ = print "### Finished Type Checking ###\n\n"
|
||||
|
||||
val _ = print"### Updating Classifier List ###\n"
|
||||
val model = Update_Model.gen_updated_classifier_list
|
||||
typed_cl ((OclLibrary.oclLib)@(#1 xmi))
|
||||
handle _ => []
|
||||
handle _ => []
|
||||
val modelUpdate = if model = [] then false else true
|
||||
val _ = print "### Finished Updating Classifier List ###\n"
|
||||
|
||||
|
|
|
|||
|
|
@ -323,6 +323,11 @@ fun find_association_path t xmiid =
|
|||
| _ => raise Option
|
||||
handle Option => error ("expected Association "^xmiid^" in table (in find_association_path)")
|
||||
|
||||
fun find_association_name t xmiid =
|
||||
case valOf (HashTable.find t xmiid) of (Association (_,{xmiid,name,connection})) => name
|
||||
| _ => raise Option
|
||||
handle Option => error ("expected Association "^xmiid^" in table (in find_association_name)")
|
||||
|
||||
fun insert_constraint table (c:XMI.Constraint) =
|
||||
HashTable.insert table (#xmiid c, Constraint c)
|
||||
|
||||
|
|
@ -388,13 +393,13 @@ fun insert_association table package_prefix (association:XMI.Association) =
|
|||
val _ = trace function_calls "insert_association\n"
|
||||
val id = #xmiid association
|
||||
val name = #name association
|
||||
val path = if (isSome name)
|
||||
then package_prefix@[valOf name]
|
||||
val path = if (isSome name) then package_prefix@[valOf name]
|
||||
else package_prefix@["association_"^(next_unique_name table)]
|
||||
in
|
||||
HashTable.insert table (id,Association(path,association))
|
||||
end
|
||||
|
||||
|
||||
(* billk_tag *)
|
||||
fun insert_classifier table package_prefix class =
|
||||
let val _ = trace function_calls "insert_classifier\n"
|
||||
|
|
@ -412,11 +417,21 @@ fun insert_classifier table package_prefix class =
|
|||
else if name = "Void" then Rep_OclType.OclVoid
|
||||
else if name = "OclAny" then Rep_OclType.OclAny
|
||||
(* now this is really ugly... *)
|
||||
else if String.isPrefix "Collection(" name then Rep_OclType.Collection (Rep_OclType.Classifier [XMI.classifier_elementtype_of class])
|
||||
else if String.isPrefix "Sequence(" name then Rep_OclType.Sequence (Rep_OclType.Classifier [XMI.classifier_elementtype_of class])
|
||||
else if String.isPrefix "Set(" name then Rep_OclType.Set (Rep_OclType.Classifier [XMI.classifier_elementtype_of class])
|
||||
else if String.isPrefix "Bag(" name then Rep_OclType.Bag (Rep_OclType.Classifier [XMI.classifier_elementtype_of class])
|
||||
else if String.isPrefix "OrderedSet(" name then Rep_OclType.OrderedSet (Rep_OclType.Classifier [XMI.classifier_elementtype_of class])
|
||||
else if String.isPrefix "Collection(" name
|
||||
then Rep_OclType.Collection (Rep_OclType.Classifier [
|
||||
XMI.classifier_elementtype_of class])
|
||||
else if String.isPrefix "Sequence(" name
|
||||
then Rep_OclType.Sequence (Rep_OclType.Classifier [
|
||||
XMI.classifier_elementtype_of class])
|
||||
else if String.isPrefix "Set(" name
|
||||
then Rep_OclType.Set (Rep_OclType.Classifier [
|
||||
XMI.classifier_elementtype_of class])
|
||||
else if String.isPrefix "Bag(" name
|
||||
then Rep_OclType.Bag (Rep_OclType.Classifier [
|
||||
XMI.classifier_elementtype_of class])
|
||||
else if String.isPrefix "OrderedSet(" name
|
||||
then Rep_OclType.OrderedSet (Rep_OclType.Classifier [
|
||||
XMI.classifier_elementtype_of class])
|
||||
else error ("didn't recognize ocltype "^name)
|
||||
else Rep_OclType.Classifier path
|
||||
(* This function is called before the associations are handled, *)
|
||||
|
|
@ -432,16 +447,9 @@ fun insert_classifier table package_prefix class =
|
|||
name = SOME acAssocName,
|
||||
connection = #connection c}:XMI.Association
|
||||
in
|
||||
(acAssoc,package_prefix @[acAssocName])
|
||||
end
|
||||
| _ =>
|
||||
let
|
||||
val dummy = {xmiid =id,
|
||||
name = NONE,
|
||||
connection = []}
|
||||
in
|
||||
(dummy,nil)
|
||||
([acAssoc],package_prefix @[acAssocName])
|
||||
end
|
||||
| _ => ([],[])
|
||||
val ag = nil
|
||||
in
|
||||
HashTable.insert table (id,Type (ocltype,assocs,acPath,class,ag));
|
||||
|
|
@ -463,7 +471,7 @@ fun insert_classifier table package_prefix class =
|
|||
List.app (insert_attribute table path) (#attributes c);
|
||||
List.app (insert_operation table path) (#operations c);
|
||||
List.app (insert_classifierInState table id) [];
|
||||
insert_association table package_prefix acAssoc;
|
||||
insert_association table package_prefix (hd acAssoc);
|
||||
()
|
||||
)
|
||||
| _ => ()
|
||||
|
|
@ -615,10 +623,12 @@ fun fix_associationend t (assoc_path:Rep_OclType.Path) (aend:XMI.AssociationEnd)
|
|||
end
|
||||
|
||||
(**
|
||||
* This handles only regular associations. An association classes belonging association is
|
||||
* handled at insert_classifier
|
||||
* Traverse the list of aends and update all listed classifiers with the path of the current
|
||||
* association.
|
||||
* This handles only regular associations. An association class's belonging
|
||||
* association is handled at insert_classifier. However, the normal classes
|
||||
* that part of that association class's association still need to add the
|
||||
* association to their list of associations.
|
||||
* Traverse the list of aends and update all listed classifiers with the path
|
||||
* of the current association.
|
||||
*)
|
||||
fun fix_association t (assoc as {xmiid,name,connection}:XMI.Association) =
|
||||
let
|
||||
|
|
@ -641,6 +651,13 @@ fun fix_association t (assoc as {xmiid,name,connection}:XMI.Association) =
|
|||
List.app (updateTableEntry t assocPath) participantIds
|
||||
end
|
||||
|
||||
fun fixAssociationFromAsssociationClass table (XMI.AssociationClass{xmiid,
|
||||
...}) =
|
||||
let
|
||||
val association = find_association table (xmiid ^ "_association")
|
||||
in
|
||||
fix_association table association
|
||||
end
|
||||
|
||||
(**
|
||||
* Handel the broken association references, meaning update the
|
||||
|
|
@ -651,16 +668,21 @@ fun fix_association t (assoc as {xmiid,name,connection}:XMI.Association) =
|
|||
* each association, we traverse the connection part and search for the
|
||||
* classifier listed as participant_id. Then we simply add the assoc-
|
||||
* iation path to the found classifier.
|
||||
* For the classifiers part of an association class's class, no association
|
||||
* construct is present in the package p, while those constructs are already
|
||||
* in the hashtable. To traverse them as well, we extract all association
|
||||
* classes and reconstruct the associations.
|
||||
*)
|
||||
fun fix_associations t (XMI.Package p)=
|
||||
let
|
||||
val associationclasses = filter (fn (XMI.AssociationClass x) => true
|
||||
val associationClasses = filter (fn (XMI.AssociationClass x) => true
|
||||
| _ => false) (#classifiers p)
|
||||
in
|
||||
(* All association ends are stored in associations, so we will
|
||||
* traverse them an update affected Classes and AssociationClasses *)
|
||||
(List.app (fix_associations t) (#packages p);
|
||||
List.app (fix_association t) (#associations p)
|
||||
List.app (fix_association t) (#associations p);
|
||||
List.app (fixAssociationFromAsssociationClass t) associationClasses
|
||||
)
|
||||
end
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue