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

only transform navigable association ends, changed exception handling 

git-svn-id: https://projects.brucker.ch/su4sml/svn/infsec-import/trunk/src/su4sml@5947 3260e6d1-4efc-4170-b0a7-36055960796d
This commit is contained in:
Jürgen Doser 2007-01-25 16:26:11 +00:00
parent 4b95bb46ca
commit 5394f456ca
31 changed files with 712 additions and 694 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src/ROOT.ML
View File

@ -23,6 +23,8 @@
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
******************************************************************************)
use "library.sml";
val ml_system = "polyml";
(* ****************************************************** *)
@ -32,7 +34,19 @@ OS.FileSys.chDir "../lib/fxp/src";
use "ROOT.ML";
OS.FileSys.chDir "../../../src";
use "library.sml";
OS.FileSys.chDir "compiler";
use "compiler_ext.sig";
val use_wrapper = if (String.isSubstring "polyml" ml_system)
then (use "../contrib/HashTable.sml"; "polyml.sml")
else "smlnj.sml";
use use_wrapper; (* or "smlnj.sml", "polyml.sml" or "mlton.sml" *)
OS.FileSys.chDir "..";
(* ****************************************************** *)
(* Abstract Representation of an XMI File of a UML Model.

12
src/codegen/ROOT.ML
View File

@ -21,18 +21,6 @@
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
******************************************************************************)
OS.FileSys.chDir "compiler";
use "compiler_ext.sig";
val use_wrapper = if (String.isSubstring "polyml" ml_system)
then "polyml.sml"
else "smlnj.sml";
use use_wrapper; (* or "smlnj.sml", "polyml.sml" or "mlton.sml" *)
OS.FileSys.chDir "..";
use "gcg_library.sml";
use "gcg_helper.sml";

2
src/codegen/SM_helper.sml
View File

@ -12,7 +12,7 @@ struct
open Rep
open Rep_OclType
open Rep_OclTerm
open Rep_SecureUML_ComponentUML.Security
(* open Rep_SecureUML_ComponentUML.Security*)
open ComponentUML
open XMI_DataTypes

2
src/codegen/c#sm_cartridge.sml
View File

@ -34,7 +34,7 @@ functor CSSM_Cartridge(SuperCart : BASE_CARTRIDGE) : CARTRIDGE =
open Rep_OclType
open Rep_StateMachine
open Gcg_Helper
open Rep_SecureUML_ComponentUML.Security
(* open Rep_SecureUML_ComponentUML.Security*)
open ComponentUML
open SM_Helper
open StateMachineTypes

2
src/codegen/codegen.cm
View File

@ -6,8 +6,6 @@ Group is
#else
#endif
../su4sml.cm
compiler/compiler_ext.sig
compiler/smlnj.sml
cartridge.sig
security_cartridge.sig
gcg_library.sml

6
src/codegen/codegen.sml
View File

@ -84,9 +84,9 @@ fun generate xmi_file "base" =
"usage: generate <xmi_file> \"base\" | \"c#\" | \"c#_secure\" | \"c#_net1\" | \"c#_secure_net1\" | \"java\" | \"junit\"\n")
fun main (_,[xmi_file,lang]) = generate xmi_file lang
| main _ = print ("usage: codegen <xmi_file> <language>\n"^
"\tlanguage = \"base\" | \"c#\" | \"c#sm\" | \"c#_secure\" | \"c#_net1\" | \"c#_secure_net1\" | \"java\" | \"junit\" | \"maude\" | \"maude_secure\" \n")
fun main (_,[xmi_file,lang]) = (generate xmi_file lang ; OS.Process.success)
| main _ = (print ("usage: codegen <xmi_file> <language>\n"^
"\tlanguage = \"base\" | \"c#\" | \"c#sm\" | \"c#_secure\" | \"c#_net1\" | \"c#_secure_net1\" | \"java\" | \"junit\" | \"maude\" | \"maude_secure\" \n"); OS.Process.success)
end

2
src/codegen/componentuml_cartridge.sml
View File

@ -55,7 +55,7 @@ fun atomic_actions_from_context env =
ComponentUML.SimpleAction (s, ComponentUMLResource.Entity
(Option.valOf (curClassifier env)))
in [make_action "create", make_action "delete"] end
else error "blubb"
else raise Fail "no current resource"
(* FIX *)
fun permissions_for_action env act =

2
src/codegen/secureuml_cartridge.sml
View File

@ -150,7 +150,7 @@ fun foreach_role (env:environment)
fun foreach_constraint (env:environment)
= let val cons = case #curPermission env
of SOME p => #constraints p
| NONE => Security.all_constraints (#2 (#model env))
| NONE => Security.all_constraints (#2 (#model env))
fun env_from_list_item c ={ model = #model env,
PermissionSet = #PermissionSet env,
curPermission = #curPermission env,

1
src/codegen/stateMachine.sml
View File

@ -39,7 +39,6 @@ open Rep
open Rep_OclType
open Rep_OclTerm
open Rep_StateMachine
open Rep_SecureUML_ComponentUML.Security
open SM_Helper
open StateMachineTypes

1
src/codegen/stateMachineTypes.sml
View File

@ -31,7 +31,6 @@ open Rep
open Rep_OclType
open Rep_OclTerm
open Rep_StateMachine
open Rep_SecureUML_ComponentUML.Security
type Pair = string * string
fun VarN((name,Value):Pair) = name

1
src/codegen/compiler/compiler_ext.sig → src/compiler/compiler_ext.sig
View File

@ -26,4 +26,5 @@ signature COMPILER_EXT =
sig
exception EvalNotSupported
val eval : bool -> string -> unit
val exnHistory : exn -> string list
end

2
src/codegen/compiler/mlton.sml → src/compiler/mlton.sml
View File

@ -25,4 +25,6 @@ structure CompilerExt : COMPILER_EXT =
struct
exception EvalNotSupported
fun eval verbose txt = raise EvalNotSupported
fun exnHistory e = MLton.Exn.history e
end

3
src/codegen/compiler/polyml.sml → src/compiler/polyml.sml
View File

@ -54,4 +54,7 @@ fun eval verbose txt =
in
eval_fh (fn s => print (s^"\n"), fn s => library.error (s^"\n")) verbose txt
end
fun exnHistory _ = []
end

5
src/codegen/compiler/smlnj.sml → src/compiler/smlnj.sml
View File

@ -46,6 +46,9 @@ fun eval verbose txt =
if verbose then print (output ()) else ()
end
in
eval_fh (fn s => print (s^"\n"), fn s => library.error (s^"\n")) verbose txt
eval_fh (fn s => print (s^"\n"), fn s => library.error_ ((s^"\n"),library.ERROR)) verbose txt
end
fun exnHistory e = SMLofNJ.exnHistory e
end

30
src/component_uml.sml
View File

@ -56,27 +56,27 @@ val root_stereotypes = ["compuml.entity"]
(** The list of all attributes of an entity. *)
fun entity_contained_attributes (Entity c) = map EntityAttribute (Rep.attributes_of c)
| entity_contained_attributes _ = library.error "entity_contained_attributes \
| entity_contained_attributes _ = library.error' "entity_contained_attributes \
\called on something that is \
\not an entity"
(** the list of all methods of an entity *)
fun entity_contained_methods (Entity c) = map EntityMethod (Rep.operations_of c)
| entity_contained_methods _ = library.error "entity_contained_methods \
| entity_contained_methods _ = library.error' "entity_contained_methods \
\called on something that is \
\not an entity"
(** The list of all side-effect free methods of an entity. *)
fun entity_contained_read_methods (Entity c) =
map EntityMethod (List.filter #isQuery (Rep.operations_of c))
| entity_contained_read_methods _ = library.error "entity_contained_read_methods \
| entity_contained_read_methods _ = library.error' "entity_contained_read_methods \
\called on something that is \
\not an entity"
(** The list of all methods with side-effects of an entity *)
fun entity_contained_update_methods (Entity c) =
map EntityMethod (List.filter (not o #isQuery) (Rep.operations_of c))
| entity_contained_update_methods _ = library.error
| entity_contained_update_methods _ = library.error'
"entity_contained_update_methods \
\called on something that is not \
\an entity"
@ -101,7 +101,7 @@ fun parse_entity_action root att_name "create" =
SimpleAction ("delete", (Entity root))
| parse_entity_action root att_name "fullaccess" =
CompositeAction ("fullaccess", (Entity root))
| parse_entity_action root att_name s = library.error ("unknown action type "^s^
| parse_entity_action root att_name s = library.error' ("unknown action type "^s^
" for entity action")
(** parses an entity attribute action permission attribute. *)
@ -109,18 +109,18 @@ fun parse_attribute_action root name "read" =
(SimpleAction ("read",
(EntityAttribute ((hd o List.filter (fn x => #name x = name))
(Rep.attributes_of root))))
handle Empty => library.error "did not find attribute")
handle Empty => library.error' "did not find attribute")
| parse_attribute_action root name "update" =
( SimpleAction ("update",
(EntityAttribute ((hd o List.filter (fn x => #name x = name))
(Rep.attributes_of root))))
handle Empty => library.error "did not find attribute")
handle Empty => library.error' "did not find attribute")
| parse_attribute_action root name "fullaccess" =
( CompositeAction ("fullaccess",
(EntityAttribute ((hd o List.filter (fn x => #name x = name))
(Rep.attributes_of root))))
handle Empty => library.error "did not find attribute")
| parse_attribute_action root name s = library.error ("unknown action type "^s^
handle Empty => library.error' "did not find attribute")
| parse_attribute_action root name s = library.error' ("unknown action type "^s^
"for attribute action")
(** parses an entity method action permission attribute. *)
@ -128,8 +128,8 @@ fun parse_method_action root name "execute"
= (SimpleAction ("execute",
(EntityMethod ((hd o List.filter (fn x => #name x = name))
(Rep.operations_of root))))
handle Empty => library.error "did not find method")
| parse_method_action roor name s = library.error ("unknown action type "^s^
handle Empty => library.error' "did not find method")
| parse_method_action roor name s = library.error' ("unknown action type "^s^
"for method action")
(**
@ -140,7 +140,7 @@ fun parse_action root (att:Rep.attribute) =
let val att_name = #name att
val att_type = #attr_type att
val cls_path = case att_type of Rep_OclType.Classifier x => x
| _ => library.error "permission attribute \
| _ => library.error' "permission attribute \
\type is not a classifier"
val action_name = hd (rev cls_path)
fun resource_path name = (hd o List.tl) (String.tokens (fn x => x= #".") name)
@ -151,11 +151,11 @@ fun parse_action root (att:Rep.attribute) =
parse_method_action root (resource_path att_name) action_name
| "dialect.entityattributeaction" =>
parse_attribute_action root (resource_path att_name) action_name
| s => library.error ("in ComponentUML.parse_action: "^
| s => library.error' ("in ComponentUML.parse_action: "^
"found unexpected stereotype "^s^
" for permission attribute")
end
handle _ => library.error "in ComponentUML.parse_action: \
handle _ => library.error' "in ComponentUML.parse_action: \
\could not parse attribute"
fun action_type_of (SimpleAction (t,_)) = t
@ -204,7 +204,7 @@ fun subordinated_actions (SimpleAction _) = nil
| subordinated_actions (CompositeAction ("full_access", a as (EntityAttribute ae)))
= [SimpleAction ("read", a),
SimpleAction ("update", a)]
| subordinated_actions (CompositeAction _) = library.error "encountered unknown \
| subordinated_actions (CompositeAction _) = library.error' "encountered unknown \
\composite action \
\type in \
\subordinated_actions"

21
src/library.sml
View File

@ -32,11 +32,11 @@ fun (x |> f) = f x;
(* of the corresponding library. The semantics of UML2CDL_HOME should *)
(* probably be fixed *)
fun su4sml_home () = case OS.Process.getEnv "HOLOCL_HOME" of
SOME p => p^"/lib/su4sml/src"
| NONE => (case OS.Process.getEnv "SU4SML_HOME" of
SOME p => p^"/src"
| NONE => getOpt(OS.Process.getEnv "UML2CDL_HOME",".")
)
SOME p => p^"/lib/su4sml/src"
| NONE => (case OS.Process.getEnv "SU4SML_HOME" of
SOME p => p^"/src"
| NONE => getOpt(OS.Process.getEnv "UML2CDL_HOME",".")
)
fun filter (pred: 'a->bool) : 'a list -> 'a list =
@ -92,15 +92,18 @@ fun take (n, []) = []
fun space_implode a bs = implode (separate a bs);
(* use print instead
fun std_output s = (TextIO.output (TextIO.stdOut, s); TextIO.flushOut TextIO.stdOut);
*)
fun print_stderr s = (TextIO.output (TextIO.stdErr, s); TextIO.flushOut TextIO.stdErr);
exception ERROR;
(* val writeln = std_output o suffix "\n";*)
(* fun error_msg s = writeln(s) *)
fun error s = (print (s^"\n"); raise ERROR);
fun info s = print (s^"\n")
fun warn s = print (s^"\n")
fun error_ (s,ex) = (print (s^"\n"); raise ex)
fun error' s = error_ (s,Fail s)
fun error s = print (s^"\n")
fun fst (x, y) = x

11
src/ocl2string.sml
View File

@ -168,7 +168,10 @@ fun ocl2string show_types oclterm =
(* Let *)
(**************************************)
(* Error *)
| Let (s,_,_,_,_,_) => error ("error: unknown Let '"^(s)^"' in ocl2string")
| Let (var,vart,rhs,rhst,i,it) => "let "^var^":"^(string_of_OclType vart)^
" = "^(ocl2string show_types rhs)^
"in\n"^(ocl2string show_types i)
(**************************************)
(* OperationWithType *)
(**************************************)
@ -178,7 +181,7 @@ fun ocl2string show_types oclterm =
(* Iterate *)
(**************************************)
(* Error *)
| Iterate (_,s,_,_,src,_,c,_,_) => error ("error: unknown Iterate '"^(s)^"' in in ocl2string")
| Iterate (_,s,_,_,src,_,c,_,_) => error' ("error: unknown Iterate '"^(s)^"' in in ocl2string")
(**************************************)
(* Iterator *)
(**************************************)
@ -206,8 +209,8 @@ fun ocl2string show_types oclterm =
(* Catch out *)
(**************************************)
(* Error *)
| _ => error ("error: unknown OCL-term in in ocl2string")
end
| _ => error' "error: unknown OCL-term in in ocl2string"
end
end
(** "pretty printing" of Repository models *)

1
src/rep.sml
View File

@ -42,3 +42,4 @@ open OclLibrary
type Model = Classifier list
end

1
src/rep_core.sml
View File

@ -443,6 +443,7 @@ fun type_of (Class{name,...}) = name
| type_of (Primitive{name,...}) = name
| type_of (Template{classifier,...}) = type_of classifier
fun error s = library.error' s
fun name_of (Class{name,...}) = path_of_OclType name
| name_of (Interface{name,...}) = path_of_OclType name

344
src/rep_parser.sml
View File

@ -24,12 +24,13 @@
structure RepParser :
sig
val transformXMI : XMI.XmiContent -> Rep.Classifier list
val readFile : string -> Rep.Classifier list
(* generic exception if something is wrong *)
exception IllFormed of string
end =
sig
val transformXMI : XMI.XmiContent -> Rep.Classifier list
val readFile : string -> Rep.Classifier list
val test: (string * string list) -> OS.Process.status
(* generic exception if something is wrong *)
exception IllFormed of string
end =
struct
open library
exception IllFormed of string
@ -42,9 +43,9 @@ exception NotYetImplemented
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
in
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}) =
@ -53,40 +54,40 @@ fun transform_expression t (XMI.LiteralExp {symbol,expression_type}) =
Rep_OclTerm.CollectionLiteral (map (transform_collection_part t) parts,
find_classifier_type t expression_type)
| transform_expression t (XMI.IfExp {condition,thenExpression,
elseExpression,expression_type}) =
elseExpression,expression_type}) =
Rep_OclTerm.If (transform_expression t condition,
find_classifier_type t (XMI.expression_type_of condition),
transform_expression t thenExpression,
find_classifier_type t (XMI.expression_type_of thenExpression),
transform_expression t elseExpression,
find_classifier_type t (XMI.expression_type_of elseExpression),
find_classifier_type t expression_type)
find_classifier_type t (XMI.expression_type_of condition),
transform_expression t thenExpression,
find_classifier_type t (XMI.expression_type_of thenExpression),
transform_expression t elseExpression,
find_classifier_type t (XMI.expression_type_of elseExpression),
find_classifier_type t expression_type)
| transform_expression t (XMI.AttributeCallExp {source,referredAttribute,
expression_type}) =
expression_type}) =
Rep_OclTerm.AttributeCall (transform_expression t source,
find_classifier_type t (XMI.expression_type_of source),
find_attribute t referredAttribute,
find_classifier_type t expression_type)
find_classifier_type t (XMI.expression_type_of source),
find_attribute t referredAttribute,
find_classifier_type t expression_type)
| transform_expression t (XMI.OperationCallExp {source,arguments,
referredOperation,
expression_type}) =
referredOperation,
expression_type}) =
let val arglist = map (transform_expression t) arguments
val argtyplist = map ((find_classifier_type t) o XMI.expression_type_of) arguments
in
Rep_OclTerm.OperationCall (transform_expression t source,
find_classifier_type t (XMI.expression_type_of source),
find_operation t referredOperation,
ListPair.zip (arglist, argtyplist),
find_classifier_type t expression_type)
find_classifier_type t (XMI.expression_type_of source),
find_operation t referredOperation,
ListPair.zip (arglist, argtyplist),
find_classifier_type t expression_type)
end
| transform_expression t (XMI.OperationWithTypeArgExp {source,name,
typeArgument,
expression_type}) =
typeArgument,
expression_type}) =
Rep_OclTerm.OperationWithType (transform_expression t source,
find_classifier_type t (XMI.expression_type_of source),
name,
find_classifier_type t typeArgument,
find_classifier_type t expression_type)
find_classifier_type t (XMI.expression_type_of source),
name,
find_classifier_type t typeArgument,
find_classifier_type t expression_type)
| transform_expression t (XMI.VariableExp {referredVariable,expression_type})=
let val var_dec = find_variable_dec t referredVariable
val name = #name var_dec
@ -113,7 +114,7 @@ fun transform_expression t (XMI.LiteralExp {symbol,expression_type}) =
*)
val classifier_type = find_type source
val path_of_classifier = (fn (Rep_OclType.Classifier p) => p
| x => error (Rep_OclType.string_of_OclType x)) classifier_type
| x => error' (Rep_OclType.string_of_OclType x)) classifier_type
val aend = find_associationend t referredAssociationEnd
val aend_name = Option.getOpt(#name aend,
(lowercase o XMI.classifier_name_of o
@ -136,7 +137,7 @@ fun transform_expression t (XMI.LiteralExp {symbol,expression_type}) =
transform_expression t source, find_classifier_type t (XMI.expression_type_of source),
transform_expression t body, find_classifier_type t (XMI.expression_type_of body),
find_classifier_type t expression_type
)
)
end
| transform_expression t (XMI.IterateExp {result,iterators,body,source,expression_type}) =
let val _ = map (insert_variable_dec t) (result::iterators )
@ -145,10 +146,10 @@ fun transform_expression t (XMI.LiteralExp {symbol,expression_type}) =
#name result,
find_classifier_type t (#declaration_type result),
transform_expression t (valOf (#init result)),
transform_expression t source, find_classifier_type t (XMI.expression_type_of source),
transform_expression t body, find_classifier_type t (XMI.expression_type_of body),
find_classifier_type t expression_type
)
transform_expression t source, find_classifier_type t (XMI.expression_type_of source),
transform_expression t body, find_classifier_type t (XMI.expression_type_of body),
find_classifier_type t expression_type
)
end
| transform_expression t (XMI.LetExp {variable, inExpression, expression_type}) =
let val _ = insert_variable_dec t variable
@ -162,7 +163,7 @@ fun transform_expression t (XMI.LiteralExp {symbol,expression_type}) =
find_classifier_type t expression_type
)
end
| transform_expression t _ = raise NotYetImplemented
| transform_expression t _ = raise Fail "unsupported OCL expression type"
and transform_collection_part t (XMI.CollectionItem {item,expression_type}) =
Rep_OclTerm.CollectionItem (transform_expression t item,
find_classifier_type t expression_type)
@ -173,15 +174,15 @@ and transform_collection_part t (XMI.CollectionItem {item,expression_type}) =
fun transform_constraint t ({xmiid,name,body,...}:XMI.Constraint) =
let val n_name = case name of
(SOME s) => if (s = "") then NONE else (SOME(s))
|NONE => NONE
in
(n_name,transform_expression t body)
handle NotYetImplemented => (print "Warning: in RepParser.transform_constraint: Something is not yet implemented.\n";(NONE, triv_expr))
| IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
| XmiParser.IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
end
let val n_name = case name of
(SOME s) => if (s = "") then NONE else (SOME(s))
|NONE => NONE
in
(n_name,transform_expression t body)
handle NotYetImplemented => (print "Warning: in RepParser.transform_constraint: Something is not yet implemented.\n";(NONE, triv_expr))
| IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
| XmiParser.IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
end
fun transform_bodyconstraint result_type t ({xmiid,name,body,...}:XMI.Constraint) =
let val result = Rep_OclTerm.Variable ("result",result_type)
@ -193,9 +194,9 @@ fun transform_bodyconstraint result_type t ({xmiid,name,body,...}:XMI.Constraint
equal,[(body,body_type)],
Rep_OclType.Boolean))
end
handle NotYetImplemented => (print "Warning: in RepParser.transform_constraint: Something is not yet implemented.\n";(NONE, triv_expr))
| IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
| XmiParser.IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
handle NotYetImplemented => (print "Warning: in RepParser.transform_constraint: Something is not yet implemented.\n";(NONE, triv_expr))
| IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
| XmiParser.IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
fun transform_parameter t {xmiid,name,kind,type_id} =
(name, find_classifier_type t type_id)
@ -205,7 +206,7 @@ fun transform_operation t {xmiid,name,isQuery,parameter,visibility,
let val result_type = find_classifier_type t
((#type_id o hd) (filter (fn x => #kind x = XMI.Return)
parameter))
val checked_constraints = filter_exists t constraints
val checked_constraints = filter_exists t constraints
in
{name=name,
arguments = (map (transform_parameter t)
@ -215,16 +216,16 @@ fun transform_operation t {xmiid,name,isQuery,parameter,visibility,
postcondition = List.concat [map ((transform_constraint t) o
(find_constraint t))
(filter_postcondition t constraints),
map ((transform_bodyconstraint result_type t) o
(find_constraint t))
(filter_bodyconstraint t checked_constraints)],
map ((transform_bodyconstraint result_type t) o
(find_constraint t))
(filter_bodyconstraint t checked_constraints)],
result = result_type,
visibility = visibility,
scope = ownerScope,
isQuery = isQuery (* FIX *)
}
}
end
fun transform_attribute t ({xmiid,name,type_id,changeability,visibility,ordering,
multiplicity,taggedValue,ownerScope,targetScope,stereotype,initialValue}) =
@ -242,12 +243,12 @@ fun transform_attribute t ({xmiid,name,type_id,changeability,visibility,ordering
}
end
fun transform_aend t ({xmiid,name,ordering,multiplicity,participant_id,
isNavigable,aggregation,changeability,visibility,targetScope})
= {name = Option.getOpt(name,
(lowercase o XMI.classifier_name_of o
find_classifier t) participant_id),
(lowercase o XMI.classifier_name_of o
find_classifier t) participant_id),
aend_type = find_classifier_type t participant_id,
multiplicity = multiplicity,
ordered = if ordering = XMI.Ordered then true else false,
@ -260,34 +261,34 @@ val filter_named_aends = List.filter (fn {name=SOME _,...}:XMI.AssociationEnd =
(* FIX *)
fun transform_state t (XMI.CompositeState {xmiid,outgoing,incoming,subvertex,
isConcurrent,name,...}) =
isConcurrent,name,...}) =
Rep.State_CompositeState { name = name,
state_id = xmiid,
outgoing = outgoing,
incoming = incoming,
subvertex = map (transform_state t) subvertex,
isConcurrent = isConcurrent }
state_id = xmiid,
outgoing = outgoing,
incoming = incoming,
subvertex = map (transform_state t) subvertex,
isConcurrent = isConcurrent }
| transform_state t (XMI.SimpleState {xmiid,outgoing,incoming,name,...}) =
Rep.State_SimpleState { state_id = xmiid,
outgoing = outgoing,
incoming = incoming,
name = name}
outgoing = outgoing,
incoming = incoming,
name = name}
| transform_state t (XMI.ActionState {xmiid,outgoing,incoming,isDynamic,
name,...}) =
name,...}) =
Rep.SimpleState_ActionState { state_id = xmiid,
outgoing = outgoing,
incoming = incoming,
isDynamic = isDynamic,
name = name}
outgoing = outgoing,
incoming = incoming,
isDynamic = isDynamic,
name = name}
| transform_state t (XMI.FinalState {xmiid,incoming,...}) =
Rep.State_FinalState { state_id = xmiid,
incoming = incoming}
incoming = incoming}
| transform_state t (XMI.PseudoState {xmiid,incoming,outgoing,kind,...}) =
Rep.PseudoState { state_id = xmiid,
outgoing = outgoing,
incoming = incoming,
kind = kind }
| transform_state t _ = library.error "in transform_state: Subactivity states, object flow states and sync states are not supported."
outgoing = outgoing,
incoming = incoming,
kind = kind }
| transform_state t _ = library.error_ ("in transform_state: Subactivity states, object flow states and sync states are not supported.",library.ERROR)
(* a primitive hack: we take the body of the guard g as the name of an *)
(* operation to be called in order to check whether the guard is true *)
fun transform_guard t (XMI.mk_Guard g) =
@ -295,10 +296,10 @@ fun transform_guard t (XMI.mk_Guard g) =
val package_path = nil (* FIX *)
in
case #expression g of
NONE => Rep_OclTerm.OperationCall ( Rep_OclTerm.Variable ("self",self_type),
self_type,
List.concat [package_path,[Option.valOf(#body g)]],nil,
Rep_OclType.Boolean )
NONE => Rep_OclTerm.OperationCall ( Rep_OclTerm.Variable ("self",self_type),
self_type,
List.concat [package_path,[Option.valOf(#body g)]],nil,
Rep_OclType.Boolean )
| SOME exp => transform_expression t exp
end
@ -333,15 +334,16 @@ fun transform_statemachine t (XMI.mk_StateMachine st) =
(** transform a XMI.Classifier classifier into a Rep.Classifier *)
fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
generalizations,attributes,operations,
invariant,stereotype,clientDependency,
supplierDependency,taggedValue,
classifierInState,activity_graphs,
state_machines}) =
generalizations,attributes,operations,
invariant,stereotype,clientDependency,
supplierDependency,taggedValue,
classifierInState,activity_graphs,
state_machines}) =
let val parents = map ((find_classifier_type t) o (find_parent t))
generalizations
val filtered_parents = filter (fn x => x <> Rep_OclType.OclAny) parents
val checked_invariants = filter_exists t invariant
val filtered_parents = filter (fn x => x <> Rep_OclType.OclAny) parents
val checked_invariants = filter_exists t invariant
val navigable_aends = filter #isNavigable (find_aends t xmiid)
in
Rep.Class {name = (* path_of_classifier *) (find_classifier_type t xmiid),
parent = case filtered_parents
@ -351,13 +353,12 @@ 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),
associationends = map (transform_aend t) navigable_aends,
stereotypes = map (find_stereotype t) stereotype,
interfaces = nil, (* FIX *)
activity_graphs = List.concat [map (transform_activitygraph t) activity_graphs,
map (transform_statemachine t) state_machines],
thyname = NONE}
thyname = NONE}
end
| transform_classifier t (XMI.AssociationClass {xmiid,name,isActive,visibility,
isLeaf,generalizations,attributes,
@ -367,72 +368,72 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
let 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 filtered_parents = filter (fn x => x <> Rep_OclType.OclAny) parents
val checked_invariants = filter_exists t invariant
in
Rep.Class {name = (* path_of_classifier *) (find_classifier_type t xmiid),
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)
(find_aends t xmiid),
stereotypes = map (find_stereotype t) stereotype,
interfaces = nil, (* FIX *)
activity_graphs = nil,
thyname = NONE}
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)
(find_aends t xmiid),
stereotypes = map (find_stereotype t) stereotype,
interfaces = nil, (* FIX *)
activity_graphs = nil,
thyname = NONE}
end
| transform_classifier t (XMI.Primitive {xmiid,name,generalizations,
operations,invariant}) =
let 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 *)
operations = map (transform_operation t) operations,
associationends = 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 *)
thyname = NONE}
end
operations,invariant}) =
let 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 *)
operations = map (transform_operation t) operations,
associationends = 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 *)
thyname = NONE}
end
| transform_classifier t (XMI.Enumeration {xmiid,name,generalizations,
operations,literals,invariant}) =
let val checked_invariants = filter_exists t invariant
in
Rep.Enumeration {name = (* case *) find_classifier_type t xmiid (* of Rep_OclType.Classifier x => x
| _ => raise Option *),
parent = NONE, (* FIX *)
literals = literals,
operations = map (transform_operation t) operations,
invariant = map ((transform_constraint t) o
(find_constraint t)) checked_invariants,
stereotypes = nil, (* FIX *)
interfaces = nil, (* FIX *)
thyname = NONE}
end
operations,literals,invariant}) =
let val checked_invariants = filter_exists t invariant
in
Rep.Enumeration {name = (* case *) find_classifier_type t xmiid (* of Rep_OclType.Classifier x => x
| _ => raise Option *),
parent = NONE, (* FIX *)
literals = literals,
operations = map (transform_operation t) operations,
invariant = map ((transform_constraint t) o
(find_constraint t)) checked_invariants,
stereotypes = nil, (* FIX *)
interfaces = nil, (* FIX *)
thyname = NONE}
end
| transform_classifier t (XMI.Interface { xmiid, name, generalizations, operations, invariant,
...}) =
...}) =
let
val checked_invariants = filter_exists t invariant
in
Rep.Interface { name = find_classifier_type t xmiid,
parents = map ((find_classifier_type t) o (find_parent t))
generalizations,
operations = map (transform_operation t) operations,
stereotypes = [], (* map (find_stereotype t) stereotype,*)
invariant = map ((transform_constraint t) o
(find_constraint t)) checked_invariants,
thyname = NONE
parents = map ((find_classifier_type t) o (find_parent t))
generalizations,
operations = map (transform_operation t) operations,
stereotypes = [], (* map (find_stereotype t) stereotype,*)
invariant = map ((transform_constraint t) o
(find_constraint t)) checked_invariants,
thyname = NONE
}
end
| transform_classifier t (_) = raise IllFormed "Not supported Classifier type found."
(** recursively transform all classes in the package. *)
fun transform_package t (XMI.Package p) =
@ -443,7 +444,7 @@ fun transform_package t (XMI.Package p) =
(#packages p)
in
(map (transform_classifier t) (#classifiers p))@
(List.concat (map (transform_package t) filteredPackages))
(List.concat (map (transform_package t) filteredPackages))
end
@ -468,14 +469,14 @@ fun transformXMI ({classifiers,constraints,packages,
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,
XMI.Primitive{name="DummyT",
xmiid="DummyT",
operations=[],
generalizations=[],
invariant=[]},
nil))
Type (Rep_OclType.DummyT,
nil,
XMI.Primitive{name="DummyT",
xmiid="DummyT",
operations=[],
generalizations=[],
invariant=[]},
nil))
(* 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
@ -485,11 +486,10 @@ 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 *)
transform_associations xmiid_table model; (* handle associations *)
transform_package xmiid_table model (* transform classes *)
end
handle Empty => raise Option
(**
@ -497,17 +497,19 @@ fun transformXMI ({classifiers,constraints,packages,
* @return a list of rep classifiers, or nil in case of problems
*)
fun readFile f = map Rep.normalize ((transformXMI o XmiParser.readFile) f)
handle XmiParser.IllFormed msg =>
(print ("Warning: in RepParser.readFile: could not parse file "^
f^":\n"^msg^"\n"); nil)
| Option =>
(print ("Warning: in RepParser.readFile: could not parse file "^
f^"\n"); nil)
| IllFormed msg =>
(print ("Warning: in RepParser.readFile: could not parse file "^
f^": "^msg^"\n"); nil)
(* handle ex as (IllFormed msg) => raise ex *)
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
(**
* Test function.
*)
fun test (_,filename::_) = (Rep2String.printList (readFile filename); OS.Process.success)
handle ex => (printStackTrace ex; OS.Process.failure)
end

5
src/rep_secure.sml
View File

@ -40,7 +40,9 @@ sig
(** *)
val readXMI: string -> Model
val test: (string * string list) -> OS.Process.status
end
functor Rep_SecureUML(structure Security : SECUREUML) : REP_SECUREUML =
@ -52,6 +54,7 @@ struct
val readXMI = Security.parse o RepParser.readFile
fun test (_,filename::_) = (Rep2String.printList (#1 (readXMI filename)); OS.Process.success)
end
structure Rep_SecureUML_ComponentUML

26
src/secure_uml.sml
View File

@ -140,12 +140,12 @@ fun filter_role cs = List.filter (classifier_has_stereotype "secuml.role") cs
fun mkRole (C as Rep.Class c) = Rep.string_of_path (Rep.name_of C)
| mkRole _ = library.error "mkRole called on something that is \
\not a class"
| mkRole _ = library.error_ ("mkRole called on something that is \
\not a class",library.ERROR)
(* FIXME: handle groups also *)
fun mkSubject (C as Rep.Class c) = User (Rep.string_of_path (Rep.name_of C))
| mkSubject _ = library.error "mkSubject called on something that is not a class"
| mkSubject _ = library.error_ ("mkSubject called on something that is not a class",library.ERROR)
fun mkPermission cs (C as Rep.Class c) =
let val atts = Rep.attributes_of (Rep.Class c)
@ -160,34 +160,34 @@ fun mkPermission cs (C as Rep.Class c) =
Design.root_stereotypes)
classifiers
val root_resource = hd root_classes
handle Empty => library.error ("no root resource found for permission "^
Rep.string_of_path (Rep.name_of C))
handle Empty => library.error_ (("no root resource found for permission "^
Rep.string_of_path (Rep.name_of C)),library.ERROR)
val action_attributes =
List.filter (fn x => List.exists
(fn y => List.exists
(fn z => y= z)
(#stereotypes x))
Design.action_stereotypes) atts
handle _ => library.error "could not parse permission attributes"
handle _ => library.error_ ("could not parse permission attributes",library.ERROR)
in
{ name = (Rep.string_of_path (Rep.name_of C)),
roles = (map (Rep.string_of_path o Rep.name_of) role_classes),
(* FIXME: find attached constraints *)
constraints = nil,
actions = if action_attributes = []
then library.error ("no action attributes found in permission "^
(Rep.string_of_path (Rep.name_of C)))
then library.error_ (("no action attributes found in permission "^
(Rep.string_of_path (Rep.name_of C))),library.ERROR)
else map (Design.parse_action root_resource) action_attributes }
end
| mkPermission _ _ = library.error "mkPermission called on something \
\that is not a class"
| mkPermission _ _ = library.error_ ("mkPermission called on something \
\that is not a class",library.ERROR)
(** parse a list of classifiers accoriding to the SecureUML profile.
* removes the classes with SecureUML stereotypes.
*)
fun parse (cs:Rep_Core.Classifier list) =
(List.filter (classifier_has_no_stereotype ["secuml.permission",
(List.filter (classifier_has_no_stereotype ["secuml.permission",
"secuml.role",
"secuml.subject",
"secuml.actiontype"])
@ -201,7 +201,7 @@ fun parse (cs:Rep_Core.Classifier list) =
(List.filter classifier_has_parent (filter_role cs)),
(* FIXME: find associations between Users and Roles. *)
sa = nil})
handle _ => library.error ("Problem during parsing security configuration")
handle _ => library.error_ ("Problem during parsing security configuration",library.ERROR)
end

2
src/su4sml.cm
View File

@ -6,6 +6,8 @@ Group is
#else
#endif
../lib/fxp/src/fxlib.cm
compiler/compiler_ext.sig
compiler/smlnj.sml
library.sml
listeq.sml
rep_ocl.sml

4
src/su4sml.mlb
View File

@ -4,9 +4,12 @@ ann
in
local
$(MLTON_ROOT)/basis/basis.mlb
$(MLTON_ROOT)/basis/mlton.mlb
$(MLTON_ROOT)/smlnj-lib/Util/smlnj-lib.mlb
../lib/fxp/src/fxlib.mlb
in
codegen/compiler/compiler_ext.sig
codegen/compiler/mlton.sml
library.sml
xmi_ocl.sml
xmltree.sml
@ -35,5 +38,6 @@ in
xmi_parser.sml
rep_parser.sml
rep_secure.sml
rep_su2holocl.sml
end
end

36
src/xmi_idtable.sml
View File

@ -472,28 +472,28 @@ fun transform_assocation t (assoc:XMI.Association) =
*)
fun transform_associationclass_as_association t (XMI.AssociationClass assoc) =
let val aends = #connection assoc
fun add_aend_to_type (id,ae) =
if not (Option.isSome (HashTable.find t id)) then () else
let val type_of_id = find_classifier_type t id
val cls_of_id = find_classifier t id
val aends_of_id = ae::(find_aends t id)
val ags_of_id = find_activity_graph_of t id
in
(HashTable.insert t (id,Type (type_of_id,aends_of_id,cls_of_id,ags_of_id));
HashTable.insert t (#xmiid ae, AssociationEnd ae))
end
in
List.app (fn x => add_aend_to_type (#xmiid assoc, x)) aends
fun add_aend_to_type (id,ae) =
if not (Option.isSome (HashTable.find t id)) then () else
let val type_of_id = find_classifier_type t id
val cls_of_id = find_classifier t id
val aends_of_id = ae::(find_aends t id)
val ags_of_id = find_activity_graph_of t id
in
(HashTable.insert t (id,Type (type_of_id,aends_of_id,cls_of_id,ags_of_id));
HashTable.insert t (#xmiid ae, AssociationEnd ae))
end
in
List.app (fn x => add_aend_to_type (#xmiid assoc, x)) aends
end
| transform_associationclass_as_association t _ = library.error "in transform_associationclass_as_association: can only be called on association classes"
| transform_associationclass_as_association t _ = library.error_ ("in transform_associationclass_as_association: can only be called on association classes",library.ERROR)
(* 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)))
List.app (transform_assocation t) (#associations p);
List.app (transform_associationclass_as_association t)
(List.filter (fn (XMI.AssociationClass x) => true
| _ => false)
(#classifiers p)))
end

2
src/xmi_ocl.sml
View File

@ -113,7 +113,7 @@ fun expression_source_of (AssociationEndCallExp{source,...}) = source
| expression_source_of (OperationWithTypeArgExp{source,...}) = source
| expression_source_of (IterateExp{source,...}) = source
| expression_source_of (IteratorExp{source,...}) = source
| expression_source_of _ = library.error "expression has no source"
| expression_source_of _ = library.error' "expression has no source"
(* from UML 1.5 Core: --------------------------------------------------------
* A constraint is a semantic condition or restriction expressed in text.

803
src/xmi_parser.sml
View File

File diff suppressed because it is too large Load Diff

2
src/xmi_state_machines.sml
View File

@ -225,7 +225,7 @@ fun state_outgoing_trans_of (CompositeState{outgoing,...}) = outgoing
| state_outgoing_trans_of (ObjectFlowState{outgoing,...}) = outgoing
| state_outgoing_trans_of (PseudoState{outgoing,...}) = outgoing
| state_outgoing_trans_of (SyncState{outgoing,...}) = outgoing
| state_outgoing_trans_of (FinalState _) = library.error "state_outgoing_trans_of called on a final state"
| state_outgoing_trans_of (FinalState _) = library.error' "state_outgoing_trans_of called on a final state"
fun state_incoming_trans_of (CompositeState{incoming,...}) = incoming
| state_incoming_trans_of (SubactivityState{incoming,...}) = incoming

2
src/xmltree.sml
View File

@ -42,7 +42,7 @@ structure XmlTree : sig
end = struct
open library
infix 1 |>
exception IllFormed of string
exception IllFormed = Fail
(** A name-value pair. *)
type Attribute = (string * string)

2
src/xmltree_helper.sml
View File

@ -47,6 +47,8 @@ structure XmlTreeHelper : sig
(* val follow_all : string -> XmlTree.Tree list -> XmlTree.Tree list list *)
(* val apply_on : string -> (Attribute list -> 'a) -> XmlTree.Tree -> 'a*)
val some_id : XmlTree.Tree -> string
val some_id': XmlTree.Attribute list -> string
end =
struct
open library

57
src/xmltree_parser.sml
View File

@ -33,42 +33,41 @@ exception FileNotFound of string
structure Parser = Parse (structure Dtd = Dtd
structure Hooks = XmlTreeHooks
structure ParserOptions = ParserOptions ()
structure Resolve = ResolveNull)
structure ParserOptions = ParserOptions ()
structure Resolve = ResolveNull)
fun readFile filename =
let val currentDir = OS.FileSys.getDir()
(* how to do the following in a clean/portable way? *)
fun read_dtd dtd =
let val _ = OS.FileSys.chDir (su4sml_home())
(* dummy check to see if the file exists...*)
val _ = OS.FileSys.fileSize "UML15OCL.xmi"
val _ = Parser.parseDocument
(SOME (Uri.String2Uri ("file:UML15OCL.xmi")))
(SOME dtd) (dtd,nil,nil)
val _ = OS.FileSys.chDir currentDir
in ()
end
handle SysErr => (print ("Warning: in readFile: "^
"did not find file UML15OCL.xmi\n");
OS.FileSys.chDir currentDir )
(OS.FileSys.chDir (su4sml_home());
(* dummy check to see if the file exists...*)
OS.FileSys.fileSize "UML15OCL.xmi" ;
(Parser.parseDocument
(SOME (Uri.String2Uri ("file:UML15OCL.xmi")))
(SOME dtd) (dtd,nil,nil)
handle ex => (error ("Error while reading file UML15OCL.xmi: "^
General.exnMessage ex);
raise ex));
OS.FileSys.chDir currentDir )
fun read_file dtd filename =
if filename = "-" then
Parser.parseDocument
(NONE)
(SOME dtd) (dtd,nil,nil)
else
let (* dummy check to see if the file exists...*)
val _ = OS.FileSys.fileSize filename
in
Parser.parseDocument
(SOME (Uri.String2Uri filename))
(SOME dtd) (dtd,nil,nil)
end
handle SysErr => (print ("Warning: in readFile: did not find file "
^filename^"\n");
Node (("",nil),nil))
if filename = "-"
then Parser.parseDocument
(NONE)
(SOME dtd) (dtd,nil,nil)
else let (* dummy check to see if the file exists...*)
val _ = OS.FileSys.fileSize filename
in
Parser.parseDocument
(SOME (Uri.String2Uri filename))
(SOME dtd) (dtd,nil,nil)
end
handle ex => (error ("Error while reading file " ^filename^": "^
General.exnMessage ex);
raise ex)
val dtd = Dtd.initDtdTables()
in ( read_dtd dtd;
read_file dtd filename )