diff --git a/su4sml/src/ROOT.ML b/su4sml/src/ROOT.ML index ad7f9ef..2d64a17 100644 --- a/su4sml/src/ROOT.ML +++ b/su4sml/src/ROOT.ML @@ -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"; diff --git a/su4sml/src/codegen/ROOT.ML b/su4sml/src/codegen/ROOT.ML index c00aeef..f689279 100644 --- a/su4sml/src/codegen/ROOT.ML +++ b/su4sml/src/codegen/ROOT.ML @@ -40,7 +40,7 @@ (* $Id$ *) use "gcg_helper.sml"; -use "stringHandling.sml"; +use "../stringHandling.sml"; use "tpl_parser.sml"; diff --git a/su4sml/src/library.sml b/su4sml/src/library.sml index b35d465..b2fd0fc 100644 --- a/su4sml/src/library.sml +++ b/su4sml/src/library.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 *) diff --git a/su4sml/src/ocl_parser/library.sml b/su4sml/src/ocl_parser/library.sml index 9b4ba81..f4466cf 100644 --- a/su4sml/src/ocl_parser/library.sml +++ b/su4sml/src/ocl_parser/library.sml @@ -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 *) diff --git a/su4sml/src/rep_core.sml b/su4sml/src/rep_core.sml index 57db938..e1991fc 100644 --- a/su4sml/src/rep_core.sml +++ b/su4sml/src/rep_core.sml @@ -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 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") diff --git a/su4sml/src/rep_parser.sml b/su4sml/src/rep_parser.sml index be9c71c..48fb84b 100644 --- a/su4sml/src/rep_parser.sml +++ b/su4sml/src/rep_parser.sml @@ -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 diff --git a/su4sml/src/secure_uml.sml b/su4sml/src/secure_uml.sml index f4f753a..f0bf67f 100644 --- a/su4sml/src/secure_uml.sml +++ b/su4sml/src/secure_uml.sml @@ -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"; diff --git a/su4sml/src/test-suite.sml b/su4sml/src/test-suite.sml index fe77de3..fcf1e00 100644 --- a/su4sml/src/test-suite.sml +++ b/su4sml/src/test-suite.sml @@ -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" diff --git a/su4sml/src/xmi_idtable.sml b/su4sml/src/xmi_idtable.sml index f120e10..08d4eb7 100644 --- a/su4sml/src/xmi_idtable.sml +++ b/su4sml/src/xmi_idtable.sml @@ -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