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

Merged importing-billk-2007-from-infsec changes r6859:6865 into the trunk. 

git-svn-id: https://projects.brucker.ch/su4sml/svn/su4sml/trunk@6866 3260e6d1-4efc-4170-b0a7-36055960796d
This commit is contained in:
Achim D. Brucker 2007-09-26 07:55:59 +00:00
parent 115c5f6de4
commit 7dffbec30f
24 changed files with 2161 additions and 269 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
su4sml/src/codegen/base_cartridge.sml
View File

@ -85,7 +85,8 @@ fun scope2Native XMI.ClassifierScope = "ClassifierScope"
| scope2Native XMI.InstanceScope = "InstanceScope"
type Model = Rep.Classifier list
(*type Model = Rep.Classifier list*)
type Model = Rep_Core.transform_model
type environment = { model : Model,
counter : int ref,
@ -103,6 +104,8 @@ type environment = { model : Model,
* list items
*)
fun getModel (env : environment) = #model env
fun getClassifiers (env: environment) = #1 (getModel env)
fun getAssociations (env: environment) = #2 (getModel env)
fun curClassifier (env : environment) = (#curClassifier env)
fun curAttribute (env : environment) = (#curAttribute env)
fun curAssociationEnd (env : environment) = (#curAssocEnd env)
@ -132,7 +135,7 @@ fun initEnv model = { model = model,
fun curClassifierPackageToString env p2sfun = (case (#curClassifier env) of
NONE => p2sfun
(Rep.package_of
(hd (#model env)))
(hd (getClassifiers env)))
| SOME c => p2sfun
(Rep.package_of
(curClassifier' env)))
@ -170,7 +173,7 @@ fun lookup env "classifier_name" = Rep_Core.short_name_of (curClassifier' env
| lookup env "attribute_visibility" = visibility2Native(#visibility
(curAttribute' env))
| lookup env "attribute_scope" = scope2Native (#scope (curAttribute' env))
| lookup env "assocend_name" = (#name o valOf o #curAssocEnd) env
| lookup env "assocend_name" = (Rep_OclType.string_of_path o #name o valOf o #curAssocEnd) env
| lookup env "assocend_type" = (oclType2Native o #aend_type o valOf o #curAssocEnd) env
| lookup env "operation_name" = Rep.name_of_op (curOperation' env)
| lookup env "operation_result_type" = oclType2Native (Rep.result_of_op
@ -222,14 +225,14 @@ fun test env "isClass" = (case (#curClassifier env) of
| test env "hasOpSpec" = ((length (Rep_Core.precondition_of_op (curOperation' env)))
+(length (Rep_Core.postcondition_of_op (curOperation' env)))) > 0
| test env "hasAttributes" = (length (Rep_Core.attributes_of (curClassifier' env))) > 0
| test env "first_classifier" = (curClassifier' env = hd (#model env))
| test env "first_classifier" = (curClassifier' env = hd (getClassifiers env))
| test env "first_attribute" = (curAttribute' env
= hd (Rep_Core.attributes_of (curClassifier' env)))
| test env "first_operation" = (curOperation' env
= hd (Rep_Core.operations_of (curClassifier' env)))
| test env "first_argument" = (curArgument' env
= hd (Rep_Core.arguments_of_op (curOperation' env)))
| test env "last_classifier" = (curClassifier' env = List.last (#model env))
| test env "last_classifier" = (curClassifier' env = List.last (getClassifiers env))
| test env "last_attribute" = (curAttribute' env =
List.last (Rep_Core.attributes_of
(curClassifier' env)))
@ -255,7 +258,7 @@ fun test env "isClass" = (case (#curClassifier env) of
(* fun foreach_classifier: environment -> environment list *)
fun foreach_classifier (env : environment)
= let val cl = (#model env)
= let val cl = (getClassifiers env)
fun env_from_classifier c = { model = #model env,
counter = #counter env,
curClassifier= SOME c,
@ -275,7 +278,7 @@ fun foreach_classifier (env : environment)
fun foreach_nonprimitive_classifier (env : environment)
= let val cl = List.filter (fn cenv => (case cenv of
Rep.Primitive{...} => false
| _ => true)) (#model env)
| _ => true)) (getClassifiers env)
fun env_from_classifier c = { model = (#model env),
counter = #counter env,
curClassifier = SOME c,
@ -392,7 +395,8 @@ fun foreach_argument (env : environment)
end
fun foreach_assocend (env : environment)
= let val aends = Rep_Core.associationends_of (curClassifier' env)
= let val associations = getAssociations env
val aends = Rep_Core.associationends_of associations (curClassifier' env)
fun env_from_argument arg = { model = #model env,
counter = #counter env,
curClassifier = SOME (curClassifier' env),

2
su4sml/src/codegen/codegen.sml
View File

@ -178,7 +178,7 @@ val supported_cartridges = [
description = "",
recommended = false,
generator = SecureMova_Gcg.generate,
parser = RepParser.transformXMI o XmiParser.readFile,
parser = RepParser.transformXMI_ext o XmiParser.readFile,
template = "securemova.tpl"}]:cartridge list

6
su4sml/src/codegen/secureuml_cartridge.sml
View File

@ -53,7 +53,8 @@ sig
structure Security:SECUREUML
include BASE_CARTRIDGE where
type Model = Rep.Classifier list * Security.Configuration
(*type Model = Rep.Classifier list * Security.Configuration*)
type Model = Rep.Model * Security.Configuration
val PermissionSet : environment -> Security.Permission list
val curPermission : environment -> Security.Permission option
@ -77,7 +78,8 @@ struct
open library
structure Security = SecureUML(structure Design = D)
type Model = Rep.Classifier list * Security.Configuration
(*type Model = Rep.Classifier list * Security.Configuration*)
type Model = Rep.Model * Security.Configuration
type environment = { model : Model,
PermissionSet : Security.Permission list,

5
su4sml/src/library.sml
View File

@ -113,6 +113,11 @@ fun space_implode a bs = implode (separate a bs);
fun print_stderr s = (TextIO.output (TextIO.stdErr, s); TextIO.flushOut TextIO.stdErr);
fun lowercase s = let val sl = String.explode s
in
String.implode ((Char.toLower (hd sl))::(tl sl))
end
exception ERROR;
(* val writeln = std_output o suffix "\n";*)

6
su4sml/src/mds.sig
View File

@ -130,9 +130,11 @@ sig
(**
* parse a UML model and return a (modified) list of classes and the
* recognized security configuration.
* FIXME: proper descr./impl. of all funtctions re the changed model
* FIXME: Associations? Classifier.association?
*)
val parse: Rep_Core.Classifier list ->
(Rep_Core.Classifier list * Configuration)
val parse: Rep.Model ->
(Rep.Model * Configuration)
end

11
su4sml/src/ocl2string.sml
View File

@ -284,6 +284,15 @@ fun classifier2string (C as Rep.Class x) =
String.concat (map attribute2string (#attributes x))^
String.concat (map operation2string (#operations x))^
"}\n"
| classifier2string (C as Rep.AssociationClass x) =
String.concat (map stereotype2string (#stereotypes x))^
"associationclass "^Rep.string_of_path (Rep.name_of C)^
parent2string (#parent x)^
" {\n"^
String.concat (map inv2string (#invariant x))^
String.concat (map attribute2string (#attributes x))^
String.concat (map operation2string (#operations x))^
"}\n"
| classifier2string (C as Rep.Interface x) =
String.concat (map stereotype2string (#stereotypes x))^
"interface "^Rep.string_of_path (Rep.name_of C)^"{\n"^
@ -299,6 +308,8 @@ fun classifier2string (C as Rep.Class x) =
"enum "^Rep.string_of_path (Rep.name_of C)^"{\n"^
String.concat (map operation2string (#operations x))^
"}\n"
| classifier2string (C as Rep.Template x) =
"template of "^ (classifier2string (#classifier x))
fun printClass (x:Rep.Classifier) = print (classifier2string x)

22
su4sml/src/ocl_library.sml
View File

@ -61,7 +61,7 @@ val oclLib =
classifier = Class
{
interfaces=[],attributes=[],
associationends=[],
associations=[],
activity_graphs=[],
invariant=[],
name=Sequence (TemplateParameter "T"),
@ -327,7 +327,7 @@ val oclLib =
classifier = Class
{
attributes=[],
associationends=[],
associations=[],
activity_graphs=[],
interfaces=[],
invariant=[],
@ -532,7 +532,7 @@ val oclLib =
classifier = Class
{
attributes=[],
associationends=[],
associations=[],
activity_graphs=[],
interfaces=[],invariant=[],
name=Set (TemplateParameter "T"),
@ -778,7 +778,7 @@ val oclLib =
classifier = Class
{
attributes=[],
associationends=[],
associations=[],
activity_graphs=[],
interfaces=[],
invariant=[],
@ -984,7 +984,7 @@ val oclLib =
classifier = Class
{
attributes=[],
associationends=[],
associations=[],
activity_graphs=[],
interfaces=[],invariant=[],name=Collection(TemplateParameter "T"),
operations=[
@ -1056,7 +1056,7 @@ val oclLib =
Class
{
attributes=[],
associationends=[],
associations=[],
activity_graphs=[],
interfaces=[],
invariant=[],
@ -1069,7 +1069,7 @@ val oclLib =
Primitive
{
associationends=[],interfaces=[],invariant=[],name=OclAny,
associations=[],interfaces=[],invariant=[],name=OclAny,
operations=[
{
arguments=[("object",OclAny)],
@ -1144,7 +1144,7 @@ val oclLib =
},
Primitive
{
associationends=[],interfaces=[],invariant=[],name=String,
associations=[],interfaces=[],invariant=[],name=String,
operations=[
{
arguments=[],isQuery=true,name="size",body=[],postcondition=[],
@ -1190,7 +1190,7 @@ val oclLib =
},
Primitive
{
associationends=[],interfaces=[],invariant=[],name=Boolean,
associations=[],interfaces=[],invariant=[],name=Boolean,
operations=[
{
arguments=[("b",Boolean)],
@ -1262,7 +1262,7 @@ val oclLib =
},
Primitive
{
associationends=[],interfaces=[],invariant=[],name=Integer,
associations=[],interfaces=[],invariant=[],name=Integer,
operations=[
{
arguments=[("i",Integer)],
@ -1327,7 +1327,7 @@ val oclLib =
},
Primitive
{
associationends=[],interfaces=[],invariant=[],name=Real,
associations=[],interfaces=[],invariant=[],name=Real,
operations=[
{
arguments=[("r",Real)],

103
su4sml/src/ocl_parser/library.sml
View File

@ -70,16 +70,24 @@ sig
val find_attribute : string -> Rep_Core.attribute list -> Rep_Core.attribute
(* operations for inheritance *)
val conforms_to : Rep_OclType.OclType -> Rep_OclType.OclType -> Rep_Core.Classifier list -> bool
val conforms_to : Rep_OclType.OclType -> Rep_OclType.OclType -> Rep_Core.transform_model -> bool
val upcast : (Rep_OclTerm.OclTerm * Rep_OclType.OclType) -> Rep_OclTerm.OclTerm
val args_interfereable : (string * Rep_OclType.OclType) list -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_Core.Classifier list -> bool
val interfere_args : (string * Rep_OclType.OclType) list -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_Core.Classifier list -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list
val interfere_methods : (Rep_Core.Classifier * Rep_Core.operation) list -> Rep_OclTerm.OclTerm -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_Core.Classifier list -> Rep_OclTerm.OclTerm
val interfere_attrs_or_assocends: (Rep_Core.Classifier * Rep_Core.attribute option * Rep_Core.associationend option) list -> Rep_OclTerm.OclTerm -> Rep_Core.Classifier list -> Rep_OclTerm.OclTerm
val get_overloaded_methods : Rep_Core.Classifier -> string -> Rep_Core.Classifier list -> (Rep_Core.Classifier * Rep_Core.operation) list
val get_overloaded_attrs_or_assocends : Rep_Core.Classifier -> string -> Rep_Core.Classifier list -> (Rep_Core.Classifier * Rep_Core.attribute option * Rep_Core.associationend option) list
val get_meth : Rep_OclTerm.OclTerm -> string -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_Core.Classifier list -> Rep_OclTerm.OclTerm
val get_attr_or_assoc : Rep_OclTerm.OclTerm -> string -> Rep_Core.Classifier list -> Rep_OclTerm.OclTerm
val args_interfereable : (string * Rep_OclType.OclType) list -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_Core.transform_model -> bool
val interfere_args : (string * Rep_OclType.OclType) list -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list
-> Rep_Core.transform_model -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list
val interfere_methods : (Rep_Core.Classifier * Rep_Core.operation) list -> Rep_OclTerm.OclTerm
-> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_Core.transform_model -> Rep_OclTerm.OclTerm
val interfere_attrs_or_assocends: (Rep_Core.Classifier * Rep_Core.attribute option * Rep_Core.associationend option) list
-> Rep_OclTerm.OclTerm -> Rep_Core.transform_model -> Rep_OclTerm.OclTerm
val get_overloaded_methods : Rep_Core.Classifier -> string -> Rep_Core.transform_model -> (Rep_Core.Classifier * Rep_Core.operation) list
(* val get_overloaded_attrs_or_assocends : Rep_Core.Classifier -> string -> Rep_Core.Classifier list
-> (Rep_Core.Classifier * Rep_Core.attribute option * Rep_Core.associationend option) list
*)
val get_overloaded_attrs_or_assocends : Rep_Core.Classifier -> string -> Rep_Core.transform_model
-> (Rep_Core.Classifier * Rep_Core.attribute option * Rep_Core.associationend option) list
val get_meth : Rep_OclTerm.OclTerm -> string -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list
-> Rep_Core.transform_model -> Rep_OclTerm.OclTerm
val get_attr_or_assoc : Rep_OclTerm.OclTerm -> string -> Rep_Core.transform_model -> Rep_OclTerm.OclTerm
(* operations/values for debugging/logging *)
val trace : int -> string -> unit
@ -276,6 +284,15 @@ fun type_of_parent (Class {parent,...}) =
| SOME (t) => t
)
end
| type_of_parent (AssociationClass {parent,...}) =
let
val _ = trace development ("type_of_parent : AssociationClass{parent,...} \n")
in
( case parent of
NONE => OclAny
| SOME (t) => t
)
end
| type_of_parent (Primitive {parent, ...}) =
( case parent of
NONE => OclAny
@ -552,7 +569,7 @@ fun substitute_classifier typ classifier =
attributes = [],
operations = ops,
(* a template has no associationends *)
associationends = [],
associations = [],
(* a template has no invariants *)
invariant = [],
(* a template has no stereotypes *)
@ -633,7 +650,7 @@ and class_of_type typ model =
get_classifier (Variable ("x",typ)) model
(* RETURN: Boolean *)
fun conforms_to_up _ OclAny _ = true
fun conforms_to_up _ OclAny (_:Rep_Core.transform_model) = true
| conforms_to_up (Set(T1)) (Collection(T2)) model =
let
val _ = trace low ("conforms_to_up: set -> collection \n")
@ -670,10 +687,10 @@ fun conforms_to_up _ OclAny _ = true
else
false
end
| conforms_to_up typ1 typ2 model =
| conforms_to_up typ1 typ2 (model as(classifiers,associations)) =
let
val class = class_of_type typ1 model
val parents_types = type_of_parents (class) model
val class = class_of_type typ1 classifiers
val parents_types = type_of_parents (class) classifiers
val _ = trace low ("conforms_to_up: ... \n")
in
member (typ2) (parents_types)
@ -681,7 +698,7 @@ fun conforms_to_up _ OclAny _ = true
and
(* RETRUN: Boolean *)
conforms_to x y model =
conforms_to x y (model:Rep_Core.transform_model) =
let
val _ = trace low ("conforms_to: " ^ string_of_OclType x ^ " -> " ^ string_of_OclType y ^ " ? \n")
in
@ -716,6 +733,13 @@ and type_of_parents (Primitive {parent,...}) model =
| SOME (OclAny) => [OclAny]
| SOME (t) => (t)::(type_of_parents (class_of_type t model) model)
)
| type_of_parents (AssociationClass {parent,...}) model =
(
case parent of
NONE => [OclAny]
| SOME (OclAny) => [OclAny]
| SOME (t) => (t)::(type_of_parents (class_of_type t model) model)
)
| type_of_parents (Interface {parents,...}) model = parents
| type_of_parents (Template {classifier,...}) model =
raise TemplateInstantiationError ("During Instantiation of template parent needn't to be accessed")
@ -727,6 +751,11 @@ fun class_of_parent (Class {parent,...}) clist =
NONE => get_classifier (Variable ("x",OclAny)) clist
| SOME (others) => get_classifier (Variable ("x",others)) clist
)
| class_of_parent (AssociationClass {parent,...}) clist =
(case parent of
NONE => get_classifier (Variable ("x",OclAny)) clist
| SOME (others) => get_classifier (Variable ("x",others)) clist
)
| class_of_parent (Primitive {parent,...}) clist =
(case parent of
NONE => class_of_type OclAny clist
@ -805,7 +834,7 @@ fun interfere_methods [] source args model =
end
(* RETURN: (OclTerm) *)
fun interfere_attrs (class,attr:attribute) source model =
fun interfere_attrs (class,attr:attribute) source (model:Rep_Core.transform_model) =
let
val check_source = conforms_to (type_of_term source) (type_of class) model
val _ = trace low ("interfere attribute: check_source "^ Bool.toString check_source ^ "\n\n")
@ -818,20 +847,25 @@ fun interfere_attrs (class,attr:attribute) source model =
end
(* RETURN: OclTerm option*)
fun interfere_assocends (class,assocend:associationend) source model =
fun interfere_assocends (class,assocend:associationend) source (model:Rep_Core.transform_model) =
let
val check_source = conforms_to (type_of_term source) (type_of class) model
val _ = trace low ("Interfere assocend: check_source " ^ Bool.toString check_source ^ "\n")
val _ = trace low ("type of assoc " ^ string_of_OclType (assoc_to_attr_type assocend) ^ "\n")
val _ = trace low ("type of assoc " ^ string_of_OclType (aend_to_attr_type assocend) ^ "\n")
in
if check_source then
SOME ((AssociationEndCall (source,type_of class,(name_of class)@[(#name assocend)],assoc_to_attr_type assocend)))
(* billk_tag *)
(* associationend has changed *)
(*SOME ((AssociationEndCall (source,type_of class,(name_of class)@[(#name assocend)],aend_to_attr_type assocend))) *)
SOME ((AssociationEndCall (source,type_of class,(name_of class)@[List.last (#name assocend)],aend_to_attr_type assocend)))
else
NONE
end
(* RETURN: OclTerm *)
fun interfere_attrs_or_assocends [] source model = raise InterferenceError ("interference_attr_or_assoc: No operation signature matches given types (source: " ^ (Ocl2String.ocl2string false source) ^ ").")
fun interfere_attrs_or_assocends [] source (model:Rep_Core.transform_model) =
raise InterferenceError ("interference_attr_or_assoc: No operation signature matches given types (source: "
^ (Ocl2String.ocl2string false source) ^ ").")
| interfere_attrs_or_assocends ((class,SOME(attr:attribute),NONE)::class_attr_or_assoc_list) source model =
(
case (interfere_attrs (class,attr) source model) of
@ -862,19 +896,19 @@ fun end_of_recursion classifier =
| others => false
(* RETURN: (Classifier * operation ) list *)
fun get_overloaded_methods class op_name [] = raise NoModelReferenced ("in 'get_overloaded_methods' ...\n")
| get_overloaded_methods class op_name model =
fun get_overloaded_methods class op_name ([],_) = raise NoModelReferenced ("in 'get_overloaded_methods' ...\n")
| get_overloaded_methods class op_name (model as (classifiers,associations)) =
let
val _ = trace low("\n")
val ops = operations_of class
val _ = trace low("Look for methods for classifier: " ^ string_of_OclType (type_of class) ^ "\n")
val ops2 = List.filter (fn a => (if ((#name a) = op_name) then true else false)) ops
val _ = trace low("operation name : " ^ op_name ^ " Found " ^ Int.toString (List.length ops2) ^ " method(s) \n")
val parent = class_of_parent class model
val parent = class_of_parent class classifiers
val _ = trace low("Parent class : " ^ string_of_OclType (type_of parent) ^ "\n\n")
val cl_op = List.map (fn a => (class,a)) ops2
in
if (class = class_of_type OclAny model)
if (class = class_of_type OclAny classifiers)
then (* end of hierarchie *)
if (List.length ops2 = 0)
then[]
@ -896,22 +930,22 @@ fun get_overloaded_methods class op_name [] = raise NoModelReferenced ("in 'get_
end
(* RETURN: (Classifier * attribute option * association option) list *)
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 =
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 low ("\n")
val attrs = attributes_of class
val assocends = associationends_of class
val assocends = associationends_of associations class
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 a => (if ((#name a) = attr_name) then true else false)) assocends
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 parent = class_of_parent class model
val parent = class_of_parent class classifiers
val _ = trace low ("Parent class : " ^ string_of_OclType(type_of parent) ^ "\n\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
in
if (class = class_of_type OclAny model) then
if (class = class_of_type OclAny classifiers) then
(* end of hierarchie *)
if (List.length attrs2 = 0)
then if (List.length assocends2 = 0)
@ -941,11 +975,11 @@ fun get_overloaded_attrs_or_assocends class attr_name [] = raise NoModelReferenc
end
(* RETURN: OclTerm *)
fun get_meth source op_name args model=
fun get_meth source op_name args (model as (classifiers,associations))=
(* object type *)
let
val _ = trace low ("Type of Classifier : " ^ string_of_OclType (type_of_term source ) ^ "\n")
val class = get_classifier source model
val class = get_classifier source classifiers
val meth_list = get_overloaded_methods class op_name model
val _ = trace low ("overloaded methods found: " ^ Int.toString (List.length meth_list) ^ "\n")
in
@ -953,10 +987,10 @@ fun get_meth source op_name args model=
end
(* RETURN: OclTerm *)
fun get_attr_or_assoc source attr_name model =
fun get_attr_or_assoc source attr_name (model as (classifiers,associations)) =
let
val _ = trace low ("GET ATTRIBUTES OR ASSOCENDS: source term = " ^ Ocl2String.ocl2string false source ^ "\n")
val class = get_classifier source model
val class = get_classifier source classifiers
val attr_or_assocend_list = get_overloaded_attrs_or_assocends class attr_name model
val _ = trace low ("overloaded attributes/associationends found: " ^ Int.toString (List.length attr_or_assocend_list) ^ "\n")
in
@ -967,4 +1001,5 @@ fun get_attr_or_assoc source attr_name model =
x
end
end
end

62
su4sml/src/ocl_parser/make_classifier_list.sml
View File

@ -172,14 +172,29 @@ fun context_to_classifier (Inv (path,string_opt,term)) model =
in
(
case c of
(Class {name,parent,attributes,operations,associationends,interfaces,stereotypes,invariant,thyname,activity_graphs}) =>
(Class {name,parent,attributes,operations,associations,interfaces,stereotypes,invariant,thyname,activity_graphs}) =>
Class
{
name = name,
parent = parent,
attributes = attributes,
operations = operations,
associationends = associationends,
associations = associations,
interfaces = interfaces,
stereotypes = stereotypes,
invariant = invariant@[(string_opt,term)],
thyname = thyname,
activity_graphs = activity_graphs
}
| (AssociationClass {name,parent,attributes,operations,associations,association,interfaces,stereotypes,invariant,thyname,activity_graphs}) =>
AssociationClass
{
name = name,
parent = parent,
attributes = attributes,
operations = operations,
associations = associations,
association = association,
interfaces = interfaces,
stereotypes = stereotypes,
invariant = invariant@[(string_opt,term)],
@ -208,17 +223,37 @@ fun context_to_classifier (Inv (path,string_opt,term)) model =
in
(
case c of
(Class {name,parent,attributes,operations,associationends,interfaces,stereotypes,invariant,thyname,activity_graphs}) =>
(Class {name,parent,attributes,operations,associations,interfaces,stereotypes,invariant,thyname,activity_graphs}) =>
(
case attrorassoc of
init =>
Class
{name = name,
parent = parent,
attributes = add_attribute (List.last path,term) (attributes),
operations = operations,
associations = associations,
interfaces = interfaces,
stereotypes = stereotypes,
invariant = invariant,
thyname = thyname,
activity_graphs = activity_graphs
}
| derive => raise NotYetSupportedError ("derive not yet supported ... sorry" ^ "\n")
| def => raise NotYetSupportedError ("def not yet supported ... sorry" ^ "\n")
)
| (AssociationClass {name,parent,attributes,operations,associations,association,interfaces,stereotypes,invariant,thyname,activity_graphs}) =>
(
case attrorassoc of
init =>
AssociationClass
{
name = name,
parent = parent,
attributes = add_attribute (List.last path,term) (attributes),
operations = operations,
associationends = associationends,
associations = associations,
association = association,
interfaces = interfaces,
stereotypes = stereotypes,
invariant = invariant,
@ -241,20 +276,35 @@ fun context_to_classifier (Inv (path,string_opt,term)) model =
in
(
case c of
(Class {name,parent,attributes,operations,associationends,interfaces,stereotypes,invariant,thyname,activity_graphs}) =>
(Class {name,parent,attributes,operations,associations,interfaces,stereotypes,invariant,thyname,activity_graphs}) =>
Class
{
name = name,
parent = parent,
attributes = attributes,
operations = add_operations cond_type (op_name,cond_name,term) operations,
associationends = associationends,
associations = associations,
interfaces = interfaces,
stereotypes = stereotypes,
invariant = invariant,
thyname = thyname,
activity_graphs = activity_graphs
}
| (AssociationClass {name,parent,attributes,operations,associations,association,interfaces,stereotypes,invariant,thyname,activity_graphs}) =>
AssociationClass
{
name = name,
parent = parent,
attributes = attributes,
operations = add_operations cond_type (op_name,cond_name,term) operations,
associations = associations,
association = association,
interfaces = interfaces,
stereotypes = stereotypes,
invariant = invariant,
thyname = thyname,
activity_graphs = activity_graphs
}
| (Interface {name,parents,operations,stereotypes,invariant,thyname}) =>
Interface
{

95
su4sml/src/ocl_parser/model_import.sml
View File

@ -42,13 +42,12 @@
signature MODEL_IMPORT =
sig
val parseUML : string -> Rep_Core.Classifier list
val parseUML : string -> Rep_Core.transform_model
val parseOCL : string -> Context.context list
val import : string -> string -> string list -> Rep_Core.Classifier list
val removePackages : (Rep_Core.Classifier list * Context.context list)
val import : string -> string -> string list -> Rep_Core.transform_model
val removePackages : (Rep_Core.transform_model * Context.context list)
-> string list
-> (Rep_Core.Classifier list * Context.context list)
-> (Rep_Core.transform_model * Context.context list)
val removeOclLibrary : Rep_Core.Classifier list -> Rep_Core.Classifier list
end
@ -64,6 +63,10 @@ open Context
open TypeChecker
open Update_Model
(* Rep_Transform *)
(* FIXME: library consolidation? *)
open Rep_Transform
(* Error logging *)
val high = 5
@ -71,7 +74,7 @@ val medium = 20
val low = 100
fun readFileUnNormalized f =
(RepParser.transformXMI o XmiParser.readFile) f
(RepParser.transformXMI_ext o XmiParser.readFile) f
fun importArgoUMLUnNormalized file =
let
@ -101,7 +104,7 @@ fun parseUML umlFile =
then importArgoUMLUnNormalized umlFile
else readFileUnNormalized umlFile
val _ = trace high ("### Finished Parsing UML Model ("
^(Int.toString(length umlModel))
^(Int.toString(length (#1 umlModel)))
^" Classifiers found)###\n\n")
in
umlModel
@ -122,7 +125,66 @@ fun parseOCL oclFile =
fun removePackages (uml,ocl) packageList =
let
fun filter_package model p = filter (fn cl => not (Rep_Core.package_of cl = p)) model
(* billk_tag
* filter package and update associations
* fun filter_package model p = filter (fn cl => not (Rep_Core.package_of cl = p)) model
*)
fun filter_package (all_classifiers,all_associations) p =
let
(* FIXME: correct handling for reflexive assocs + !isNavigable *)
fun valid_assoc {name,aends,aclass} = case aends of
[] => false
| [x] => false
| _ => true
fun update_association cls_name {name,aends,aclass}:Rep_Core.association =
let
val cls_path = Rep_OclType.path_of_OclType cls_name
val modified_aclass = if (cls_path = (valOf aclass))
then
NONE
else
aclass
val modified_aends = filter (fn {aend_type,...} => not (aend_type = cls_name)) aends
in
{name=name,
aends=modified_aends,
aclass=modified_aclass}
end
fun update_associationends ((Rep_Core.Class {name,associations,...}),assocs):Rep_Core.association list =
let
val assocs = map (get_association all_associations) associations
val modified_assocs = map (update_association name) assocs
in
filter valid_assoc modified_assocs
end
| update_associationends ((Rep_Core.AssociationClass{name,associations,association,...}),assocs) =
let
(* update_association also handles the aclass update *)
val assocs = map (get_association all_associations) (association::associations)
val modified_assocs = map (update_association name) assocs
in
filter valid_assoc modified_assocs
end
| update_associationends ((Rep_Core.Primitive{name,associations,...}),assocs) =
let
val assocs = map (get_association all_associations) associations
val modified_assocs = map (update_association name) assocs
in
filter valid_assoc modified_assocs
end
| update_associationends ((Rep_Core.Template{parameter,classifier}),assocs) =
(* FIXME: sound? *)
update_associationends (classifier,assocs)
| update_associationends (_,assocs) =
assocs
val (kept_classifiers,removed_cls) = partition (fn cl => not (Rep_Core.package_of cl = p)) all_classifiers
val kept_associations = case removed_cls of
[] => all_associations
| xs => foldl update_associationends all_associations xs
in
(kept_classifiers,kept_associations)
end
fun filter_cl_package cl p = filter (fn cl => not (package_of_context cl = p)) cl
val _ = trace high "### Excluding Packages ###\n"
val uml =
@ -138,8 +200,10 @@ fun removePackages (uml,ocl) packageList =
foldr (fn (p,m) => filter_cl_package m (stringToPath p)) ocl packageList
end
val _ = trace high ("### Finished excluding Packages ("
^(Int.toString(length uml))
^(Int.toString(length (#1 uml)))
^ " Classifiers found and "
^(Int.toString(length (#2 uml)))
^ " Associations found and "
^(Int.toString(length ocl))
^" Constraints Found) ###\n\n")
in
@ -164,22 +228,22 @@ fun import xmifile oclfile excludePackages =
let
val xmi = parseUML xmifile
val ocl = parseOCL oclfile
val (xmi,ocl) = removePackages (xmi,ocl) excludePackages
val ((xmi_cls,xmi_assocs),ocl) = removePackages (xmi,ocl) excludePackages
val model = case ocl of
[] => xmi
[] => xmi_cls
| ocl => let
val _ = trace high "### Preprocess Context List ###\n"
val fixed_ocl = Preprocessor.preprocess_context_list ocl ((OclLibrary.oclLib)@xmi)
val fixed_ocl = Preprocessor.preprocess_context_list ocl ((OclLibrary.oclLib)@xmi_cls)
val _ = trace high "### Finished Preprocess Context List ###\n\n"
val _ = trace high "### Type Checking ###\n"
val typed_cl = TypeChecker.check_context_list fixed_ocl ((OclLibrary.oclLib)@xmi);
val typed_cl = TypeChecker.check_context_list fixed_ocl (((OclLibrary.oclLib)@xmi_cls),xmi_assocs);
val _ = trace high "### Finished Type Checking ###\n\n"
val _ = print"### Updating Classifier List ###\n"
val model = Update_Model.gen_updated_classifier_list typed_cl ((OclLibrary.oclLib)@xmi);
val model = Update_Model.gen_updated_classifier_list typed_cl ((OclLibrary.oclLib)@xmi_cls);
val _ = trace high ("### Finished Updating Classifier List "
^(Int.toString(length model))
^ " Classifiers found (11 from 'oclLib') ###\n")
@ -195,7 +259,8 @@ fun import xmifile oclfile excludePackages =
end
in
model
(* FIXME: propagate associations into the ocl_parser *)
(model,xmi_assocs)
end
end

66
su4sml/src/ocl_parser/type_checker.sml
View File

@ -54,11 +54,11 @@ sig
exception IterateAccumulatorTypeError of string
exception IterateTypeMissMatch of string
val check_context_list : Context.context list -> Rep_Core.Classifier list -> Context.context option list
val check_context : Context.context -> Rep_Core.Classifier list -> Context.context option
val resolve_OclTerm : Rep_OclTerm.OclTerm -> Rep_Core.Classifier list -> Rep_OclTerm.OclTerm
val resolve_CollectionPart : Rep_Core.Classifier list -> Rep_OclTerm.CollectionPart -> Rep_OclTerm.CollectionPart
val resolve_arguments : (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_Core.Classifier list -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list
val check_context_list : Context.context list -> Rep_Core.transform_model -> Context.context option list
val check_context : Context.context -> Rep_Core.transform_model -> Context.context option
val resolve_OclTerm : Rep_OclTerm.OclTerm -> Rep_Core.transform_model -> Rep_OclTerm.OclTerm
val resolve_CollectionPart : Rep_Core.transform_model -> Rep_OclTerm.CollectionPart -> Rep_OclTerm.CollectionPart
val resolve_arguments : (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_Core.transform_model -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list
end
structure TypeChecker:TYPECHECKER =
@ -84,8 +84,8 @@ exception NoSuchIteratorNameError of Rep_OclTerm.OclTerm * string
exception TypeCheckerResolveIfError of Rep_OclTerm.OclTerm * string
exception NotYetSupportedError of string
exception WrongContextChecked of context
exception AsSetError of (OclTerm * string list * int * (OclTerm * OclType) list * Classifier list)
exception DesugaratorCall of (OclTerm * string list * int * (OclTerm * OclType) list * Classifier list)
exception AsSetError of (OclTerm * string list * int * (OclTerm * OclType) list * Rep_Core.transform_model)
exception DesugaratorCall of (OclTerm * string list * int * (OclTerm * OclType) list * Rep_Core.transform_model)
exception IterateError of string
exception IterateAccumulatorTypeError of string
exception IterateTypeMissMatch of string
@ -109,7 +109,7 @@ fun check_argument_type [] [] = true
(* RETURN: OclTerm (OperationCall/AttributeCall) *)
fun FromSet_desugarator rterm path attr_or_meth rargs model =
fun FromSet_desugarator rterm path attr_or_meth rargs (model as (cls,assocs)) =
if (attr_or_meth = 0)
then (* OperationCall *)
let
@ -117,7 +117,7 @@ fun FromSet_desugarator rterm path attr_or_meth rargs model =
val _ = trace low ("\n==> FromSet-desugarator: operation ... \n")
val new_type = template_parameter (type_of_term rterm)
val iterVar = (("anonIterVar_" ^ (varcounter.nextStr())),new_type)
val class = get_classifier (Variable (iterVar)) model
val class = get_classifier (Variable (iterVar)) cls
val ops = get_overloaded_methods class (List.last path) model
in
if (List.length ops = 0)
@ -136,7 +136,7 @@ fun FromSet_desugarator rterm path attr_or_meth rargs model =
val _ = trace low ("\n==> FromSet-desugarator: attribute/assocend ... \n")
val new_type = template_parameter (type_of_term rterm)
val iterVar = (("anonIterVar_" ^ (varcounter.nextStr())),new_type)
val class = get_classifier (Variable (iterVar)) model
val class = get_classifier (Variable (iterVar)) cls
val attrs_or_assocs = get_overloaded_attrs_or_assocends class (List.last path) model
in
if (List.length attrs_or_assocs = 0)
@ -177,14 +177,14 @@ fun FromSet_desugarator rterm path attr_or_meth rargs model =
end
(* RETURN: OclTerm (OperationCall/AttributeCall) *)
fun AsSet_desugarator rterm path attr_or_meth rargs model =
fun AsSet_desugarator rterm path attr_or_meth rargs (model as (cls,assocs)) =
if (attr_or_meth = 0)
then (* OperationCall *)
let
val _ = trace low ("\n==> AsSet-desugarator: operation ... \n")
val rtyp = Set(type_of_term rterm)
val _ = trace low ("Type of source term " ^ string_of_OclType rtyp ^ " ---> try Set(" ^ string_of_OclType rtyp ^ ")\n")
val class = get_classifier (Variable ("anonIterVar_" ^ (varcounter.nextStr()),rtyp)) model
val class = get_classifier (Variable ("anonIterVar_" ^ (varcounter.nextStr()),rtyp)) cls
val ops = get_overloaded_methods class (List.last path) model
val new_rterm = CollectionLiteral([CollectionItem(rterm,type_of_term rterm)],rtyp)
in
@ -199,7 +199,7 @@ fun AsSet_desugarator rterm path attr_or_meth rargs model =
val _ = trace low ("\n==> AsSet-desugarator: attribute/assocend\n")
val rtyp = Set(type_of_term rterm)
val _ = trace low (string_of_OclType rtyp ^ "\n")
val class = get_classifier (Variable ("anonIterVar_" ^ (varcounter.nextStr()),Set(rtyp))) model
val class = get_classifier (Variable ("anonIterVar_" ^ (varcounter.nextStr()),Set(rtyp))) cls
val attrs = get_overloaded_attrs_or_assocends class (List.last path) model
(* source term is a dummy-Term *)
val new_rterm = CollectionLiteral([CollectionItem(rterm,type_of_term rterm)],rtyp)
@ -287,7 +287,7 @@ and resolve_OclTerm (Literal (s,typ)) model =
in
(resolve_OclTerm term model)
end
| resolve_OclTerm (AttributeCall (term,_,attr_path,_)) model =
| resolve_OclTerm (AttributeCall (term,_,attr_path,_)) (model as (cls,assocs)) =
let
val _ = trace medium ("RESOLVE AttributeCall: attribute name: " ^ (List.last attr_path) ^ "\n")
(* resolve source term *)
@ -312,10 +312,10 @@ and resolve_OclTerm (Literal (s,typ)) model =
val rtyp = type_of_term rterm
val _ = trace low (string_of_OclType rtyp ^ "\n")
val templ_type = template_parameter rtyp
val pclass = get_classifier (Variable ("x",templ_type)) model
val pclass = get_classifier (Variable ("x",templ_type)) cls
val ntempl_type = type_of_parent pclass
val new_type = replace_templ_para rtyp ntempl_type
val new_class = get_classifier (Variable ("x",new_type)) model
val new_class = get_classifier (Variable ("x",new_type)) cls
val attrs = get_overloaded_attrs_or_assocends new_class (List.last attr_path) model
val _ = trace low ("parent type of term:" ^ string_of_OclType new_type ^ "\n")
in
@ -332,7 +332,7 @@ and resolve_OclTerm (Literal (s,typ)) model =
(* built in Operations not include in Library: oclIsKindOf, oclIsTypOf, oclAsType *)
(* OperationWithType Calls *)
(* OCLISTYPEOF *)
| resolve_OclTerm (OperationCall (term,_,["oclIsTypeOf"],[(AttributeCall (Variable ("self",vtyp),_,[real_typ], _),argt)],_)) model =
| resolve_OclTerm (OperationCall (term,_,["oclIsTypeOf"],[(AttributeCall (Variable ("self",vtyp),_,[real_typ], _),argt)],_)) (model as (cls,assocs)) =
let
(* prefix type of iterator variable *)
@ -344,7 +344,7 @@ let
val _ = trace low ("res OpCall: oclIsTypeOf 3: " ^ "\n")
(* need to prefix the package *)
(* because parameter is written relativly *)
val class = get_classifier rterm model
val class = get_classifier rterm cls
val prfx = package_of class
val _ = trace low ("type of classifier: " ^ string_of_path prfx ^ "\n")
val ctyp = prefix_type prfx (string_to_type [real_typ])
@ -353,7 +353,7 @@ let
OperationWithType (rterm,rtyp,"oclIsTypeOf",ctyp,Boolean)
end
(* OCLISKINDOF *)
| resolve_OclTerm (OperationCall (term,_,["oclIsKindOf"],[(AttributeCall (Variable ("self",_),_,[real_typ], _),argt)],_)) model =
| resolve_OclTerm (OperationCall (term,_,["oclIsKindOf"],[(AttributeCall (Variable ("self",_),_,[real_typ], _),argt)],_)) (model as (cls,assocs)) =
let
val _ = trace medium ("RESOLVE OperationCallWithType: oclIsKindOf\n")
val rterm = resolve_OclTerm term model
@ -362,7 +362,7 @@ let
val _ = trace low ("res OpCall: oclIsKindOf 3:" ^ "... " ^ "\n")
(* need to prefix the package *)
(* because parameter is written relativly *)
val class = get_classifier rterm model
val class = get_classifier rterm cls
val prfx = package_of class
val _ = trace low ("type of classifier: " ^ string_of_path prfx ^ "\n")
val ctyp = prefix_type prfx (string_to_type [real_typ])
@ -371,7 +371,7 @@ let
OperationWithType (rterm,rtyp,"oclIsKindOf",ctyp,Boolean)
end
(* OCLASTYPE *)
| resolve_OclTerm (OperationCall (term,_,["oclAsType"],[(AttributeCall (Variable ("self",_),_,[real_typ], _),argt)],_)) model =
| resolve_OclTerm (OperationCall (term,_,["oclAsType"],[(AttributeCall (Variable ("self",_),_,[real_typ], _),argt)],_)) (model as (cls,assocs)) =
let
val _ = trace medium ("RESOLVE OperationCallWithType: oclIsKindOf\n")
val rterm = resolve_OclTerm term model
@ -380,7 +380,7 @@ let
val _ = trace low ("res OpCall: oclAsType 3:" ^ "... " ^ "\n")
(* need to prefix the package *)
(* because parameter is written relativly *)
val class = get_classifier rterm model
val class = get_classifier rterm cls
val prfx = package_of class
val _ = trace low ("type of classifier: " ^ string_of_path prfx ^ "\n")
val ctyp = prefix_type prfx (string_to_type [real_typ])
@ -399,7 +399,7 @@ let
in
OperationCall (rterm,rtyp,[OclLibPackage,"OclAny","atPre"],[],rtyp)
end
| resolve_OclTerm (OperationCall (term,typ,meth_path,args,res_typ)) model =
| resolve_OclTerm (OperationCall (term,typ,meth_path,args,res_typ)) (model as (cls,assocs)) =
let
val _ = trace medium ("RESOLVE OperatioCall: name = " ^ (List.last (meth_path)) ^ "\n")
(* resolve source term *)
@ -425,11 +425,11 @@ let
val rtyp = type_of_term rterm
val _ = trace low (string_of_OclType rtyp ^ "\n")
val templ_type = template_parameter rtyp
val pclass = get_classifier (Variable ("x",templ_type)) model
val pclass = get_classifier (Variable ("x",templ_type)) cls
val ntempl_type = type_of_parent pclass
val _ = trace low (string_of_OclType ntempl_type ^ "\n")
val new_type = replace_templ_para rtyp ntempl_type
val new_class = get_classifier (Variable ("x",new_type)) model
val new_class = get_classifier (Variable ("x",new_type)) cls
val ops = get_overloaded_methods new_class (List.last meth_path) model
val _ = trace low ("parent type of term: " ^ string_of_OclType new_type ^ "\n")
in
@ -444,7 +444,7 @@ let
end
end
(* Iterator *)
| resolve_OclTerm (Iterator (name,iter_vars,source_term,_,expr,expr_typ,res_typ)) model =
| resolve_OclTerm (Iterator (name,iter_vars,source_term,_,expr,expr_typ,res_typ)) (model as (cls,assocs)) =
let
(* resolve source term, type *)
val _ = trace low ("RESOLVE Itertor: name = " ^ name ^ "\n")
@ -452,7 +452,7 @@ end
val rtyp = type_of_term rterm
val _ = trace low ("res Iter (" ^ name ^ "): source type " ^ string_of_OclType (type_of_term rterm) ^ "\n\n")
(* get source classifier *)
val source_class = get_classifier rterm model
val source_class = get_classifier rterm cls
val _ = trace low ("res Iter (" ^ name ^ "): type of classifier: " ^ string_of_OclType (type_of source_class) ^ "\n")
(* prefix types *)
val prfx = (package_of_template_parameter (type_of source_class))
@ -501,7 +501,7 @@ end
else
raise IteratorTypeMissMatch (Iterator (name,iter_vars,source_term,DummyT,expr,expr_typ,res_typ),("Iterator variable doesn't conform to choosen set \n"))
end
| resolve_OclTerm (Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) model =
| resolve_OclTerm (Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) (model as (cls,assocs)) =
let
(* resolve source term, type *)
val _ = trace medium ("RESOLVE Iterate: accumulator " ^ acc_var_name ^ "\n")
@ -509,7 +509,7 @@ let
val rtyp = type_of_term rterm
val _ = trace medium ("res Iterate: source type " ^ string_of_OclType (type_of_term rterm) ^ "\n\n")
(* get source classifier *)
val source_class = get_classifier rterm model
val source_class = get_classifier rterm cls
val _ = trace medium ("res Iterate: type of classifier: " ^ string_of_OclType (type_of source_class) ^ "\n")
(* prefix types *)
val prfx = (package_of_template_parameter (type_of source_class))
@ -600,11 +600,11 @@ let
(* RETURN: context option *)
fun check_context (Cond (path,op_name,op_sign,result_type,cond,pre_name,expr)) model =
fun check_context (Cond (path,op_name,op_sign,result_type,cond,pre_name,expr)) (model as (cls,assocs)) =
let
val _ = trace high ("Starts typechecking: ")
val _ = trace high ("pre/post/body : " ^ Ocl2String.ocl2string false expr ^ "\n")
val classifier = class_of_type (Classifier (path)) model
val classifier = class_of_type (Classifier (path)) cls
val oper_list = operations_of classifier
val oper = find_operation op_name oper_list
val check1 = (op_sign = (#arguments oper))
@ -619,11 +619,11 @@ in
NONE
end
| check_context (Attr (path,typ,attrorassoc,expr)) model =
| check_context (Attr (path,typ,attrorassoc,expr)) (model as (cls,assocs)) =
let
val _ = trace high ("Starts typechecking: ")
val _ = trace high ("init/derive : " ^ Ocl2String.ocl2string false expr ^ "\n")
val classifier = class_of_type (Classifier (real_path path)) model
val classifier = class_of_type (Classifier (real_path path)) cls
val _ = trace low ( "classifier found ... " ^ "\n")
val attr_list = attributes_of classifier
val _ = trace low ( "attr_list found ... " ^ "\n")

6
su4sml/src/rep.sml
View File

@ -47,7 +47,8 @@ include REP_CORE
include REP_ACTIVITY_GRAPH
include OCL_LIBRARY
type Model = Classifier list
(*type Model = Classifier list*)
type Model = Classifier list * association list
end
@ -57,6 +58,7 @@ struct
open Rep_Core Rep_StateMachine Rep_ActivityGraph
open OclLibrary
type Model = Classifier list
(*type Model = Classifier list *)
type Model = Classifier list * association list
end

308
su4sml/src/rep_core.sml
View File

@ -55,8 +55,8 @@ type operation = { name : string,
visibility : Visibility
}
type associationend = {name : string,
aend_type : Rep_OclType.OclType,
type associationend = {name : Rep_OclType.Path (* path_of_association @ [aend_name]*),
aend_type : Rep_OclType.OclType, (* participant type *)
multiplicity: (int * int) list,
ordered: bool,
visibility: Visibility,
@ -72,19 +72,45 @@ type attribute = {
init : Rep_OclTerm.OclTerm option
}
type association = { name: Rep_OclType.Path (* path_of_package @ [assoc_name] *),
aends: associationend list,
aclass: Rep_OclType.Path option
}
type constraint = (string option * Rep_OclTerm.OclTerm)
datatype Classifier =
Class of
{ name : Rep_OclType.OclType,
parent : Rep_OclType.OclType option,
attributes : attribute list,
operations : operation list,
associationends : associationend list,
associations: Rep_OclType.Path list (* associations *),
invariant : (string option * Rep_OclTerm.OclTerm) list,
stereotypes : string list,
interfaces : Rep_OclType.OclType list,
thyname : string option,
activity_graphs : Rep_ActivityGraph.ActivityGraph list
}
| AssociationClass of (* billk_tag *)
{ name : Rep_OclType.OclType,
parent : Rep_OclType.OclType option,
attributes : attribute list,
operations : operation list,
invariant : (string option * Rep_OclTerm.OclTerm) list,
stereotypes : string list,
interfaces : Rep_OclType.OclType list,
thyname : string option,
activity_graphs : Rep_ActivityGraph.ActivityGraph list,
(* visibility : Visibility,
isActive : bool,
generalizations : string list,
taggedValue : TaggedValue list,
clientDependency : string list,
supplierDependency : string list,
*) associations: Rep_OclType.Path list,
association: Rep_OclType.Path
}
| Interface of (* not supported yet *)
{ name : Rep_OclType.OclType,
parents : Rep_OclType.OclType list,
@ -107,7 +133,7 @@ datatype Classifier =
{ name : Rep_OclType.OclType,
parent : Rep_OclType.OclType option,
operations : operation list,
associationends : associationend list,
associations: Rep_OclType.Path list,
invariant : (string option * Rep_OclTerm.OclTerm) list,
stereotypes : string list,
interfaces : Rep_OclType.OclType list,
@ -118,10 +144,13 @@ datatype Classifier =
classifier : Classifier
}
type transform_model = (Classifier list * association list)
val OclAnyC : Classifier
val normalize : Classifier -> Classifier
val normalize : association list -> Classifier -> Classifier
val normalize_init : Classifier -> Classifier
val normalize_ext : transform_model -> transform_model
val name_of : Classifier -> Rep_OclType.Path
val type_of : Classifier -> Rep_OclType.OclType
@ -136,7 +165,10 @@ val parent_interfaces_of : Classifier -> Rep_OclType.OclType list
val thy_name_of : Classifier -> string
val attributes_of : Classifier -> attribute list
val associationends_of: Classifier -> associationend 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 operations_of : Classifier -> operation list
val invariant_of : Classifier -> (string option * Rep_OclTerm.OclTerm) list
val stereotypes_of : Classifier -> string list
@ -156,9 +188,13 @@ val parent_of : Classifier -> Classifier list -> Classifier
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 : Classifier -> 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
val assoc_to_attr_type : associationend -> Rep_OclType.OclType
(* billk_tag *)
(* changed assoc to aend, since associations are now part of the model *)
val aend_to_attr_type : associationend -> Rep_OclType.OclType
val update_thyname : string -> Classifier -> Classifier
val update_invariant : (string option * Rep_OclTerm.OclTerm) list -> Classifier -> Classifier
@ -167,6 +203,7 @@ val update_operations : operation list -> Classifier -> Classifier
val update_precondition : (string option * Rep_OclTerm.OclTerm) list -> operation -> operation
val update_postcondition : (string option * Rep_OclTerm.OclTerm) list -> operation -> operation
end
structure Rep_Core : REP_CORE =
@ -188,7 +225,7 @@ type operation = { name : string,
scope : Scope }
type associationend = {
name : string,
name : Rep_OclType.Path,
aend_type : Rep_OclType.OclType,
multiplicity : (int*int) list,
visibility : Visibility,
@ -206,7 +243,12 @@ type attribute = {
}
type association = { name: Rep_OclType.Path,
aends: associationend list,
aclass: Rep_OclType.Path option
}
type constraint = (string option * Rep_OclTerm.OclTerm)
datatype Classifier =
Class of
@ -214,13 +256,32 @@ datatype Classifier =
parent : Rep_OclType.OclType option,
attributes : attribute list,
operations : operation list,
associationends : associationend list,
associations: Rep_OclType.Path list,
invariant : (string option * Rep_OclTerm.OclTerm) list,
stereotypes : string list,
interfaces : Rep_OclType.OclType list,
thyname : string option,
activity_graphs : Rep_ActivityGraph.ActivityGraph list
}
| AssociationClass of (* billk_tag *)
{ name : Rep_OclType.OclType,
parent : Rep_OclType.OclType option,
attributes : attribute list,
operations : operation list,
invariant : (string option * Rep_OclTerm.OclTerm) list,
stereotypes : string list,
interfaces : Rep_OclType.OclType list,
thyname : string option,
activity_graphs : Rep_ActivityGraph.ActivityGraph list,
(* visibility : Visibility,
isActive : bool,
generalizations : string list,
taggedValue : TaggedValue list,
clientDependency : string list,
supplierDependency : string list,
*) associations: Rep_OclType.Path list,
association: Rep_OclType.Path
}
| Interface of (* not supported yet *)
{ name : Rep_OclType.OclType,
parents : Rep_OclType.OclType list,
@ -243,7 +304,7 @@ datatype Classifier =
{ name : Rep_OclType.OclType,
parent : Rep_OclType.OclType option,
operations : operation list,
associationends : associationend list,
associations: Rep_OclType.Path list,
invariant : (string option * Rep_OclTerm.OclTerm) list,
stereotypes : string list,
interfaces : Rep_OclType.OclType list,
@ -254,29 +315,49 @@ datatype Classifier =
classifier : Classifier
}
type transform_model = (Classifier list * association list)
(* convert an association end into the corresponding collection type *)
fun assoc_to_attr_type {name,aend_type,multiplicity,ordered,visibility,init} =
fun aend_to_attr_type ({name,aend_type,multiplicity,ordered,visibility,init}:associationend) =
case multiplicity of
[(0,1)] => aend_type
| [(1,1)] => aend_type
| _ =>if ordered then Rep_OclType.Sequence aend_type (* OrderedSet? *)
else Rep_OclType.Set aend_type
(* convert an association end into an attribute of the *)
(* corresponding collection type *)
(* original version
fun assoc_to_attr (assoc:associationend) = {name = #name assoc,
attr_type = assoc_to_attr_type assoc,
visibility = #visibility assoc,
scope = XMI.InstanceScope,
stereotypes = nil,
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),
attr_type = aend_to_attr_type aend,
visibility = #visibility aend,
scope = XMI.InstanceScope,
stereotypes = nil,
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) =
let val cls = Rep_OclType.Classifier cls_name
val attr_type = assoc_to_attr_type aend
val attr_name = cls_name@[#name aend]
val attr_type = aend_to_attr_type aend
val attr_name = cls_name@[List.last (#name aend)]
val literal_a = Rep_OclTerm.Literal (Int.toString a, Rep_OclType.Integer)
val literal_b = Rep_OclTerm.Literal (Int.toString b, Rep_OclType.Integer)
val self = Rep_OclTerm.Variable ("self",cls)
@ -314,13 +395,13 @@ fun range_to_inv cls_name aend (a,b) =
(* 2. consistency constraints between opposing association ends *)
(* i.e., A.b.a->includes(A) *)
(* FIXME: 2. is not implemented yet... *)
fun assoc_to_inv cls_name (aend:associationend) =
let val inv_name = "multconstraint_for_aend_"^(#name aend)
fun aend_to_inv cls_name (aend:associationend) =
let val inv_name = "multconstraint_for_aend_"^string_of_path (#name aend)
val range_constraints = case (#multiplicity aend) of
[(0,1)] => []
| [(1,1)] => let
val attr_name = cls_name@[#name aend]
val attr_type = assoc_to_attr_type aend
val attr_name = cls_name@[List.last (#name aend)]
val attr_type = aend_to_attr_type aend
val cls = Rep_OclType.Classifier cls_name
val self = Rep_OclTerm.Variable ("self",cls)
val attribute = Rep_OclTerm.AttributeCall (self,cls,attr_name,attr_type)
@ -341,37 +422,72 @@ fun assoc_to_inv cls_name (aend:associationend) =
end
fun association_to_associationends (associations:association list) (assoc:Path):associationend list=
(* FIXME: only return opposite association ends*)
let
val assoc = filter (fn {name,...} => name=assoc ) associations
val aends = if (List.length assoc) > 1 then error ("in association_to_associationends: non-unique association name")
else #aends (hd assoc)
in
aends
end
(* billk_tag *)
(** find the associations belonging to a classifier *)
fun associationends_of (all_associations:association list) (Class{associations,...}):associationend list=
List.concat (map (association_to_associationends all_associations) associations)
| associationends_of all_associations (AssociationClass{associations,association,...}) =
(* association only contains endpoints to the other, pure clases *)
List.concat (map (association_to_associationends all_associations) (association::associations))
| associationends_of all_associations (Primitive{associations,...}) =
List.concat (map (association_to_associationends all_associations) associations)
| associationends_of _ _ = error ("in associationends_of: This classifier has no associationends") (*FIXME: or rather []? *)
(* convert association ends into attributes + invariants *)
fun normalize (Class {name,parent,attributes,operations,associationends,invariant,
stereotypes,interfaces,thyname,activity_graphs}) =
(** convert association ends into attributes + invariants *)
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 assoc_to_attr associationends)
attributes),
attributes = (append (map (aend_to_attr (string_of_path (path_of_OclType name)))
(associationends_of all_associations C)) attributes),
operations = operations,
associationends = nil,
invariant = append (map (assoc_to_inv (path_of_OclType name)) associationends)
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}
| normalize (Primitive p) =
| normalize all_associations (AC as (AssociationClass {name,parent,attributes,association,associations,operations,invariant,
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? *)}
| normalize all_associations (Primitive p) =
(* Primitive's do not have attributes, so we have to convert *)
(* them into Classes... *)
if (#associationends p) = []
if (#associations p) = []
then Primitive p
else normalize (Class {name = #name p, parent = #parent p, attributes=[],
else normalize all_associations (Class {name = #name p, parent = #parent p, attributes=[],
operations = #operations p, invariant = #invariant p,
associationends = #associationends p,
associations = #associations p,
stereotypes = #stereotypes p,
interfaces = #interfaces p,
thyname = #thyname p,
activity_graphs=nil})
| normalize c = c
| normalize all_associations c = c
fun rm_init_attr (attr:attribute) = {
@ -410,31 +526,51 @@ fun init_to_inv cls_name (attr:attribute) =
end
fun normalize_init (Class {name,parent,attributes,operations,associationends,invariant,
fun normalize_init (Class {name,parent,attributes,operations,associations,invariant,
stereotypes,interfaces,thyname,activity_graphs}) =
Class {name = name,
parent = parent,
attributes = (map rm_init_attr attributes),
operations = operations,
associationends = nil,
associations = nil,
invariant = append (map (init_to_inv (path_of_OclType name)) attributes)
invariant,
stereotypes = stereotypes,
interfaces = interfaces,
thyname = thyname,
activity_graphs=activity_graphs}
| normalize_init (AssociationClass {name,parent,attributes,operations,associations,association,
invariant,stereotypes,interfaces,thyname,activity_graphs}) =
AssociationClass {name = name,
parent = parent,
attributes = (map rm_init_attr attributes),
operations = operations,
associations = nil,
association = []:Path (* FIXME: better dummy? *),
invariant = append (map (init_to_inv (path_of_OclType name)) attributes)
invariant,
stereotypes = stereotypes,
interfaces = interfaces,
thyname = thyname,
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)
val OclAnyC = Class{name=Rep_OclType.OclAny,parent=NONE,attributes=[],
operations=[], interfaces=[],
invariant=[],stereotypes=[], associationends=[],
invariant=[],stereotypes=[], associations=[],
thyname=NONE,
activity_graphs=nil}
val OclAnyAC = AssociationClass{name=Rep_OclType.OclAny,parent=NONE,attributes=[],
operations=[], interfaces=[],
invariant=[],stereotypes=[], associations=[],
association= []:Path (* FIXME: sensible dummy *),
thyname=NONE,
activity_graphs=nil}
fun string_of_path (path:Rep_OclType.Path) = case path of
[] => ""
@ -444,10 +580,15 @@ fun string_of_path (path:Rep_OclType.Path) = case path of
fun update_thyname tname (Class{name,parent,attributes,operations,invariant,
stereotypes,interfaces,associationends,activity_graphs,...})
stereotypes,interfaces,associations,activity_graphs,...})
= Class{name=name,parent=parent,attributes=attributes,operations=operations,
associationends=associationends,invariant=invariant,stereotypes=stereotypes,
associations=associations,invariant=invariant,stereotypes=stereotypes,
interfaces=interfaces,thyname=(SOME tname),activity_graphs=activity_graphs }
| update_thyname tname (AssociationClass{name,parent,attributes,operations,invariant,stereotypes,
interfaces,associations,association,activity_graphs,...})
= AssociationClass{name=name,parent=parent,attributes=attributes,operations=operations,
associations=associations,association=association,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)}
@ -456,17 +597,23 @@ fun update_thyname tname (Class{name,parent,attributes,operations,invariant,
= 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,
| update_thyname tname (Primitive{name,parent,operations,associations,invariant,
stereotypes,interfaces,...})
= Primitive{name=name,parent=parent,operations=operations,
associationends=associationends,invariant=invariant,
associations=associations,invariant=invariant,
stereotypes=stereotypes,interfaces=interfaces,thyname=(SOME tname)}
| update_thyname _ (Template T) = error ("in update_thyname: Template does not have a theory")
fun update_invariant invariant' (Class{name,parent,attributes,operations,invariant,
stereotypes,interfaces,associationends,activity_graphs,thyname})
stereotypes,interfaces,associations,activity_graphs,thyname})
= Class{name=name,parent=parent,attributes=attributes,operations=operations,
associationends=associationends,invariant=invariant',stereotypes=stereotypes,
associations=associations,invariant=invariant',stereotypes=stereotypes,
interfaces=interfaces,thyname=thyname,activity_graphs=activity_graphs }
| update_invariant invariant' (AssociationClass{name,parent,attributes,operations,invariant,stereotypes,
interfaces,association,associations,activity_graphs,thyname})
= AssociationClass{name=name,parent=parent,attributes=attributes,operations=operations,
associations=associations,association=association,invariant=invariant',
stereotypes=stereotypes,interfaces=interfaces,thyname=thyname,activity_graphs=activity_graphs }
| update_invariant invariant' (Interface{name,parents,operations,stereotypes,invariant,thyname})
= Interface{name=name,parents=parents,operations=operations,stereotypes=stereotypes,
invariant=invariant',thyname=thyname}
@ -475,18 +622,24 @@ fun update_invariant invariant' (Class{name,parent,attributes,operations,invaria
= Enumeration{name=name,parent=parent,operations=operations,literals=literals,
invariant=invariant',stereotypes=stereotypes,interfaces=interfaces,
thyname=thyname}
| update_invariant invariant' (Primitive{name,parent,operations,associationends,invariant,
| update_invariant invariant' (Primitive{name,parent,operations,associations,invariant,
stereotypes,interfaces,thyname})
= Primitive{name=name,parent=parent,operations=operations,
associationends=associationends,invariant=invariant',
associations=associations,invariant=invariant',
stereotypes=stereotypes,interfaces=interfaces,thyname=thyname}
| update_invariant _ (Template T) = error ("in update_invariant: Template does not have an invariant")
fun update_operations operations' (Class{name,parent,attributes,invariant,operations,
stereotypes,interfaces,associationends,activity_graphs,thyname})
stereotypes,interfaces,associations,activity_graphs,thyname})
= Class{name=name,parent=parent,attributes=attributes,invariant=invariant,
associationends=associationends,operations=operations',stereotypes=stereotypes,
associations=associations,operations=operations',stereotypes=stereotypes,
interfaces=interfaces,thyname=thyname,activity_graphs=activity_graphs }
| update_operations operations' (AssociationClass{name,parent,attributes,invariant,operations,stereotypes,
interfaces,associations,association,activity_graphs,thyname})
= AssociationClass{name=name,parent=parent,attributes=attributes,invariant=invariant,
associations=associations,association=association,operations=operations',stereotypes=stereotypes,
interfaces=interfaces,thyname=thyname,activity_graphs=activity_graphs }
| update_operations operations' (Interface{name,parents,invariant,stereotypes,operations,thyname})
= Interface{name=name,parents=parents,invariant=invariant,stereotypes=stereotypes,
operations=operations',thyname=thyname}
@ -495,14 +648,14 @@ fun update_operations operations' (Class{name,parent,attributes,invariant,operat
= Enumeration{name=name,parent=parent,invariant=invariant,literals=literals,
operations=operations',stereotypes=stereotypes,interfaces=interfaces,
thyname=thyname}
| update_operations operations' (Primitive{name,parent,invariant,associationends,operations,
| update_operations operations' (Primitive{name,parent,invariant,associations,operations,
stereotypes,interfaces,thyname})
= Primitive{name=name,parent=parent,invariant=invariant,
associationends=associationends,operations=operations',
associations=associations,operations=operations',
stereotypes=stereotypes,interfaces=interfaces,thyname=thyname}
| update_operations _ (Template T) = error ("in update_operations: Template does not have operations")
fun update_precondition pre' ({name,precondition,postcondition,body,arguments,result,isQuery,scope,visibility}:operation)
= ({name=name,precondition=pre',postcondition=postcondition,
arguments=arguments,body=body,result=result,isQuery=isQuery,scope=scope,
@ -516,6 +669,7 @@ fun update_postcondition post' ({name,precondition,postcondition,body,arguments,
fun type_of (Class{name,...}) = name
| type_of (AssociationClass{name,...}) = name
| type_of (Interface{name,...}) = name
| type_of (Enumeration{name,...}) = name
| type_of (Primitive{name,...}) = name
@ -523,6 +677,7 @@ fun type_of (Class{name,...}) = name
fun name_of (Class{name,...}) = path_of_OclType name
| name_of (AssociationClass{name,...}) = path_of_OclType name
| name_of (Interface{name,...}) = path_of_OclType name
| name_of (Enumeration{name,...}) = path_of_OclType name
| name_of (Primitive{name,...}) = path_of_OclType name
@ -533,6 +688,7 @@ fun short_name_of C = case (name_of C) of
| p => (hd o rev) p
fun stereotypes_of (Class{stereotypes,...}) = stereotypes
| stereotypes_of (AssociationClass{stereotypes,...}) = stereotypes
| stereotypes_of (Interface{stereotypes,...}) = stereotypes
| stereotypes_of (Enumeration{stereotypes,...}) = stereotypes
| stereotypes_of (Primitive{stereotypes,...}) = stereotypes
@ -545,6 +701,10 @@ fun package_of (Class{name,...}) = if (length (path_of_OclType name)) > 1
then take (((length (path_of_OclType name)) -1),
(path_of_OclType name))
else []
| package_of (AssociationClass{name,...}) = if (length (path_of_OclType name)) > 1
then take (((length (path_of_OclType name)) -1),
(path_of_OclType name))
else []
| package_of (Interface{name,...}) = if (length (path_of_OclType name)) > 1
then take (((length (path_of_OclType name)) -1),
(path_of_OclType name))
@ -562,6 +722,9 @@ fun package_of (Class{name,...}) = if (length (path_of_OclType name)) > 1
fun parent_name_of (C as Class{parent,...}) =
(case parent of NONE => name_of OclAnyC
| SOME p => path_of_OclType p )
| parent_name_of (AC as AssociationClass{parent,...}) =
(case parent of NONE => name_of OclAnyAC
| SOME p => path_of_OclType p )
| parent_name_of (Interface{...}) = error "in Rep.parent_name_of: \
\unsupported argument type Interface"
| parent_name_of (E as Enumeration{parent,...}) =
@ -588,6 +751,13 @@ fun parent_package_of (Class{parent,...}) =
then (take (((length p) -1),p))
else []
end)
| parent_package_of (AssociationClass{parent,...}) =
(case parent of NONE => package_of OclAnyC
| SOME q => let val p = path_of_OclType q in
if (length p) > 1
then (take (((length p) -1),p))
else []
end)
| parent_package_of (Interface{...}) =
error "in Rep.parent_package_of: unsupported argument type Interface"
| parent_package_of (E as Enumeration{parent,...}) =
@ -614,6 +784,7 @@ fun parent_package_of (Class{parent,...}) =
(* Get parent interfaces of a Classifier. *)
fun parent_interfaces_of (Interface{parents,...}) = parents
| parent_interfaces_of (Class{interfaces,...}) = interfaces
| parent_interfaces_of (AssociationClass{interfaces,...}) = interfaces
| parent_interfaces_of (Enumeration{interfaces,...}) = interfaces
| parent_interfaces_of (Primitive{interfaces,...}) = interfaces
| parent_interfaces_of (Template{...}) = error "parent_interfaces_of <Template> not supported"
@ -622,6 +793,7 @@ fun parent_interfaces_of (Interface{parents,...}) = parents
fun parent_interface_names_of c = map path_of_OclType (parent_interfaces_of c)
fun attributes_of (Class{attributes,...}) = attributes
| attributes_of (AssociationClass{attributes,...}) = attributes
| attributes_of (Interface{...}) =
error "in Rep.attributes_of: argument is Interface"
| attributes_of (Enumeration{...}) =
@ -630,16 +802,25 @@ fun attributes_of (Class{attributes,...}) = attributes
(* error "attributes_of <Primitive> not supported" *)
| attributes_of (Template{parameter,classifier}) = attributes_of classifier
fun associationends_of (Class{associationends,...}) = associationends
| associationends_of (Primitive{associationends,...}) = associationends
(* 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
| operations_of (Enumeration{operations,...}) = operations
| operations_of (Primitive{operations,...}) = operations
| operations_of (Template{parameter,classifier}) = operations_of classifier
fun p_invariant_of (Class{invariant,...}) = invariant
| p_invariant_of (AssociationClass{invariant,...}) = invariant
| p_invariant_of (Interface{invariant,...}) = invariant
| p_invariant_of (Enumeration{invariant,...}) = invariant
| p_invariant_of (Primitive{invariant,...}) = invariant
@ -683,6 +864,10 @@ 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 (AC as AssociationClass{thyname,...}) =
(case thyname of SOME tname => tname
| NONE => error ("AssociationClass "^((string_of_path o name_of) AC)^
" 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)
@ -742,20 +927,31 @@ fun topsort_cl cl =
foldl (op@) [] (map (fn a => sub cl a) (OclAny_subcl))
end
fun connected_classifiers_of (Class {attributes,associationends,...}) (cl:Classifier list) =
fun connected_classifiers_of (all_associations:association list) (C as Class {attributes,associations,...}) (cl:Classifier list) =
let val att_classifiers = List.mapPartial (fn (Classifier p) => SOME (class_of p cl)
| _ => NONE)
(map #attr_type attributes)
val aend_classifiers = List.mapPartial (fn (Classifier p) => SOME (class_of p cl)
| _ => NONE)
(map #aend_type associationends)
(map #aend_type (associationends_of all_associations C))
in
att_classifiers @ aend_classifiers
end
| connected_classifiers_of (Primitive {associationends,...}) (cl:Classifier list) =
| connected_classifiers_of all_associations (AC as AssociationClass {attributes,associations,association,...}) (cl:Classifier list) =
let val att_classifiers = List.mapPartial (fn (Classifier p) => SOME (class_of p cl)
| _ => NONE)
(map #attr_type attributes)
(* FIXME: correct handling for association classes? *)
val aend_classifiers = List.mapPartial (fn (Classifier p) => SOME (class_of p cl)
| _ => NONE)
(map #aend_type (associationends_of all_associations AC))
in
att_classifiers @ aend_classifiers
end
| connected_classifiers_of all_associations (P as Primitive {associations,...}) (cl:Classifier list) =
List.mapPartial (fn (Classifier p) => SOME (class_of p cl)
| _ => NONE)
(map #aend_type associationends)
| connected_classifiers_of _ _ = nil
(map #aend_type (associationends_of all_associations P))
| connected_classifiers_of _ _ _ = nil
end

41
su4sml/src/rep_ocl.sml
View File

@ -52,6 +52,7 @@ sig
| Classifier of Path | OclVoid | DummyT | TemplateParameter of string
val path_of_OclType : OclType -> Path
val collection_type_of_OclType : OclType -> OclType
val string_of_OclType : OclType -> string
val string_of_path : Path -> string
val string_of_OclType_colon : OclType -> string
@ -149,6 +150,13 @@ fun string_of_OclType' f Integer = "Integer"
| string_of_OclType' f DummyT = "DummyT"
| string_of_OclType' f (TemplateParameter s) = "TemplateParameter \""^s^"\""
fun collection_type_of_OclType (Set t) = t
| collection_type_of_OclType (Sequence t) = t
| collection_type_of_OclType (OrderedSet t) = t
| collection_type_of_OclType (Bag t) = t
| collection_type_of_OclType (Collection t) = t
fun string_of_OclType t = string_of_OclType' "." t
@ -235,6 +243,20 @@ fun type_of (Literal (_,t)) = t
| type_of (Iterate (_,_,_,_,_,_,_,_,t)) = t
| type_of (Iterator (_,_,_,_,_,_,t)) = t
(* or rather short_string_of ?*)
fun term_name_of (Literal _) = "Literal"
| term_name_of (CollectionLiteral _) = "CollectionLiteral"
| term_name_of (If _) = "If"
| term_name_of (AssociationEndCall _) = "AssociationEndCall"
| term_name_of (AttributeCall _) = "AttributeCall"
| term_name_of (OperationCall _) = "OperationCall"
| term_name_of (OperationWithType _) = "OperationWithType"
| term_name_of (Variable _) = "Variable"
| term_name_of (Let _) = "Let"
| term_name_of (Iterate _) = "Iterate"
| term_name_of (Iterator _) = "Iterator"
fun self t = Variable ("self",t)
fun result t = Variable ("result", t)
@ -274,6 +296,9 @@ fun ocl_implies a b = ocl_opcall a ["oclLib", "Boolean", "implies"] [b] Boolean
(* Integer: -,+,-,*,/,abs,div,mod,max,min *)
(* Real : -,+,-,*,/,abs,floor,round,max,min,<,>,<=,>= *)
(* String : size, concat, substring, toInteger, toReal *)
(* billk_tag *)
fun ocl_leq a b = ocl_opcall a ["oclLib", "Integer", "<="] [b] Boolean
fun ocl_geq a b = ocl_opcall a ["oclLib", "Integer", ">="] [b] Boolean
(* OclAny *)
fun ocl_eq a b = ocl_opcall a ["oclLib", "OclAny", "="] [b] Boolean
@ -300,10 +325,15 @@ fun ocl_asType a t = ocl_opwithtype a "oclAsType" t t
(* asSet,asOrderedSet *)
fun ocl_includes a b = ocl_opcall a ["oclLib", "Collection", "includes"] [b] Boolean
fun ocl_includesAll a b = ocl_opcall a ["oclLib", "Collection", "includesAll"] [b] Boolean
fun ocl_excludes a b = ocl_opcall a ["oclLib", "Collection", "excludes"] [b] Boolean
fun ocl_excludesAll a b = ocl_opcall a ["oclLib", "Collection", "excludesAll"] [b] Boolean
fun ocl_modifiedOnly a = ocl_opcall a ["oclLib", "Set", "modifiedOnly"] [] Boolean
(* billk_tag *)
fun ocl_size a = ocl_opcall a ["oclLib", "Collection", "size"] [] Integer
(* Collection constructors *)
fun ocl_set xs t = CollectionLiteral (map (fn x => CollectionItem (x, type_of x)) xs, Set t)
@ -321,6 +351,17 @@ fun ocl_collect source var body = Iterator ("collect", [(var,type_of source)],
body, type_of body,
Bag (type_of body))
(* billk_tag, using a Variable: type_of variable == type_of_source *)
fun ocl_forAll (source:OclTerm) (Variable variable) (body:OclTerm) = Iterator ("forAll", [variable],
source, type_of source,
body, type_of body,
Bag (type_of body))
fun ocl_select (source:OclTerm) (Variable variable) (body:OclTerm) = Iterator ("select", [variable],
source, type_of source,
body, type_of body,
Bag (type_of body))
fun atpre exp = ocl_opcall exp ["oclLib","OclAny","atPre"] nil (type_of exp)
end

287
su4sml/src/rep_parser.sml
View File

@ -42,8 +42,9 @@
structure RepParser :
sig
val transformXMI : XMI.XmiContent -> Rep.Classifier list
val readFile : string -> Rep.Classifier list
val importArgoUML : string -> Rep.Classifier list
val transformXMI_ext : XMI.XmiContent -> Rep.transform_model
val readFile : string -> Rep.Model
val importArgoUML : string -> Rep.Model
val test: (string * string list) -> OS.Process.status
(* generic exception if something is wrong *)
end =
@ -52,6 +53,12 @@ open library
open Xmi_IDTable
(* billk_tag *)
open Rep_OclTerm
open Rep_OclType
open Rep_OclHelper
open Rep_Core
(** thrown when something is not yet implemented *)
exception NotYetImplemented
@ -62,6 +69,7 @@ fun lowercase s = let val sl = String.explode s
String.implode ((Char.toLower (hd sl))::(tl sl))
end
(** transform an xmi ocl expression into a rep ocl term *)
fun transform_expression t (XMI.LiteralExp {symbol,expression_type}) =
Rep_OclTerm.Literal (symbol,find_classifier_type t expression_type)
@ -283,7 +291,7 @@ fun transform_attribute t ({xmiid,name,type_id,changeability,visibility,ordering
}
end
(* old
fun transform_aend t ({xmiid,name,ordering,multiplicity,participant_id,
isNavigable,aggregation,changeability,visibility,targetScope})
= {name = Option.getOpt(name,
@ -295,6 +303,20 @@ fun transform_aend t ({xmiid,name,ordering,multiplicity,participant_id,
visibility = visibility,
init = NONE (* FIX *)
}
*)
fun transform_aend t ({xmiid,name,association,ordering,multiplicity,participant_id,
isNavigable,aggregation,changeability,visibility,targetScope}:XMI.AssociationEnd):Rep.associationend =
let
val aend_path = path_of_associationend t xmiid
in
{name = aend_path,
aend_type = find_classifier_type t participant_id,
multiplicity = multiplicity,
ordered = if ordering = XMI.Ordered then true else false,
visibility = visibility,
init = NONE (* FIXME *)
}
end
val filter_named_aends = List.filter (fn {name=SOME _,...}:XMI.AssociationEnd => true
| _ => false)
@ -381,7 +403,9 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
supplierDependency,taggedValue,
classifierInState,activity_graphs,
state_machines}) =
let val parents = map ((find_classifier_type t) o (find_parent t))
let
val assocs = find_classifier_associations t xmiid
val parents = map ((find_classifier_type t) o (find_parent t))
generalizations
val filtered_parents = filter (fn x => x <> Rep_OclType.OclAny) parents
val filtered_parent = case filtered_parents
@ -392,15 +416,19 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
(Rep_OclType.string_of_OclType x)^"'.");
SOME x)
val checked_invariants = filter_exists t invariant
val navigable_aends = filter #isNavigable (find_aends t xmiid)
(* val navigable_aends = filter #isNavigable (find_aends t xmiid)*)
val class_type = find_classifier_type t xmiid
in
Rep.Class {name = (* path_of_classifier *) (find_classifier_type t xmiid),
parent = filtered_parent,
Rep.Class {name = (* type_of_classifier *) class_type,
parent = case filtered_parents
of [] => NONE
| xs => SOME ((* path_of_classifier *) (hd xs)),
attributes = map (transform_attribute t) attributes,
operations = map (transform_operation t) operations,
invariant = map ((transform_constraint t) o
(find_constraint t)) checked_invariants,
associationends = map (transform_aend t) navigable_aends,
(* associationends = map (transform_aend t) navigable_aends, *)
associations = assocs,
stereotypes = map (find_stereotype t) stereotype,
interfaces = nil, (* FIX *)
activity_graphs = List.concat [map (transform_activitygraph t) activity_graphs,
@ -412,13 +440,17 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
operations,invariant,stereotype,
clientDependency,connection,
supplierDependency,taggedValue}) =
let val parents = map ((find_classifier_type t) o (find_parent t))
let
val (_,assocs,assoc,_,_) = find_classifier_entries t xmiid
val parents = map ((find_classifier_type t) o (find_parent t))
generalizations
(* FIXME: filter for classes vs. interfaces *)
val filtered_parents = filter (fn x => x <> Rep_OclType.OclAny) parents
val checked_invariants = filter_exists t invariant
(*val navigable_aends = filter #isNavigable connection *)
val class_type = find_classifier_type t xmiid
in
Rep.Class {name = (* path_of_classifier *) (find_classifier_type t xmiid),
Rep.AssociationClass {name = (* type_of_classifier *)class_type,
parent = case filtered_parents
of [] => NONE
| xs => SOME ((*path_of_classifier *) (hd xs)),
@ -426,27 +458,31 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
operations = map (transform_operation t) operations,
invariant = map ((transform_constraint t) o
(find_constraint t)) checked_invariants,
associationends = map (transform_aend t)
(find_aends t xmiid),
stereotypes = map (find_stereotype t) stereotype,
interfaces = nil, (* FIX *)
activity_graphs = nil,
thyname = NONE}
thyname = NONE,
activity_graphs = [] (* FIXME *),
(*connection = map (transform_aend t) navigable_aends*)
associations = assocs,
association = assoc}
end
| transform_classifier t (XMI.Primitive {xmiid,name,generalizations,
operations,invariant,taggedValue}) =
let val checked_invariants = filter_exists t invariant
| transform_classifier t (XMI.Primitive {xmiid,name,generalizations,operations,invariant,taggedValue}) =
let
val (_,assocs,assoc,_,_) = find_classifier_entries t xmiid
val checked_invariants = filter_exists t invariant
in
Rep.Primitive {name = (* case *) find_classifier_type t xmiid (*of Rep_OclType.Classifier x => x
| _ => raise Option*) ,
parent = NONE, (* FIX *)
parent = NONE (* FIX *),
operations = map (transform_operation t) operations,
associationends = map (transform_aend t)
(find_aends t xmiid),
associations = assocs
(*associations = map (transform_aend t)
(find_aends t xmiid), *),
invariant = map ((transform_constraint t) o
(find_constraint t)) checked_invariants,
stereotypes = nil, (*FIX *)
interfaces = nil, (* FIX *)
stereotypes = nil (*FIX *),
interfaces = nil (* FIX *),
thyname = NONE}
end
| transform_classifier t (XMI.Enumeration {xmiid,name,generalizations,
@ -481,20 +517,189 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
end
| transform_classifier t (_) = error "Not supported Classifier type found."
(* billk_tag *)
(** transform an XMI.Association into a Rep.association *)
fun transform_association t ({xmiid,name,connection}:XMI.Association):Rep.association =
let
val association_path = find_association_path t xmiid
val association_ends = map (transform_aend t) connection
in
{name = (* path_of_association *) association_path,
aends = association_ends,
aclass = NONE} (* FIXME *)
end
(** recursively transform all classes in the package. *)
fun transform_package t (XMI.Package p) =
fun transform_package t (XMI.Package p) :transform_model=
let (* we do not transform the ocl library *)
val filteredPackages =
filter (fn (XMI.Package x) =>
((#name x <> "oclLib") andalso (#name x <> "UML_OCL")))
(#packages p)
val local_associations = map (transform_association t) (#associations p)
val local_classifiers = map (transform_classifier t) (#classifiers p)
val (res_classifiers,res_associations) = ListPair.unzip (map (transform_package t) filteredPackages)
val associations = local_associations @ (List.concat res_associations)
val classifiers =local_classifiers @ (List.concat res_classifiers)
in
(map (transform_classifier t) (#classifiers p))@
(List.concat (map (transform_package t) filteredPackages))
(classifiers, associations )
end
(***********************
(* billk_tag *)
(* recursively transforms all associations in the package p. *)
fun transform_associations t (XMI.Package p) =
(List.app (transform_associations t) (#packages p);
List.app (transform_assocation t) (#associations p);
List.app (transform_associationclass_as_association t)
(List.filter (fn (XMI.AssociationClass x) => true
| _ => false)
(#classifiers p))
)
(* billk_tag *)
(* The new class retains the original xmi-id. *)
fun transform_association_class_into_class table (XMI.AssociationClass ac) =
XMI.Class { xmiid = #xmiid ac,
name = #name ac,
isActive = #isActive ac,
visibility = #visibility ac,
isLeaf = #isLeaf ac,
generalizations = #generalizations ac,
attributes = #attributes ac,
operations = #operations ac,
invariant = #invariant ac,
stereotype = #stereotype ac,
taggedValue = #taggedValue ac,
clientDependency = #clientDependency ac,
supplierDependency = #supplierDependency ac,
classifierInState = [], (* FIXME: better dummy? *)
activity_graphs = [], (* FIXME: better dummy? *)
state_machines = []} (* FIXME: better dummy? *)
(* billk_tag *)
fun transform_association_class_into_association table (XMI.AssociationClass ac) =
let
val new_aend= {xmiid = #xmiid ac ^ "0",
name = SOME (#name ac),
isNavigable = true,
ordering = XMI.Unordered,
aggregation = XMI.NoAggregation,
targetScope = XMI.InstanceScope,
multiplicity = [(1,1)], (* injective *)
changeability = XMI.Changeable,
visibility = #visibility ac,
participant_id = #xmiid ac (* the new class retains the id *)
}:XMI.AssociationEnd
in
{xmiid = #xmiid ac ^ "1",
name = NONE, (* FIXME: proper value? *)
connection = new_aend :: (#connection ac)}:XMI.Association
end
(* billk_tag *)
fun transform_association_classes table (XMI.Package p) =
let
val (association_classes,other_classifiers) = List.partition (fn (XMI.AssociationClass x) => true
| _ => false)
(#classifiers p)
in
XMI.Package {xmiid = #xmiid p,
name = #name p,
visibility = #visibility p,
packages = map (transform_association_classes table) (#packages p),
classifiers = map (transform_association_class_into_class table) association_classes @ other_classifiers ,
state_machines = #state_machines p,
activity_graphs = #activity_graphs p,
associations = map (transform_association_class_into_association table) association_classes @ (#associations p),
generalizations = #generalizations p,
constraints = #constraints p,
stereotypes = #stereotypes p,
dependencies = #dependencies p,
tag_definitions = #tag_definitions p,
stereotype = #stereotype p,
taggedValue = #taggedValue p,
events = #events p}
end
(* billk_tag *)
(* multiplicities -> constraints *)
fun transform_multiplicities table (XMI.Package p) =
XMI.Package {xmiid = #xmiid p,
name = #name p,
visibility = #visibility p,
packages = #packages p,
classifiers = #classifiers p,
state_machines = #state_machines p,
activity_graphs = #activity_graphs p,
associations = map (transform_association_multiplicities table) (#associations p),
generalizations = #generalizations p,
constraints = #constraints p,
stereotypes = #stereotypes p,
dependencies = #dependencies p,
tag_definitions = #tag_definitions p,
stereotype = #stereotype p,
taggedValue = #taggedValue p,
events = #events p}
fun add_constraint_to_class table (Rep_Core.Class cls) (name:string option,constr:OclTerm) =
let
val cls_type = find_classifier_type table (#xmiid cls)
val aends = find_aends table (#xmiid cls)
val agraphs = find_activity_graph_of table (#xmiid cls)
val modified_cls = {xmiid = #xmiid cls,
name = #name cls,
isActive = #isActive cls,
visibility = #visibility cls,
isLeaf = #isLeaf cls,
generalizations = #generalizations cls,
attributes = #attributes cls,
operations = #operations cls,
invariant =(name,constr)::(#invariant cls) ,
stereotype = #stereotype cls,
taggedValue = #taggedValue cls,
clientDependency = #clientDependency cls,
supplierDependency = #supplierDependency cls,
classifierInState = #classifierInState cls,
activity_graphs = #activity_graphs cls,
state_machines = #state_machines cls}
in
HashTable.insert table (#xmiid cls,Type (cls_type,aends,modified_cls,agraphs))
end
fun generate_n_ary_constraint table (ac:XMI.Association) =
let
(* use side-effects to manipulate the table *)
val association_xmiids = map #xmiid (#connection ac)
val classifiers = map (find_classifier table) association_xmiids
val multiplicities = map #multiplicity (#connection ac)
fun generate_local_match_constraint others (XMI.Class cls)=
let
val aend = name_of classifier
val var = Rep_OclTerm.Variable ("n"^(#xmiid cls), type_of cls)
fun get_collection cls = ocl_aendcall var aend (Collection (Classifier (name_of classifier)))
fun collection_equality coll1 coll2 = ocl_and (ocl_includes coll1 coll2) (ocl_includes coll2 coll1)
val sample = get_collection (head others)
fun append_match (current,partial_expression) = ocl_and partial_expression (collection_equality sample (get_collection current))
fun match_ocl_expression = foldr1 append_match (tail others)
fun nest_allInstances (current, partial:OclTerm):OclTerm = ocl_forAll (ocl_allInstances current) ("n"^(#xmiid current)) partial
in
foldr nest_allInstances match_ocl_expression others
end
(* multipliciteis are handled when they are removed later on *)
fun iterate_over_connection done (cls::todo)=
( add_constraint_to_class table cls (generate_local_match_constraint (done@todo) cls);
iterate_over_connection (cls::done) todo;
())
| iterate_over_connection done []= ()
in
ac
end
*********)
(** transform a UML model into a list of Rep classes.
*
@ -510,14 +715,15 @@ fun transform_package t (XMI.Package p) =
* 3. traverse again, transforming all remaining model elements,
* i.e., classes with their operations, attributes,
* constraints, etc *)
fun transformXMI ({classifiers,constraints,packages,
stereotypes,variable_declarations,state_machines, activity_graphs}) =
fun transformXMI_ext ({classifiers,constraints,packages,
stereotypes,variable_declarations,state_machines, activity_graphs}):transform_model=
let val (xmiid_table: (string,HashTableEntry) HashTable.hash_table) =
HashTable.mkTable (HashString.hashString, (op =)) (101, Option)
(* hack: insert a dummy type into the table *)
val _ = HashTable.insert xmiid_table ("DummyT",
Type (Rep_OclType.DummyT,
nil,
nil,
XMI.Primitive{name="DummyT",
xmiid="DummyT",
operations=[],
@ -525,6 +731,7 @@ fun transformXMI ({classifiers,constraints,packages,
invariant=[],
taggedValue=[]},
nil))
val _ = HashTable.insert xmiid_table ("-1",UniqueName(123456)) (* arbitrary startnu,ber *)
(* for some reasons, there are model elements outside of the top-level *)
(* model the xmi-file. So we have to handle them here seperately: *)
val _ = map (insert_classifier xmiid_table nil) classifiers
@ -534,20 +741,27 @@ fun transformXMI ({classifiers,constraints,packages,
(* "hd packages" is supposed to be the first model in the xmi-file *)
val model = hd packages
in
insert_model xmiid_table model; (* fill xmi.id table *)
transform_associations xmiid_table model; (* handle associations *)
transform_package xmiid_table model (* transform classes *)
insert_model xmiid_table model (* fill xmi.id table *);
fix_associations xmiid_table model (* handle associations *);
transform_package xmiid_table model (* transform classifiers *)
end
fun transformXMI x:Classifier list = fst (transformXMI_ext x)
(**
* read and transform a .xmi file.
* @return a list of rep classifiers, or nil in case of problems
*)
fun normalize_ext ((clsses,accs):transform_model):Rep.Model =
(map (Rep.normalize accs) clsses,accs)
fun readFile f = (info ("opening "^f);
(map Rep.normalize o transformXMI o XmiParser.readFile) f)
(normalize_ext o transformXMI_ext o XmiParser.readFile) f)
(* handle ex as (IllFormed msg) => raise ex *)
exception FileNotFound of string
fun importArgoUML file =
@ -576,10 +790,17 @@ fun printStackTrace e =
app (fn s => print_stderr ("\t" ^ s ^ "\n")) ss
end
(**
(****************************************************
*****************************************************
* Test function.
*)
fun test (_,filename::_) = (Rep2String.printList (readFile filename); OS.Process.success)
fun test (_,filename::_) = (Rep2String.printList (fst (readFile filename)); OS.Process.success)
handle ex => (printStackTrace ex; OS.Process.failure)
end

9
su4sml/src/rep_secure.sml
View File

@ -51,7 +51,8 @@ sig
* a "secure repository" model consist of a repository model
* plus a security configuration.
*)
type Model = Rep_Core.Classifier list * Security.Configuration
(*type Model = Rep_Core.Classifier list * Security.Configuration*)
type Model = Rep.Model * Security.Configuration
(** *)
val readXMI: string -> Model
@ -65,11 +66,13 @@ struct
structure Security = Security
type Model = Rep_Core.Classifier list * Security.Configuration
(*type Model = Rep_Core.Classifier list * Security.Configuration*)
type Model = Rep.Model * Security.Configuration
val readXMI = Security.parse o RepParser.readFile
fun test (_,filename::_) = (Rep2String.printList (#1 (readXMI filename)); OS.Process.success)
(* FIXME: extend to associations? *)
fun test (_,filename::_) = (Rep2String.printList (#1(#1 (readXMI filename))); OS.Process.success)
end
structure Rep_SecureUML_ComponentUML

114
su4sml/src/rep_su2holocl.sml
View File

@ -288,14 +288,24 @@ fun create_secured {name, body,precondition, postcondition, arguments, result,
* Should be moved to Rep_Core?
*)
fun add_invariant_to_classifier inv (Class {name, parent, attributes,
operations, associationends,
operations, associations,
invariant, stereotypes,
interfaces, thyname, activity_graphs})
= Class {name=name, parent=parent, attributes=attributes,
operations=operations,
associationends=associationends, invariant=inv::invariant,
associations=associations, invariant=inv::invariant,
stereotypes=stereotypes, interfaces=interfaces,
thyname=thyname, activity_graphs=activity_graphs}
| add_invariant_to_classifier inv (AssociationClass {name, parent, attributes,
operations, associations,
association, invariant,
stereotypes, interfaces,
thyname, activity_graphs})
= AssociationClass {name=name, parent=parent, attributes=attributes,
operations=operations, associations=associations,
association=association, invariant=inv::invariant,
stereotypes=stereotypes, interfaces=interfaces,
thyname=thyname, activity_graphs=activity_graphs}
| add_invariant_to_classifier inv (Interface {name, parents, operations,
invariant, stereotypes, thyname})
= Interface {name=name, parents=parents, operations=operations,
@ -307,10 +317,10 @@ fun add_invariant_to_classifier inv (Class {name, parent, attributes,
invariant=inv::invariant, stereotypes=stereotypes,
interfaces=interfaces, thyname=thyname}
| add_invariant_to_classifier inv (Primitive {name, parent, operations,
associationends, invariant,
associations, invariant,
stereotypes, interfaces, thyname})
= Primitive{name=name, parent=parent, operations=operations,
associationends=associationends, invariant=inv::invariant,
associations=associations, invariant=inv::invariant,
stereotypes=stereotypes, interfaces=interfaces, thyname=thyname}
| add_invariant_to_classifier inv (Template {parameter, classifier})
= Template { parameter=parameter,
@ -322,14 +332,24 @@ fun add_invariant_to_classifier inv (Class {name, parent, attributes,
* Should be moved to Rep_Core?
*)
fun add_operation_to_classifier oper (Class {name, parent, attributes,
operations, associationends,
operations, associations,
invariant, stereotypes,
interfaces, thyname, activity_graphs})
= Class {name=name, parent=parent, attributes=attributes,
operations=oper::operations,
associationends=associationends, invariant=invariant,
associations=associations, invariant=invariant,
stereotypes=stereotypes, interfaces=interfaces,
thyname=thyname, activity_graphs=activity_graphs}
| add_operation_to_classifier oper (AssociationClass {name, parent, attributes,
operations, associations,
association, invariant,
stereotypes, interfaces,
thyname, activity_graphs})
= AssociationClass {name=name, parent=parent, attributes=attributes,
operations=oper::operations, associations=associations,
association=association, invariant=invariant,
stereotypes=stereotypes, interfaces=interfaces,
thyname=thyname, activity_graphs=activity_graphs}
| add_operation_to_classifier oper (Interface {name, parents, operations,
invariant, stereotypes, thyname})
= Interface {name=name, parents=parents, operations=oper::operations,
@ -341,10 +361,10 @@ fun add_operation_to_classifier oper (Class {name, parent, attributes,
literals=literals, invariant=invariant, stereotypes=stereotypes,
interfaces=interfaces, thyname=thyname}
| add_operation_to_classifier oper (Primitive {name, parent, operations,
associationends, invariant,
associations, invariant,
stereotypes, interfaces, thyname})
= Primitive{name=name, parent=parent, operations=oper::operations,
associationends=associationends, invariant=invariant,
associations=associations, invariant=invariant,
stereotypes=stereotypes, interfaces=interfaces, thyname=thyname}
| add_operation_to_classifier oper (Template {parameter, classifier})
= Template { parameter=parameter,
@ -395,14 +415,65 @@ fun add_operations c =
end
(* billk_tag: associationend -> path + associations *)
val identity_role_association =
{name=["AuthorizationEnvironment","IdentityRoleAssociation"],
aends=[{name=["AuthorizationEnvironment","Association","identity"],
aend_type=Classifier ["AuthorizationEnvironment","Identity"],
init=NONE,
multiplicity=[(0,~1)],
ordered=false,
visibility=public},
{name=["AuthorizationEnvironment","Association","roles"],
aend_type=Classifier ["AuthorizationEnvironment","Role"],
init=NONE,multiplicity=[(0,~1)],
ordered=false,
visibility=public}
],
aclass=NONE}
val identity_principal_association =
{name=["AuthorizationEnvironment","IdentityPrincipalAssociation"],
aends=[{name=["AuthorizationEnvironment","Association","identity"],
aend_type=Classifier ["AuthorizationEnvironment","Identity"],
init=NONE,
multiplicity=[(1,1)],
ordered=false,
visibility=public},
{name=["AuthorizationEnvironment","Association","principal"],
aend_type=Classifier ["AuthorizationEnvironment","Principal"],
init=NONE,multiplicity=[(0,~1)],
ordered=false,
visibility=public}
],
aclass=NONE}
val context_principal_association =
{name=["AuthorizationEnvironment","ContextPrincipalAssociation"],
aends=[{name=["AuthorizationEnvironment","ContextPrincipalAssociation","principal"],
aend_type=Classifier ["AuthorizationEnvironment","Principal"],
init=NONE,
multiplicity=[(1,1)],
ordered=false,
visibility=public},
{name=["AuthorizationEnvironment","ContextPrincipalAssociation","context"],
aend_type=Classifier ["AuthorizationEnvironment","Context"],
init=NONE,
multiplicity=[(0,~1)],
ordered=false,
visibility=public}
],
aclass=NONE}
val role =
Class {activity_graphs=[],
associationends=[{aend_type=Classifier
(* associationends=[{aend_type=Classifier
["AuthorizationEnvironment","Identity"],
init=NONE,multiplicity=[(0,~1)],
name="identity",
ordered=false,
visibility=public}],
*) associations=[["AuthorizationEnvironment","IdentityRoleAssociation"]],
attributes=[{attr_type=String,
init=NONE,name="name",
scope=InstanceScope,
@ -426,7 +497,7 @@ val role =
val identity =
Class { activity_graphs=[],
associationends=[{aend_type=Classifier
(* associations=[{aend_type=Classifier
["AuthorizationEnvironment","Role"],
init=NONE,multiplicity=[(0,~1)],
name="roles",
@ -439,6 +510,9 @@ val identity =
name="principal",
ordered=false,
visibility=public}],
*) associations= [["AuthorizationEnvironment","IdentityRoleAssociation"],
["AuthorizationEnvironment","IdentityPrincipalAssociation"]
],
attributes=[{attr_type=String,
init=NONE,name="name",
scope=InstanceScope,
@ -453,16 +527,16 @@ val identity =
thyname=NONE
}
val static_auth_env = [
Class { activity_graphs=[],
associationends=[{aend_type=Classifier
(* associations=[{aend_type=Classifier
["AuthorizationEnvironment","Principal"],
init=NONE,
multiplicity=[(1,1)],
name="principal",
ordered=false,
visibility=public}],
*) associations=[["AuthorizationEnvironment","ContextPrincipalAssociation"]],
attributes=[],
interfaces=[],
invariant=[],
@ -473,7 +547,7 @@ val static_auth_env = [
thyname=NONE},
Class
{ activity_graphs=[],
associationends=[{aend_type=Classifier
(* associations=[{aend_type=Classifier
["AuthorizationEnvironment","Identity"],
init=NONE,
multiplicity=[(1,1)],
@ -487,6 +561,9 @@ val static_auth_env = [
name="context",
ordered=false,
visibility=public}],
*) associations=[["AuthorizationEnvironment","IdentityPrincipalAssociation"],
["AuthorizationEnvironment","ContextPrincipalAssociation"]
],
attributes=[],
interfaces=[],
invariant=[],
@ -557,13 +634,14 @@ fun define_roles sc =
fun create_sec_postconds sc c = c
fun transform (cl,sc) =
fun transform (model:Rep.Model,sc) =
let
val transformed_design_model = map add_operations cl
val transformed_model = map (create_sec_postconds sc) transformed_design_model
val auth_env = map normalize (define_roles sc::define_role_hierarchy sc::static_auth_env)
val transformed_design_model = (map add_operations (#1 model),#2 model)
val transformed_model = create_sec_postconds sc transformed_design_model
val auth_env = map (normalize (#2 transformed_model)) (define_roles sc::define_role_hierarchy sc::static_auth_env)
in
transformed_model @ auth_env
((#1 transformed_model) @ auth_env,identity_role_association::identity_principal_association::
context_principal_association::(#2 transformed_model))
end
end

640
su4sml/src/rep_transform.sml Normal file
View File

@ -0,0 +1,640 @@
(*****************************************************************************
* su4sml --- a SML repository for managing (Secure)UML/OCL models
* http://projects.brucker.ch/su4sml/
*
* rep_transform.ML ---
* This file is part of su4sml.
*
* Copyright (c) 2007, ETH Zurich, Switzerland
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
* met:
*
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following
* disclaimer in the documentation and/or other materials provided
* with the distribution.
*
* * Neither the name of the copyright holders nor the names of its
* contributors may be used to endorse or promote products derived
* from this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************)
(* $Id: ROOT.ML 6662 2007-07-04 06:41:30Z brucker $ *)
signature REP_TRANSFORM =
sig
val transformClassifiers_ext : Rep_Core.transform_model -> Rep.Model
val transformClassifiers : Rep_Core.transform_model -> Rep.Classifier list
val transformFile : string -> Rep.Model
(* transforms *)
val transform_association_classes: Rep_Core.transform_model -> Rep_Core.transform_model (* split an association classe into a class and an association*)
val transform_qualifier : Rep_Core.transform_model -> Rep_Core.transform_model
val transform_aggregation : Rep_Core.transform_model -> Rep_Core.transform_model
val transform_n_ary_associations : Rep_Core.transform_model -> Rep_Core.transform_model (* remove n-ary associations *)
val transform_multiplicities : Rep_Core.transform_model -> Rep_Core.transform_model (* remove multiplicities *)
(* helper functions *)
val get_prefix : Rep_OclType.Path -> Rep_OclType.Path
val get_aend_name : Rep_Core.associationend -> string
val generate_pairs : 'a list -> ('a * 'a) list (* including symmetry *)
(* quantify_allInstances : normal variables -> body -> result *)
val quantify_allInstances : Rep_OclTerm.OclTerm list -> Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm
val update_classifier_with_constraint : Rep_Core.constraint -> Rep_Core.Classifier -> Rep_Core.Classifier
(* single: exactly 1 match *)
val update_classifiers_single : Rep_Core.Classifier list -> Rep_OclType.OclType -> (Rep_Core.Classifier -> Rep_Core.Classifier) -> Rep_Core.Classifier list
val update_classifiers_with_constraint: Rep_Core.Classifier list -> Rep_OclType.OclType -> Rep_Core.constraint -> Rep_Core.Classifier list
val get_association : Rep_Core.association list -> Rep_OclType.Path -> Rep_Core.association
(* only one of the below will remain *)
val get_other_associationends: Rep_Core.association list -> Rep_OclType.Path -> Rep_OclType.OclType -> Rep_Core.associationend list
val get_other_associationends_alt : Rep_Core.association list -> Rep_OclType.OclType -> Rep_OclType.Path -> Rep_Core.associationend list
val get_associationends : Rep_Core.association list -> Rep_OclType.Path -> Rep_Core.associationend list
end
structure Rep_Transform:REP_TRANSFORM =
struct
open library
open Rep_OclTerm
open Rep_OclType
open Rep_OclHelper
open Rep_Core
(** not found library funtioncs *)
fun uncurry f(x,y) = f x y
infix |>>
fun (x |>> f) = (f x)
(** thrown when something is not yet implemented *)
exception NotYetImplemented
(***********************************
******** Usefull functions ********
***********************************)
val triv_expr = Rep_OclTerm.Literal ("true",Rep_OclType.Boolean)
fun lowercase s = let val sl = String.explode s
in
String.implode ((Char.toLower (hd sl))::(tl sl))
end
(** chop-off the last part of the path *)
fun get_prefix (path:Path):Path =
List.take (path,List.length path - 1)
fun get_aend_name (aend:associationend) =
List.last (#name aend)
fun generate_pairs [] =
error "in generate_pairs: argument list is empty" (* or simply return []? *)
| generate_pairs [a] =
[(a,a)]
| generate_pairs [a,b] =
(* not necessary *)
[(a,b),(b,a)]
| generate_pairs (x::xs) =
let
val pairs = map (fn a => (x,a)) xs
val rev_pairs = map (fn a => (a,x)) xs
in
pairs@rev_pairs@(generate_pairs xs)
end
(* nest the vars in x.allInstances->forAll expressions *)
(* FIXME: Literal correct? *)
fun quantify_allInstances [Variable var] body =
let
val lit = Literal(#1 var ,#2 var)
in
ocl_forAll (ocl_allInstances lit) (Variable var) body
end
| quantify_allInstances ((Variable var)::vars) body =
let
val lit = Literal(#1 var ,#2 var)
val rest = quantify_allInstances vars body
in
ocl_forAll (ocl_allInstances lit) (Variable var) rest
end
| quantify_allInstances vars _ =
let
val qnt = List.length vars
val error_term = if (qnt > 0) then
((Int.toString qnt)^" "^(term_name_of (hd vars)))
else
"nothing"
in
error ("in quantify_allInstances: only Variables supported and at least 1 needed, "^
error_term^" provided")
end
fun update_classifier_with_constraint constraint (Class {name,parent,attributes,operations,associations,
invariant,stereotypes,interfaces,thyname,activity_graphs}) =
Class {name = name,
parent = parent,
attributes = attributes,
operations = operations,
associations = associations,
invariant = constraint::invariant,
stereotypes = stereotypes,
interfaces = interfaces,
thyname = thyname,
activity_graphs = activity_graphs}
| update_classifier_with_constraint constraint (AssociationClass {name,parent,attributes,operations,associations,association,
invariant,stereotypes,interfaces,thyname,activity_graphs})=
AssociationClass {name = name,
parent = parent,
attributes = attributes,
operations = operations,
associations = associations,
association = association,
invariant = constraint::invariant,
stereotypes = stereotypes,
interfaces = interfaces,
thyname = thyname,
activity_graphs = activity_graphs}
| update_classifier_with_constraint constraint (Interface {name,parents,operations,stereotypes,invariant,thyname}) =
Interface {name=name,
parents=parents,
operations=operations,
stereotypes=stereotypes,
invariant=constraint::invariant,
thyname=thyname}
| update_classifier_with_constraint constraint (Enumeration {name,parent,operations,literals,invariant,stereotypes,interfaces,thyname}) =
Enumeration {name = name,
parent = parent,
operations = operations,
literals=literals,
invariant = constraint::invariant,
stereotypes = stereotypes,
interfaces = interfaces,
thyname = thyname}
| update_classifier_with_constraint constraint (Primitive {name,parent,operations,associations,invariant,stereotypes,interfaces,thyname}) =
Primitive{name = name,
parent = parent,
operations = operations,
associations = associations,
invariant = constraint::invariant,
stereotypes = stereotypes,
interfaces = interfaces,
thyname = thyname}
| update_classifier_with_constraint constraint (Template {parameter,classifier}) =
Template{parameter=parameter,
classifier = update_classifier_with_constraint constraint classifier} (* sensible? *)
fun update_classifiers_single (all_classifiers:Classifier list) (classifier:OclType) (update:Classifier -> Classifier) :Classifier list=
let
val (match,rest) = List.partition (fn (Class {name,...}) => name=classifier
| (AssociationClass {name,...}) => name=classifier
| (Interface {name,...}) => name=classifier
| (Enumeration {name,...}) => name=classifier
| (Primitive {name,...}) => name=classifier
| _ => false ) all_classifiers
in
case match of
[x] => (update x)::rest
| [] => error "in update_classifiers_single: no match found"
| _ => error "in update_classifiers_single: more than 1 match found"
end
fun update_classifiers_with_constraint (all_classifiers:Classifier list) (classifier:OclType) (constraint:constraint) :Classifier list =
update_classifiers_single all_classifiers classifier (update_classifier_with_constraint constraint)
fun get_association (all_assocs: Rep_Core.association list) (assoc_path:Path): association =
let
val assoc = filter (fn {name,...}=> name=assoc_path) all_assocs
in
case assoc of [x] => x
| [] => error "in get_association: no match found"
| _ => error "in get_association: more than 1 match found"
end
fun get_other_associationends (all_assocs:association list) (assoc_path:Path) (cls_type:Rep_OclType.OclType):associationend list =
let
fun all_others ({aend_type,...}:associationend) = (collection_type_of_OclType aend_type) <> cls_type
val association = get_association all_assocs assoc_path
val aends = filter all_others (#aends association)
in
aends
end
(** a simple wrap for get_other_associationends *)
fun get_other_associationends_alt (all_assocs:association list) (cls_type:Rep_OclType.OclType) (assoc_path:Path):associationend list =
get_other_associationends all_assocs assoc_path cls_type
fun get_associationends (all_assocs:association list) (assoc_path:Path):associationend list =
let
val assoc:association = get_association all_assocs assoc_path
in
#aends assoc
end
(****************************
******** Transforms ********
****************************)
(** Remove qualifiers
* requires: qualifier
* generates: constraint, AssociationClass
* removes: qualifier
*)
fun transform_qualifier ((all_classifiers,all_associations):transform_model):transform_model =
(all_classifiers,all_associations) (*dummy*)
(** Remove aggregations
* requires: aggregation
* generates: constraint
* removes: aggregation
*)
fun transform_aggregation ((all_classifiers,all_associations):transform_model):transform_model =
(all_classifiers,all_associations) (*dummy*)
(** Transform an Association Class into a Class
* requires: AssociationClass
* generates: Class, constraint
* removes:
*)
fun transform_association_class_into_class (all_associations: association list )
(Rep_Core.AssociationClass {name,parent,attributes,operations,
associations,association,invariant,
stereotypes,interfaces,thyname,activity_graphs})
: Rep_Core.Classifier =
let
(* the association of the association class to the original
* association is injective, meaning that each instance of
* the newly created class is associated with exactly one
* association pair of the original association.
* The new association end already contains the 1..1 multi-
* plicity, so the constraint only needs to ensure, that
* each instance is "used" only once.
* To do this locally, simply make sure that all association
* end calls have a size of 1.
*)
val self = self name
val src_path = path_of_OclType name
(* the corresponding association hasn't been modified yet *)
val aends = get_associationends all_associations association
fun handle_aend ({name,aend_type,...}:associationend) =
(src_path@[List.last name],aend_type)
val parts = map handle_aend aends
fun quantify (aend,target_type):OclTerm=
let
(* FIXME: aendcall again *)
val aend_call = ocl_aendcall self aend target_type
val eq_constraint = ocl_eq (ocl_size aend_call) (Literal ("1",Integer))
in
eq_constraint
end
val quantified_parts = map quantify parts
val combined_parts:OclTerm = foldl (uncurry ocl_and) (hd quantified_parts) (tl quantified_parts)
val constraint = (SOME (lowercase (List.last src_path) ^"_injective_constraint"),combined_parts)
in
Rep_Core.Class { name = name,
parent = parent,
attributes = attributes,
operations = operations,
associations = associations,
invariant = constraint::invariant,
stereotypes = stereotypes,
interfaces = interfaces,
thyname = thyname,
activity_graphs = activity_graphs}
end
| transform_association_class_into_class _ cls = error ("in transform_association_class_into_class: only AssociationClass supported, "^
(short_name_of cls)^" provided")
(** Transform an Association Class into an Association.
* requires: AssociationClass
* generates: association
* removes:
*)
fun transform_association_class_into_association (all_associations:association list)
(AssociationClass {name,association,...}):Rep_Core.association=
let
val name_path = path_of_OclType name
val prefix = List.take(name_path,List.length name_path - 1)
(* the name of the association end call (role) is the association class name *)
val new_aend= {name = prefix@[List.last name_path] (* FIXME: convention? *),
aend_type = name, (* target of the association is the original AssociationClass *)
multiplicity = [(1,1)], (* dummy *)
visibility = XMI.public (* dummy *),
ordered = false, (* dummy *)
init = NONE (* dummy *)
}:Rep_Core.associationend
val aends = get_associationends all_associations association
val names = map (List.last o #name) (new_aend::aends)
(* pretty printing *)
fun combine [] = ""
| combine [x,y] = x^"_"^y
| combine (x::xs) = x^"_"^(combine xs)
val combined = combine names
in
{name = prefix@["Association_"^combined] (* FIXME: better/proper convention? *),
aends = new_aend :: aends,
aclass = NONE
}
end
| transform_association_class_into_association _ cls = error ("in transform_association_class_into_association: only AssociationClass supported, "^
(short_name_of cls)^" provided")
(** Transform an AssociationClass into a Class and an Association
* requires: AssociationClass
* generates: Class, Association, constraint
* removes: AssociationClass
*)
fun transform_association_classes ((classifiers,associations):transform_model):transform_model =
let
val (association_classes,other_classifiers) =
List.partition (fn (Rep_Core.AssociationClass x) => true
| _ => false) classifiers
val modified_classifiers = map (transform_association_class_into_class associations) association_classes
val modified_associations = map (transform_association_class_into_association associations) association_classes
in
(other_classifiers @ modified_classifiers,
associations @ modified_associations)
end
(* FIXME: binary only or general? *)
(** Move multiplicities from association ends to classifier constraints.
* requires: binary multiplicities
* generates: constraints
* removes: multiplicities
*)
fun transform_multiplicities ((classifiers,all_associations):transform_model):transform_model =
let
fun binary_constraint (Variable src_var) (aend_path:Path) target_type (multiplicity as (lower,upper)):OclTerm =
let
(* FIXME: is ocl_aendcall src aend t correct? *)
(* FIXME: handling of *? *)
val aend_call = ocl_aendcall (Variable src_var) aend_path target_type
val lower_bound = ocl_geq (ocl_size aend_call) (Literal (Int.toString lower,Integer)) (* size >= lower *)
val upper_bound = ocl_leq (ocl_size aend_call) (Literal (Int.toString upper,Integer)) (* size <= upper *)
val combined_bound = ocl_and lower_bound upper_bound
in
combined_bound
end
| binary_constraint term _ _ _ = error ("in transform_multiplicities.binary_constraint: only Variables supported, "^
(term_name_of term)^" supplied")
fun generate_multiplicity_constraints ({name,aends=[a,b],aclass}:association):(OclType * constraint) list =
let
fun all_binary_constraints src_type ({name,aend_type,multiplicity,...}:associationend) =
let
val self = self src_type
val aend_name = List.last name
val aend = path_of_OclType src_type @[aend_name]
val binary_parts = map (binary_constraint self aend aend_type) multiplicity
val combined_parts = foldl (uncurry ocl_or) (hd binary_parts) (tl binary_parts)
val constraint_name = List.last (path_of_OclType src_type) ^"_"^ aend_name ^"_"^
(List.last (path_of_OclType aend_type))
in
(SOME constraint_name,combined_parts)
end
val ab = all_binary_constraints (#aend_type a) b
val ba = all_binary_constraints (#aend_type b) a
in
[(#aend_type a,ab),(#aend_type b,ba)]
end
| generate_multiplicity_constraints {name,aends,aclass} =
let
(* FIXME: all.. *)
(* FIXME: take isNavigable into account *)
fun update_wrap target_type (constraint,classifiers):Rep_Core.Classifier list=
update_classifiers_with_constraint classifiers target_type constraint
fun handle_aend (({multiplicity,aend_type=target_type,name=aend_name,...},classifiers)
:(Rep_Core.associationend * Rep_Core.Classifier list)):Rep_Core.Classifier list =
let
(* val source_name = short_name_of classifier
val src_var = Variable (string_of_OclType source_name ^"_to_"^ aend_name,source_type)
val aend_path = path_of_OclType source_type @ [aend_name]
val constraints = map (binary_constraint src_var aend_path target_type) multiplicity
*) in
(* foldl (update_wrap target_type) classifiers constraints
*) []
end
in
(* foldl handle_aend all_classifiers associationends
*) []
end
fun add_multiplicity_constraints ((assoc,classifiers):association * Classifier list):Classifier list =
let
val constraint_list:((OclType * constraint) list) = generate_multiplicity_constraints assoc
fun fold_update ((cls_type,constraint),classfiers) =
update_classifiers_with_constraint classifiers cls_type constraint
val modified_classifiers = foldl fold_update classifiers constraint_list
in
modified_classifiers
end
fun strip_multiplicities ({name,aends,aclass}:association):association =
let
fun handle_aend ({name,aend_type,multiplicity,visibility,ordered,init}):associationend =
{name=name,
aend_type=aend_type,
multiplicity=[],
visibility=XMI.public (* dummy *),
ordered=ordered,
init=init}
val modified_aends = map handle_aend aends
in
{name = name,
aends = modified_aends,
aclass = aclass}
end
(* add the constraints to the classifiers *)
val modified_classifiers = foldl add_multiplicity_constraints classifiers all_associations
(* update the associationends *)
val modified_associations = map strip_multiplicities all_associations
in
(modified_classifiers, modified_associations)
end
(** Process an association, add it to the processed list and update the relevant classifier invariants.
* For each association end, generate the matching-constraint and add it to the classifier. Multiplicities
* are not handled here.
*)
fun handle_n_ary_constraint ((association as {name,aends=[a,b],aclass},(all_classifiers,processed_assocs))
:(association * transform_model)): transform_model =
(all_classifiers,association::processed_assocs)
| handle_n_ary_constraint ((association as {name,aends,aclass},(all_classifiers,processed_assocs))
:(association * transform_model)) :transform_model =
let
fun collection_equality coll1 coll2 =
ocl_and (ocl_includesAll coll1 coll2) (ocl_includesAll coll2 coll1)
(* generate the aend call *)
fun generate_collection ({name=target_name, aend_type=target_type, ...}:associationend)
({name=souce_name, aend_type=source_type,...}:associationend) =
let
(* FIXME: what's the proper convention? *)
(* variable name: <souce_name>_<aend_call_name>_<target_name> *)
val var_name = lowercase (List.last (path_of_OclType source_type)) ^"_"^
(lowercase (List.last target_name))^"_"^
(lowercase (List.last (path_of_OclType target_type)))
val var = Variable(var_name,source_type)
in
(* FIXME: ocl_aendcall source aend t, is 't' correct/...? *)
(* path of aend call: source path + aend name (as with
* attributes *)
(ocl_aendcall var ((path_of_OclType source_type)@[List.last target_name]) (Collection target_type),var)
end
(* link the seperate aend call results together
* needs at least 2 elements *)
fun match_associations (match::coll::rem) variables:OclTerm =
(* match is the linking element *)
let
val equalities = map (collection_equality match) (coll::rem)
val body = foldl (uncurry ocl_and) (hd equalities) (tl equalities)
in
quantify_allInstances variables body
end
| match_associations elements variables = error ("in handle_n_ary_constraint.match_associations: at least 2 elements needed, "^
(Int.toString (List.length elements))^" provided")
(* update the participant with the new constraint *)
fun n_ary_local_part (classifiers: Classifier list) (remaining_connection:associationend list) (aend:associationend):Classifier list =
let
val (collections,vars) = ListPair.unzip (map (generate_collection aend) remaining_connection)
val constraint = (SOME ("n-ary association constraint for "^(List.last name)), match_associations collections vars)
val classifier_type = #aend_type aend
in
update_classifiers_with_constraint all_classifiers classifier_type constraint
end
(* Instead of fold, for clarity.
* Each step updates the participant of the association end *)
fun iterate_over_connection f clses done [] = clses
| iterate_over_connection f clses done (x::xs) = iterate_over_connection f (f clses (done@xs) x) (x::done) xs
val modified_classifiers = iterate_over_connection n_ary_local_part all_classifiers [] aends (* aends > 2 *)
in
(modified_classifiers, association::processed_assocs)
end
fun handle_n_ary_constraints ((classifiers,associations):transform_model):transform_model =
(* using fold for commulative transformation *)
foldl handle_n_ary_constraint (classifiers,[]) associations
fun split_n_ary_association (ac as {name,aends=[a,b],aclass}:association):association list =
[ac]
| split_n_ary_association (ac as {name,aends,aclass}:association) =
(* We need to generate the pairs as well as the new names *)
let
val prefix = get_prefix name
fun process (a,b) = {name=prefix@[get_aend_name a ^"_"^ (get_aend_name b)],
aends=[a,b],
aclass=aclass}
(* FIXME: reflexiv parts? *)
(* No dupplicates due to symmetry generated *)
fun associate source targets = map (fn x => (source,x)) targets
fun iterate [] = error "in split_n_ary_association.iterate: at least 2 elements needed, 0 provided"
| iterate [x] = error "in split_n_ary_association.iterate: at least 2 elements needed, 1 provided"
| iterate [x,y] = [(x,y)]
| iterate (src::rest) = associate src rest @ (iterate rest)
val pairs = iterate aends
val binary_associations = map process pairs
in
binary_associations
end
fun split_n_ary_associations ((classifiers,associations):transform_model):transform_model =
(classifiers, List.concat (map split_n_ary_association associations))
(** We need to add OCL constraints to handle the broken relationship
* The problem is, that when splitting an n-ary association into it's
* components, the matching of the now 'local' associations is lost.
* For instance, participants A and B are associated to participant C
* with mulitplicity 2..3.
* 1. After the splitting, A may point to 2 instances, while B points
* to 3 instances.
* 2. Even if the cardinalities agree, A and B may point to different
* instances of C.
* Instead of having every participant re-check the same constraints,
* each participant will only validate it's own multiplicity boundary.
* Additionally, the 2 points are handled separately, such that all
* multiplicities will be removed silmultaniously. For this, the
* newly generated binary associations need to retain the correct
* association names for the association end calls.
*
* requires: n-ary associations
* generates: constraints, binary associations
* removes: n-ary associations
*)
fun transform_n_ary_associations ((classifiers,associations):transform_model):transform_model =
handle_n_ary_constraints (classifiers,associations) |>> (* pack the association bindings into constraints *)
split_n_ary_associations (* n-ary -> binary *)
(*******************************
******** Control part ********
*******************************)
(**
* Transformations on Classifiers and Associations
*)
fun transformClassifiers_ext (model:transform_model):transform_model =
transform_association_classes model |>> (* split an association classe into a class and an association*)
(* transform_qualifier |>>
transform_aggregation |>>
*) transform_n_ary_associations |>> (* remove n-ary associations *)
transform_multiplicities (* remove multiplicities *)
fun transformClassifiers (model:transform_model):Rep.Classifier list =
fst (transformClassifiers_ext model) (* return classifiers *)
fun normalize_ext ((classifiers,associations):transform_model) =
(map (Rep.normalize associations) classifiers, associations)
(**
* read and transform an .xmi file.
* @return a list of rep classifiers, or nil in case of problems
*)
fun transformFile f:transform_model = (info ("opening "^f);
(normalize_ext o transformClassifiers_ext o RepParser.transformXMI_ext o XmiParser.readFile) f)
(* handle ex as (IllFormed msg) => raise ex *)
exception FileNotFound of string
fun printStackTrace e =
let val ss = CompilerExt.exnHistory e
in
print_stderr ("uncaught exception " ^ (General.exnMessage e) ^ " at:\n");
app (fn s => print_stderr ("\t" ^ s ^ "\n")) ss
end
end

152
su4sml/src/secure_uml.sml
View File

@ -153,6 +153,7 @@ fun classifier_has_no_stereotype strings c =
* (could be moved to rep_core?)
*)
fun classifier_has_parent (Rep.Class c) = Option.isSome (#parent c)
| classifier_has_parent (Rep.AssociationClass c) = Option.isSome (#parent c)
| classifier_has_parent (Rep.Interface c) = not (List.null (#parents c))
| classifier_has_parent (Rep.Enumeration c) = Option.isSome (#parent c)
| classifier_has_parent (Rep.Primitive c) = Option.isSome (#parent c)
@ -172,7 +173,7 @@ fun mkRole (C as Rep.Class c) = Rep.string_of_path (Rep.name_of C)
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 c cs)
let val classifiers = (Rep.connected_classifiers_of_old c cs)
val role_classes = List.filter (classifier_has_stereotype "secuml.role")
classifiers
val root_classes = List.filter (fn x => ListEq.overlaps
@ -205,18 +206,59 @@ fun mkSubjectAssignment cs (c as (Rep.Class _)) =
(* 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 c cs)
(Rep.connected_classifiers_of_old c cs)
in
(mkSubject c, map mkRole classifiers)
end
fun update_aends (Rep.Class { name, parent, attributes, operations, associationends,
invariant, stereotypes, interfaces, thyname, activity_graphs})
aends = Rep.Class {name=name, parent=parent, attributes=attributes,
operations=operations, associationends=aends,
(*
fun update_aends (Rep.Class { name, parent,attributes,operations,associations,
invariant, stereotypes,interfaces,thyname,activity_graphs}) aends =
let
(*
*)
fun assoc_of_aend ({name,...}:Rep_Core.associationend) = List.take (name,List.length name -1 )
val assocs = map assoc_of_aend aends
fun is_member ({name,...}:Rep_Core.association) = List.exists (fn x => x=name) assocs
in
Rep.Class {name=name, parent=parent, attributes=attributes,
operations=operations(*, associations=map assoc_of_aend aends*),
associations = filter is_member associations,
invariant=invariant, stereotypes=stereotypes,
interfaces=interfaces, thyname=thyname,
activity_graphs=activity_graphs}
end
| update_aends (Rep.AssociationClass { name, parent,attributes,operations,associations,association,
invariant, stereotypes,interfaces,thyname,activity_graphs}) aends =
let
fun assoc_of_aend ({name,...}:Rep_Core.associationend) = List.take (name,List.length name -1 )
val assocs = map assoc_of_aend aends
fun is_member ({name,...}:Rep_Core.association) = List.exists (fn x => x=name) assocs
in
Rep.AssociationClass {name=name, parent=parent, attributes=attributes,
operations=operations(*, associations=map assoc_of_aend aends*),
associations = filter is_member associations,
association = association (* FIXME: proper handling? *),
invariant=invariant, stereotypes=stereotypes,
interfaces=interfaces, thyname=thyname,
activity_graphs=activity_graphs}
end
*)
fun update_assocs (Rep.Class { name, parent,attributes,operations,associations,
invariant, stereotypes,interfaces,thyname,activity_graphs}) assocs =
Rep.Class {name=name, parent=parent, attributes=attributes,
operations=operations, associations=assocs,
invariant=invariant, stereotypes=stereotypes,
interfaces=interfaces, thyname=thyname,
activity_graphs=activity_graphs}
| update_assocs (Rep.AssociationClass { name, parent,attributes,operations,associations,association,
invariant, stereotypes,interfaces,thyname,activity_graphs}) assocs =
Rep.AssociationClass {name=name, parent=parent, attributes=attributes,
operations=operations, associations=assocs,association=association,
invariant=invariant, stereotypes=stereotypes,
interfaces=interfaces, thyname=thyname,
activity_graphs=activity_graphs}
fun assocConnectsToSecureUml cs (a:Rep.associationend) =
classifier_has_no_stereotype ["secuml.permission",
@ -224,24 +266,108 @@ fun assocConnectsToSecureUml cs (a:Rep.associationend) =
"secuml.user"]
(Rep.class_of (Rep_OclType.path_of_OclType (#aend_type a)) cs)
(** remove aends from classifiers to permissions and roles. *)
fun removeSecureUmlAends (cs:Rep.Classifier list) ((Rep.Class c):Rep.Classifier) =
update_aends (Rep.Class c) (List.filter (assocConnectsToSecureUml cs)
(#associationends c))
(** remove aends from classifiers to permissions and roles.
* Actual generation of permissions and roles is done in parse below.
*)
fun removeSecureUmlAends (Rep.Class {name=class_name,...},(assocs,removed_assocs)):(Rep.association list * Rep.association list) =
let
fun remove_aend ({name,aclass,aends}:Rep.association):Rep.association =
{name = name,
aclass = aclass,
aends = filter (fn {aend_type,...} => not (aend_type = class_name)) aends
}
fun non_emtpy ({aends,...}:Rep.association) = List.length aends >= 2 (* FIXME: reflexive association -> 2 aends? *)
val reduced_assocs = map remove_aend assocs
val (modified_assocs,newly_removed_assocs) = List.partition non_emtpy reduced_assocs
in
(modified_assocs,newly_removed_assocs @ removed_assocs)
end
| removeSecureUmlAends (Rep.AssociationClass {name=class_name,...},(assocs,removed_assocs)):(Rep.association list * Rep.association list) =
let
fun remove_aend ({name,aclass,aends}:Rep.association):Rep.association =
{name = name,
aclass = aclass,
aends = filter (fn {aend_type,...} => not (aend_type = class_name)) aends
}
fun non_emtpy ({aends,...}:Rep.association) = List.length aends >= 2 (* FIXME: reflexive association -> 2 aends? *)
val reduced_assocs = map remove_aend assocs
val (modified_assocs,newly_removed_assocs) = List.partition non_emtpy reduced_assocs
(* FIXME: proper handling for aclass? *)
in
(modified_assocs,newly_removed_assocs @ removed_assocs)
end
(** parse a list of classifiers accoriding to the SecureUML profile.
(** parse a list of classifiers according to the SecureUML profile.
* removes the classes with SecureUML stereotypes.
*)
fun parse (cs:Rep_Core.Classifier list) =
fun parse (model as (cs,assocs):Rep.Model) =
let val _ = info "parsing security configuration"
val non_secureumlstereotypes = List.filter (classifier_has_no_stereotype ["secuml.permission",
"secuml.role",
"secuml.subject",
"secuml.actiontype"]) cs
val secureumlstereotypes = List.filter (classifier_has_no_stereotype ["secuml.permission",
"secuml.role",
"secuml.user"]) cs
(* remove classes with SecureUML stereotypes from the association list
* and update affected classes if the association ceases to exist
*)
fun updateClassifierAssociations rem_assocs (Rep.Class {name, parent, attributes, operations,
associations, invariant, stereotypes,
interfaces, thyname, activity_graphs}) =
let
val assoc_names = map (fn {name,aends,aclass} => name) rem_assocs
fun non_emtpy path = not (List.exists (fn aname => aname = path) assoc_names)
in
Rep.Class {name = name,
parent = parent,
attributes = attributes,
operations = operations,
associations = filter non_emtpy associations,
invariant = invariant,
stereotypes = stereotypes,
interfaces = interfaces,
thyname = thyname,
activity_graphs = activity_graphs
}
end
| updateClassifierAssociations rem_assocs (Rep.AssociationClass {name, parent, attributes,
operations, associations,
association, invariant,
stereotypes, interfaces,
thyname, activity_graphs}) =
let
val assoc_names = map (fn {name,aends,aclass} => name) rem_assocs
fun non_emtpy path = not (List.exists (fn aname => aname = path) assoc_names)
in
Rep.AssociationClass {name = name,
parent = parent,
attributes = attributes,
operations = operations,
associations = filter non_emtpy associations,
association = association (* FIXME: proper handling? *),
invariant = invariant,
stereotypes = stereotypes,
interfaces = interfaces,
thyname = thyname,
activity_graphs = activity_graphs
}
end
val (modified_assocs,removed_assocs) = case secureumlstereotypes of [] => (assocs,[])
| xs => foldl removeSecureUmlAends (assocs,[]) xs
val modified_classifiers = case removed_assocs of [] => non_secureumlstereotypes
| xs => map (updateClassifierAssociations xs) non_secureumlstereotypes
in
(
map (removeSecureUmlAends cs)
(* map (removeSecureUmlAends cs)
(List.filter (classifier_has_no_stereotype ["secuml.permission",
"secuml.role",
"secuml.subject",
"secuml.actiontype"])
cs),
*) (modified_classifiers,modified_assocs),
{ config_type = "SecureUML",
permissions = map (mkPermission cs) (filter_permission cs),
subjects = map mkSubject (filter_subject cs),

1
su4sml/src/su4sml_core.cm
View File

@ -83,6 +83,7 @@ Group is
xmi_idtable.sml
ocl2string.sml
rep_parser.sml
rep_transform.sml
mds.sig
component_uml.sml
secure_uml.sml

222
su4sml/src/test-suite.sml Normal file
View File

@ -0,0 +1,222 @@
(*****************************************************************************
* su4sml --- a SML repository for managing (Secure)UML/OCL models
* http://projects.brucker.ch/su4sml/
*
* test-suite.sml --- a regression test-suite for su4sml
* This file is part of su4sml.
*
* Copyright (c) 2006, 2007 ETH Zurich, Switzerland
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
* met:
*
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following
* disclaimer in the documentation and/or other materials provided
* with the distribution.
*
* * Neither the name of the copyright holders nor the names of its
* contributors may be used to endorse or promote products derived
* from this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************)
(* $Id$ *)
signature TESTSUITE = sig
val runTest : unit -> unit list
end
structure testsuite:TESTSUITE = struct
type result = {
parse : bool,
preprocess : bool,
typecheck : bool,
update : bool,
codegen : bool,
msg : string
}
type testcase = {
name : string,
uml : string,
ocl : string,
result : result
}
val initResult = {
parse = false,
preprocess = false,
typecheck = false,
update = false,
codegen = false,
msg = ""
}:result
val prefix = "../../examples/"
val testcases = [
{
name = "Company",
uml = prefix^"company/company.zargo",
ocl = prefix^"company/company.ocl",
result = initResult
}:testcase,
{
name = "ebank",
uml = prefix^"ebank/ebank.zargo",
ocl = prefix^"ebank/ebank.ocl",
result = initResult
}:testcase,
{
name = "encoding_example",
uml = prefix^"encoding_example/encoding_example.zargo",
ocl = prefix^"encoding_example/encoding_example.ocl",
result = initResult
}:testcase,
{
name = "isp",
uml = prefix^"isp/isp.zargo",
ocl = prefix^"isp/isp.ocl",
result = initResult
}:testcase,
{
name = "Royals and Loyals",
uml = prefix^"royals_and_loyals/royals_and_loyals.zargo",
ocl = prefix^"royals_and_loyals/royals_and_loyals.ocl",
result = initResult
}:testcase,
{
name = "simple",
uml = prefix^"simple/simple.zargo",
ocl = prefix^"simple/simple.ocl",
result = initResult
}:testcase,
{
name = "stack",
uml = prefix^"stack/stack.zargo",
ocl = prefix^"stack/stack.ocl",
result = initResult
}:testcase,
{
name = "digraph",
uml = prefix^"digraph/digraph.zargo",
ocl = prefix^"digraph/digraph.ocl",
result = initResult
}:testcase,
{
name = "vehicles",
uml = prefix^"vehicles/vehicles.zargo",
ocl = prefix^"vehicles/vehicles.ocl",
result = initResult
}:testcase
]
fun test (tc:testcase) =
let
val xmi = ModelImport.parseUML (#uml tc)
handle _ => ([],[])
val ocl = ModelImport.parseOCL (#ocl tc)
handle _ => []
val OclParse = if ocl = [] then false else true
val (xmi,ocl) = ModelImport.removePackages (xmi,ocl) []
handle _ => (([],[]),[])
val _ = print "### Preprocess Context List ###\n"
val fixed_ocl = Preprocessor.preprocess_context_list
ocl ((OclLibrary.oclLib)@(#1 xmi))
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 _ => []
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 _ => []
val modelUpdate = if model = [] then false else true
val _ = print "### Finished Updating Classifier List ###\n"
val model = ModelImport.removeOclLibrary model
val CodeGen =
let
val _ = Codegen.generateFromModel xmi "java"
in
true
end
handle _ => false
in
{
name = #name tc,
uml = #uml tc,
ocl = #ocl tc,
result =
{
parse = OclParse,
preprocess = OclParse andalso OclPreprocess,
typecheck = OclParse andalso OclPreprocess andalso OclTC,
update = OclParse andalso OclPreprocess andalso OclTC andalso modelUpdate,
codegen = OclParse andalso OclPreprocess andalso OclTC andalso modelUpdate andalso CodeGen,
msg = ""
}:result
}:testcase
end
fun printResult (tc:testcase) =
let
fun printBool b = if b then "passed" else "FAILED"
val _ = print ("\n *** "^(#name tc)^" ***\n")
val res = (#result tc)
val _ = print (" parsing: "^(printBool (#parse res))^"\n")
val _ = print (" preprocess: "^(printBool (#preprocess res))^"\n")
val _ = print (" typecheck: "^(printBool (#typecheck res))^"\n")
val _ = print (" update: "^(printBool (#update res))^"\n")
val _ = print (" codegen: "^(printBool (#codegen res))^"\n\n")
val _ = print (" ==> overall: "^(printBool ((#parse res)
andalso (#preprocess res)
andalso (#typecheck res)
andalso (#update res)
andalso (#codegen res)))^"\n")
in
()
end
(* val _ = (Ext_Library.log_level := 1);(); *)
fun runTest () = map printResult (map test testcases)
end
val _ = testsuite.runTest()

1
su4sml/src/xmi_core.sml
View File

@ -261,6 +261,7 @@ type Void = {xmiid: string,
* --------------------------------------------------------------------------*)
type AssociationEnd = { xmiid : string,
name : string option,
association: string (* xmiid of enclosing association *),
isNavigable: bool,
ordering : OrderingKind,
aggregation : AggregationKind,

188
su4sml/src/xmi_idtable.sml
View File

@ -45,22 +45,40 @@ open library
datatype HashTableEntry = Package of Rep_OclType.Path
| Type of (Rep_OclType.OclType *
(XMI.AssociationEnd list) *
(*(XMI.AssociationEnd list)* *)
(Rep_OclType.Path list)* (* associations *)
(Rep_OclType.Path)* (* association of an association class *)
XMI.Classifier *
(XMI.ActivityGraph list))
| Association of (Rep_OclType.Path *
XMI.Association)
| Generalization of (string * string)
| Constraint of XMI.Constraint
| Stereotype of string
| Variable of XMI.VariableDeclaration
| Attribute of Rep_OclType.Path
| Operation of Rep_OclType.Path
| AssociationEnd of XMI.AssociationEnd
| AssociationEnd of (Rep_OclType.Path *
XMI.AssociationEnd)
| State of XMI.StateVertex
| Transition of XMI.Transition
| Dependency of XMI.Dependency
| TagDefinition of string
| ClassifierInState of string
| Event of XMI.Event
| UniqueName of int (* xmiid=-1;for naming when a name is missing *)
fun next_unique_name t:string=
let
val number = case valOf (HashTable.find t "-1")
of UniqueName x => x
| _ => raise Option
in
(HashTable.insert t ("-1",UniqueName (number+1));
Int.toString number
)
end
handle Option => error ("expected UniqueName to be defined in table")
fun find_tagdefinition t xmiid =
(case valOf (HashTable.find t xmiid)
@ -122,12 +140,20 @@ fun find_type t xmiid =
| _ => raise Option)
handle Option => error ("expected Type "^xmiid^" in table (find_type)")
fun find_aends t xmiid =
fun find_assocs t xmiid =
(case valOf (HashTable.find t xmiid)
of (Type (c,xs,_,_)) => xs
of (Type (c,xs,_,_,_)) => xs
| _ => raise Option)
handle Option => error ("expected Type "^xmiid^" in table (find_aends)")
(* FIXME: assoc -> aend *)
fun find_aends t xmiid =
let
val assocs = find_assocs xmiid
in
[] (* dummy *)
end
fun find_variable_dec t xmiid =
(case valOf (HashTable.find t xmiid)
of Variable x => x
@ -153,11 +179,44 @@ fun find_constraint t xmiid =
fun find_associationend t xmiid =
(case valOf (HashTable.find t xmiid)
of AssociationEnd ae => ae
of AssociationEnd (path,ae) => ae
| _ => raise Option)
handle Option => error ("expected AssociationEnd "^xmiid^" in table")
fun path_of_association t xmiid =
(case valOf (HashTable.find t xmiid)
of Association (path,ae) => path
| _ => raise Option)
handle Option => error ("expected Association "^xmiid^" in table")
fun path_of_associationend t xmiid =
(case valOf (HashTable.find t xmiid)
of AssociationEnd (path,ae) => path
| _ => raise Option)
handle Option => error ("expected AssociationEnd "^xmiid^" in table")
fun find_association t xmiid =
(case valOf (HashTable.find t xmiid)
of Association (p,a) => a
| _ => raise Option)
handle Option => error ("expected Association "^xmiid^" in table")
fun find_association_of_associationend t xmiid =
let
val aend = find_associationend t xmiid
val assoc_xmiid = #association aend
in
find_association t assoc_xmiid
end
fun find_classifier_associations t xmiid =
(case valOf (HashTable.find t xmiid)
of Type(_,assocs,_,_,_) => assocs
| _ => raise Option)
handle Option => error ("expected Association "^xmiid^" in table")
fun filter_exists t cs =
filter (fn x => Option.isSome (HashTable.find t x)) cs
@ -188,30 +247,40 @@ fun filter_bodyconstraint t cs
constr_type_name = "body"
end) cs
fun find_classifier_entries t xmiid =
(case valOf (HashTable.find t xmiid)
of Type c => c
| _ => raise Option)
handle Option => error ("expected Classifier "^xmiid^" in table (in find_classifer_entries)")
fun find_classifier t xmiid =
(case valOf (HashTable.find t xmiid)
of Type (_,_,c,_) => c
of Type (_,_,_,c,_) => c
| _ => raise Option)
handle Option => error ("expected Classifier "^xmiid^" in table (in find_classifer)")
fun find_classifierInState_classifier t cis_id =
(case valOf (HashTable.find t cis_id)
of ClassifierInState c => find_classifier t c
| Type (_,_,c,_) => c
| Type (_,_,_,c,_) => c
| _ => raise Option)
handle Option => error ("expected ClassifierInState "
^cis_id^" in table")
fun find_association_of_associationclass t xmiid =
(case valOf (HashTable.find t xmiid)
of Type (_,_,ac,_,_) => ac
| _ => raise Option)
handle Option => error ("expected associationclass "^xmiid^" in table (in find_association_of_associationclass)")
fun find_activity_graph_of t xmiid =
(case valOf (HashTable.find t xmiid)
of Type (_,_,_,ag) => ag
of Type (_,_,_,_,ag) => ag
| _ => raise Option)
handle Option => error ("expected Classifier "^xmiid^" in table (in find_activity_graph_of)")
fun find_classifier_type t xmiid
= let val ocltype = case valOf (HashTable.find t xmiid) of (Type (x,xs,_,_)) => x
= let val ocltype = case valOf (HashTable.find t xmiid) of (Type (x,xs,ac,_,_)) => x
| _ => raise Option
in
case ocltype of Rep_OclType.Integer => ocltype
@ -232,6 +301,11 @@ fun find_classifier_type t xmiid
handle Option => error ("expected Classifier "^xmiid^" in table (in find_classifier_type)")
fun find_association_path t xmiid =
case valOf (HashTable.find t xmiid) of (Association (x,xs)) => x
| _ => raise Option
handle Option => error ("expected Association "^xmiid^" in table (in find_association_path)")
fun insert_constraint table (c:XMI.Constraint) =
HashTable.insert table (#xmiid c, Constraint c)
@ -273,8 +347,8 @@ fun insert_activity_graph table (XMI.mk_ActivityGraph ag) =
let val context = #contextxmiid ag
in
(case valOf (HashTable.find table context)
of (Type (c,xs,aes,ags)) => HashTable.insert
table (context, Type (c,xs,aes,
of (Type (c,xs,assocs,ac,ags)) => HashTable.insert
table (context, Type (c,xs,assocs,ac,
XMI.mk_ActivityGraph ag::ags))
| _ => raise Option)
handle Option => error ("expected Type "^context^" in table (insert_activity_graph)");
@ -291,6 +365,7 @@ fun insert_tagdefinition table (td:XMI.TagDefinition) =
fun insert_classifierInState table cls_id cis_id =
HashTable.insert table (cis_id,ClassifierInState cls_id)
(* billk_tag *)
fun insert_classifier table package_prefix class =
let val id = XMI.classifier_xmiid_of class
val name = XMI.classifier_name_of class
@ -315,10 +390,11 @@ fun insert_classifier table package_prefix class =
else Rep_OclType.Classifier path
(* This function is called before the associations are handled, *)
(* so we do not have to take care of them now... *)
val aends = nil
val assocs = nil
val ac = nil
val ag = nil
in
HashTable.insert table (id,Type (ocltype,aends,class,ag));
HashTable.insert table (id,Type (ocltype,assocs,ac,class,ag));
case class
of XMI.Class c => (List.app (insert_attribute table path) (#attributes c);
List.app (insert_operation table path) (#operations c);
@ -332,10 +408,37 @@ fun insert_classifier table package_prefix class =
| XMI.Set c => (List.app (insert_operation table path) (#operations c); ())
| XMI.Bag c => (List.app (insert_operation table path) (#operations c); ())
| XMI.OrderedSet c => (List.app (insert_operation table path) (#operations c); ())
| XMI.AssociationClass c => (List.app (insert_attribute table path) (#attributes c);
List.app (insert_operation table path) (#operations c);
List.app (insert_classifierInState table id) [];
())
| _ => ()
end
(** insert an association end into the hashtable *)
fun insert_associationend table (association_prefix:Rep_OclType.Path) (aend:XMI.AssociationEnd) =
let
val id = #xmiid aend
val path = if (isSome (#name aend))
then association_prefix@[valOf (#name aend)]
else association_prefix@["associationend_"^(next_unique_name table)]
in
HashTable.insert table (id,AssociationEnd(path,aend))
end
(** insert an association into the hashtable *)
fun insert_association table package_prefix (association:XMI.Association) =
let
val id = #xmiid association
val name = #name association
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));
List.app (insert_associationend table path) (#connection association)
)
end
(* recursively insert mapping of xmi.id's to model elements into Hashtable *)
fun insert_package table package_prefix (XMI.Package p) =
@ -346,6 +449,7 @@ fun insert_package table package_prefix (XMI.Package p) =
List.app (insert_stereotype table) (#stereotypes p);
List.app (insert_classifier table full_name) (#classifiers p);
List.app (insert_package table full_name) (#packages p);
List.app (insert_association table full_name) (#associations p);
List.app (insert_activity_graph table) (#activity_graphs p);
List.app (insert_dependency table) (#dependencies p);
List.app (insert_tagdefinition table) (#tag_definitions p);
@ -449,6 +553,60 @@ fun classifier_has_stereotype t st c =
List.exists (fn x => (find_stereotype t x) = st)
(XMI.classifier_stereotype_of c)
fun fix_associationend t (assoc_path:Rep_OclType.Path) (aend:XMI.AssociationEnd) =
let
val id = #xmiid aend
val participant_id = #participant_id aend
val (cls_type,assocs,assoc,cls,ags) = find_classifier_entries t participant_id
val name = Option.getOpt(#name aend,
(lowercase o XMI.classifier_name_of o
find_classifier t) participant_id)
in
(* add the association to the participant *)
(HashTable.insert t (participant_id, Type (cls_type,assoc_path::assocs,assoc,cls,ags));
HashTable.insert t (#xmiid aend, AssociationEnd (List.concat [assoc_path, [name]], aend)))
end
(* FIXME: handle AssociationClasses *)
(** add this associationend to all participants *)
fun fix_association t ({xmiid,name,connection}:XMI.Association) =
List.app (fix_associationend t (path_of_association t xmiid)) connection
(** handel association classes *)
fun fix_associationclasses t (ac as XMI.AssociationClass {xmiid,name,connection,visibility,...})=
let
val (cls_type,assocs,assoc,cls,ags) = find_classifier_entries t xmiid
(* FIXME: add a direct querry *)
val aend = hd connection
(* val association = find_association_of_associationend t (#xmiid aend)*)
val assoc_path = Rep_OclType.path_of_OclType (#1 (find_type t xmiid))
in
(List.app (fix_associationend t (assoc_path)) connection;
HashTable.insert t (xmiid,Type (cls_type,assoc_path::assocs,assoc_path,cls,ags));
()
)
end
| fix_associationclasses t _ = error "in fix_associationclasses: AssociationClass expected"
(** Handel the broken association references *)
fun fix_associations t (XMI.Package p)=
let
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_associationclasses t) associationclasses
)
end
(* billk_tag *)
(* old: *)
(**
* split an association into association ends, and put the association ends
* ends into the xmi.id table under the corresponding (i.e., opposite)
@ -462,7 +620,8 @@ fun classifier_has_stereotype t st c =
* hashtable
* 4. insert mapping xmi.id of association end to path into the hashtable
*)
fun transform_assocation t (assoc:XMI.Association) =
(* orig:
fun insert_assocation t (assoc:XMI.Association) =
let val aends = #connection assoc
fun all_others x xs = List.filter
(fn (y:XMI.AssociationEnd) => y <> x) xs
@ -488,4 +647,5 @@ fun transform_assocation t (assoc:XMI.Association) =
fun transform_associations t (XMI.Package p) =
(List.app (transform_associations t) (#packages p);
List.app (transform_assocation t) (#associations p))
*)
end

63
su4sml/src/xmi_parser.sml
View File

@ -179,11 +179,12 @@ fun mkMultiplicity tree =
|> get "UML:Multiplicity.range"
|> map mkRange
fun mkAssociationEnd tree =
fun mkAssociationEnd association tree =
let val atts = tree |> assert "UML:AssociationEnd" |> attributes
in
{ xmiid = atts |> xmiid,
name = atts |> optional_value_of "name",
association = association,
isNavigable = atts |> bool_value_of "isNavigable" ,
ordering = atts |> ordering,
aggregation = atts |> aggregation,
@ -225,25 +226,28 @@ fun mkAssociationEndFromAssociationClass tree =
(* From an AssociationClass, we build the corresponding association *)
(* that will later be handles just like any other association. *)
fun mkAssociationFromAssociationClass tree =
let val atts = tree |> assert "UML:AssociationClass" |> attributes
let
val atts = tree |> assert "UML:AssociationClass" |> attributes
val id = atts |> xmiid
in
{ xmiid = atts |> xmiid,
{ xmiid = id,
name = atts |> optional_value_of "name" ,
connection = (tree |> get_many "UML:Association.connection"
|> map mkAssociationEnd)@
[(mkAssociationEndFromAssociationClass tree)] (* *)
connection = tree |> get_many "UML:Association.connection"
|> map (mkAssociationEnd id)
}
end
(*handle IllFormed msg => error ("in mkAssociation: "^msg)*)
fun mkAssociation tree =
let val atts = tree |> assert "UML:Association" |> attributes
let
val atts = tree |> assert "UML:Association" |> attributes
val id = atts |> xmiid
in
{ xmiid = atts |> xmiid,
{ xmiid = id,
name = atts |> optional_value_of "name",
connection = tree |> get_many "UML:Association.connection"
|> map mkAssociationEnd
|> map (mkAssociationEnd id)
}
end
(* handle IllFormed msg => error ("in mkAssociation: "^msg)*)
@ -402,10 +406,16 @@ and mkVariableDec vtree =
(* handle IllFormed msg => error ("in mkVariableDec: "^msg)*)
(* FIX: Handle AssociationClasses like Associations. *)
(* See mkAssociationFromAssociationClass for details. *)
(* billk_tag: handle separately *)
val filterAssociations = filter "UML:Association"
val filterAssociationClasses = filter "UML:AssociationClass"
fun getAssociations t = (map mkAssociation (filter "UML:Association" t))@
(map mkAssociationFromAssociationClass
(filter "UML:AssociationClass" t))
fun getAssociations t = (map mkAssociation (filter "UML:Association" t))
(* @*)
(* (map mkAssociationFromAssociationClass *)
(* (filter "UML:AssociationClass" t))*)
(*handle _ => error ("Error in getAssociations") *)
@ -825,9 +835,14 @@ fun mkClass atts tree =
(*handle IllFormed msg => error ("Error in mkClass "^(name atts)^
": "^msg)*)
fun mkAssociationClass atts tree
= XMI.AssociationClass
{ xmiid = atts |> xmiid,
(* billk_tag *)
(* extended to match Rep.AssociationClass *)
fun mkAssociationClass atts tree =
let
val id = atts |> xmiid
in
XMI.AssociationClass
{ xmiid = id,
name = atts |> name,
isActive = atts |> bool_value_of "isActive",
visibility = atts |> visibility,
@ -850,9 +865,20 @@ fun mkAssociationClass atts tree
|> map xmiidref,
supplierDependency = tree |> get "UML:ModelElement.supplierDependency"
|> map xmiidref,
connection = tree |> get_many "UML:Association.connection"
|> map mkAssociationEnd
(* classifierInState = tree |> get "UML:Namespace.ownedElement"
|> filter "UML:ClassifierInState"
|> map (xmiid o attributes),
state_machines = tree |> get "UML:Namespace.ownedElement"
|> filter "UML:StateMachine"
|> map mkStateMachine,
activity_graphs = tree |> get "UML:Namespace.ownedElement"
|> filter "UML:ActivityGraph"
|> map mkActivityGraph,
*) connection = tree |> get_many "UML:Association.connection"
|> map (mkAssociationEnd id)
}
end
(*handle IllFormed msg => error ("in mkAssociationClass: "^msg)*)
@ -1030,7 +1056,8 @@ fun mkPackage tree =
visibility = atts |> visibility,
packages = trees |> filterPackages |> map mkPackage,
classifiers = trees |> filterClassifiers |> map mkClassifier,
associations = trees |> getAssociations,
(*associations = trees |> getAssociations,*)
associations = trees |> filterAssociations |> map mkAssociation,
generalizations = trees |> filter "UML:Generalization"
|> map mkGeneralization,
constraints = trees |> filterConstraints |> map mkConstraint,