another typechecking but not (fully) functional version
git-svn-id: https://projects.brucker.ch/su4sml/svn/infsec-import/trunk/src/su4sml@4446 3260e6d1-4efc-4170-b0a7-36055960796d
This commit is contained in:
Jürgen Doser
parent
8199af7c64
commit
76f9ee17e7
|
|
@ -22,16 +22,25 @@
|
|||
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
******************************************************************************)
|
||||
|
||||
(**
|
||||
* This cartridge knows about the basic elements of UML class diagrams.
|
||||
* The elements are classifiers, attributes, and operations with their
|
||||
* parameters in terms of the Rep interface
|
||||
*)
|
||||
signature BASE_CARTRIDGE =
|
||||
sig
|
||||
include CARTRIDGE
|
||||
|
||||
(** returns the current classifier. *)
|
||||
val curClassifier: environment -> Rep.Classifier option
|
||||
|
||||
(** returns the current attribute *)
|
||||
val curAttribute: environment -> Rep.attribute option
|
||||
|
||||
(** returns the current operation *)
|
||||
val curOperation: environment -> Rep.operation option
|
||||
|
||||
include CARTRIDGE
|
||||
|
||||
(* specific for BASE_CARTRIDGE *)
|
||||
val model : environment -> Rep_SecureUML_ComponentUML.Model
|
||||
val curClassifier: environment -> Rep.Classifier option
|
||||
val curAttribute: environment -> Rep.attribute option
|
||||
val curOperation: environment -> Rep.operation option
|
||||
val curArgument : environment -> (string * Rep_OclType.OclType) option
|
||||
|
||||
end
|
||||
(** returns the current operation parameter *)
|
||||
val curArgument : environment -> (string * Rep_OclType.OclType) option
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -26,28 +26,30 @@ struct
|
|||
(* translation functions *)
|
||||
(* type translation table *)
|
||||
|
||||
fun oclType2Native t = Rep_OclType.string_of_OclType t
|
||||
|
||||
fun visibility2Native XMI.public = "public"
|
||||
| visibility2Native XMI.private = "private"
|
||||
fun oclType2Native t = Rep_OclType.string_of_OclType t
|
||||
|
||||
fun visibility2Native XMI.public = "public"
|
||||
| visibility2Native XMI.private = "private"
|
||||
| visibility2Native XMI.protected = "protected"
|
||||
| visibility2Native XMI.package = "package"
|
||||
|
||||
fun scope2Native XMI.ClassifierScope = "ClassifierScope"
|
||||
| scope2Native XMI.InstanceScope = "InstanceScope"
|
||||
|
||||
| visibility2Native XMI.package = "package"
|
||||
|
||||
fun scope2Native XMI.ClassifierScope = "ClassifierScope"
|
||||
| scope2Native XMI.InstanceScope = "InstanceScope"
|
||||
|
||||
|
||||
type Model = Rep.Classifier list
|
||||
|
||||
type environment = {model : Rep_SecureUML_ComponentUML.Model,
|
||||
curClassifier: Rep_Core.Classifier option,
|
||||
curOperation : Rep_Core.operation option,
|
||||
curAttribute : Rep_Core.attribute option ,
|
||||
curArgument : (string * Rep_OclType.OclType) option
|
||||
}
|
||||
|
||||
type environment = {model : Model,
|
||||
curClassifier: Rep_Core.Classifier option,
|
||||
curOperation : Rep_Core.operation option,
|
||||
curAttribute : Rep_Core.attribute option ,
|
||||
curArgument : (string * Rep_OclType.OclType) option
|
||||
}
|
||||
|
||||
(* service functions for other cartridges to have access to the current
|
||||
* list items
|
||||
*)
|
||||
fun model (env : environment) = #model env
|
||||
fun getModel (env : environment) = #model env
|
||||
fun curClassifier (env : environment) = (#curClassifier env)
|
||||
fun curAttribute (env : environment) = (#curAttribute env)
|
||||
fun curOperation (env : environment) = (#curOperation env)
|
||||
|
|
@ -59,134 +61,186 @@ fun curOperation' (env : environment) = Option.valOf((#curOperation env))
|
|||
fun curArgument' (env : environment) = Option.valOf((#curArgument env))
|
||||
|
||||
fun initEnv model = { model = model,
|
||||
curClassifier = NONE,
|
||||
curOperation = NONE,
|
||||
curAttribute = NONE,
|
||||
curArgument = NONE
|
||||
} : environment
|
||||
curClassifier = NONE,
|
||||
curOperation = NONE,
|
||||
curAttribute = NONE,
|
||||
curArgument = NONE } : environment
|
||||
|
||||
|
||||
(* FIX: check for NONEs in arguments environment *)
|
||||
fun lookup (env : environment) "classifier_name" = Rep_Core.short_name_of (curClassifier' env)
|
||||
| lookup (env : environment) "classifier_package" = (case (#curClassifier env) of
|
||||
NONE => Rep_OclType.string_of_path (Rep.package_of (hd (#1 (#model env))))
|
||||
| SOME c => Rep_OclType.string_of_path (Rep.package_of (curClassifier' env)))
|
||||
|
||||
| lookup (env : environment) "classifier_parent" = Rep_Core.short_parent_name_of (curClassifier' env)
|
||||
| lookup (env : environment) "attribute_name" = #name (curAttribute' env)
|
||||
| lookup (env : environment) "attribute_type" = oclType2Native (#attr_type (curAttribute' env))
|
||||
| lookup (env : environment) "attribute_visibility"= visibility2Native(#visibility (curAttribute' env))
|
||||
| lookup (env : environment) "attribute_scope" = scope2Native (#scope (curAttribute' env))
|
||||
| lookup (env : environment) "operation_name" = Rep.name_of_op (curOperation' env)
|
||||
| lookup (env : environment) "operation_result_type"= oclType2Native (Rep.result_of_op (curOperation' env))
|
||||
| lookup (env : environment) "operation_visibility"= visibility2Native (#visibility (curOperation' env))
|
||||
| lookup (env : environment) "operation_scope" = scope2Native (#scope (curOperation' env))
|
||||
(**
|
||||
* lookup base cartridge specific string-valued variables
|
||||
* The base cartridge knows the following variables:
|
||||
* classifier_name, classifier_package, classifier_parent,
|
||||
* attribute_name, attribute_type, attribute_visibility,
|
||||
* attribute_scope, operation_name, operation_result_type,
|
||||
* operation_visibility, operation_scope, argument_name, argument_type
|
||||
*)
|
||||
fun lookup (env : environment) "classifier_name"
|
||||
= Rep_Core.short_name_of (curClassifier' env)
|
||||
| lookup (env : environment) "classifier_package"
|
||||
= (case (#curClassifier env) of
|
||||
NONE => Rep_OclType.string_of_path (Rep.package_of (hd (#model env)))
|
||||
| SOME c => Rep_OclType.string_of_path
|
||||
(Rep.package_of (curClassifier' env)))
|
||||
| lookup (env : environment) "classifier_parent"
|
||||
= Rep_Core.short_parent_name_of (curClassifier' env)
|
||||
| lookup (env : environment) "attribute_name"
|
||||
= #name (curAttribute' env)
|
||||
| lookup (env : environment) "attribute_type"
|
||||
= oclType2Native (#attr_type (curAttribute' env))
|
||||
| lookup (env : environment) "attribute_visibility"
|
||||
= visibility2Native(#visibility (curAttribute' env))
|
||||
| lookup (env : environment) "attribute_scope"
|
||||
= scope2Native (#scope (curAttribute' env))
|
||||
| lookup (env : environment) "operation_name"
|
||||
= Rep.name_of_op (curOperation' env)
|
||||
| lookup (env : environment) "operation_result_type"
|
||||
= oclType2Native (Rep.result_of_op (curOperation' env))
|
||||
| lookup (env : environment) "operation_visibility"
|
||||
= visibility2Native (#visibility (curOperation' env))
|
||||
| lookup (env : environment) "operation_scope"
|
||||
= scope2Native (#scope (curOperation' env))
|
||||
| lookup (env : environment) "argument_name" = #1 (curArgument' env)
|
||||
| lookup (env : environment) "argument_type" = oclType2Native (#2 (curArgument' env))
|
||||
| lookup _ s = (Gcg_Helper.gcg_warning ("Couldn't lookup \""^s^"\" in base_cartridge.lookup !"); s)
|
||||
| lookup (env : environment) "argument_type"
|
||||
= oclType2Native (#2 (curArgument' env))
|
||||
| lookup _ s = (Gcg_Helper.gcg_warning ("Couldn't lookup \""^s^
|
||||
"\" in base_cartridge.lookup !"); s)
|
||||
|
||||
|
||||
|
||||
(**
|
||||
* evaluate base cartridge specific predicates.
|
||||
* The base cartridge supports the following predicates:
|
||||
* isClass, isInterface, isEnumeration, isPrimitive, hasParent,
|
||||
* first_classifier, first_attribute, first_operation, first_argument,
|
||||
* last_classifier, last_attribute, last_operation, last_argument,
|
||||
* attribute_isPublic, attribute_isProtected, attribute_isPrivate,
|
||||
* attribute_isPackage, attribute_isStatic, operation_isPublic,
|
||||
* operation_isPrivate, operation_isProtected, operation_isPackage,
|
||||
* operation_isStatic,
|
||||
*)
|
||||
fun evalCondition (env : environment) "isClass"
|
||||
= (case (#curClassifier env) of SOME (Rep.Class{...}) => true
|
||||
| _ => false)
|
||||
= (case (#curClassifier env) of SOME (Rep.Class{...}) => true
|
||||
| _ => false)
|
||||
| evalCondition (env : environment) "isInterface"
|
||||
= (case (#curClassifier env) of SOME (Rep.Interface{...}) => true
|
||||
| _ => false)
|
||||
= (case (#curClassifier env) of SOME (Rep.Interface{...}) => true
|
||||
| _ => false)
|
||||
| evalCondition (env : environment) "isEnumeration"
|
||||
= (case (#curClassifier env) of SOME (Rep.Enumeration{...}) => true
|
||||
| _ => false)
|
||||
= (case (#curClassifier env) of SOME (Rep.Enumeration{...}) => true
|
||||
| _ => false)
|
||||
| evalCondition (env : environment) "isPrimitive"
|
||||
= (case (#curClassifier env) of SOME (Rep.Primitive{...}) => true
|
||||
| _ => false)
|
||||
= (case (#curClassifier env) of SOME (Rep.Primitive{...}) => true
|
||||
| _ => false)
|
||||
| evalCondition (env : environment) "hasParent"
|
||||
= let val parentName =
|
||||
Rep_OclType.string_of_path (Rep.parent_name_of (curClassifier' env))
|
||||
= let val parentName =
|
||||
Rep_OclType.string_of_path (Rep.parent_name_of (curClassifier' env))
|
||||
in
|
||||
(parentName <> "OclAny")
|
||||
end
|
||||
| evalCondition (env : environment) "first_classifier" = (curClassifier' env = hd (#1 (#model env)))
|
||||
| evalCondition (env : environment) "first_attribute" = (curAttribute' env = hd (Rep_Core.attributes_of (curClassifier' env)))
|
||||
| evalCondition (env : environment) "first_operation" = (curOperation' env = hd (Rep_Core.operations_of (curClassifier' env)))
|
||||
| evalCondition (env : environment) "first_argument" = (curArgument' env = hd (Rep_Core.arguments_of_op (curOperation' env)))
|
||||
| evalCondition (env : environment) "last_classifier" = (curClassifier' env = List.last (#1 (#model env)))
|
||||
| evalCondition (env : environment) "last_attribute" = (curAttribute' env = List.last (Rep_Core.attributes_of (curClassifier' env)))
|
||||
| evalCondition (env : environment) "last_operation" = (curOperation' env = List.last (Rep_Core.operations_of (curClassifier' env)))
|
||||
| evalCondition (env : environment) "last_argument" = (curArgument' env = List.last (Rep_Core.arguments_of_op (curOperation' env)))
|
||||
| evalCondition (env : environment) "attribute_isPublic" = ((#visibility (curAttribute' env)) = XMI.public)
|
||||
| evalCondition (env : environment) "attribute_isPrivate" = ((#visibility (curAttribute' env)) = XMI.private)
|
||||
| evalCondition (env : environment) "attribute_isProtected"=((#visibility (curAttribute' env)) = XMI.protected)
|
||||
| evalCondition (env : environment) "attribute_isPackage" = ((#visibility (curAttribute' env)) = XMI.package)
|
||||
| evalCondition (env : environment) "attribute_isStatic" = ((#scope (curAttribute' env)) = XMI.ClassifierScope)
|
||||
| evalCondition (env : environment) "operation_isPublic" = ((#visibility (curOperation' env)) = XMI.public)
|
||||
| evalCondition (env : environment) "operation_isPrivate" = ((#visibility (curOperation' env)) = XMI.private)
|
||||
| evalCondition (env : environment) "operation_isProtected"=((#visibility (curOperation' env)) = XMI.protected)
|
||||
| evalCondition (env : environment) "operation_isPackage" = ((#visibility (curOperation' env)) = XMI.package)
|
||||
| evalCondition (env : environment) "operation_isStatic" = ((#scope (curOperation' env)) = XMI.ClassifierScope)
|
||||
(parentName <> "OclAny")
|
||||
end
|
||||
| evalCondition (env : environment) "first_classifier"
|
||||
= (curClassifier' env = hd (#model env))
|
||||
| evalCondition (env : environment) "first_attribute"
|
||||
= (curAttribute' env = hd (Rep_Core.attributes_of (curClassifier' env)))
|
||||
| evalCondition (env : environment) "first_operation"
|
||||
= (curOperation' env = hd (Rep_Core.operations_of (curClassifier' env)))
|
||||
| evalCondition (env : environment) "first_argument"
|
||||
= (curArgument' env = hd (Rep_Core.arguments_of_op (curOperation' env)))
|
||||
| evalCondition (env : environment) "last_classifier"
|
||||
= (curClassifier' env = List.last (#model env))
|
||||
| evalCondition (env : environment) "last_attribute"
|
||||
= (curAttribute' env = List.last (Rep_Core.attributes_of (curClassifier' env)))
|
||||
| evalCondition (env : environment) "last_operation"
|
||||
= (curOperation' env = List.last (Rep_Core.operations_of (curClassifier' env)))
|
||||
| evalCondition (env : environment) "last_argument"
|
||||
= (curArgument' env = List.last (Rep_Core.arguments_of_op (curOperation' env)))
|
||||
| evalCondition (env : environment) "attribute_isPublic"
|
||||
= ((#visibility (curAttribute' env)) = XMI.public)
|
||||
| evalCondition (env : environment) "attribute_isPrivate"
|
||||
= ((#visibility (curAttribute' env)) = XMI.private)
|
||||
| evalCondition (env : environment) "attribute_isProtected"
|
||||
=((#visibility (curAttribute' env)) = XMI.protected)
|
||||
| evalCondition (env : environment) "attribute_isPackage"
|
||||
= ((#visibility (curAttribute' env)) = XMI.package)
|
||||
| evalCondition (env : environment) "attribute_isStatic"
|
||||
= ((#scope (curAttribute' env)) = XMI.ClassifierScope)
|
||||
| evalCondition (env : environment) "operation_isPublic"
|
||||
= ((#visibility (curOperation' env)) = XMI.public)
|
||||
| evalCondition (env : environment) "operation_isPrivate"
|
||||
= ((#visibility (curOperation' env)) = XMI.private)
|
||||
| evalCondition (env : environment) "operation_isProtected"
|
||||
=((#visibility (curOperation' env)) = XMI.protected)
|
||||
| evalCondition (env : environment) "operation_isPackage"
|
||||
= ((#visibility (curOperation' env)) = XMI.package)
|
||||
| evalCondition (env : environment) "operation_isStatic"
|
||||
= ((#scope (curOperation' env)) = XMI.ClassifierScope)
|
||||
| evalCondition (env : environment) s
|
||||
= Gcg_Helper.gcg_error ("Couldn't evaluate if-condition: "^s^" in base_cartridge.evalCondition")
|
||||
= Gcg_Helper.gcg_error ("Couldn't evaluate if-condition: "^s^
|
||||
" in base_cartridge.evalCondition")
|
||||
|
||||
|
||||
(* fun foreach_classifier: environment -> environment list *)
|
||||
fun foreach_classifier (env : environment)
|
||||
= let val cl = #1 (#model env);
|
||||
fun env_from_classifier c =
|
||||
{ model = (#model env),
|
||||
curClassifier = SOME c,
|
||||
curOperation = NONE,
|
||||
curAttribute = NONE,
|
||||
curArgument = NONE
|
||||
}
|
||||
in
|
||||
List.map env_from_classifier cl
|
||||
end
|
||||
|
||||
= let val cl = (#model env)
|
||||
fun env_from_classifier c = { model = (#model env),
|
||||
curClassifier = SOME c,
|
||||
curOperation = NONE,
|
||||
curAttribute = NONE,
|
||||
curArgument = NONE }
|
||||
in
|
||||
List.map env_from_classifier cl
|
||||
end
|
||||
|
||||
fun foreach_attribute (env : environment)
|
||||
= let val attrs = Rep_Core.attributes_of (curClassifier' env);
|
||||
fun env_from_attr a =
|
||||
{ model = #model env,
|
||||
curClassifier = SOME (curClassifier' env),
|
||||
curOperation = NONE,
|
||||
curAttribute = SOME a,
|
||||
curArgument = NONE
|
||||
}
|
||||
in
|
||||
List.map env_from_attr attrs
|
||||
end
|
||||
= let val attrs = Rep_Core.attributes_of (curClassifier' env)
|
||||
fun env_from_attr a = { model = #model env,
|
||||
curClassifier = SOME (curClassifier' env),
|
||||
curOperation = NONE,
|
||||
curAttribute = SOME a,
|
||||
curArgument = NONE }
|
||||
in
|
||||
List.map env_from_attr attrs
|
||||
end
|
||||
|
||||
fun foreach_operation (env : environment)
|
||||
= let val ops = Rep_Core.operations_of (curClassifier' env);
|
||||
fun env_from_op operation =
|
||||
{ model = #model env,
|
||||
curClassifier = SOME (curClassifier' env),
|
||||
curOperation = SOME operation,
|
||||
curAttribute = NONE,
|
||||
curArgument = NONE
|
||||
}
|
||||
in
|
||||
List.map env_from_op ops
|
||||
end
|
||||
= let val ops = Rep_Core.operations_of (curClassifier' env)
|
||||
fun env_from_op operation = { model = #model env,
|
||||
curClassifier = SOME (curClassifier' env),
|
||||
curOperation = SOME operation,
|
||||
curAttribute = NONE,
|
||||
curArgument = NONE }
|
||||
in
|
||||
List.map env_from_op ops
|
||||
end
|
||||
|
||||
fun foreach_argument (env : environment)
|
||||
= let val args = Rep_Core.arguments_of_op (curOperation' env);
|
||||
fun env_from_argument arg =
|
||||
{ model = #model env,
|
||||
curClassifier = SOME (curClassifier' env),
|
||||
curOperation = SOME (curOperation' env),
|
||||
curAttribute = NONE,
|
||||
curArgument = SOME arg
|
||||
}
|
||||
in
|
||||
List.map env_from_argument args
|
||||
end
|
||||
|
||||
fun foreach "classifier_list" env = foreach_classifier env
|
||||
| foreach "attribute_list" env = foreach_attribute env
|
||||
| foreach "operation_list" env = foreach_operation env
|
||||
| foreach "argument_list" env = foreach_argument env
|
||||
(* hier muss man das Environment noch etwas umpacken
|
||||
| foreach listType env = map (pack env) (<SuperCartridge>.foreach name (unpack env))
|
||||
*)
|
||||
| foreach s _ = Gcg_Helper.gcg_error ("Couldn't write foreach "^s^" ." ^
|
||||
"\""^s^"\" not defined in base_cartridge.foreach ")
|
||||
= let val args = Rep_Core.arguments_of_op (curOperation' env)
|
||||
fun env_from_argument arg = { model = #model env,
|
||||
curClassifier = SOME (curClassifier' env),
|
||||
curOperation = SOME (curOperation' env),
|
||||
curAttribute = NONE,
|
||||
curArgument = SOME arg }
|
||||
in
|
||||
List.map env_from_argument args
|
||||
end
|
||||
|
||||
(**
|
||||
* compute the base cartridge specific lists.
|
||||
* The base cartridge supports the following lists:
|
||||
* classifier_list iterates over all classifiers of the model,
|
||||
* attribute_list iterates over all attributes of the current
|
||||
* classifier, operation_list iterates over all operations of the
|
||||
* current classifier, argument_list iterates over all arguments of
|
||||
* the current operation
|
||||
*)
|
||||
fun foreach "classifier_list" env = foreach_classifier env
|
||||
| foreach "attribute_list" env = foreach_attribute env
|
||||
| foreach "operation_list" env = foreach_operation env
|
||||
| foreach "argument_list" env = foreach_argument env
|
||||
(* hier muss man das Environment noch etwas umpacken
|
||||
| foreach listType env = map (pack env)
|
||||
(<SuperCartridge>.foreach name (unpack env))
|
||||
*)
|
||||
| foreach s _ = Gcg_Helper.gcg_error ("Couldn't write foreach "^s^" ."^"\""^s^
|
||||
"\" not defined in base_cartridge.foreach ")
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -22,22 +22,27 @@
|
|||
******************************************************************************)
|
||||
|
||||
functor CSharp_Cartridge(SuperCart : CARTRIDGE) : CARTRIDGE =
|
||||
struct
|
||||
open Rep_OclType
|
||||
|
||||
|
||||
struct
|
||||
open Rep_OclType
|
||||
|
||||
|
||||
type Model = SuperCart.Model
|
||||
|
||||
type environment = { extension : SuperCart.environment }
|
||||
|
||||
|
||||
|
||||
fun getModel (env:environment) = SuperCart.getModel (#extension env)
|
||||
|
||||
|
||||
|
||||
|
||||
fun initEnv model = { extension = SuperCart.initEnv model } : environment
|
||||
|
||||
|
||||
fun unpack (env : environment) = #extension env
|
||||
|
||||
|
||||
fun pack superEnv = {extension = superEnv} : environment
|
||||
|
||||
|
||||
(* internal translation table *)
|
||||
|
||||
(* internal translation table *)
|
||||
fun super2Native "ClassifierScope" = "static"
|
||||
| super2Native "InstanceScope" = ""
|
||||
| super2Native "package" = "public"
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ functor CSharp_NET1_Cartridge(SuperCart : CARTRIDGE) : CARTRIDGE =
|
|||
|
||||
|
||||
type environment = { extension : SuperCart.environment }
|
||||
|
||||
type Model = SuperCart.Model
|
||||
|
||||
|
||||
fun initEnv model = { extension = SuperCart.initEnv model } : environment
|
||||
|
|
@ -36,6 +36,7 @@ fun unpack (env : environment) = #extension env
|
|||
|
||||
fun pack superEnv = {extension = superEnv} : environment
|
||||
|
||||
fun getModel (env:environment) = SuperCart.getModel (unpack env)
|
||||
|
||||
(* internal translation table *)
|
||||
fun super2Native "ClassifierScope" = "static"
|
||||
|
|
|
|||
|
|
@ -21,13 +21,42 @@
|
|||
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
******************************************************************************)
|
||||
|
||||
(** the minimal signature every code-generator cartridge has to implement. *)
|
||||
signature CARTRIDGE =
|
||||
sig
|
||||
(* translation functions *)
|
||||
type environment
|
||||
val initEnv : Rep_SecureUML_ComponentUML.Model -> environment
|
||||
|
||||
val lookup : environment -> string -> string
|
||||
val evalCondition : environment -> string -> bool
|
||||
val foreach : string -> environment -> environment list
|
||||
end
|
||||
|
||||
(**
|
||||
* the environment in which template-file statements are to be evaluated.
|
||||
* Ususally this will contain lists of model elements and
|
||||
* "pointers" to the "current" elements
|
||||
*)
|
||||
type environment
|
||||
|
||||
(**
|
||||
* The particular model from which model element information is
|
||||
* taken.
|
||||
* This can be cartridge specific.
|
||||
*)
|
||||
type Model
|
||||
|
||||
(**
|
||||
* returns the model information as it is part of the current
|
||||
* environment.
|
||||
*)
|
||||
val getModel : environment -> Model
|
||||
|
||||
(** initialze the environment by parsing the given classifier list *)
|
||||
val initEnv : Rep.Model -> environment
|
||||
|
||||
(** look up string-valued variables in the environment by name. *)
|
||||
val lookup : environment -> string -> string
|
||||
|
||||
(** evaluate boolean-valued predicates in the environment by name. *)
|
||||
val evalCondition : environment -> string -> bool
|
||||
|
||||
(**
|
||||
* return a list of environment, where the "current" element
|
||||
* iterates over a given list.
|
||||
*)
|
||||
val foreach : string -> environment -> environment list
|
||||
end
|
||||
|
|
|
|||
|
|
@ -43,15 +43,15 @@ structure JavaSecure_Gcg = GCG_Core (Java_Cartridge(SecureUML_Cartridge(Base_Car
|
|||
*)
|
||||
|
||||
fun generate xmi_file "base" =
|
||||
Base_Gcg.generate ( Rep_SecureUML_ComponentUML.readXMI xmi_file) "templates/base.tpl"
|
||||
Base_Gcg.generate ( Xmi2Rep.readXMI xmi_file) "templates/base.tpl"
|
||||
| generate xmi_file "c#" =
|
||||
CSharp_Gcg.generate ( Rep_SecureUML_ComponentUML.readXMI xmi_file) "templates/C#.tpl"
|
||||
CSharp_Gcg.generate ( Xmi2Rep.readXMI xmi_file) "templates/C#.tpl"
|
||||
| generate xmi_file "c#_secure" =
|
||||
CSharpSecure_Gcg.generate ( Rep_SecureUML_ComponentUML.readXMI xmi_file) "templates/C#_SecureUML.tpl"
|
||||
CSharpSecure_Gcg.generate ( Xmi2Rep.readXMI xmi_file) "templates/C#_SecureUML.tpl"
|
||||
| generate xmi_file "c#_net1" =
|
||||
CSharp_NET1_Gcg.generate ( Rep_SecureUML_ComponentUML.readXMI xmi_file) "templates/C#.tpl"
|
||||
CSharp_NET1_Gcg.generate ( Xmi2Rep.readXMI xmi_file) "templates/C#.tpl"
|
||||
| generate xmi_file "c#_secure_net1" =
|
||||
CSharpSecure_NET1_Gcg.generate ( Rep_SecureUML_ComponentUML.readXMI xmi_file) "templates/C#_SecureUML.tpl"
|
||||
CSharpSecure_NET1_Gcg.generate ( Xmi2Rep.readXMI xmi_file) "templates/C#_SecureUML.tpl"
|
||||
(*
|
||||
| generate "java" = Java_Gcg.generate model "templates/java.tpl"
|
||||
| generate "java_secure" = JavaSecure_Gcg.generate model "templates/java_SecureUML.tpl"
|
||||
|
|
|
|||
|
|
@ -6,8 +6,10 @@ struct
|
|||
|
||||
structure Design = ComponentUML
|
||||
|
||||
|
||||
(* TODO: fill out *)
|
||||
type environment = {extension: SuperCart.environment}
|
||||
type environment = { extension: SuperCart.environment}
|
||||
type Model = SuperCart.Model
|
||||
|
||||
(* unpack : environment -> SuperCart.environment *)
|
||||
fun unpack (env : environment) = #extension env
|
||||
|
|
@ -16,13 +18,14 @@ fun unpack (env : environment) = #extension env
|
|||
fun pack (env: environment) (new_env : SuperCart.environment) = {extension = new_env}
|
||||
|
||||
fun initEnv model = {extension = SuperCart.initEnv model}
|
||||
fun model (env : environment) = SuperCart.model (unpack env)
|
||||
fun getModel (env : environment) = SuperCart.getModel (unpack env)
|
||||
fun curClassifier (env : environment) = SuperCart.curClassifier (unpack env)
|
||||
fun curAttribute (env : environment) = SuperCart.curAttribute (unpack env)
|
||||
fun curOperation (env : environment) = SuperCart.curOperation (unpack env)
|
||||
fun curArgument (env : environment) = SuperCart.curArgument (unpack env)
|
||||
|
||||
|
||||
(* FIX *)
|
||||
fun permissionsForAction env _ = nil
|
||||
|
||||
(* computePermissionContext: environment -> permissionContext
|
||||
|
|
@ -59,7 +62,7 @@ fun computePermissionContext (env : environment)=
|
|||
destructor_permissions = permissionsForAction env (getAction "delete")
|
||||
}
|
||||
else
|
||||
{permissions = #permissions (#2 (model env)),
|
||||
{permissions = SuperCart.Security.getPermissions (#2 (getModel env)),
|
||||
setter_permissions = [],
|
||||
getter_permissions = [],
|
||||
constructor_permissions = [],
|
||||
|
|
|
|||
|
|
@ -23,15 +23,3 @@
|
|||
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
******************************************************************************)
|
||||
|
||||
signature GCG =
|
||||
sig
|
||||
|
||||
(*structure C : CARTRIDGE*)
|
||||
|
||||
val writeLine : string -> unit
|
||||
|
||||
val generate : Rep_SecureUML_ComponentUML.Model -> string -> unit
|
||||
(*
|
||||
val generate : C.environment -> unit
|
||||
*)
|
||||
end
|
||||
|
|
@ -23,48 +23,44 @@
|
|||
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
******************************************************************************)
|
||||
|
||||
signature GCG =
|
||||
sig
|
||||
|
||||
val writeLine : string -> unit
|
||||
val generate : Rep.Model -> string -> unit
|
||||
|
||||
end
|
||||
|
||||
functor GCG_Core (C: CARTRIDGE): GCG =
|
||||
struct
|
||||
|
||||
val curFile = ref "";
|
||||
val curFile = ref ""
|
||||
|
||||
|
||||
val out = ref TextIO.stdOut;
|
||||
val out = ref TextIO.stdOut
|
||||
|
||||
fun closeFile ()= if (!curFile = "")
|
||||
then ()
|
||||
else (TextIO.closeOut (!out);
|
||||
print ((!curFile)^" ... done\n");
|
||||
curFile := "")
|
||||
then ()
|
||||
else (TextIO.closeOut (!out);
|
||||
print ((!curFile)^" ... done\n");
|
||||
curFile := "")
|
||||
|
||||
|
||||
fun openFile file = (closeFile ();
|
||||
print ("opening "^file^"...\n");
|
||||
Gcg_Helper.assureDir file;
|
||||
out := (TextIO.openOut file);
|
||||
curFile := file
|
||||
)
|
||||
print ("opening "^file^"...\n");
|
||||
Gcg_Helper.assureDir file;
|
||||
out := (TextIO.openOut file);
|
||||
curFile := file
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
fun initOut () = (out := TextIO.stdOut;
|
||||
curFile := "")
|
||||
curFile := "")
|
||||
|
||||
|
||||
|
||||
fun writeLine s = TextIO.output (!out,s)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
fun eval s = (print ("<eval>\n");
|
||||
CompilerExt.eval true s;
|
||||
print "<>\n")
|
||||
|
||||
|
||||
|
||||
CompilerExt.eval true s;
|
||||
print "<>\n")
|
||||
|
||||
(** applies f to every other element in l starting with the second
|
||||
*)
|
||||
|
|
@ -78,10 +74,7 @@ fun substituteVars e s = let val tkl = (Gcg_Helper.joinEscapeSplitted "$") (Gcg_
|
|||
end
|
||||
|
||||
|
||||
(**
|
||||
* main function of gcg_core.
|
||||
* traverses a templateParseTree and executes the given instructions
|
||||
*)
|
||||
(** traverses a templateParseTree and executes the given instructions *)
|
||||
fun write env (Tpl_Parser.RootNode(l)) = List.app (write env) l
|
||||
| write env (Tpl_Parser.OpenFileLeaf(file)) = openFile (substituteVars env file)
|
||||
| write env (Tpl_Parser.EvalLeaf(l)) = let fun collectEval [] = ""
|
||||
|
|
@ -114,17 +107,17 @@ fun write env (Tpl_Parser.RootNode(l)) = List.app (write env) l
|
|||
end
|
||||
|
||||
|
||||
|
||||
(** generate code according to the given template file for the given model *)
|
||||
fun generate model template
|
||||
= let val env = C.initEnv model ;
|
||||
val tree = Tpl_Parser.parse template
|
||||
in
|
||||
(initOut();
|
||||
(*printTTree tree;*)
|
||||
write env tree;
|
||||
closeFile () )
|
||||
handle GCG_Error => (closeFile(); raise GCG_Error)
|
||||
end
|
||||
|
||||
|
||||
= let val env = C.initEnv model
|
||||
val tree = Tpl_Parser.parse template
|
||||
in
|
||||
(initOut();
|
||||
(*printTTree tree;*)
|
||||
write env tree;
|
||||
closeFile () )
|
||||
handle GCG_Error => (closeFile(); raise GCG_Error)
|
||||
end
|
||||
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -22,17 +22,19 @@
|
|||
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
******************************************************************************)
|
||||
|
||||
|
||||
signature SECUREUML_CARTRIDGE =
|
||||
sig
|
||||
include BASE_CARTRIDGE
|
||||
|
||||
(* from CARTRIDGE *)
|
||||
include BASE_CARTRIDGE
|
||||
(* specific for SECUREUML_CARTRIDGE *)
|
||||
val curPermissionSet: environment -> Rep_SecureUML_ComponentUML.Security.Permission list option
|
||||
val curPermission : environment -> Rep_SecureUML_ComponentUML.Security.Permission option
|
||||
val curRole : environment -> string option
|
||||
val curConstraint : environment -> Rep_OclTerm.OclTerm option
|
||||
(** the particular secureuml dialect used *)
|
||||
structure Security:SECURITY_LANGUAGE
|
||||
|
||||
val curPermissionSet: environment -> Security.Permission list option
|
||||
val curPermission : environment -> Security.Permission option
|
||||
val curRole : environment -> string option
|
||||
val curConstraint : environment -> Rep_OclTerm.OclTerm option
|
||||
|
||||
val isInPermission : Security.Design.Action -> Security.Permission -> bool
|
||||
|
||||
val isInPermission : Rep_SecureUML_ComponentUML.Security.Design.Action -> Rep_SecureUML_ComponentUML.Security.Permission -> bool
|
||||
structure Security:SECURITY_LANGUAGE
|
||||
end
|
||||
|
|
|
|||
|
|
@ -24,58 +24,65 @@
|
|||
******************************************************************************)
|
||||
|
||||
|
||||
functor SecureUML_Cartridge(structure SuperCart : BASE_CARTRIDGE; structure D: DESIGN_LANGUAGE) : SECURITY_LANGUAGE_CARTRIDGE =
|
||||
struct
|
||||
functor SecureUML_Cartridge(structure SuperCart : BASE_CARTRIDGE;
|
||||
structure D: DESIGN_LANGUAGE)
|
||||
: SECUREUML_CARTRIDGE =
|
||||
struct
|
||||
|
||||
structure Security = SecureUML(structure Design = D)
|
||||
|
||||
structure Security = SecureUML(structure Design = D)
|
||||
|
||||
type environment = { curPermissionSet: Security.Permission list option,
|
||||
curPermission : Security.Permission option,
|
||||
curRole : string option,
|
||||
curConstraint : Rep_OclTerm.OclTerm option,
|
||||
extension : SuperCart.environment }
|
||||
|
||||
|
||||
(* service functions for other cartridges to have access to the current
|
||||
* list items
|
||||
* FIX: check for NONE's
|
||||
type Model = Rep.Classifier list * Security.Configuration
|
||||
|
||||
type environment = { model : Model,
|
||||
curPermissionSet: Security.Permission list option,
|
||||
curPermission : Security.Permission option,
|
||||
curRole : string option,
|
||||
curConstraint : Rep_OclTerm.OclTerm option,
|
||||
extension : SuperCart.environment }
|
||||
|
||||
fun getPermissions conf = Security.getPermissions conf
|
||||
|
||||
(* service functions for other cartridges to have access to the current
|
||||
* list items
|
||||
* FIX: check for NONE's
|
||||
*)
|
||||
fun curPermissionSet (env : environment) = (#curPermissionSet env)
|
||||
fun curPermission (env : environment) = (#curPermission env)
|
||||
fun curRole (env : environment) = (#curRole env)
|
||||
fun curConstraint (env : environment) = (#curConstraint env)
|
||||
|
||||
fun curPermissionSet' (env : environment) = Option.valOf (#curPermissionSet env)
|
||||
fun curPermission' (env : environment) = Option.valOf (#curPermission env)
|
||||
fun curRole' (env : environment) = Option.valOf (#curRole env)
|
||||
fun curConstraint' (env : environment) = Option.valOf (#curConstraint env)
|
||||
|
||||
fun initEnv model = { curPermissionSet = NONE,
|
||||
curPermission = NONE,
|
||||
curRole = NONE,
|
||||
curConstraint = NONE,
|
||||
extension = SuperCart.initEnv model } : environment
|
||||
fun curPermissionSet (env : environment) = (#curPermissionSet env)
|
||||
fun curPermission (env : environment) = (#curPermission env)
|
||||
fun curRole (env : environment) = (#curRole env)
|
||||
fun curConstraint (env : environment) = (#curConstraint env)
|
||||
|
||||
fun curPermissionSet' (env : environment) = Option.valOf (#curPermissionSet env)
|
||||
fun curPermission' (env : environment) = Option.valOf (#curPermission env)
|
||||
fun curRole' (env : environment) = Option.valOf (#curRole env)
|
||||
fun curConstraint' (env : environment) = Option.valOf (#curConstraint env)
|
||||
|
||||
fun initEnv model = { model = Security.parse model,
|
||||
curPermissionSet = NONE,
|
||||
curPermission = NONE,
|
||||
curRole = NONE,
|
||||
curConstraint = NONE,
|
||||
extension = SuperCart.initEnv model } : environment
|
||||
|
||||
(* unpack : environment -> SuperCart.environment *)
|
||||
fun unpack (env : environment) = #extension env
|
||||
|
||||
(* pack : environment -> SuperCart.environment -> environment *)
|
||||
fun pack (env: environment) (new_env : SuperCart.environment)
|
||||
= { curPermissionSet = #curPermissionSet env,
|
||||
curPermission = #curPermission env,
|
||||
curRole = #curRole env,
|
||||
curConstraint = #curConstraint env,
|
||||
extension=new_env}
|
||||
|
||||
|
||||
= { model = #model env,
|
||||
curPermissionSet = #curPermissionSet env,
|
||||
curPermission = #curPermission env,
|
||||
curRole = #curRole env,
|
||||
curConstraint = #curConstraint env,
|
||||
extension = new_env}
|
||||
|
||||
|
||||
(* Helper functions that get the SuperCartridge's needed environment values *)
|
||||
fun model (env : environment) = SuperCart.model (unpack env)
|
||||
fun getModel (env : environment) = #model env
|
||||
fun curClassifier (env : environment) = SuperCart.curClassifier (unpack env)
|
||||
fun curAttribute (env : environment) = SuperCart.curAttribute (unpack env)
|
||||
fun curOperation (env : environment) = SuperCart.curOperation (unpack env)
|
||||
fun curArgument (env : environment) = SuperCart.curArgument (unpack env)
|
||||
|
||||
|
||||
fun is_contained_in a1 a2 = (a1 = a2) orelse
|
||||
List.exists (fn x=> x=true) ((List.map (is_contained_in a1) (D.subordinated_actions a2)))
|
||||
|
||||
|
|
@ -109,28 +116,28 @@ fun evalCondition (env : environment) "first_permission" = (curPermission' env
|
|||
|
||||
|
||||
fun foreach_role (env : environment)
|
||||
= let val roles = #roles (curPermission' env);
|
||||
fun env_from_list_item r ={curPermissionSet = #curPermissionSet env,
|
||||
curPermission = #curPermission env,
|
||||
curRole = SOME r ,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
List.map env_from_list_item roles
|
||||
end
|
||||
|
||||
= let val roles = #roles (curPermission' env);
|
||||
fun env_from_list_item r ={ model = #model env,
|
||||
curPermissionSet = #curPermissionSet env,
|
||||
curPermission = #curPermission env,
|
||||
curRole = SOME r ,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env } : environment
|
||||
in
|
||||
List.map env_from_list_item roles
|
||||
end
|
||||
|
||||
fun foreach_constraint (env : environment)
|
||||
= let val cons = #constraints (curPermission' env);
|
||||
fun env_from_list_item c ={curPermissionSet = #curPermissionSet env,
|
||||
curPermission = #curPermission env,
|
||||
curRole = NONE ,
|
||||
curConstraint = SOME c,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
List.map env_from_list_item cons
|
||||
end
|
||||
= let val cons = #constraints (curPermission' env);
|
||||
fun env_from_list_item c ={ model = #model env,
|
||||
curPermissionSet = #curPermissionSet env,
|
||||
curPermission = #curPermission env,
|
||||
curRole = NONE ,
|
||||
curConstraint = SOME c,
|
||||
extension = #extension env } : environment
|
||||
in
|
||||
List.map env_from_list_item cons
|
||||
end
|
||||
|
||||
|
||||
fun foreach "role_list" env = foreach_role env
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
signature SECURITY_LANGUAGE_CARTRIDGE =
|
||||
sig
|
||||
|
||||
include BASE_CARTRIDGE
|
||||
structure Security: SECURITY_LANGUAGE
|
||||
|
||||
structure Security: SECURITY_LANGUAGE
|
||||
|
||||
include BASE_CARTRIDGE where
|
||||
type Model = Rep.Classifier list * Security.Configuration
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -65,7 +65,8 @@ sig
|
|||
val name_of : User -> string
|
||||
|
||||
eqtype Permission
|
||||
|
||||
|
||||
val getPermissions : Configuration -> Permission list
|
||||
(* a bit unclear, which of the following we really need *)
|
||||
val users_of : Permission -> User list
|
||||
(* val permissions_of : User -> Permission list *)
|
||||
|
|
|
|||
|
|
@ -27,5 +27,6 @@ sig
|
|||
|
||||
include REP_CORE
|
||||
include REP_ACTIVITY_GRAPH
|
||||
|
||||
|
||||
type Model = Rep_Core.Classifier list
|
||||
end
|
||||
|
|
|
|||
|
|
@ -26,4 +26,6 @@ structure Rep : REP =
|
|||
struct
|
||||
|
||||
open Rep_Core Rep_StateMachine Rep_ActivityGraph
|
||||
|
||||
type Model = Classifier list
|
||||
end
|
||||
|
|
|
|||
|
|
@ -70,6 +70,7 @@ fun type_of (c:Configuration) = #config_type c
|
|||
fun is_empty (c:Configuration) = List.null (#permissions c) andalso
|
||||
List.null (#subjects c)
|
||||
|
||||
fun getPermissions (c:Configuration) = #permissions c
|
||||
|
||||
(* the following functions have yet to be implemented *)
|
||||
fun users_of p = nil
|
||||
|
|
|
|||
Loading…
Reference in New Issue