First restructuring with including activity graphs.

git-svn-id: https://projects.brucker.ch/su4sml/svn/infsec-import/trunk/src/su4sml@3030 3260e6d1-4efc-4170-b0a7-36055960796d

src/ROOT.ML

@@ -25,20 +25,22 @@
 use "library.sml";
 open library;
 fun su4sml_home () = if (getenv "HOLOCL_HOME") <> ""
-                  then getenv "HOLOCL_HOME"
+                     then getenv "HOLOCL_HOME" else ".";
-		                    else ".";
 
 
 cd "../lib/fxp/src"; 
 use "ROOT.ML"; 
 cd "../../../src";
 
-use "ocl.sig";
+use "rep_ocl.sig";
-use "ocl.sml";
+use "rep_ocl.sml";
-use "mdr_core.sig";
+use "rep_state_machine.sig";
-use "mdr_core.sml";
+use "rep_state_machine.sml";
-use "state_machine.sig";
+use "rep_activity_graphs.sig";
-use "mdr.sig";
+use "rep_activity_graphs.sml";
+use "rep_core.sig";
+use "rep_core.sml";
+use "rep.sig";
 use "xmi_uml.sml";
 use "xmltree_parser.sml";
 use "parse_xmi.sml";

src/library.sml

@@ -52,7 +52,9 @@ fun getenv var =
       NONE => ""
         | SOME txt => txt);
 	                                
-
+fun print_depth n = 
+   (Control.Print.printDepth := n div 2;
+    Control.Print.printLength := n); 
 
 val cd = OS.FileSys.chDir;
 val pwd = OS.FileSys.getDir;

src/mdr_core.sig

@@ -49,7 +49,8 @@ datatype Classifier =
 	   invariant   : (string option * ocl_term.OclTerm) list,
 	   stereotypes : string list,
 	   interfaces  : ocl_type.Path list,
-	   thyname     : string option
+	   thyname     : string option,
+           activity_graphs : rep_ActivityGraph.ActivityGraph list
 	  }
        | Interface of               (* not supported yet *)
 	 { name        : ocl_type.Path,

src/mdr_core.sml

@@ -46,7 +46,8 @@ datatype Classifier =
 	   invariant   : (string option * ocl_term.OclTerm) list,
 	   stereotypes : string list,
 	   interfaces  : ocl_type.Path list,
-	   thyname     : string option
+	   thyname     : string option,
+           activity_graphs : rep_ActivityGraph.ActivityGraph list
 	  }
        | Interface of               (* not supported yet *)
 	 { name        : ocl_type.Path,
@@ -141,7 +142,7 @@ fun assoc_to_inv cls_name (aend:associationend) =
 	     
 (* convert association ends into attributes + invariants *)
 fun normalize (Class {name,parent,attributes,operations,associationends,invariant,
-		      stereotypes,interfaces,thyname}) =
+		      stereotypes,interfaces,thyname,activity_graphs}) =
 	       Class {name   = name,
 		      parent = parent,
 		      attributes = (append (map assoc_to_attr associationends) 
@@ -152,7 +153,8 @@ fun normalize (Class {name,parent,attributes,operations,associationends,invarian
 					  invariant,
 		      stereotypes = stereotypes,
                       interfaces = interfaces,
-                      thyname = thyname }
+		      thyname = thyname,
+                      activity_graphs=activity_graphs}
   | normalize (Primitive p) =
     (* Primitive's do not have attributes, so we have to convert *)
     (* them into Classes...                                      *)
@@ -163,13 +165,15 @@ fun normalize (Class {name,parent,attributes,operations,associationends,invarian
 			   associationends = #associationends p,
 			   stereotypes = #stereotypes p,
 			   interfaces = #interfaces p,
-			   thyname = #thyname p})
+			   thyname = #thyname p,
+                           activity_graphs=nil})
   | normalize c = c
 
 val OclAnyC = Class{name=["OclAny"],parent=NONE,attributes=[],
 			  operations=[], interfaces=[],
 			  invariant=[],stereotypes=[], associationends=[],
-			  thyname=NONE}
+			  thyname=NONE,
+                          activity_graphs=nil}
 
 		   
 fun string_of_path (path:ocl_type.Path) = case path of
@@ -178,14 +182,24 @@ fun string_of_path (path:ocl_type.Path) = case path of
 
 
 
-fun update_thyname tname (Class{name,parent,attributes,operations,invariant,stereotypes,interfaces,associationends,...})
+fun update_thyname tname (Class{name,parent,attributes,operations,invariant,
-    = Class{name=name,parent=parent,attributes=attributes,operations=operations,associationends=associationends,invariant=invariant,stereotypes=stereotypes,interfaces=interfaces,thyname=(SOME tname)}
+                                stereotypes,interfaces,associationends,activity_graphs,...})
+    = Class{name=name,parent=parent,attributes=attributes,operations=operations,
+            associationends=associationends,invariant=invariant,stereotypes=stereotypes,
+            interfaces=interfaces,thyname=(SOME tname),activity_graphs=activity_graphs }
   | update_thyname tname (Interface{name,parents,operations,stereotypes,invariant,...}) 
-    = Interface{name=name,parents=parents,operations=operations,stereotypes=stereotypes,invariant=invariant,thyname=(SOME tname)} 
+    = Interface{name=name,parents=parents,operations=operations,stereotypes=stereotypes,
-  | update_thyname tname (Enumeration{name,parent,operations,literals,invariant,stereotypes,interfaces,...}) 
+                invariant=invariant,thyname=(SOME tname)} 
-    = Enumeration{name=name,parent=parent,operations=operations,literals=literals,invariant=invariant,stereotypes=stereotypes,interfaces=interfaces,thyname=(SOME tname)}
+  | update_thyname tname (Enumeration{name,parent,operations,literals,invariant,
-  | update_thyname tname (Primitive{name,parent,operations,associationends,invariant,stereotypes,interfaces,...}) 
+                                      stereotypes,interfaces,...}) 
-    = Primitive{name=name,parent=parent,operations=operations,associationends=associationends,invariant=invariant,stereotypes=stereotypes,interfaces=interfaces,thyname=(SOME tname)} 
+    = Enumeration{name=name,parent=parent,operations=operations,literals=literals,
+                  invariant=invariant,stereotypes=stereotypes,interfaces=interfaces,
+                  thyname=(SOME tname)}
+  | update_thyname tname (Primitive{name,parent,operations,associationends,invariant,
+                                    stereotypes,interfaces,...}) 
+    = Primitive{name=name,parent=parent,operations=operations,
+                associationends=associationends,invariant=invariant,
+                stereotypes=stereotypes,interfaces=interfaces,thyname=(SOME tname)} 
 
 
 fun name_of (Class{name,...})       = name  
@@ -200,57 +214,83 @@ fun short_name_of (Class{name,...})       = (hd o rev) name
 
 
 
-fun package_of (Class{name,...})       = if (length name) > 1 then take (((length name) -1),name)  else []
+fun package_of (Class{name,...})       = if (length name) > 1 
-  | package_of (Interface{name,...})   = if (length name) > 1 then take (((length name) -1),name) else []
+                                         then take (((length name) -1),name)  
-  | package_of (Enumeration{name,...}) = if (length name) > 1 then take (((length name) -1),name) else []
+                                         else []
-  | package_of (Primitive{name,...})    = if (length name) > 1 then take (((length name) -1),name) else []
+  | package_of (Interface{name,...})   = if (length name) > 1 
+                                         then take (((length name) -1),name) 
+                                         else []
+  | package_of (Enumeration{name,...}) = if (length name) > 1 
+                                         then take (((length name) -1),name) 
+                                         else []
+  | package_of (Primitive{name,...})   = if (length name) > 1 
+                                         then take (((length name) -1),name) 
+                                         else []
 
-fun parent_name_of (C as Class{parent,...})       = (case parent  of 
+fun parent_name_of (C as Class{parent,...}) = 
-						  NONE => name_of OclAnyC
+    (case parent  of NONE   => name_of OclAnyC
-						| (SOME p)  => p ) 
+		    |SOME p => p ) 
-  | parent_name_of (Interface{...})        = error "parent_name_of <Interface> not supported"
+  | parent_name_of (Interface{...})         = 
-  | parent_name_of (E as Enumeration{parent,...}) = (case parent  of 
+                    error "parent_name_of <Interface> not supported"
-						  NONE => error ("Enumeration "^((string_of_path o name_of) E)^" has no parent")
+  | parent_name_of (E as Enumeration{parent,...}) = 
-						| (SOME p)  => p )  
+    (case parent  of NONE => error ("Enumeration "^((string_of_path o name_of) E)
-  | parent_name_of (D as Primitive{parent,...})    = (case parent  of 
+                                    ^" has no parent")
-						  NONE => name_of OclAnyC
+		   | SOME p  => p )  
-								  (* error ("Primitive "^((string_of_path o name_of) D)^" has no parent") *)
+  | parent_name_of (D as Primitive{parent,...})    = 
-						| (SOME p)  => p )
+    (case parent  of NONE => name_of OclAnyC
+	(* error ("Primitive "^((string_of_path o name_of) D)^" has no parent") *)
+		   | SOME p  => p )
  
-fun short_parent_name_of (C as Class{parent,...})       = (case parent  of 
+fun short_parent_name_of (C as Class{parent,...})       = 
-						  NONE => short_name_of OclAnyC
+    (case parent  of NONE => short_name_of OclAnyC
-						| (SOME p)  => (hd o rev) p ) 
+		   | SOME p  => (hd o rev) p ) 
-  | short_parent_name_of (Interface{...})        = error "parent_name_of <Interface> not supported"
+  | short_parent_name_of (Interface{...})        = 
-  | short_parent_name_of (E as Enumeration{parent,...}) = (case parent  of 
+    error "parent_name_of <Interface> not supported"
-						  NONE => error ("Enumeration "^((string_of_path o name_of) E)^" has no parent")
+  | short_parent_name_of (E as Enumeration{parent,...}) = 
-						| (SOME p)  => (hd o rev) p )  
+    (case parent  of  NONE => error ("Enumeration "^((string_of_path o name_of) E)^
-  | short_parent_name_of (D as Primitive{parent,...})    = (case parent  of 
+                                     " has no parent")
-						  NONE =>  short_name_of OclAnyC (* error ("Primitive "^((string_of_path o name_of) D)^" has no parent") *)
+		   |  SOME p  => (hd o rev) p )  
-						| (SOME p)  => (hd o rev) p ) 
+  | short_parent_name_of (D as Primitive{parent,...})    = 
+    (case parent  of  NONE =>  short_name_of OclAnyC 
+          (* error ("Primitive "^((string_of_path o name_of) D)^" has no parent") *)
+		   | SOME p  => (hd o rev) p ) 
 					     					     
 							 
-fun parent_package_of (Class{parent,...})       = (case parent of 
+fun parent_package_of (Class{parent,...})       = 
-						     NONE => package_of OclAnyC
+    (case parent of  NONE => package_of OclAnyC
-						   | (SOME p)   =>if (length p) > 1 then  (take (((length p) -1),p))  else [])
+		   | SOME p   =>if (length p) > 1 
-  | parent_package_of (Interface{...})        = error "parent_package_of <Interface> not supported"
+                                then  (take (((length p) -1),p))  
-  | parent_package_of (Enumeration{parent,...}) = (case parent of 
+                                else [])
-						     NONE => error "Enumeration has no parent"
+  | parent_package_of (Interface{...})        = 
-						   | (SOME p)  => if (length p) > 1 then (take (((length p) -1),p))  else [])
+                   error "parent_package_of <Interface> not supported"
-  | parent_package_of (Primitive{parent,...})    = (case parent of 
+  | parent_package_of (Enumeration{parent,...}) = 
-							NONE => package_of OclAnyC
+    (case parent of  NONE => error "Enumeration has no parent"
-						      (* NONE => error "Primitive has no parent" *)
+		   | SOME p  => if (length p) > 1 
-						      | (SOME p)   => if (length p) > 1 then (take (((length p) -1),p))  else [])
+                                then (take (((length p) -1),p))  
+                                else [])
+  | parent_package_of (Primitive{parent,...})    = 
+    (case parent of NONE => package_of OclAnyC
+	  (* NONE => error "Primitive has no parent" *)
+		 |  SOME p   => if (length p) > 1 
+                                then (take (((length p) -1),p))  
+                                else [])
 						
 
 fun attributes_of (Class{attributes,...}) = attributes
-  | attributes_of (Interface{...})        = error "attributes_of <Interface> not supported" 
+  | attributes_of (Interface{...})        = 
-  | attributes_of (Enumeration{...})      = error "attributes_of <Enumeration> not supported"  
+         error "attributes_of <Interface> not supported" 
-  | attributes_of (Primitive{...})         = []  (* error "attributes_of <Primitive> not supported" *)  
+  | attributes_of (Enumeration{...})      = 
+         error "attributes_of <Enumeration> not supported"  
+  | attributes_of (Primitive{...})         = []  
+         (* error "attributes_of <Primitive> not supported" *)  
 
 fun operations_of (Class{operations,...}) = operations
-  | operations_of (Interface{...})        = error "operations_of <Interface> not supported" 
+  | operations_of (Interface{...})        = 
-  | operations_of (Enumeration{...})      = error "operations_of <Enumeration> not supported"  
+         error "operations_of <Interface> not supported" 
-  | operations_of (Primitive{...})         = []  (* error "operations_of <Primitive> not supported" *)  
+  | operations_of (Enumeration{...})      = 
+         error "operations_of <Enumeration> not supported"  
+  | operations_of (Primitive{...})         = []  
+         (* error "operations_of <Primitive> not supported" *)  
 
 
 fun p_invariant_of (Class{invariant,...})       = invariant 
@@ -278,7 +318,8 @@ fun mangled_name_of_op ({name,arguments,result,...}:operation) =
     let
 	val arg_typestrs = map (fn a => (ocl_type.string_of_OclType o snd ) a ) arguments
     in 
-	 foldr1 (fn (a,b) =>(a^"_"^b)) ((name::arg_typestrs)@[ocl_type.string_of_OclType result])
+	 foldr1 (fn (a,b) =>(a^"_"^b)) 
+                ((name::arg_typestrs)@[ocl_type.string_of_OclType result])
     end
 							   
 fun result_of_op ({result,...}:operation) = result
@@ -289,17 +330,21 @@ fun arguments_of_op ({arguments,...}:operation) = arguments
 
 
 
-fun thy_name_of (C as Class{thyname,...})       = (case thyname of
+fun thy_name_of (C as Class{thyname,...})       = 
-						   (SOME tname) =>  tname
+     (case thyname of  SOME tname =>  tname
-						 | NONE => error  ("Class "^((string_of_path o name_of) C)^" has no thyname"))
+		     | NONE => error  ("Class "^((string_of_path o name_of) C)^
-  | thy_name_of (I as Interface{thyname,...})   = (case thyname of
+                                       " has no thyname"))
-						   (SOME tname) =>  tname
+  | thy_name_of (I as Interface{thyname,...})   = 
-						 | NONE => error  ("Interface "^((string_of_path o name_of) I)^" has no thyname"))
+     (case thyname of SOME tname =>  tname
-  | thy_name_of (E as Enumeration{thyname,...}) = (case thyname of
+		     | NONE => error  ("Interface "^((string_of_path o name_of) I)
-						   (SOME tname) =>  tname
+                                       ^" has no thyname"))
-						 | NONE => error  ("Enumeration "^((string_of_path o name_of) E)^" has no thyname"))
+  | thy_name_of (E as Enumeration{thyname,...}) = 
-  | thy_name_of (P as Primitive{thyname,...})    = (case thyname of
+      (case thyname of SOME tname =>  tname
-						   (SOME tname) =>  tname
+		     | NONE => error  ("Enumeration "^((string_of_path o name_of) E)
-						 | NONE => error  ("Primitive "^((string_of_path o name_of) P)^" has no thyname"))
+                                       ^" has no thyname"))
+  | thy_name_of (P as Primitive{thyname,...})    = 
+      (case thyname of SOME tname =>  tname
+		     | NONE => error  ("Primitive "^((string_of_path o name_of) P)^
+                                       " has no thyname"))
  
 end

src/parse_xmi.sml

@@ -548,6 +548,13 @@ fun mkGeneralization tree =
        handle XmlTree.IllFormed msg => raise IllFormed ("in mkGeneralization: "^msg)
     end
 
+
+fun mkActivityGraph tree =
+    let fun f atts trees = XMI_ActivityGraphs.dummy
+    in  XmlTree.apply_on "UML:ActivityGraph" f tree
+    end;
+
+
 fun mkPackage tree = 
     (if XmlTree.tagname_of tree = "UML:Model" orelse
 	XmlTree.tagname_of tree = "UML:Package" then 
@@ -566,7 +573,10 @@ fun mkPackage tree =
 						      (XmlTree.filter "UML:Generalization"
 								    trees)),
 			       constraints     = map mkConstraint 
-						     (filterConstraints trees) }
+						     (filterConstraints trees),
+                               statemachines   = nil,
+                               activitygraphs  = nil
+                              }
 	 end
      else raise IllFormed "did not find a UML:Model or UML: Package")
     handle XmlTree.IllFormed msg => raise IllFormed ("in mkPackage: "^msg)
@@ -583,13 +593,15 @@ fun mkStereotype tree =
        handle XmlTree.IllFormed msg => raise IllFormed ("in mkStereotype: "^msg)
     end 
 
+
+
 fun mkXmiContent tree =
     let fun f atts trees = 
 	    { packages    = (map mkPackage    (filterPackages trees)),
 	      constraints = (map mkConstraint (filterConstraints trees)),
 	      classifiers = (map mkClassifier (filterClassifiers trees)),
 	      stereotypes = (map mkStereotype (filterStereotypes trees)),
-	      variable_declarations = (map mkVariableDec (filterVariableDecs trees)) }
+	      variable_declarations = (map mkVariableDec   (filterVariableDecs trees))}
     in XmlTree.apply_on "XMI.content" f tree
        handle XmlTree.IllFormed msg => raise IllFormed ("in mkXmiContent: "^msg)
     end
@@ -599,7 +611,7 @@ val emptyXmiContent = { packages = nil,
 			constraints = nil,
 			classifiers = nil,
 			stereotypes = nil,
-			variable_declarations = nil }
+			variable_declarations = nil}
 
 fun findXmiContent tree = valOf (XmlTree.dfs "XMI.content" tree)
     handle Option => raise IllFormed "in findXmiContent: did not find XMI.content"

src/state_machine.sig

@@ -23,7 +23,7 @@
  * 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.                  
  ******************************************************************************)
 
-signature STATE_MACHINE = 
+signature REP_STATE_MACHINE = 
 sig
     
 type     StateVertex_Id

src/xmi2mdr.sml

@@ -338,6 +338,7 @@ fun transform_classifier t (XMI_UML.Class {xmiid,name,isActive,visibility,isLeaf
 					      (find_aends t xmiid), 
 			stereotypes = nil, (* FIX *)
 			interfaces = nil, (* FIX *)
+                        activity_graphs = nil,
 			thyname = NONE}
     end
   | transform_classifier t (XMI_UML.Primitive {xmiid,name,generalizations,

src/xmi_uml.sml

@@ -30,7 +30,7 @@
  * of references.
  * --------------------------------------------------------------------------*)
 
-structure UML_OCL = 
+structure XMI_OCL = 
 struct
 (* from OCL 2.0 Expressions: -------------------------------------------------
  * A VariableDeclaration declares a variable name and binds it to a type. The 
@@ -102,7 +102,7 @@ fun expression_type_of (LiteralExp{expression_type,...})           = expression_
  * --------------------------------------------------------------------------*)
 datatype ConstraintType = Inv | Pre | Post | Def | Body
 
-(* We put Constraint into OCL, not into UML_Core because we only use *)
+(* We put Constraint into OCL, not into XMI_Core because we only use *)
 (* OCL Constraints.                                                  *)
 type Constraint = { xmiid           : string,
 		    name            : string option,
@@ -115,7 +115,7 @@ end
 
 
 
-structure UML_DataTypes =
+structure XMI_DataTypes =
 (* from UML 1.5 Core Overview: ----------------------------------------------
  * The Data Types package is the subpackage that specifies the different data 
  * types that are used to define UML. 
@@ -127,7 +127,7 @@ structure UML_DataTypes =
  * TypeExpression, UnlimitedInteger
  * --------------------------------------------------------------------------*)
 struct
-open UML_OCL
+open XMI_OCL
 
 datatype AggregationKind        = NoAggregation | Aggregate | Composite
 
@@ -183,7 +183,7 @@ datatype VisibilityKind = public (* Other elements may see and use the target*)
 end
 
 
-structure UML_ExtensionMechanisms =
+structure XMI_ExtensionMechanisms =
 (* from UML 1.5 Extension Mechanisms Overview:--------------------------------
  * The Extension Mechanisms package is the subpackage that specifies how 
  * specific UML model elements are customized and extended with new semantics 
@@ -192,7 +192,7 @@ structure UML_ExtensionMechanisms =
  * constitutes a UML profile.
  * --------------------------------------------------------------------------*)
 struct
-open UML_DataTypes
+open XMI_DataTypes
                     
 (* from UML 1.5 Extension Mechanisms:-----------------------------------------
  * The stereotype concept provides a way of branding (classifying) model 
@@ -234,7 +234,7 @@ end
 
 
 
-structure UML_Core = 
+structure XMI_Core = 
 (* from UML 1.5 Core Overview: ----------------------------------------------
  * The Core package is the most fundamental of the subpackages that compose 
  * the UML Foundation package. It defines the basic abstract and concrete 
@@ -260,7 +260,7 @@ structure UML_Core =
  *    TemplateArgument, TemplateParameter, Usage
  * --------------------------------------------------------------------------*)
 struct
-open UML_ExtensionMechanisms
+open XMI_ExtensionMechanisms
 
 (* from UML 1.5 Core: --------------------------------------------------------
  * A generalization is a taxonomic relationship between a more general 
@@ -538,8 +538,24 @@ fun classifier_elementtype_of (Collection{elementtype,...}) = elementtype
 end
 
 
+structure XMI_CommonBehavior = 
+struct
+end
 
-structure UML_ModelManagement =
+structure XMI_StateMachines =
+struct
+open XMI_CommonBehavior
+datatype StateMachine = dummy
+end
+
+structure XMI_ActivityGraphs =
+struct
+open XMI_StateMachines
+datatype ActivityGraph = dummy
+end
+
+
+structure XMI_ModelManagement =
 (* from UML 1.5 Model Management Overview: ------------------------------------
  * The Model Management package is dependent on the Foundation package. It 
  * defines Model, Package, and Subsystem, which all serve as grouping units 
@@ -550,7 +566,7 @@ structure UML_ModelManagement =
  * dedicated to group UML extensions.
  * --------------------------------------------------------------------------*)
 struct
-open UML_Core
+open XMI_Core XMI_ActivityGraphs
 (* from UML 1.5 Model Management: --------------------------------------------
  * A package is a grouping of model elements.
  * [...]
@@ -559,43 +575,34 @@ open UML_Core
  * StateMachines, Stereotypes, and TaggedValues.
  * --------------------------------------------------------------------------*)
 (* We treat "Model" the same way as a "Package".                             *)
-datatype Package = Package of { xmiid: string,
+datatype Package = Package of { xmiid          : string,
-				name: string,
+				name           : string,
-				visibility:  VisibilityKind,
+				visibility     : VisibilityKind,
-				packages:    Package list,
+				packages       : Package list,
-				classifiers: Classifier list,
+				classifiers    : Classifier list,
-				associations: Association list,
+                                statemachines  : StateMachine list,
+                                activitygraphs : ActivityGraph list,
+				associations   : Association list,
 				generalizations: Generalization list,
-				constraints: Constraint list }
+				constraints    : Constraint list }
 		  
 end
 
 
-structure UML_CommonBehavior = 
-struct
-open UML_ModelManagement
-end
-
-structure UML_StateMachines =
-struct
-open UML_CommonBehavior
-end
-
-structure UML_ActivityGraphs =
-struct
-open UML_StateMachines
-end
 
 structure XMI_UML =
 struct
-open UML_ActivityGraphs
+open XMI_Core XMI_ActivityGraphs XMI_ModelManagement
 
-(* There may be (are) model elements outside of the UML model *)
+(* There may be (are) model elements outside of the UML model,
+   due to errors in the Dresden Package.
+   The only relevant Xmi Content is the head of the
+   package list. *)
 type XmiContent = {classifiers:           Classifier list,
 		   constraints:           Constraint list,
 		   packages:              Package list,
 		   stereotypes:           Stereotype list,
 		   variable_declarations: VariableDeclaration list
-					  }
+                  }
 
 end