HOL-OCL
/
su4sml
1
0
Fork 0
Code Issues Pull Requests Releases Activity

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
This commit is contained in:
Achim D. Brucker 2005-09-07 17:02:47 +00:00
parent e3ca4161e1
commit 280d3cdfea
8 changed files with 185 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/ROOT.ML
View File

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

4
src/library.sml
View File

@ -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;

3
src/mdr_core.sig
View File

@ -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,

179
src/mdr_core.sml
View File

@ -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,...})
= Class{name=name,parent=parent,attributes=attributes,operations=operations,associationends=associationends,invariant=invariant,stereotypes=stereotypes,interfaces=interfaces,thyname=(SOME tname)}
fun update_thyname tname (Class{name,parent,attributes,operations,invariant,
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)}
| update_thyname tname (Enumeration{name,parent,operations,literals,invariant,stereotypes,interfaces,...})
= 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)}
= Interface{name=name,parents=parents,operations=operations,stereotypes=stereotypes,
invariant=invariant,thyname=(SOME tname)}
| update_thyname tname (Enumeration{name,parent,operations,literals,invariant,
stereotypes,interfaces,...})
= 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 []
| 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 package_of (Class{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
NONE => name_of OclAnyC
| (SOME p) => p )
| parent_name_of (Interface{...}) = error "parent_name_of <Interface> not supported"
| parent_name_of (E as Enumeration{parent,...}) = (case parent of
NONE => error ("Enumeration "^((string_of_path o name_of) E)^" has no parent")
| (SOME p) => p )
| parent_name_of (D as Primitive{parent,...}) = (case parent of
NONE => name_of OclAnyC
(* error ("Primitive "^((string_of_path o name_of) D)^" has no parent") *)
| (SOME p) => p )
fun parent_name_of (C as Class{parent,...}) =
(case parent of NONE => name_of OclAnyC
|SOME p => p )
| parent_name_of (Interface{...}) =
error "parent_name_of <Interface> not supported"
| parent_name_of (E as Enumeration{parent,...}) =
(case parent of NONE => error ("Enumeration "^((string_of_path o name_of) E)
^" has no parent")
| SOME p => p )
| parent_name_of (D as Primitive{parent,...}) =
(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
NONE => short_name_of OclAnyC
| (SOME p) => (hd o rev) p )
| short_parent_name_of (Interface{...}) = error "parent_name_of <Interface> not supported"
| short_parent_name_of (E as Enumeration{parent,...}) = (case parent of
NONE => error ("Enumeration "^((string_of_path o name_of) E)^" has no parent")
| (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 short_parent_name_of (C as Class{parent,...}) =
(case parent of NONE => short_name_of OclAnyC
| SOME p => (hd o rev) p )
| short_parent_name_of (Interface{...}) =
error "parent_name_of <Interface> not supported"
| short_parent_name_of (E as Enumeration{parent,...}) =
(case parent of NONE => error ("Enumeration "^((string_of_path o name_of) E)^
" has no parent")
| 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
NONE => package_of OclAnyC
| (SOME p) =>if (length p) > 1 then (take (((length p) -1),p)) else [])
| parent_package_of (Interface{...}) = error "parent_package_of <Interface> not supported"
| parent_package_of (Enumeration{parent,...}) = (case parent of
NONE => error "Enumeration has no parent"
| (SOME p) => if (length p) > 1 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 parent_package_of (Class{parent,...}) =
(case parent of NONE => package_of OclAnyC
| SOME p =>if (length p) > 1
then (take (((length p) -1),p))
else [])
| parent_package_of (Interface{...}) =
error "parent_package_of <Interface> not supported"
| parent_package_of (Enumeration{parent,...}) =
(case parent of NONE => error "Enumeration has no parent"
| SOME p => if (length p) > 1
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 (Enumeration{...}) = error "attributes_of <Enumeration> not supported"
| attributes_of (Primitive{...}) = [] (* error "attributes_of <Primitive> not supported" *)
| attributes_of (Interface{...}) =
error "attributes_of <Interface> 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 (Enumeration{...}) = error "operations_of <Enumeration> not supported"
| operations_of (Primitive{...}) = [] (* error "operations_of <Primitive> not supported" *)
| operations_of (Interface{...}) =
error "operations_of <Interface> 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
(SOME tname) => tname
| NONE => error ("Class "^((string_of_path o name_of) C)^" has no thyname"))
| thy_name_of (I as Interface{thyname,...}) = (case thyname of
(SOME tname) => tname
| NONE => error ("Interface "^((string_of_path o name_of) I)^" has no thyname"))
| thy_name_of (E as Enumeration{thyname,...}) = (case thyname of
(SOME tname) => tname
| NONE => error ("Enumeration "^((string_of_path o name_of) E)^" 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"))
fun thy_name_of (C as Class{thyname,...}) =
(case thyname of SOME tname => tname
| NONE => error ("Class "^((string_of_path o name_of) C)^
" has no thyname"))
| thy_name_of (I as Interface{thyname,...}) =
(case thyname of SOME tname => tname
| NONE => error ("Interface "^((string_of_path o name_of) I)
^" has no thyname"))
| thy_name_of (E as Enumeration{thyname,...}) =
(case thyname of SOME tname => tname
| NONE => error ("Enumeration "^((string_of_path o name_of) E)
^" 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

18
src/parse_xmi.sml
View File

@ -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"

2
src/state_machine.sig
View File

@ -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

1
src/xmi2mdr.sml
View File

@ -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,

75
src/xmi_uml.sml
View File

@ -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,
name: string,
visibility: VisibilityKind,
packages: Package list,
classifiers: Classifier list,
associations: Association list,
datatype Package = Package of { xmiid : string,
name : string,
visibility : VisibilityKind,
packages : Package list,
classifiers : Classifier 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