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

re-worked logger 

git-svn-id: https://projects.brucker.ch/su4sml/svn/su4sml/trunk@8370 3260e6d1-4efc-4170-b0a7-36055960796d
This commit is contained in:
Achim D. Brucker 2009-01-03 21:18:36 +00:00
parent ef3d967d8a
commit f4f523bb50
57 changed files with 998 additions and 1013 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
su4sml/src/ROOT.ML
View File

@ -39,6 +39,7 @@
******************************************************************************) ******************************************************************************)
(* $Id$ *) (* $Id$ *)
use "config.sml";
use "rep_helper.sml"; use "rep_helper.sml";
use "rep_logger.sml"; use "rep_logger.sml";
use "stringHandling.sml"; use "stringHandling.sml";

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

@ -70,7 +70,6 @@ end
structure Base_Cartridge : BASE_CARTRIDGE = structure Base_Cartridge : BASE_CARTRIDGE =
struct struct
open Rep_Logger
(* translation functions *) (* translation functions *)
(* type translation table *) (* type translation table *)
@ -187,7 +186,7 @@ fun lookup env "classifier_name" = Rep_Core.short_name_of (curClassifier' env
| lookup env "counter" = Int.toString (!(#counter env)) | lookup env "counter" = Int.toString (!(#counter env))
| lookup env "counter_next" = ((#counter env) := !(#counter env)+1; | lookup env "counter_next" = ((#counter env) := !(#counter env)+1;
Int.toString (!(#counter env))) Int.toString (!(#counter env)))
| lookup _ s = (warn ("in Base_Cartridge.lookup: unknown variable \""^s^"\"."); "$"^s^"$") | lookup _ s = (Logger.warn ("in Base_Cartridge.lookup: unknown variable \""^s^"\"."); "$"^s^"$")
(** (**
@ -254,7 +253,7 @@ fun test env "isClass" = (case (#curClassifier env) of
| test env "operation_isPackage" = ((#visibility (curOperation' env)) = XMI.package) | test env "operation_isPackage" = ((#visibility (curOperation' env)) = XMI.package)
| test env "operation_isStatic" = ((#scope (curOperation' env)) = XMI.ClassifierScope) | test env "operation_isStatic" = ((#scope (curOperation' env)) = XMI.ClassifierScope)
| test env "operation_isQuery" = #isQuery (curOperation' env) | test env "operation_isQuery" = #isQuery (curOperation' env)
| test env s = error ("in Base_Cartridge.test: undefined predicate: \""^s^"\".") | test env s = Logger.error ("in Base_Cartridge.test: undefined predicate: \""^s^"\".")
(* fun foreach_classifier: environment -> environment list *) (* fun foreach_classifier: environment -> environment list *)
@ -434,7 +433,7 @@ fun foreach "classifier_list" env = foreach_classifier env
| foreach listType env = map (pack env) | foreach listType env = map (pack env)
(<SuperCartridge>.foreach name (unpack env)) (<SuperCartridge>.foreach name (unpack env))
*) *)
| foreach s _ = (error_msg ("in Base_Cartridge.foreach: unknown list \""^s^"\"."); | foreach s _ = (Logger.error ("in Base_Cartridge.foreach: unknown list \""^s^"\".");
[]) [])
end end

3
su4sml/src/codegen/componentuml_cartridge.sml
View File

@ -45,7 +45,6 @@ struct
structure SuperCart = SecureUML_Cartridge(structure SuperCart=S; structure D=ComponentUML) structure SuperCart = SecureUML_Cartridge(structure SuperCart=S; structure D=ComponentUML)
structure Design = SuperCart.Security.Design structure Design = SuperCart.Security.Design
open Rep_Logger
(* TODO: fill out *) (* TODO: fill out *)
type environment = { curPermissionList : SuperCart.Security.Permission list option, type environment = { curPermissionList : SuperCart.Security.Permission list option,
@ -141,7 +140,7 @@ fun test env "first_permission" =
fun foreach_permission env name = fun foreach_permission env name =
let val action = Option.valOf (List.find (fn x => ComponentUML.action_type_of x = name) let val action = Option.valOf (List.find (fn x => ComponentUML.action_type_of x = name)
(atomic_actions_from_context env)) (atomic_actions_from_context env))
handle Option => error ("error in finding action "^name) handle Option => Logger.error ("error in finding action "^name)
val permissions = permissions_for_action env action val permissions = permissions_for_action env action
fun env_from_list_item c = { curPermissionList = SOME permissions, fun env_from_list_item c = { curPermissionList = SOME permissions,
curPermission = SOME c, curPermission = SOME c,

17
su4sml/src/codegen/gcg_core.sml
View File

@ -54,7 +54,6 @@ end
functor GCG_Core (C: CARTRIDGE): GCG = functor GCG_Core (C: CARTRIDGE): GCG =
struct struct
open Rep_Logger
val curFile = ref "" val curFile = ref ""
val out = ref TextIO.stdOut val out = ref TextIO.stdOut
@ -67,14 +66,14 @@ fun closeFile () = if (!curFile = "")
(* FIXME: set out to a real NullStream *) (* FIXME: set out to a real NullStream *)
fun openNull file = (closeFile (); fun openNull file = (closeFile ();
info ("skipping "^file); Logger.info ("skipping "^file);
out := (TextIO.openOut "/dev/null"); out := (TextIO.openOut "/dev/null");
curFile := "/dev/null" curFile := "/dev/null"
) )
fun openFile file = (closeFile (); fun openFile file = (closeFile ();
info ("opening "^file); Logger.info ("opening "^file);
Gcg_Helper.assureDir file; Gcg_Helper.assureDir file;
out := (TextIO.openOut file); out := (TextIO.openOut file);
curFile := file curFile := file
@ -91,7 +90,7 @@ fun initOut () = (out := TextIO.stdOut;
fun writeLine s = TextIO.output (!out,s) fun writeLine s = TextIO.output (!out,s)
fun eval s = (info "<eval>"; CompilerExt.eval true s) fun eval s = (Logger.info "<eval>"; CompilerExt.eval true s)
(** applies f to every other element in l starting with the second (** applies f to every other element in l starting with the second
*) *)
@ -103,7 +102,7 @@ fun substituteVars e s =
let val tkl = Gcg_Helper.joinEscapeSplitted "$" (Gcg_Helper.fieldSplit #"$" s) let val tkl = Gcg_Helper.joinEscapeSplitted "$" (Gcg_Helper.fieldSplit #"$" s)
in in
String.concat (map2EveryOther (C.lookup e) tkl) String.concat (map2EveryOther (C.lookup e) tkl)
handle ex => (error_msg ("in GCG_Core.substituteVars: \ handle ex => (Logger.error ("in GCG_Core.substituteVars: \
\variable lookup failure in string \""^s^"\"."); \variable lookup failure in string \""^s^"\".");
s) s)
end end
@ -117,7 +116,7 @@ fun write env (Tpl_Parser.RootNode(l)) = List.app (write env)
let fun collectEval [] = "" let fun collectEval [] = ""
| collectEval ((Tpl_Parser.TextLeaf(expr))::t) = expr^"\n"^(collectEval t) | collectEval ((Tpl_Parser.TextLeaf(expr))::t) = expr^"\n"^(collectEval t)
| collectEval _ = | collectEval _ =
error "in GCG_Core.write: No TextLeaf in EvalLeaf" Logger.error "in GCG_Core.write: No TextLeaf in EvalLeaf"
in in
eval (substituteVars env (collectEval l)) eval (substituteVars env (collectEval l))
end end
@ -131,7 +130,7 @@ fun write env (Tpl_Parser.RootNode(l)) = List.app (write env)
then writeThen env l then writeThen env l
else case (List.last l) of nd as (Tpl_Parser.ElseNode(_)) => write env nd else case (List.last l) of nd as (Tpl_Parser.ElseNode(_)) => write env nd
| _ => ()) | _ => ())
handle ex => error ("in GCG_Core.write: problem in IfNode "^cond) handle ex => Logger.error ("in GCG_Core.write: problem in IfNode "^cond)
end end
| write env (Tpl_Parser.ElseNode(l)) = List.app (write env) l | write env (Tpl_Parser.ElseNode(l)) = List.app (write env) l
| write env (Tpl_Parser.ForEachNode(listType,children))= | write env (Tpl_Parser.ForEachNode(listType,children))=
@ -139,7 +138,7 @@ fun write env (Tpl_Parser.RootNode(l)) = List.app (write env)
fun write_children e = List.app (fn tree => write e tree) children fun write_children e = List.app (fn tree => write e tree) children
in in
List.app (fn e => write_children e) list_of_environments List.app (fn e => write_children e) list_of_environments
handle ex => (error_msg ("in GCG_Core.write: error in foreach node "^listType^ handle ex => (Logger.error ("in GCG_Core.write: error in foreach node "^listType^
": "^General.exnMessage ex); ": "^General.exnMessage ex);
()) ())
end end
@ -154,7 +153,7 @@ fun generate model template
(*printTTree tree;*) (*printTTree tree;*)
write env tree; write env tree;
closeFile (); closeFile ();
info "codegen finished successfully" Logger.info "codegen finished successfully"
) )
handle ex => (closeFile(); raise ex) handle ex => (closeFile(); raise ex)
end end

1
su4sml/src/codegen/java_cartridge.sml
View File

@ -43,7 +43,6 @@
(* Probably, some things have to be adjusted to Java syntax *) (* Probably, some things have to be adjusted to Java syntax *)
functor Java_Cartridge(SuperCart : BASE_CARTRIDGE) : BASE_CARTRIDGE = functor Java_Cartridge(SuperCart : BASE_CARTRIDGE) : BASE_CARTRIDGE =
struct struct
open Rep_Logger
open Rep_OclType open Rep_OclType

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

@ -75,7 +75,6 @@ functor SecureUML_Cartridge(structure SuperCart : BASE_CARTRIDGE;
structure D: DESIGN_LANGUAGE) : SECUREUML_CARTRIDGE = structure D: DESIGN_LANGUAGE) : SECUREUML_CARTRIDGE =
struct struct
open Rep_Logger
structure Security = SecureUML(structure Design = D) structure Security = SecureUML(structure Design = D)
(*type Model = Rep.Classifier list * Security.Configuration*) (*type Model = Rep.Classifier list * Security.Configuration*)
@ -154,7 +153,7 @@ fun lookup env "permission_name" = #name (curPermission' env)
| lookup env "subject_name" = (Security.subject_name_of o valOf o curSubject) env | lookup env "subject_name" = (Security.subject_name_of o valOf o curSubject) env
| lookup env "superrole_name" = (name_of_role o valOf o curSuperrole) env | lookup env "superrole_name" = (name_of_role o valOf o curSuperrole) env
| lookup env s = SuperCart.lookup (unpack env) s | lookup env s = SuperCart.lookup (unpack env) s
handle Option => error "variable outside of context" handle Option => Logger.error "variable outside of context"
(********** ADDING IF-CONDITION TYPE *****************************************) (********** ADDING IF-CONDITION TYPE *****************************************)
fun test env "first_permission" = (curPermission' env = hd (PermissionSet env)) fun test env "first_permission" = (curPermission' env = hd (PermissionSet env))
| test env "first_role" = (curRole' env = hd (#roles (curPermission' env))) | test env "first_role" = (curRole' env = hd (#roles (curPermission' env)))
@ -193,7 +192,7 @@ fun foreach_role (env:environment)
(** iterate over all superroles in the context of a role *) (** iterate over all superroles in the context of a role *)
fun foreach_superrole (env:environment) = fun foreach_superrole (env:environment) =
let val cur = valOf (curRole env ) let val cur = valOf (curRole env )
handle Option => error ("no current role") handle Option => Logger.error ("no current role")
val superroles = List.mapPartial (fn (r,s) => if r=cur then SOME s val superroles = List.mapPartial (fn (r,s) => if r=cur then SOME s
else NONE) else NONE)
(#rh (security_conf env)) (#rh (security_conf env))

15
su4sml/src/codegen/tpl_parser.sml
View File

@ -61,14 +61,13 @@ end
structure Tpl_Parser : TPL_PARSER = structure Tpl_Parser : TPL_PARSER =
struct struct
open Rep_Logger
open Gcg_Helper open Gcg_Helper
val tplStream = ref (TextIO.openString "@// dummy template\n"); val tplStream = ref (TextIO.openString "@// dummy template\n");
fun opentFile file = (TextIO.closeIn (!tplStream) ; fun opentFile file = (TextIO.closeIn (!tplStream) ;
tplStream := (TextIO.openIn file)) tplStream := (TextIO.openIn file))
handle ex => error ("in Tpl_Parser.opentFile: \ handle ex => Logger.error ("in Tpl_Parser.opentFile: \
\couldn't open preprocessed template file: "^ \couldn't open preprocessed template file: "^
General.exnMessage ex) General.exnMessage ex)
@ -157,7 +156,7 @@ fun getType l = let val sl = tokenize l
then "text" (* rather: comment? *) then "text" (* rather: comment? *)
else hd (tokenSplit #" " (String.concat sl)) else hd (tokenSplit #" " (String.concat sl))
end end
handle ex => error ("in Tpl_Parser.getType: "^General.exnMessage ex) handle ex => Logger.error ("in Tpl_Parser.getType: "^General.exnMessage ex)
(** (**
* getContent line * getContent line
@ -169,7 +168,7 @@ fun getContent l = let val sl = tokenize l
else if (length sl = 1) then hd sl else if (length sl = 1) then hd sl
else String.concat (tl (fieldSplit #" " (String.concat (tl sl)))) else String.concat (tl (fieldSplit #" " (String.concat (tl sl))))
end end
handle ex => error ("in Tpl_Parser.getContent: "^General.exnMessage ex) handle ex => Logger.error ("in Tpl_Parser.getContent: "^General.exnMessage ex)
(** cleans line, replaces nl and tabs so that no space char is left out. *) (** cleans line, replaces nl and tabs so that no space char is left out. *)
fun preprocess s = replaceSafely "@spc" " " (replaceSafely "@tab" "\t" (replaceSafely "@nl" "\n" (cleanLine s))) fun preprocess s = replaceSafely "@spc" " " (replaceSafely "@tab" "\t" (replaceSafely "@nl" "\n" (cleanLine s)))
@ -194,18 +193,18 @@ fun buildTree (SOME line) =
:: buildTree (readNextLine()) :: buildTree (readNextLine())
| getNode ("eval", expr) = EvalLeaf [ TextLeaf expr ]:: buildTree (readNextLine()) | getNode ("eval", expr) = EvalLeaf [ TextLeaf expr ]:: buildTree (readNextLine())
| getNode ("end",_) = [] | getNode ("end",_) = []
| getNode (t,c) = error ("in Tpl_Parser.buildTree: error while parsing \ | getNode (t,c) = Logger.error ("in Tpl_Parser.buildTree: error while parsing \
\node \""^t^"\" with content \""^c^"\".") \node \""^t^"\" with content \""^c^"\".")
val prLine = preprocess line val prLine = preprocess line
in in
getNode ((getType prLine),(getContent prLine)) getNode ((getType prLine),(getContent prLine))
end end
handle ex => error ("in Tpl_Parser.buildTree: error "^General.exnMessage ex)) handle ex => Logger.error ("in Tpl_Parser.buildTree: error "^General.exnMessage ex))
| buildTree NONE = [] | buildTree NONE = []
fun codegen_home _ = getOpt (OS.Process.getEnv "CODEGEN_HOME", su4sml_home()^"/codegen") fun codegen_home _ = getOpt (OS.Process.getEnv "CODEGEN_HOME", Config.su4sml_home()^"/codegen")
(** calls the external cpp ( C PreProcessor). (** calls the external cpp ( C PreProcessor).
* writes merged template to a file with extension .tmp instead of .tpl * writes merged template to a file with extension .tmp instead of .tpl
@ -223,7 +222,7 @@ fun call_cpp file =
(** parse template-file (** parse template-file
* @return the parsed template tree * @return the parsed template tree
*) *)
fun parse file = let val _ = info ("parsing template "^file) fun parse file = let val _ = Logger.info ("parsing template "^file)
val mergedTpl = call_cpp file; val mergedTpl = call_cpp file;
val _ = opentFile mergedTpl; val _ = opentFile mergedTpl;
val pt = RootNode(buildTree (readNextLine())); val pt = RootNode(buildTree (readNextLine()));

2
su4sml/src/compiler/polyml-5.2.sml
View File

@ -75,7 +75,7 @@ fun eval verbose txt =
if verbose then print (output ()) else () if verbose then print (output ()) else ()
end end
in in
eval_fh (fn s => print (s^"\n"), fn s => Rep_Logger.error (s^"\n")) verbose txt eval_fh (fn s => print (s^"\n"), fn s => Logger.error (s^"\n")) verbose txt
end end
fun exnHistory _ = [] fun exnHistory _ = []

2
su4sml/src/compiler/polyml.sml
View File

@ -70,7 +70,7 @@ fun eval verbose txt =
if verbose then print (output ()) else () if verbose then print (output ()) else ()
end end
in in
eval_fh (fn s => print (s^"\n"), fn s => Rep_Logger.error (s^"\n")) verbose txt eval_fh (fn s => print (s^"\n"), fn s => Logger.error (s^"\n")) verbose txt
end end
fun exnHistory _ = [] fun exnHistory _ = []

2
su4sml/src/compiler/smlnj.sml
View File

@ -64,7 +64,7 @@ fun eval verbose txt =
if verbose then print (output ()) else () if verbose then print (output ()) else ()
end end
in in
eval_fh (fn s => print (s^"\n"), fn s => Rep_Logger.error s) verbose txt eval_fh (fn s => print (s^"\n"), fn s => Logger.error s) verbose txt
end end
fun exnHistory e = SMLofNJ.exnHistory e fun exnHistory e = SMLofNJ.exnHistory e

31
su4sml/src/component_uml.sml
View File

@ -43,7 +43,6 @@
(** Auxiliary structure to specialize the resource type for ComponentUML. *) (** Auxiliary structure to specialize the resource type for ComponentUML. *)
structure ComponentUMLResource = structure ComponentUMLResource =
struct struct
open Rep_Logger
(** The type of resource, plus a path name specifiying the resource. (** The type of resource, plus a path name specifiying the resource.
* Resource types can be entities, methods, and attributes. * Resource types can be entities, methods, and attributes.
* FIX: using Path for methods is unsafe, there can be severable * FIX: using Path for methods is unsafe, there can be severable
@ -72,24 +71,24 @@ val root_stereotypes = ["compuml.entity"]
(** The list of all attributes of an entity. *) (** The list of all attributes of an entity. *)
fun entity_contained_attributes (Entity c) = map EntityAttribute (Rep.attributes_of c) fun entity_contained_attributes (Entity c) = map EntityAttribute (Rep.attributes_of c)
| entity_contained_attributes _ = error "in entity_contained_attributes: \ | entity_contained_attributes _ = Logger.error "in entity_contained_attributes: \
\argument is not an entity" \argument is not an entity"
(** the list of all methods of an entity *) (** the list of all methods of an entity *)
fun entity_contained_methods (Entity c) = map EntityMethod (Rep.operations_of c) fun entity_contained_methods (Entity c) = map EntityMethod (Rep.operations_of c)
| entity_contained_methods _ = error "in entity_contained_methods: \ | entity_contained_methods _ = Logger.error "in entity_contained_methods: \
\argument is not an entity" \argument is not an entity"
(** The list of all side-effect free methods of an entity. *) (** The list of all side-effect free methods of an entity. *)
fun entity_contained_read_methods (Entity c) = fun entity_contained_read_methods (Entity c) =
map EntityMethod (List.filter #isQuery (Rep.operations_of c)) map EntityMethod (List.filter #isQuery (Rep.operations_of c))
| entity_contained_read_methods _ = error "in entity_contained_read_methods: \ | entity_contained_read_methods _ = Logger.error "in entity_contained_read_methods: \
\argument is not an entity" \argument is not an entity"
(** The list of all methods with side-effects of an entity *) (** The list of all methods with side-effects of an entity *)
fun entity_contained_update_methods (Entity c) = fun entity_contained_update_methods (Entity c) =
map EntityMethod (List.filter (not o #isQuery) (Rep.operations_of c)) map EntityMethod (List.filter (not o #isQuery) (Rep.operations_of c))
| entity_contained_update_methods _ = error | entity_contained_update_methods _ = Logger.error
"in entity_contained_update_methods: \ "in entity_contained_update_methods: \
\argument is not an entity" \argument is not an entity"
@ -113,7 +112,7 @@ fun parse_entity_action root att_name "create" =
SimpleAction ("delete", (Entity root)) SimpleAction ("delete", (Entity root))
| parse_entity_action root att_name "fullaccess" = | parse_entity_action root att_name "fullaccess" =
CompositeAction ("fullaccess", (Entity root)) CompositeAction ("fullaccess", (Entity root))
| parse_entity_action root att_name s = error ("in parse_entity_action: \ | parse_entity_action root att_name s = Logger.error ("in parse_entity_action: \
\unknown action type "^s) \unknown action type "^s)
(** parses an entity attribute action permission attribute. *) (** parses an entity attribute action permission attribute. *)
@ -121,21 +120,21 @@ fun parse_attribute_action root name "read" =
(SimpleAction ("read", (SimpleAction ("read",
(EntityAttribute ((hd o List.filter (fn x => #name x = name)) (EntityAttribute ((hd o List.filter (fn x => #name x = name))
(Rep.attributes_of root)))) (Rep.attributes_of root))))
handle Empty => error ("in parse_attribute_action: \ handle Empty => Logger.error ("in parse_attribute_action: \
\did not find attribute "^name)) \did not find attribute "^name))
| parse_attribute_action root name "update" = | parse_attribute_action root name "update" =
( SimpleAction ("update", ( SimpleAction ("update",
(EntityAttribute ((hd o List.filter (fn x => #name x = name)) (EntityAttribute ((hd o List.filter (fn x => #name x = name))
(Rep.attributes_of root)))) (Rep.attributes_of root))))
handle Empty => error ("in parse_attribute_action: \ handle Empty => Logger.error ("in parse_attribute_action: \
\did not find attribute "^name)) \did not find attribute "^name))
| parse_attribute_action root name "fullaccess" = | parse_attribute_action root name "fullaccess" =
( CompositeAction ("fullaccess", ( CompositeAction ("fullaccess",
(EntityAttribute ((hd o List.filter (fn x => #name x = name)) (EntityAttribute ((hd o List.filter (fn x => #name x = name))
(Rep.attributes_of root)))) (Rep.attributes_of root))))
handle Empty => error ("in parse_attribute_action: \ handle Empty => Logger.error ("in parse_attribute_action: \
\did not find attribute "^name)) \did not find attribute "^name))
| parse_attribute_action root name s = error ("in parse_attribute_action: \ | parse_attribute_action root name s = Logger.error ("in parse_attribute_action: \
\unknown action type "^s^ \unknown action type "^s^
"for attribute action "^name) "for attribute action "^name)
@ -144,8 +143,8 @@ fun parse_method_action root name "execute"
= (SimpleAction ("execute", = (SimpleAction ("execute",
(EntityMethod ((hd o List.filter (fn x => #name x = name)) (EntityMethod ((hd o List.filter (fn x => #name x = name))
(Rep.operations_of root)))) (Rep.operations_of root))))
handle Empty => error ("in parse_method_action: did not find method "^name)) handle Empty => Logger.error ("in parse_method_action: did not find method "^name))
| parse_method_action roor name s = error ("unknown action type "^s^ | parse_method_action roor name s = Logger.error ("unknown action type "^s^
"for method action "^name) "for method action "^name)
(** (**
@ -156,7 +155,7 @@ fun parse_action root (att:Rep.attribute) =
let val att_name = #name att let val att_name = #name att
val att_type = #attr_type att val att_type = #attr_type att
val cls_path = case att_type of Rep_OclType.Classifier x => x val cls_path = case att_type of Rep_OclType.Classifier x => x
| _ => error "type of permission attribute \ | _ => Logger.error "type of permission attribute \
\is not a classifier" \is not a classifier"
val action_name = hd (rev cls_path) val action_name = hd (rev cls_path)
fun resource_path name = (hd o List.tl) (String.tokens (fn x => x= #".") name) fun resource_path name = (hd o List.tl) (String.tokens (fn x => x= #".") name)
@ -167,10 +166,10 @@ fun parse_action root (att:Rep.attribute) =
parse_method_action root (resource_path att_name) action_name parse_method_action root (resource_path att_name) action_name
| "dialect.entityattributeaction" => | "dialect.entityattributeaction" =>
parse_attribute_action root (resource_path att_name) action_name parse_attribute_action root (resource_path att_name) action_name
| s => error ("in ComponentUML.parse_action: "^ | s => Logger.error ("in ComponentUML.parse_action: "^
"permission attribute "^att_name^"has unexpected stereotype "^s) "permission attribute "^att_name^"has unexpected stereotype "^s)
end end
handle ex => (error_msg "in ComponentUML.parse_action: \ handle ex => (Logger.warn "in ComponentUML.parse_action: \
\could not parse permission attribute"; raise ex) \could not parse permission attribute"; raise ex)
fun action_type_of (SimpleAction (t,_)) = t fun action_type_of (SimpleAction (t,_)) = t
@ -219,7 +218,7 @@ fun subordinated_actions (SimpleAction _) = nil
| subordinated_actions (CompositeAction ("full_access", a as (EntityAttribute ae))) | subordinated_actions (CompositeAction ("full_access", a as (EntityAttribute ae)))
= [SimpleAction ("read", a), = [SimpleAction ("read", a),
SimpleAction ("update", a)] SimpleAction ("update", a)]
| subordinated_actions (CompositeAction (s,_)) = error ("in subordinated_actions: \ | subordinated_actions (CompositeAction (s,_)) = Logger.error ("in subordinated_actions: \
\unsupported composite action \ \unsupported composite action \
\type "^s) \type "^s)
end end

62
su4sml/src/config.sml Normal file
View File

@ -0,0 +1,62 @@
(*****************************************************************************
* su4sml --- a SML repository for managing (Secure)UML/OCL models
* http://projects.brucker.ch/su4sml/
*
* config.sml ---
* This file is part of su4sml.
*
* Copyright (c) 2009 Achim D. Brucker, Germany
*
* 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 CONFIG =
sig
val su4sml_home : unit -> string
end
structure Config:>CONFIG =
struct
(* HOLOCL_HOME resp. SU4SML_HOME should point to the top-level directory *)
(* 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 => (case OS.Process.getEnv "UML2CDL_HOME" of
SOME p => p^"../../../src"
| NONE => ".")
)
end

4
su4sml/src/ocl2dresdenjava.sml
View File

@ -70,7 +70,6 @@ end
structure preMap = structure preMap =
struct struct
open Rep_Helper open Rep_Helper
open Rep_Logger
val entries : (string * int) list ref = ref nil val entries : (string * int) list ref = ref nil
@ -100,7 +99,6 @@ end
structure Ocl2DresdenJava = structure Ocl2DresdenJava =
struct struct
open Rep_Helper open Rep_Helper
open Rep_Logger
open Rep_OclType open Rep_OclType
open Rep_OclTerm open Rep_OclTerm
open Rep_Core open Rep_Core
@ -497,7 +495,7 @@ fun preExtract env on curOp =
| _ => (getPres src)^(join "\n" (map (getPres o fst) args)) | _ => (getPres src)^(join "\n" (map (getPres o fst) args))
in in
case precond of case precond of
OperationCall (src,styp,["oclLib","OclAny","atPre"],[],_) => error "atPre()-operation should not be reached." OperationCall (src,styp,["oclLib","OclAny","atPre"],[],_) => Logger.error "atPre()-operation should not be reached."
| OperationCall (src,styp,op_name,args,rtype) => resSave src styp op_name args rtype | OperationCall (src,styp,op_name,args,rtype) => resSave src styp op_name args rtype
| Literal (_,_) => "" | Literal (_,_) => ""
| If (cond,_,thenb,_,elseb,_,_) => (getPres cond)^(getPres thenb)^(getPres elseb) | If (cond,_,thenb,_,elseb,_,_) => (getPres cond)^(getPres thenb)^(getPres elseb)

8
su4sml/src/ocl2string.sml
View File

@ -52,7 +52,6 @@ end
structure Ocl2String:OCL2STRING = structure Ocl2String:OCL2STRING =
struct struct
open Rep_Helper open Rep_Helper
open Rep_Logger
open Rep_OclType open Rep_OclType
open Rep_OclTerm open Rep_OclTerm
@ -321,14 +320,13 @@ fun ocl2string show_types oclterm =
"Tuple{"^(String.substring(x,0,size-1))^"}\n" "Tuple{"^(String.substring(x,0,size-1))^"}\n"
end end
| _ => error "error: unknown OCL-term in in ocl2string" | _ => Logger.error "error: unknown OCL-term in in ocl2string"
end end
end end
(** "pretty printing" of Repository models *) (** "pretty printing" of Repository models *)
structure Rep2String = structure Rep2String =
struct struct
open Rep_Logger
fun precond2string (SOME n,t) = " pre "^n^":\n "^ fun precond2string (SOME n,t) = " pre "^n^":\n "^
(Ocl2String.ocl2string false t)^"\n" (Ocl2String.ocl2string false t)^"\n"
@ -394,8 +392,8 @@ fun classifier2string (C as Rep.Class x) =
| classifier2string (C as Rep.Template x) = | classifier2string (C as Rep.Template x) =
"template of "^ (classifier2string (#classifier x)) "template of "^ (classifier2string (#classifier x))
fun printClass (x:Rep.Classifier) = trace medium (classifier2string x) fun printClass (x:Rep.Classifier) = Logger.info (classifier2string x)
fun printList (x:Rep.Classifier list) = fun printList (x:Rep.Classifier list) =
trace medium (String.concatWith "\n\n" (map classifier2string x )) Logger.info (String.concatWith "\n\n" (map classifier2string x ))
end end

63
su4sml/src/ocl_parser/context_declarations.sml
View File

@ -6,7 +6,7 @@
* This file is part of su4sml. * This file is part of su4sml.
* *
* Copyright (c) 2005-2007 ETH Zurich, Switzerland * Copyright (c) 2005-2007 ETH Zurich, Switzerland
* (c) 2008 Achim D. Brucker, Germany * (c) 2008-2009 Achim D. Brucker, Germany
* *
* All rights reserved. * All rights reserved.
* *
@ -107,7 +107,6 @@ structure Context:CONTEXT =
struct struct
open Rep_Logger
open Rep_Core open Rep_Core
open Rep_OclType open Rep_OclType
open Rep_OclTerm open Rep_OclTerm
@ -219,26 +218,26 @@ fun real_signature ([]) = []
fun add_source (source,(AttributeCall (_, _, path, res_typ ))) = fun add_source (source,(AttributeCall (_, _, path, res_typ ))) =
let let
val test = (AttributeCall (source,DummyT,path,res_typ)) val test = (AttributeCall (source,DummyT,path,res_typ))
val _ = trace low ("source added for AttributeCall..." ^ Ocl2String.ocl2string true test ^ "\n"); val _ = Logger.debug4 ("source added for AttributeCall..." ^ Ocl2String.ocl2string true test ^ "\n");
in in
(AttributeCall (source, DummyT, path, res_typ)) (AttributeCall (source, DummyT, path, res_typ))
end end
| add_source (source,(OperationCall (_,_,path,paras,res_typ))) = | add_source (source,(OperationCall (_,_,path,paras,res_typ))) =
let let
val _ = trace low ("source added for OperationCall..." ^ "\n"); val _ = Logger.debug1 ("source added for OperationCall..." ^ "\n");
in in
(OperationCall (source,DummyT,path,paras,res_typ)) (OperationCall (source,DummyT,path,paras,res_typ))
end end
| add_source (source, Literal(s,t)) = Literal (s,t) | add_source (source, Literal(s,t)) = Literal (s,t)
| add_source (source, CollectionLiteral (part_list,typ)) = | add_source (source, CollectionLiteral (part_list,typ)) =
let let
val _ = trace low ("source added for AttributeCall..." ^ "\n"); val _ = Logger.debug1 ("source added for AttributeCall..." ^ "\n");
in in
(CollectionLiteral (part_list,typ)) (CollectionLiteral (part_list,typ))
end end
| add_source (source, Iterator(name,iter_vars_list,_,_,body_term,body_typ,res_typ)) = | add_source (source, Iterator(name,iter_vars_list,_,_,body_term,body_typ,res_typ)) =
let let
val _ = trace low ("source added for Iterator..." ^ "\n"); val _ = Logger.debug1 ("source added for Iterator..." ^ "\n");
in in
(Iterator (name,iter_vars_list,source,DummyT,body_term,body_typ,res_typ)) (Iterator (name,iter_vars_list,source,DummyT,body_term,body_typ,res_typ))
end end
@ -250,13 +249,13 @@ fun add_source (source,(AttributeCall (_, _, path, res_typ ))) =
If (paras) If (paras)
| add_source (source, Iterate([],acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) = | add_source (source, Iterate([],acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) =
let let
val _ = trace low ("source added for Iterate ..." ^ "\n"); val _ = Logger.debug1 ("source added for Iterate ..." ^ "\n");
in in
(Iterate ([],acc_var_name,acc_var_type,acc_var_term,source,DummyT,bterm,btype,res_type)) (Iterate ([],acc_var_name,acc_var_type,acc_var_term,source,DummyT,bterm,btype,res_type))
end end
| add_source (source, Iterate(iter_vars,acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) = | add_source (source, Iterate(iter_vars,acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) =
let let
val _ = trace high ("source added for Iterate ..." ^ "\n"); val _ = Logger.debug1 ("source added for Iterate ..." ^ "\n");
in in
(Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,source,DummyT,bterm,btype,res_type)) (Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,source,DummyT,bterm,btype,res_type))
end end
@ -275,20 +274,20 @@ fun add_source_to_list source (h::tail) = (add_source (source,h))::tail
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
fun nest_source (OperationCall (sterm,styp,[OclLibPackage,rtyp,"-"],[],res_typ)::tail) = fun nest_source (OperationCall (sterm,styp,[OclLibPackage,rtyp,"-"],[],res_typ)::tail) =
let let
val _ = trace low ("unary_exp_cs Call: '-' ... \n") val _ = Logger.debug1 ("unary_exp_cs Call: '-' ... \n")
in in
foldl (switch add_source) (OperationCall (sterm,styp,[OclLibPackage,rtyp,"-"],[],res_typ)) tail foldl (switch add_source) (OperationCall (sterm,styp,[OclLibPackage,rtyp,"-"],[],res_typ)) tail
end end
| nest_source (OperationCall (sterm,styp,[OclLibPackage,rtyp,"not"],[],res_typ)::tail) = | nest_source (OperationCall (sterm,styp,[OclLibPackage,rtyp,"not"],[],res_typ)::tail) =
let let
val _ = trace low ("unary_exp_cs Call: 'not' ... \n") val _ = Logger.debug1 ("unary_exp_cs Call: 'not' ... \n")
in in
foldl (switch add_source) (OperationCall (sterm,styp,[OclLibPackage,rtyp,"not"],[],res_typ)) tail foldl (switch add_source) (OperationCall (sterm,styp,[OclLibPackage,rtyp,"not"],[],res_typ)) tail
end end
| nest_source term_list = | nest_source term_list =
let let
val _ = trace low ("source nested for AttributeCall..." ^ "\n"); val _ = Logger.debug1 ("source nested for AttributeCall..." ^ "\n");
val _ = trace low ((Ocl2String.ocl2string true (List.last term_list)) ^ "bla\n"); val _ = Logger.debug1 ((Ocl2String.ocl2string true (List.last term_list)) ^ "bla\n");
in in
foldl (switch add_source) (Variable ("dummy_source",DummyT)) term_list foldl (switch add_source) (Variable ("dummy_source",DummyT)) term_list
end end
@ -296,13 +295,13 @@ fun nest_source (OperationCall (sterm,styp,[OclLibPackage,rtyp,"-"],[],res_typ):
(* RETURN: context list *) (* RETURN: context list *)
fun attr_list (context,Typ,[]) = fun attr_list (context,Typ,[]) =
let let
val _ = trace low ("Contextes created form list of Attributes ..." ^ "\n") val _ = Logger.debug1 ("Contextes created form list of Attributes ..." ^ "\n")
in in
[] []
end end
| attr_list (context,Typ,((asser,expr)::tail)) = | attr_list (context,Typ,((asser,expr)::tail)) =
let let
val _ = trace low ("Contextes created form list of Attributes ..." ^ "\n") val _ = Logger.debug1 ("Contextes created form list of Attributes ..." ^ "\n")
in in
(Attr (context,Typ,asser,expr))::(attr_list (context,Typ,tail)) (Attr (context,Typ,asser,expr))::(attr_list (context,Typ,tail))
end end
@ -310,13 +309,13 @@ fun attr_list (context,Typ,[]) =
(* RETURN: context list *) (* RETURN: context list *)
fun inv_list (context,[]) = fun inv_list (context,[]) =
let let
val _ = trace low ("Contextes created form list of invs ..." ^ "\n") val _ = Logger.debug4 ("Contextes created form list of invs ..." ^ "\n")
in in
[] []
end end
| inv_list (context,((name,expr)::tail)) = | inv_list (context,((name,expr)::tail)) =
let let
val _ = trace low ("Contextes created form list of invs ..." ^ "\n") val _ = Logger.debug4 ("Contextes created form list of invs ..." ^ "\n")
in in
(Inv(context,name,expr))::(inv_list (context,tail)) (Inv(context,name,expr))::(inv_list (context,tail))
end end
@ -324,13 +323,13 @@ fun inv_list (context,[]) =
(* RETURN: context list *) (* RETURN: context list *)
fun cond_list (path,sign,[]) = fun cond_list (path,sign,[]) =
let let
val _ = trace low ("Contextes created form list of conds ..." ^ "\n") val _ = Logger.debug4 ("Contextes created form list of conds ..." ^ "\n")
in in
[] []
end end
| cond_list (path,sign,((asser,name_cond,expr)::tail)) = | cond_list (path,sign,((asser,name_cond,expr)::tail)) =
let let
val _ = trace low ("Contextes created form list of conds ..." ^ "\n") val _ = Logger.debug4 ("Contextes created form list of conds ..." ^ "\n")
in in
Cond(real_path path,List.last path,real_signature sign, #2(List.last sign),asser,name_cond,expr)::cond_list (path,sign,tail) Cond(real_path path,List.last path,real_signature sign, #2(List.last sign),asser,name_cond,expr)::cond_list (path,sign,tail)
end end
@ -354,7 +353,7 @@ fun cxt_list2string ([]) = ""
fun rename_classifier path (Class{name=name,parent=parent,attributes=attributes,operations=operations,associations=associations,invariant=invariant,stereotypes=stereotypes,interfaces=interfaces,thyname=thyname,visibility=visibility,activity_graphs=activity_graphs}) = fun rename_classifier path (Class{name=name,parent=parent,attributes=attributes,operations=operations,associations=associations,invariant=invariant,stereotypes=stereotypes,interfaces=interfaces,thyname=thyname,visibility=visibility,activity_graphs=activity_graphs}) =
let let
val _ = trace function_calls ("Context.rename_classifier\n") val _ = Logger.debug2 ("Context.rename_classifier\n")
val res = Class { val res = Class {
name = Classifier (path), name = Classifier (path),
parent=parent, parent=parent,
@ -368,14 +367,14 @@ fun rename_classifier path (Class{name=name,parent=parent,attributes=attributes,
visibility=visibility, visibility=visibility,
activity_graphs=activity_graphs activity_graphs=activity_graphs
} }
val _ = trace function_ends ("Context.rename_classifier\n") val _ = Logger.debug2 ("Context.rename_classifier\n")
in in
res res
end end
fun merge_classifier ((a as Class{attributes=a_atts,operations=a_ops,invariant=a_invs,associations=a_assocs,...}),(b as Class{attributes=b_atts,operations=b_ops,invariant=b_invs,associations=b_assocs,...})) = fun merge_classifier ((a as Class{attributes=a_atts,operations=a_ops,invariant=a_invs,associations=a_assocs,...}),(b as Class{attributes=b_atts,operations=b_ops,invariant=b_invs,associations=b_assocs,...})) =
let let
val _ = trace function_calls ("Context.merge_classifier\n") val _ = Logger.debug2 ("Context.merge_classifier\n")
val res = Class { val res = Class {
name = OclVoid, name = OclVoid,
parent=NONE, parent=NONE,
@ -389,14 +388,14 @@ fun merge_classifier ((a as Class{attributes=a_atts,operations=a_ops,invariant=a
visibility=public:Rep_Core.Visibility, visibility=public:Rep_Core.Visibility,
activity_graphs=[] activity_graphs=[]
} }
val _ = trace function_ends ("Context.merge_classifier\n") val _ = Logger.debug2 ("Context.merge_classifier\n")
in in
res res
end end
fun merge_classifiers list = fun merge_classifiers list =
let let
val _ = trace function_calls ("Context.merge_classifiers\n") val _ = Logger.debug2 ("Context.merge_classifiers\n")
val Empty_Class = Class{ val Empty_Class = Class{
name = OclVoid, name = OclVoid,
parent=NONE, parent=NONE,
@ -411,7 +410,7 @@ fun merge_classifiers list =
activity_graphs=[] activity_graphs=[]
} }
val res = List.foldr (merge_classifier) Empty_Class list val res = List.foldr (merge_classifier) Empty_Class list
val _ = trace function_ends ("Context.merge_classifier\n") val _ = Logger.debug2 ("Context.merge_classifier\n")
in in
res res
end end
@ -419,7 +418,7 @@ fun merge_classifiers list =
fun operations_to_classifier ops = fun operations_to_classifier ops =
let let
val _ = trace function_calls ("Context.operation_to_classifier\n") val _ = Logger.debug2 ("Context.operation_to_classifier\n")
val res = Class{ val res = Class{
name = OclVoid, name = OclVoid,
parent=NONE, parent=NONE,
@ -433,14 +432,14 @@ fun operations_to_classifier ops =
visibility=public:Rep_Core.Visibility, visibility=public:Rep_Core.Visibility,
activity_graphs=[] activity_graphs=[]
} }
val _ = trace function_ends ("Context.operation_to_classifier\n") val _ = Logger.debug2 ("Context.operation_to_classifier\n")
in in
res res
end end
fun attributes_to_classifier atts = fun attributes_to_classifier atts =
let let
val _ = trace function_calls ("Context.attributes_to_classifier\n") val _ = Logger.debug2 ("Context.attributes_to_classifier\n")
val res = Class{ val res = Class{
name = OclVoid, name = OclVoid,
parent=NONE, parent=NONE,
@ -454,14 +453,14 @@ fun attributes_to_classifier atts =
visibility=public:Rep_Core.Visibility, visibility=public:Rep_Core.Visibility,
activity_graphs=[] activity_graphs=[]
} }
val _ = trace function_ends ("Context.attributes_to_classifier\n") val _ = Logger.debug2 ("Context.attributes_to_classifier\n")
in in
res res
end end
fun constraints_to_classifier invs = fun constraints_to_classifier invs =
let let
val _ = trace function_calls ("Context.constraints_to_classifier\n") val _ = Logger.debug2 ("Context.constraints_to_classifier\n")
val res = Class{ val res = Class{
name = OclVoid, name = OclVoid,
parent=NONE, parent=NONE,
@ -475,19 +474,19 @@ fun constraints_to_classifier invs =
visibility=public:Rep_Core.Visibility, visibility=public:Rep_Core.Visibility,
activity_graphs=[] activity_graphs=[]
} }
val _ = trace function_ends ("Context.constraints_to_classifier\n") val _ = Logger.debug2 ("Context.constraints_to_classifier\n")
in in
res res
end end
fun dispatch_pre_or_post (cond_type:ConditionType) (list:(ConditionType * string option * OclTerm) list) = fun dispatch_pre_or_post (cond_type:ConditionType) (list:(ConditionType * string option * OclTerm) list) =
let let
val _ = trace function_calls ("Context.dispatch_pre_or_post") val _ = Logger.debug2 ("Context.dispatch_pre_or_post")
val filter = List.filter (fn (a,b,c) => if cond_type = a val filter = List.filter (fn (a,b,c) => if cond_type = a
then true then true
else false) list else false) list
val res = List.map (fn (a,b,c) => (b,c)) filter val res = List.map (fn (a,b,c) => (b,c)) filter
val _ = trace function_ends ("Context.dispatch_pre_or_post") val _ = Logger.debug2 ("Context.dispatch_pre_or_post")
in in
res res
end end

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

@ -60,7 +60,6 @@ end
structure Update_Model:UPDATE_MODEL = structure Update_Model:UPDATE_MODEL =
struct struct
open Rep_Logger
open Rep_Core; open Rep_Core;
open Context; open Context;
@ -133,19 +132,19 @@ fun add_operations cond_type (op_name,cond_name,term) [] = raise OperationUpdate
case cond_type of case cond_type of
pre => pre =>
let let
val _ = trace low ("pre\n") val _ = Logger.debug3 ("pre\n")
in in
add_precondition (op_name,cond_name,term) op_list add_precondition (op_name,cond_name,term) op_list
end end
| post => | post =>
let let
val _ = trace low ("post\n") val _ = Logger.debug3 ("post\n")
in in
add_postcondition (op_name,cond_name,term) op_list add_postcondition (op_name,cond_name,term) op_list
end end
| body => | body =>
let let
val _ = trace low ("body\n") val _ = Logger.debug3 ("body\n")
in in
add_body (op_name,cond_name,term) op_list add_body (op_name,cond_name,term) op_list
end end
@ -170,7 +169,7 @@ fun add_attribute (attr_name,term) ((attr: attribute)::attribute_tail) =
(* INVARIANTS *) (* INVARIANTS *)
fun context_to_classifier (Inv (path,string_opt,term)) model = fun context_to_classifier (Inv (path,string_opt,term)) model =
let let
val _ = trace low ("Invariant to Classifier ... " ^ "\n") val _ = Logger.debug3 ("Invariant to Classifier ... " ^ "\n")
val c = class_of_type (Rep_OclType.Classifier (path)) model val c = class_of_type (Rep_OclType.Classifier (path)) model
in in
( (
@ -223,7 +222,7 @@ fun context_to_classifier (Inv (path,string_opt,term)) model =
(* Attribute constraints *) (* Attribute constraints *)
| context_to_classifier (Attr (path,typ,attrorassoc,term)) model = | context_to_classifier (Attr (path,typ,attrorassoc,term)) model =
let let
val _ = trace low ("Attribute to Classifier ... " ^ "\n") val _ = Logger.debug3 ("Attribute to Classifier ... " ^ "\n")
val c = class_of_type (Rep_OclType.Classifier (real_path path)) model val c = class_of_type (Rep_OclType.Classifier (real_path path)) model
in in
( (
@ -278,7 +277,7 @@ fun context_to_classifier (Inv (path,string_opt,term)) model =
(* Operation constraints *) (* Operation constraints *)
| context_to_classifier (Cond (path,op_name,args,ret_typ,cond_type,cond_name,term)) model= | context_to_classifier (Cond (path,op_name,args,ret_typ,cond_type,cond_name,term)) model=
let let
val _ = trace low ("Cond to Classifier ... " ^ "\n") val _ = Logger.debug3 ("Cond to Classifier ... " ^ "\n")
val c = class_of_type (Rep_OclType.Classifier (path)) model val c = class_of_type (Rep_OclType.Classifier (path)) model
in in
( (
@ -347,41 +346,37 @@ fun gen_updated_classifier_list [] model = model
gen_updated_classifier_list context_list_tail (merge_classifier updated_classifier model) gen_updated_classifier_list context_list_tail (merge_classifier updated_classifier model)
handle AlreadyInitValueError (attr_path,term,mes) => handle AlreadyInitValueError (attr_path,term,mes) =>
let let
val _ = trace zero ("\n\n#################################################\n") val _ = Logger.error("AlreadyInitValueError:\n"
val _ = trace zero ("AlreadyInitValueError:\n") ^"Error Message: " ^ mes ^ "\n"
val _ = trace zero ("Error Message: " ^ mes ^ "\n") ^"In attribute or association: " ^ (attr_path) ^ "\n"
val _ = trace zero ("In attribute or association: " ^ (attr_path) ^ "\n") ^"In Term: " ^ Ocl2String.ocl2string false term ^ "\n")
val _ = trace zero ("In Term: " ^ Ocl2String.ocl2string false term ^ "\n")
in in
[] []
end end
| NotYetSupportedError mes => | NotYetSupportedError mes =>
let let
val _ = trace zero ("\n\n#################################################\n") val _ = Logger.error ("NotYetSupportedError:\n"
val _ = trace zero ("NotYetSupportedError:\n") ^"Error Message: " ^ mes ^ "\n")
val _ = trace zero ("Error Message: " ^ mes ^ "\n")
in in
[] []
end end
| ContextToClassifierError (term,mes) => | ContextToClassifierError (term,mes) =>
let let
val _ = trace zero ("\n\n#################################################\n") val _ = Logger.error ("ContextToClassifierError:\n"
val _ = trace zero ("ContextToClassifierError:\n") ^"Error Message: " ^ mes ^ "\n"
val _ = trace zero ("Error Message: " ^ mes ^ "\n") ^"In Term: " ^ Ocl2String.ocl2string false term ^ "\n")
val _ = trace zero ("In Term: " ^ Ocl2String.ocl2string false term ^ "\n")
in in
[] []
end end
| OperationUpdateError (meth_path,cond_type,term,mes) => | OperationUpdateError (meth_path,cond_type,term,mes) =>
let let
val _ = trace zero ("\n\n#################################################\n") val _ = Logger.error ("AlreadyInitValueError:\n"
val _ = trace zero ("AlreadyInitValueError:\n") ^"Error Message: " ^ mes ^ "\n"
val _ = trace zero ("Error Message: " ^ mes ^ "\n") ^"In condition: " ^ (cond_type_to_string cond_type) ^ "\n"
val _ = trace zero ("In condition: " ^ (cond_type_to_string cond_type) ^ "\n") ^"In operation: " ^ (meth_path) ^ "\n"
val _ = trace zero ("In operation: " ^ (meth_path) ^ "\n") ^"In Term: " ^ Ocl2String.ocl2string false term ^ "\n")
val _ = trace zero ("In Term: " ^ Ocl2String.ocl2string false term ^ "\n")
in in
[] []
end end
end end
| gen_updated_classifier_list (NONE::context_list_tail) model = gen_updated_classifier_list context_list_tail model | gen_updated_classifier_list (NONE::context_list_tail) model = gen_updated_classifier_list context_list_tail model

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

@ -58,7 +58,6 @@ open List
open Posix.Error open Posix.Error
(* su4sml *) (* su4sml *)
open Rep_Logger
open Rep_Core open Rep_Core
(* OclParser *) (* OclParser *)
@ -87,7 +86,7 @@ fun importArgoUMLUnNormalized file =
val base = if String.isSuffix ".zargo" file val base = if String.isSuffix ".zargo" file
then String.substring(file,0, (String.size file) -6) then String.substring(file,0, (String.size file) -6)
else file else file
val _ = print ("*** Syscall: unzip -p -ca "^base^".zargo "^(basename base)^".xmi > "^tmpFile^"\n") val _ = Logger.info ("*** Syscall: unzip -p -ca "^base^".zargo "^(basename base)^".xmi > "^tmpFile)
val _ = OS.Process.system ("unzip -p -ca "^base^".zargo "^(basename base)^".xmi > "^tmpFile) val _ = OS.Process.system ("unzip -p -ca "^base^".zargo "^(basename base)^".xmi > "^tmpFile)
val model = readFileUnNormalized tmpFile val model = readFileUnNormalized tmpFile
val _ = OS.FileSys.remove tmpFile val _ = OS.FileSys.remove tmpFile
@ -103,11 +102,11 @@ fun importArgoUMLUnNormalized file =
fun parseUML umlFile = fun parseUML umlFile =
let let
val _ = trace high "### Parsing UML Model ###\n" val _ = Logger.info "### Parsing UML Model ###\n"
val umlModel = if String.isSuffix ".zargo" umlFile val umlModel = if String.isSuffix ".zargo" umlFile
then importArgoUMLUnNormalized umlFile then importArgoUMLUnNormalized umlFile
else readFileUnNormalized umlFile else readFileUnNormalized umlFile
val _ = trace high ("### Finished Parsing UML Model (" val _ = Logger.info ("### Finished Parsing UML Model ("
^(Int.toString(length (#1 umlModel))) ^(Int.toString(length (#1 umlModel)))
^" Classifiers found)###\n\n") ^" Classifiers found)###\n\n")
in in
@ -116,11 +115,11 @@ fun parseUML umlFile =
fun parseOCL oclFile = fun parseOCL oclFile =
let let
val _ = trace high "### Parsing OCL File ###\n" val _ = Logger.info "### Parsing OCL File ###\n"
val context_classes = case oclFile of val context_classes = case oclFile of
"" => ([],[]) "" => ([],[])
| filename => OclParser.parse_contextlist oclFile; | filename => OclParser.parse_contextlist oclFile;
val _ = trace high ("### Finished Parsing OCL File (" val _ = Logger.info ("### Finished Parsing OCL File ("
^(Int.toString(length (#1 context_classes))) ^(Int.toString(length (#1 context_classes)))
^" Constraints Found) ###\n\n") ^" Constraints Found) ###\n\n")
in in
@ -129,11 +128,11 @@ fun parseOCL oclFile =
fun parseModel oclFile = fun parseModel oclFile =
let let
val _ = trace high "### Parsing OCL File ###\n" val _ = Logger.info "### Parsing OCL File ###\n"
val context_classes = case oclFile of val context_classes = case oclFile of
"" => ([],[]) "" => ([],[])
| filename => OclParser.parse_contextlist oclFile; | filename => OclParser.parse_contextlist oclFile;
val _ = trace high ("### Finished Parsing OCL File (" val _ = Logger.info ("### Finished Parsing OCL File ("
^(Int.toString(length (#2 context_classes))) ^(Int.toString(length (#2 context_classes)))
^" Constraints Found) ###\n\n") ^" Constraints Found) ###\n\n")
in in
@ -145,11 +144,11 @@ fun removePackages packageList (cl,al) =
fun filter_package_assoc model p = filter fun filter_package_assoc model p = filter
(fn a => not ((rev o tl o rev) (Rep_Core.name_of_association a) = p)) model (fn a => not ((rev o tl o rev) (Rep_Core.name_of_association a) = p)) model
fun filter_package model p = filter (fn cl => not (Rep_Core.package_of cl = p)) model fun filter_package model p = filter (fn cl => not (Rep_Core.package_of cl = p)) model
val _ = trace high "### Excluding Packages ###\n" val _ = Logger.info "### Excluding Packages ###\n"
fun stringToPath s = (String.tokens (fn s => (s = (#":"))) s) fun stringToPath s = (String.tokens (fn s => (s = (#":"))) s)
val cl =foldr (fn (p,m) => filter_package m (stringToPath p)) cl packageList val cl =foldr (fn (p,m) => filter_package m (stringToPath p)) cl packageList
val al =foldr (fn (p,m) => filter_package_assoc m (stringToPath p)) al packageList val al =foldr (fn (p,m) => filter_package_assoc m (stringToPath p)) al packageList
val _ = trace high ("### Finished excluding Packages (" val _ = Logger.info ("### Finished excluding Packages ("
^(Int.toString(length cl)) ^(Int.toString(length cl))
^ " Classifiers found ###\n\n") ^ " Classifiers found ###\n\n")
(* TODO: Implement check for dangeling references/Types and Ocl Expressions *) (* TODO: Implement check for dangeling references/Types and Ocl Expressions *)
@ -175,41 +174,41 @@ fun removeOclLibrary (model) =
fun import xmifile oclfile excludePackages = fun import xmifile oclfile excludePackages =
let let
val xmi = parseUML xmifile val xmi = parseUML xmifile
val _ = init_offset() (* val _ = init_offset() *)
val ocl = parseOCL oclfile val ocl = parseOCL oclfile
val (xmi_cls, xmi_assocs) = xmi val (xmi_cls, xmi_assocs) = xmi
val _ = init_offset() (* val _ = init_offset() *)
val model = case ocl of val model = case ocl of
[] => (xmi_cls,xmi_assocs) [] => (xmi_cls,xmi_assocs)
| ocl => let | ocl => let
val _ = init_offset() (* val _ = init_offset() *)
val _ = trace high "### Preprocess Context List ###\n" val _ = Logger.info "### Preprocess Context List ###\n"
val fixed_ocl = Preprocessor.preprocess_context_list ocl ((OclLibrary.oclLib)@xmi_cls) val fixed_ocl = Preprocessor.preprocess_context_list ocl ((OclLibrary.oclLib)@xmi_cls)
val _ = trace high "### Finished Preprocess Context List ###\n\n" val _ = Logger.info "### Finished Preprocess Context List ###\n\n"
val _ = init_offset() (* val _ = init_offset() *)
val _ = trace high "### Type Checking ###\n" val _ = Logger.info "### Type Checking ###\n"
val typed_cl = TypeChecker.check_context_list fixed_ocl (((OclLibrary.oclLib)@xmi_cls),xmi_assocs); val typed_cl = TypeChecker.check_context_list fixed_ocl (((OclLibrary.oclLib)@xmi_cls),xmi_assocs);
val _ = trace high "### Finished Type Checking ###\n\n" val _ = Logger.info "### Finished Type Checking ###\n\n"
val _ = init_offset() (* val _ = init_offset() *)
val _ = print"### Updating Classifier List ###\n" val _ = Logger.info "### Updating Classifier List ###\n"
val model = Update_Model.gen_updated_classifier_list typed_cl ((OclLibrary.oclLib)@xmi_cls); val model = Update_Model.gen_updated_classifier_list typed_cl ((OclLibrary.oclLib)@xmi_cls);
val _ = trace high ("### Finished Updating Classifier List " val _ = Logger.info ("### Finished Updating Classifier List "
^(Int.toString(length model)) ^(Int.toString(length model))
^ " Classifiers found (11 from 'oclLib') ###\n") ^ " Classifiers found (11 from 'oclLib') ###\n")
val _ = init_offset() (* val _ = init_offset() *)
val _ = trace high "### Fixing Types ###\n" val _ = Logger.info "### Fixing Types ###\n"
val model = removeOclLibrary model val model = removeOclLibrary model
val model = removePackages excludePackages (model,xmi_assocs) val model = removePackages excludePackages (model,xmi_assocs)
(* (*
val model = FixTyping.transform_ocl_spec FixTyping.transformForHolOcl model val model = FixTyping.transform_ocl_spec FixTyping.transformForHolOcl model
*) *)
val _ = trace high "### Finished Fixing Types ###\n\n" val _ = Logger.info "### Finished Fixing Types ###\n\n"
in in
model model
end end

87
su4sml/src/ocl_parser/ocl.grm
View File

@ -60,7 +60,6 @@ THIS POINTS HAVE TO BE NOTICED TO UNDERSTAND THE SEMANTICS OF:
*) *)
open Rep_Logger
open Rep_Core open Rep_Core
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType
@ -326,8 +325,8 @@ package_constraint_list_cs_p : package_constraint_list_cs (package_const
| package_constraint_list_cs package_constraint_list_cs_p (package_constraint_list_cs@package_constraint_list_cs_p) | package_constraint_list_cs package_constraint_list_cs_p (package_constraint_list_cs@package_constraint_list_cs_p)
(* RETURN: context list *) (* RETURN: context list *)
package_constraint_list_cs : PACKAGE path_name_cs ENDPACKAGE (trace low ("Starts creatind empty package ... " ^ "\n"); ([Empty_context ("this is an empty context", Literal ("empty",OclVoid))])) package_constraint_list_cs : PACKAGE path_name_cs ENDPACKAGE (Logger.debug3 ("Starts creatind empty package ... " ^ "\n"); ([Empty_context ("this is an empty context", Literal ("empty",OclVoid))]))
| PACKAGE path_name_cs context_declaration_list_cs ENDPACKAGE (trace low ("Starts creating contextes ..." ^ "\n"); (list_extend_path path_name_cs context_declaration_list_cs)) | PACKAGE path_name_cs context_declaration_list_cs ENDPACKAGE (Logger.debug3 ("Starts creating contextes ..." ^ "\n"); (list_extend_path path_name_cs context_declaration_list_cs))
(* RETURN: context list *) (* RETURN: context list *)
context_declaration_list_cs : context_declaration_cs (context_declaration_cs) context_declaration_list_cs : context_declaration_cs (context_declaration_cs)
@ -344,7 +343,7 @@ attr_or_assoc_cs : CONTEXT path_name_cs COLON type_specifier init_
(* RETURN: string *) (* RETURN: string *)
simple_name : SIMPLE_NAME (trace low ("simple_name..." ^ "\n");SIMPLE_NAME) simple_name : SIMPLE_NAME (Logger.debug3 ("simple_name..." ^ "\n");SIMPLE_NAME)
(* RETURN: context list *) (* RETURN: context list *)
classifier_context_declaration_cs : CONTEXT path_name_cs classifier_constraint_cs_p (inv_list (path_name_cs, classifier_constraint_cs_p)) classifier_context_declaration_cs : CONTEXT path_name_cs classifier_constraint_cs_p (inv_list (path_name_cs, classifier_constraint_cs_p))
@ -376,15 +375,15 @@ init_or_der_value_cs : INIT COLON ocl_expression_cs (INI
| DERIVE COLON ocl_expression_cs (DERIVE, ocl_expression_cs) | DERIVE COLON ocl_expression_cs (DERIVE, ocl_expression_cs)
(* RETURN: (string option, OclTerm) 1.name 2.expression *) (* RETURN: (string option, OclTerm) 1.name 2.expression *)
classifier_constraint_cs : INV COLON ocl_expression_cs (trace low ("INV COLON ocl_expression_cs ..." ^ "\n"); (NONE,ocl_expression_cs)) classifier_constraint_cs : INV COLON ocl_expression_cs (Logger.debug3 ("INV COLON ocl_expression_cs ..." ^ "\n"); (NONE,ocl_expression_cs))
| INV simple_name COLON ocl_expression_cs (trace low ("INV simple_name COLON ocl_expression_cs ..." ^ "\n");(SOME(simple_name),ocl_expression_cs)) | INV simple_name COLON ocl_expression_cs (Logger.debug3 ("INV simple_name COLON ocl_expression_cs ..." ^ "\n");(SOME(simple_name),ocl_expression_cs))
| DEF COLON definition_constraint_cs (NONE,definition_constraint_cs) | DEF COLON definition_constraint_cs (NONE,definition_constraint_cs)
| DEF simple_name COLON definition_constraint_cs (SOME(simple_name),definition_constraint_cs) | DEF simple_name COLON definition_constraint_cs (SOME(simple_name),definition_constraint_cs)
(* RETURN: (ConditionType, string option, OclTerm) 1.{Pre|Post|Body} 2. name 3.expression*) (* RETURN: (ConditionType, string option, OclTerm) 1.{Pre|Post|Body} 2. name 3.expression*)
operation_constraint_cs : op_constraint_stereotype_cs COLON ocl_expression_cs (trace low ("operation_constraint_cs 1..." ^ "\n"); (op_constraint_stereotype_cs,NONE,ocl_expression_cs)) operation_constraint_cs : op_constraint_stereotype_cs COLON ocl_expression_cs (Logger.debug3 ("operation_constraint_cs 1..." ^ "\n"); (op_constraint_stereotype_cs,NONE,ocl_expression_cs))
| op_constraint_stereotype_cs simple_name COLON ocl_expression_cs (trace low ("operation_constraint_cs 23454..." ^ "\n"); (op_constraint_stereotype_cs,SOME(simple_name),ocl_expression_cs)) | op_constraint_stereotype_cs simple_name COLON ocl_expression_cs (Logger.debug3 ("operation_constraint_cs 23454..." ^ "\n"); (op_constraint_stereotype_cs,SOME(simple_name),ocl_expression_cs))
(* RETURN: (string option, OclTerm) 1.name 2.expression *) (* RETURN: (string option, OclTerm) 1.name 2.expression *)
guard_constraint_cs : GUARD COLON ocl_expression_cs (NONE,ocl_expression_cs) guard_constraint_cs : GUARD COLON ocl_expression_cs (NONE,ocl_expression_cs)
@ -395,7 +394,7 @@ guard_constraint_cs : GUARD COLON ocl_expression_cs (NO
definition_constraint_cs : defined_entity_decl_cs EQUALS ocl_expression_cs (OperationCall (defined_entity_decl_cs,DummyT,[OclLibPackage,"DummyT",EQUALS],[(ocl_expression_cs,DummyT)],DummyT)) definition_constraint_cs : defined_entity_decl_cs EQUALS ocl_expression_cs (OperationCall (defined_entity_decl_cs,DummyT,[OclLibPackage,"DummyT",EQUALS],[(ocl_expression_cs,DummyT)],DummyT))
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
defined_entity_decl_cs : ocl_attribute_defined_entity_decl_cs (trace low ("AttributeCall 1 ..." ^ "\n");AttributeCall (Literal ("self2",DummyT),DummyT,[#1(ocl_attribute_defined_entity_decl_cs)],#2(ocl_attribute_defined_entity_decl_cs))) defined_entity_decl_cs : ocl_attribute_defined_entity_decl_cs (Logger.debug3 ("AttributeCall 1 ..." ^ "\n");AttributeCall (Literal ("self2",DummyT),DummyT,[#1(ocl_attribute_defined_entity_decl_cs)],#2(ocl_attribute_defined_entity_decl_cs)))
| ocl_operation_defined_entity_decl_cs (OperationCall (Literal ("self2",DummyT),DummyT,[#1(ocl_operation_defined_entity_decl_cs)],List.map gen_literal_term (real_signature (#2(ocl_operation_defined_entity_decl_cs))),#2(List.last (#2(ocl_operation_defined_entity_decl_cs))))) | ocl_operation_defined_entity_decl_cs (OperationCall (Literal ("self2",DummyT),DummyT,[#1(ocl_operation_defined_entity_decl_cs)],List.map gen_literal_term (real_signature (#2(ocl_operation_defined_entity_decl_cs))),#2(List.last (#2(ocl_operation_defined_entity_decl_cs)))))
(* RETURN: (string * OclType) *) (* RETURN: (string * OclType) *)
@ -408,12 +407,12 @@ ocl_operation_defined_entity_decl_cs : simple_name operation_signature_cs (s
(* RETURN: (string * OclType) list *) (* RETURN: (string * OclType) list *)
(* last element of list is the return type. Only second part of tuple then used *) (* last element of list is the return type. Only second part of tuple then used *)
operation_signature_cs : PAREN_OPEN PAREN_CLOSE (trace low ("operation_signature_cs ..." ^ "\n");[("",OclVoid)]) operation_signature_cs : PAREN_OPEN PAREN_CLOSE (Logger.debug3 ("operation_signature_cs ..." ^ "\n");[("",OclVoid)])
| PAREN_OPEN PAREN_CLOSE operation_return_type_specifier_cs (trace low ("operation_signature_cs ..." ^ "\n");[("",operation_return_type_specifier_cs)]) | PAREN_OPEN PAREN_CLOSE operation_return_type_specifier_cs (Logger.debug3 ("operation_signature_cs ..." ^ "\n");[("",operation_return_type_specifier_cs)])
| PAREN_OPEN formal_parameter_list_cs PAREN_CLOSE (trace low ("operation_signature_cs ..." ^ "\n");formal_parameter_list_cs@[("",OclVoid)]) | PAREN_OPEN formal_parameter_list_cs PAREN_CLOSE (Logger.debug3 ("operation_signature_cs ..." ^ "\n");formal_parameter_list_cs@[("",OclVoid)])
| PAREN_OPEN formal_parameter_list_cs PAREN_CLOSE operation_return_type_specifier_cs (trace low ("operation_signature_cs ..." ^ "\n");formal_parameter_list_cs@[("",operation_return_type_specifier_cs)]) | PAREN_OPEN formal_parameter_list_cs PAREN_CLOSE operation_return_type_specifier_cs (Logger.debug3 ("operation_signature_cs ..." ^ "\n");formal_parameter_list_cs@[("",operation_return_type_specifier_cs)])
(* RETURN: OclType *) (* RETURN: OclType *)
operation_return_type_specifier_cs : COLON type_specifier (trace low ("Contextes created form list of Attributes ..." ^ "\n");type_specifier) operation_return_type_specifier_cs : COLON type_specifier (Logger.debug3 ("Contextes created form list of Attributes ..." ^ "\n");type_specifier)
(* RETURN: (ConditionType) *) (* RETURN: (ConditionType) *)
op_constraint_stereotype_cs : PRE (PRE) op_constraint_stereotype_cs : PRE (PRE)
| POST (POST) | POST (POST)
@ -472,9 +471,9 @@ tuple_type_specifier_cs : TUPLE_TYPE PAREN_OPEN PAREN_CLOSE
*) *)
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
ocl_expression_cs : logical_exp_cs (trace low ("ocl_expression_cs..." ^ "\n");logical_exp_cs) ocl_expression_cs : logical_exp_cs (Logger.debug3 ("ocl_expression_cs..." ^ "\n");logical_exp_cs)
| let_exp_cs (trace low ("ocl_expression_cs..." ^ "\n");let_exp_cs) | let_exp_cs (Logger.debug3 ("ocl_expression_cs..." ^ "\n");let_exp_cs)
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
let_exp_cs : LET initialized_variable_list_cs IN expression (gen_let_term initialized_variable_list_cs expression) let_exp_cs : LET initialized_variable_list_cs IN expression (gen_let_term initialized_variable_list_cs expression)
@ -508,30 +507,30 @@ ocl_op_name : OCLISKINDOF (OCLISKINDOF)
| OCLISTYPEOF (OCLISTYPEOF) | OCLISTYPEOF (OCLISTYPEOF)
| OCLASTYPE (OCLASTYPE) | OCLASTYPE (OCLASTYPE)
(* RETURN: Path *) (* RETURN: Path *)
path_name_cs : identifier_cs (trace low ("path_name finished..." ^ "\n");[identifier_cs]) path_name_cs : identifier_cs (Logger.debug3 ("path_name finished..." ^ "\n");[identifier_cs])
| path_name_head_cs identifier_cs (trace low ("path_name generation ..." ^ "\n");path_name_head_cs@[identifier_cs]) | path_name_head_cs identifier_cs (Logger.debug3 ("path_name generation ..." ^ "\n");path_name_head_cs@[identifier_cs])
(* RETURN : string *) (* RETURN : string *)
identifier_cs : simple_name (trace low ("path_name generation..." ^ "\n");simple_name) identifier_cs : simple_name (Logger.debug3 ("path_name generation..." ^ "\n");simple_name)
| ITERATE (ITERATE) | ITERATE (ITERATE)
| iterator_name_cs (iterator_name_cs) | iterator_name_cs (iterator_name_cs)
| ocl_op_name (ocl_op_name) | ocl_op_name (ocl_op_name)
(* RETURN: Path *) (* RETURN: Path *)
path_name_head_cs : identifier_cs DBL_COLON (trace low ("path_name generation..." ^ "\n");[identifier_cs]) path_name_head_cs : identifier_cs DBL_COLON (Logger.debug3 ("path_name generation..." ^ "\n");[identifier_cs])
| path_name_head_cs identifier_cs DBL_COLON (trace low ("path_name generation..." ^ "\n");path_name_head_cs@[identifier_cs]) | path_name_head_cs identifier_cs DBL_COLON (Logger.debug3 ("path_name generation..." ^ "\n");path_name_head_cs@[identifier_cs])
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
literal_exp_cs : primitive_literal_exp_cs (trace low ("primitive_literal_exp_cs..." ^ "\n");primitive_literal_exp_cs) literal_exp_cs : primitive_literal_exp_cs (Logger.debug3 ("primitive_literal_exp_cs..." ^ "\n");primitive_literal_exp_cs)
| collection_literal_exp_cs (collection_literal_exp_cs) | collection_literal_exp_cs (collection_literal_exp_cs)
(* NOT YET SUPPORTED ... (* NOT YET SUPPORTED ...
| tuple_literal_exp_cs (tuple_literal_exp_cs) | tuple_literal_exp_cs (tuple_literal_exp_cs)
*) *)
primitive_literal_exp_cs : numeric_literal_exp_cs (trace low ("numeric_literal_exp_cs..." ^ "\n");numeric_literal_exp_cs) primitive_literal_exp_cs : numeric_literal_exp_cs (Logger.debug3 ("numeric_literal_exp_cs..." ^ "\n");numeric_literal_exp_cs)
| string_literal_exp_cs (trace low ("string_literal_exp_cs..." ^ "\n");string_literal_exp_cs) | string_literal_exp_cs (Logger.debug3 ("string_literal_exp_cs..." ^ "\n");string_literal_exp_cs)
| boolean_literal_exp_cs (boolean_literal_exp_cs) | boolean_literal_exp_cs (boolean_literal_exp_cs)
numeric_literal_exp_cs : INTEGER_LITERAL (trace low ("INTEGER_LITERAL..." ^ "\n");Literal (INTEGER_LITERAL,Integer)) numeric_literal_exp_cs : INTEGER_LITERAL (Logger.debug3 ("INTEGER_LITERAL..." ^ "\n");Literal (INTEGER_LITERAL,Integer))
| REAL_LITERAL (Literal (REAL_LITERAL,Real)) | REAL_LITERAL (Literal (REAL_LITERAL,Real))
string_literal_exp_cs : STRING_LITERAL (Literal (STRING_LITERAL,String)) string_literal_exp_cs : STRING_LITERAL (Literal (STRING_LITERAL,String))
boolean_literal_exp_cs : TRUE (Literal ("true",Boolean)) boolean_literal_exp_cs : TRUE (Literal ("true",Boolean))
@ -541,8 +540,8 @@ tuple_literal_exp_cs : TUPLE BRACE_OPEN initialized_variable_
*) *)
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
logical_exp_cs : relational_exp_cs (trace low ("logical_exp_cs..." ^ "\n");relational_exp_cs) logical_exp_cs : relational_exp_cs (Logger.debug3 ("logical_exp_cs..." ^ "\n");relational_exp_cs)
| relational_exp_cs logical_exp_tail_cs_p (trace low ("logical_exp_cs..." ^ "\n");OperationCall(relational_exp_cs,Boolean,[OclLibPackage,"Boolean",#1(logical_exp_tail_cs_p)],[(#2(logical_exp_tail_cs_p),Boolean)],Boolean)) | relational_exp_cs logical_exp_tail_cs_p (Logger.debug3 ("logical_exp_cs..." ^ "\n");OperationCall(relational_exp_cs,Boolean,[OclLibPackage,"Boolean",#1(logical_exp_tail_cs_p)],[(#2(logical_exp_tail_cs_p),Boolean)],Boolean))
(* RETURN: (logic_op, OclTerm) *) (* RETURN: (logic_op, OclTerm) *)
logical_exp_tail_cs_p : logical_exp_tail_cs (logical_exp_tail_cs) logical_exp_tail_cs_p : logical_exp_tail_cs (logical_exp_tail_cs)
@ -557,23 +556,23 @@ logic_op : LOG_AND
| LOG_IMPL (LOG_IMPL) | LOG_IMPL (LOG_IMPL)
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
relational_exp_cs : additive_exp_cs (trace low ("additive_exp_cs..." ^ "\n");additive_exp_cs) relational_exp_cs : additive_exp_cs (Logger.debug3 ("additive_exp_cs..." ^ "\n");additive_exp_cs)
| additive_exp_cs relational_exp_tail_cs (trace low ("additive_exp_cs relational_exp_tail_cs ..." ^ "\n");OperationCall(additive_exp_cs,DummyT,[OclLibPackage,"DummyT",#1(relational_exp_tail_cs)],[(#2(relational_exp_tail_cs),DummyT)],Boolean)) | additive_exp_cs relational_exp_tail_cs (Logger.debug3 ("additive_exp_cs relational_exp_tail_cs ..." ^ "\n");OperationCall(additive_exp_cs,DummyT,[OclLibPackage,"DummyT",#1(relational_exp_tail_cs)],[(#2(relational_exp_tail_cs),DummyT)],Boolean))
(* RETURN: (rel_op, Ocl_Term) *) (* RETURN: (rel_op, Ocl_Term) *)
relational_exp_tail_cs : rel_op additive_exp_cs (trace low ("relational_exp_tail_cs..." ^ "\n");(rel_op, additive_exp_cs)) relational_exp_tail_cs : rel_op additive_exp_cs (Logger.debug3 ("relational_exp_tail_cs..." ^ "\n");(rel_op, additive_exp_cs))
(* RETURN: string *) (* RETURN: string *)
rel_op : EQUALS (EQUALS) rel_op : EQUALS (EQUALS)
| REL_GT (trace low (">..." ^ "\n");REL_GT) | REL_GT (Logger.debug3 (">..." ^ "\n");REL_GT)
| REL_LT (trace low ("<..." ^ "\n");REL_LT) | REL_LT (Logger.debug3 ("<..." ^ "\n");REL_LT)
| REL_GTE (REL_GTE) | REL_GTE (REL_GTE)
| REL_LTE (REL_LTE) | REL_LTE (REL_LTE)
| REL_NOTEQUAL (REL_NOTEQUAL) | REL_NOTEQUAL (REL_NOTEQUAL)
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
additive_exp_cs : multiplicative_exp_cs (trace low ("multiplicative_exp_cs..." ^ "\n");multiplicative_exp_cs) additive_exp_cs : multiplicative_exp_cs (Logger.debug3 ("multiplicative_exp_cs..." ^ "\n");multiplicative_exp_cs)
| multiplicative_exp_cs additive_exp_tail_cs_p (trace low ("multiplicative_exp_cs additive_exp_tail_cs_p..." ^ "\n");OperationCall (multiplicative_exp_cs,DummyT,[OclLibPackage,"DummyT",#1(additive_exp_tail_cs_p)],[(#2(additive_exp_tail_cs_p),DummyT)],DummyT)) | multiplicative_exp_cs additive_exp_tail_cs_p (Logger.debug3 ("multiplicative_exp_cs additive_exp_tail_cs_p..." ^ "\n");OperationCall (multiplicative_exp_cs,DummyT,[OclLibPackage,"DummyT",#1(additive_exp_tail_cs_p)],[(#2(additive_exp_tail_cs_p),DummyT)],DummyT))
(* RETURN: (add_op, Ocl_Term) *) (* RETURN: (add_op, Ocl_Term) *)
additive_exp_tail_cs_p : additive_exp_tail_cs (additive_exp_tail_cs) additive_exp_tail_cs_p : additive_exp_tail_cs (additive_exp_tail_cs)
@ -585,7 +584,7 @@ additive_exp_tail_cs : add_op multiplicative_exp_cs
add_op: PLUS (PLUS) add_op: PLUS (PLUS)
| MINUS (MINUS) | MINUS (MINUS)
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
multiplicative_exp_cs: unary_exp_cs (trace low ("unary_exp_cs ..." ^ "\n");unary_exp_cs) multiplicative_exp_cs: unary_exp_cs (Logger.debug3 ("unary_exp_cs ..." ^ "\n");unary_exp_cs)
| unary_exp_cs multiplicative_exp_tail_cs_p (OperationCall (unary_exp_cs,DummyT,[OclLibPackage,"DummyT",#1(multiplicative_exp_tail_cs_p)],[(#2(multiplicative_exp_tail_cs_p),DummyT)],DummyT)) | unary_exp_cs multiplicative_exp_tail_cs_p (OperationCall (unary_exp_cs,DummyT,[OclLibPackage,"DummyT",#1(multiplicative_exp_tail_cs_p)],[(#2(multiplicative_exp_tail_cs_p),DummyT)],DummyT))
(* RETURN: (mult_op, Ocl_Term ) *) (* RETURN: (mult_op, Ocl_Term ) *)
@ -607,22 +606,22 @@ unary_op : MINUS
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
postfix_exp_cs : primary_exp_cs (primary_exp_cs) postfix_exp_cs : primary_exp_cs (primary_exp_cs)
| primary_exp_cs postfix_exp_tail_cs_p (trace low ("literal_call_exp_cs..." ^ "\n");nest_source ([primary_exp_cs]@postfix_exp_tail_cs_p)) | primary_exp_cs postfix_exp_tail_cs_p (Logger.debug3 ("literal_call_exp_cs..." ^ "\n");nest_source ([primary_exp_cs]@postfix_exp_tail_cs_p))
(* NOT YET IMPLEMENTED (* NOT YET IMPLEMENTED
| msg_operator_cs signal_spec_exp_cs | msg_operator_cs signal_spec_exp_cs
*) *)
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
primary_exp_cs : literal_exp_cs (trace low ("literal_call_exp_cs..." ^ "\n");literal_exp_cs) primary_exp_cs : literal_exp_cs (Logger.debug3 ("literal_call_exp_cs..." ^ "\n");literal_exp_cs)
| PAREN_OPEN expression PAREN_CLOSE (expression) | PAREN_OPEN expression PAREN_CLOSE (expression)
| property_call_exp_cs (trace low ("property_call_exp_cs..." ^ "\n");property_call_exp_cs) | property_call_exp_cs (Logger.debug3 ("property_call_exp_cs..." ^ "\n");property_call_exp_cs)
| if_exp_cs (if_exp_cs) | if_exp_cs (if_exp_cs)
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
if_exp_cs: IF logical_exp_cs THEN ocl_expression_cs ELSE ocl_expression_cs ENDIF (If (logical_exp_cs,DummyT,ocl_expression_cs1,DummyT,ocl_expression_cs2,DummyT,DummyT)) if_exp_cs: IF logical_exp_cs THEN ocl_expression_cs ELSE ocl_expression_cs ENDIF (If (logical_exp_cs,DummyT,ocl_expression_cs1,DummyT,ocl_expression_cs2,DummyT,DummyT))
(* RETURN: OclTerm list *) (* RETURN: OclTerm list *)
postfix_exp_tail_cs_p : postfix_exp_tail_cs (trace low ("end of recursion..." ^ Ocl2String.ocl2string false postfix_exp_tail_cs ^ "\n");[postfix_exp_tail_cs]) postfix_exp_tail_cs_p : postfix_exp_tail_cs (Logger.debug3 ("end of recursion..." ^ Ocl2String.ocl2string false postfix_exp_tail_cs ^ "\n");[postfix_exp_tail_cs])
| postfix_exp_tail_cs postfix_exp_tail_cs_p (trace low ("add_source ..." ^ "\n" ^ "done");([postfix_exp_tail_cs]@postfix_exp_tail_cs_p)) | postfix_exp_tail_cs postfix_exp_tail_cs_p (Logger.debug3 ("add_source ..." ^ "\n" ^ "done");([postfix_exp_tail_cs]@postfix_exp_tail_cs_p))
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
postfix_exp_tail_cs : DOT property_call_exp_cs (property_call_exp_cs) postfix_exp_tail_cs : DOT property_call_exp_cs (property_call_exp_cs)
@ -646,8 +645,8 @@ property_call_exp_cs : path_name_cs (AttributeCall (Va
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
arrow_property_call_exp_cs: iterator_name_cs PAREN_OPEN expression PAREN_CLOSE (Iterator (iterator_name_cs,[],Variable("dummy_source",DummyT),DummyT,expression,DummyT,DummyT)) arrow_property_call_exp_cs: iterator_name_cs PAREN_OPEN expression PAREN_CLOSE (Iterator (iterator_name_cs,[],Variable("dummy_source",DummyT),DummyT,expression,DummyT,DummyT))
| iterator_name_cs PAREN_OPEN iterator_vars_cs expression PAREN_CLOSE (trace low ("arrow_property_call_cs: iterator with vars..." ^ "\n");Iterator (iterator_name_cs,iterator_vars_cs,Variable("dummy_source",DummyT),DummyT,expression,DummyT,DummyT)) | iterator_name_cs PAREN_OPEN iterator_vars_cs expression PAREN_CLOSE (Logger.debug3 ("arrow_property_call_cs: iterator with vars..." ^ "\n");Iterator (iterator_name_cs,iterator_vars_cs,Variable("dummy_source",DummyT),DummyT,expression,DummyT,DummyT))
| simple_name PAREN_OPEN PAREN_CLOSE (trace low ("arrow_property_call_exp_cs..." ^ "\n");OperationCall (Variable ("dummy_source",DummyT),DummyT,(["arrow"]@[simple_name]),[],DummyT)) | simple_name PAREN_OPEN PAREN_CLOSE (Logger.debug3 ("arrow_property_call_exp_cs..." ^ "\n");OperationCall (Variable ("dummy_source",DummyT),DummyT,(["arrow"]@[simple_name]),[],DummyT))
| simple_name PAREN_OPEN actual_parameter_list_cs PAREN_CLOSE (OperationCall (Variable ("dummy_source",DummyT),DummyT,(["arrow"]@[simple_name]),actual_parameter_list_cs,DummyT)) | simple_name PAREN_OPEN actual_parameter_list_cs PAREN_CLOSE (OperationCall (Variable ("dummy_source",DummyT),DummyT,(["arrow"]@[simple_name]),actual_parameter_list_cs,DummyT))
(* (*
| ITERATE PAREN_OPEN initialized_variable_cs VERTICAL_BAR expression PAREN_CLOSE (Iterate ([],(#1 initialized_variable_cs),(#2 initialized_variable_cs),(#3 initialized_variable_cs),Variable ("dummy_source",DummyT),DummyT,expression,DummyT,DummyT)) | ITERATE PAREN_OPEN initialized_variable_cs VERTICAL_BAR expression PAREN_CLOSE (Iterate ([],(#1 initialized_variable_cs),(#2 initialized_variable_cs),(#3 initialized_variable_cs),Variable ("dummy_source",DummyT),DummyT,expression,DummyT,DummyT))
@ -711,7 +710,7 @@ formal_parameter_cs : simple_name formal_parameter_type_specifier (simple
formal_parameter_type_specifier : COLON type_specifier (type_specifier) formal_parameter_type_specifier : COLON type_specifier (type_specifier)
(* RETURN: OclType *) (* RETURN: OclType *)
type_specifier: simple_type_specifier_cs (trace low ("type_specifier ..." ^ "\n");simple_type_specifier_cs) type_specifier: simple_type_specifier_cs (Logger.debug3 ("type_specifier ..." ^ "\n");simple_type_specifier_cs)
| collection_type_specifier_cs (collection_type_specifier_cs) | collection_type_specifier_cs (collection_type_specifier_cs)
(* (*
| typle_type_specifier_cs | typle_type_specifier_cs
@ -719,7 +718,7 @@ type_specifier: simple_type_specifier_cs
*) *)
(* RETURN: OclType *) (* RETURN: OclType *)
simple_type_specifier_cs : simple_name (trace wgen ("simple_type_name_specifier_cs : " ^ simple_name ^ "\n");string_to_type simple_name) simple_type_specifier_cs : simple_name (Logger.debug3 ("simple_type_name_specifier_cs : " ^ simple_name ^ "\n");string_to_type simple_name)
(* RETURN: (string * OclType * OclTerm) list *) (* RETURN: (string * OclType * OclTerm) list *)

113
su4sml/src/ocl_parser/ocl.grm.sml
View File

@ -70,7 +70,6 @@ THIS POINTS HAVE TO BE NOTICED TO UNDERSTAND THE SEMANTICS OF:
*) *)
open Rep_Logger
open Rep_Core open Rep_Core
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType
@ -1412,7 +1411,7 @@ PACKAGE1 = PACKAGE1 ()
val path_name_cs1 = path_name_cs1 () val path_name_cs1 = path_name_cs1 ()
val ENDPACKAGE1 = ENDPACKAGE1 () val ENDPACKAGE1 = ENDPACKAGE1 ()
in ( in (
trace low ("Starts creatind empty package ... " ^ "\n"); ([Empty_context ("this is an empty context", Literal ("empty",OclVoid))]) Logger.debug3 ("Starts creatind empty package ... " ^ "\n"); ([Empty_context ("this is an empty context", Literal ("empty",OclVoid))])
) )
end) end)
in ( LrTable.NT 10, ( result, PACKAGE1left, ENDPACKAGE1right), in ( LrTable.NT 10, ( result, PACKAGE1left, ENDPACKAGE1right),
@ -1430,7 +1429,7 @@ PACKAGE1 ()
context_declaration_list_cs1 () context_declaration_list_cs1 ()
val ENDPACKAGE1 = ENDPACKAGE1 () val ENDPACKAGE1 = ENDPACKAGE1 ()
in ( in (
trace low ("Starts creating contextes ..." ^ "\n"); (list_extend_path path_name_cs context_declaration_list_cs) Logger.debug3 ("Starts creating contextes ..." ^ "\n"); (list_extend_path path_name_cs context_declaration_list_cs)
) )
end) end)
in ( LrTable.NT 10, ( result, PACKAGE1left, ENDPACKAGE1right), in ( LrTable.NT 10, ( result, PACKAGE1left, ENDPACKAGE1right),
@ -1528,7 +1527,7 @@ end
SIMPLE_NAME1right)) :: rest671)) => let val result = SIMPLE_NAME1right)) :: rest671)) => let val result =
MlyValue.simple_name (fn _ => let val (SIMPLE_NAME as SIMPLE_NAME1) = MlyValue.simple_name (fn _ => let val (SIMPLE_NAME as SIMPLE_NAME1) =
SIMPLE_NAME1 () SIMPLE_NAME1 ()
in (trace low ("simple_name..." ^ "\n");SIMPLE_NAME) in (Logger.debug3 ("simple_name..." ^ "\n");SIMPLE_NAME)
end) end)
in ( LrTable.NT 32, ( result, SIMPLE_NAME1left, SIMPLE_NAME1right), in ( LrTable.NT 32, ( result, SIMPLE_NAME1left, SIMPLE_NAME1right),
rest671) rest671)
@ -1712,7 +1711,7 @@ ocl_expression_cs1right)) :: ( _, ( MlyValue.COLON COLON1, _, _)) :: (
val (ocl_expression_cs as ocl_expression_cs1) = ocl_expression_cs1 val (ocl_expression_cs as ocl_expression_cs1) = ocl_expression_cs1
() ()
in ( in (
trace low ("INV COLON ocl_expression_cs ..." ^ "\n"); (NONE,ocl_expression_cs) Logger.debug3 ("INV COLON ocl_expression_cs ..." ^ "\n"); (NONE,ocl_expression_cs)
) )
end) end)
in ( LrTable.NT 23, ( result, INV1left, ocl_expression_cs1right), in ( LrTable.NT 23, ( result, INV1left, ocl_expression_cs1right),
@ -1729,7 +1728,7 @@ INV1 ()
val (ocl_expression_cs as ocl_expression_cs1) = ocl_expression_cs1 val (ocl_expression_cs as ocl_expression_cs1) = ocl_expression_cs1
() ()
in ( in (
trace low ("INV simple_name COLON ocl_expression_cs ..." ^ "\n");(SOME(simple_name),ocl_expression_cs) Logger.debug3 ("INV simple_name COLON ocl_expression_cs ..." ^ "\n");(SOME(simple_name),ocl_expression_cs)
) )
end) end)
in ( LrTable.NT 23, ( result, INV1left, ocl_expression_cs1right), in ( LrTable.NT 23, ( result, INV1left, ocl_expression_cs1right),
@ -1774,7 +1773,7 @@ op_constraint_stereotype_cs1) = op_constraint_stereotype_cs1 ()
val (ocl_expression_cs as ocl_expression_cs1) = ocl_expression_cs1 val (ocl_expression_cs as ocl_expression_cs1) = ocl_expression_cs1
() ()
in ( in (
trace low ("operation_constraint_cs 1..." ^ "\n"); (op_constraint_stereotype_cs,NONE,ocl_expression_cs) Logger.debug3 ("operation_constraint_cs 1..." ^ "\n"); (op_constraint_stereotype_cs,NONE,ocl_expression_cs)
) )
end) end)
in ( LrTable.NT 26, ( result, op_constraint_stereotype_cs1left, in ( LrTable.NT 26, ( result, op_constraint_stereotype_cs1left,
@ -1793,7 +1792,7 @@ op_constraint_stereotype_cs1 ()
val (ocl_expression_cs as ocl_expression_cs1) = ocl_expression_cs1 val (ocl_expression_cs as ocl_expression_cs1) = ocl_expression_cs1
() ()
in ( in (
trace low ("operation_constraint_cs 23454..." ^ "\n"); (op_constraint_stereotype_cs,SOME(simple_name),ocl_expression_cs) Logger.debug3 ("operation_constraint_cs 23454..." ^ "\n"); (op_constraint_stereotype_cs,SOME(simple_name),ocl_expression_cs)
) )
end) end)
in ( LrTable.NT 26, ( result, op_constraint_stereotype_cs1left, in ( LrTable.NT 26, ( result, op_constraint_stereotype_cs1left,
@ -1852,7 +1851,7 @@ ocl_attribute_defined_entity_decl_cs as
ocl_attribute_defined_entity_decl_cs1) = ocl_attribute_defined_entity_decl_cs1) =
ocl_attribute_defined_entity_decl_cs1 () ocl_attribute_defined_entity_decl_cs1 ()
in ( in (
trace low ("AttributeCall 1 ..." ^ "\n");AttributeCall (Literal ("self2",DummyT),DummyT,[#1(ocl_attribute_defined_entity_decl_cs)],#2(ocl_attribute_defined_entity_decl_cs)) Logger.debug3 ("AttributeCall 1 ..." ^ "\n");AttributeCall (Literal ("self2",DummyT),DummyT,[#1(ocl_attribute_defined_entity_decl_cs)],#2(ocl_attribute_defined_entity_decl_cs))
) )
end) end)
in ( LrTable.NT 34, ( result, in ( LrTable.NT 34, ( result,
@ -1903,7 +1902,8 @@ PAREN_OPEN1left, _)) :: rest671)) => let val result =
MlyValue.operation_signature_cs (fn _ => let val PAREN_OPEN1 = MlyValue.operation_signature_cs (fn _ => let val PAREN_OPEN1 =
PAREN_OPEN1 () PAREN_OPEN1 ()
val PAREN_CLOSE1 = PAREN_CLOSE1 () val PAREN_CLOSE1 = PAREN_CLOSE1 ()
in (trace low ("operation_signature_cs ..." ^ "\n");[("",OclVoid)]) in (
Logger.debug3 ("operation_signature_cs ..." ^ "\n");[("",OclVoid)])
end) end)
in ( LrTable.NT 24, ( result, PAREN_OPEN1left, PAREN_CLOSE1right), in ( LrTable.NT 24, ( result, PAREN_OPEN1left, PAREN_CLOSE1right),
@ -1921,7 +1921,7 @@ PAREN_OPEN1 = PAREN_OPEN1 ()
operation_return_type_specifier_cs1) = operation_return_type_specifier_cs1) =
operation_return_type_specifier_cs1 () operation_return_type_specifier_cs1 ()
in ( in (
trace low ("operation_signature_cs ..." ^ "\n");[("",operation_return_type_specifier_cs)] Logger.debug3 ("operation_signature_cs ..." ^ "\n");[("",operation_return_type_specifier_cs)]
) )
end) end)
in ( LrTable.NT 24, ( result, PAREN_OPEN1left, in ( LrTable.NT 24, ( result, PAREN_OPEN1left,
@ -1937,7 +1937,7 @@ PAREN_OPEN1 ()
formal_parameter_list_cs1 () formal_parameter_list_cs1 ()
val PAREN_CLOSE1 = PAREN_CLOSE1 () val PAREN_CLOSE1 = PAREN_CLOSE1 ()
in ( in (
trace low ("operation_signature_cs ..." ^ "\n");formal_parameter_list_cs@[("",OclVoid)] Logger.debug3 ("operation_signature_cs ..." ^ "\n");formal_parameter_list_cs@[("",OclVoid)]
) )
end) end)
in ( LrTable.NT 24, ( result, PAREN_OPEN1left, PAREN_CLOSE1right), in ( LrTable.NT 24, ( result, PAREN_OPEN1left, PAREN_CLOSE1right),
@ -1958,7 +1958,7 @@ formal_parameter_list_cs1 ()
operation_return_type_specifier_cs1) = operation_return_type_specifier_cs1) =
operation_return_type_specifier_cs1 () operation_return_type_specifier_cs1 ()
in ( in (
trace low ("operation_signature_cs ..." ^ "\n");formal_parameter_list_cs@[("",operation_return_type_specifier_cs)] Logger.debug3 ("operation_signature_cs ..." ^ "\n");formal_parameter_list_cs@[("",operation_return_type_specifier_cs)]
) )
end) end)
in ( LrTable.NT 24, ( result, PAREN_OPEN1left, in ( LrTable.NT 24, ( result, PAREN_OPEN1left,
@ -1971,7 +1971,7 @@ MlyValue.operation_return_type_specifier_cs (fn _ => let val COLON1 =
COLON1 () COLON1 ()
val (type_specifier as type_specifier1) = type_specifier1 () val (type_specifier as type_specifier1) = type_specifier1 ()
in ( in (
trace low ("Contextes created form list of Attributes ..." ^ "\n");type_specifier Logger.debug3 ("Contextes created form list of Attributes ..." ^ "\n");type_specifier
) )
end) end)
in ( LrTable.NT 40, ( result, COLON1left, type_specifier1right), in ( LrTable.NT 40, ( result, COLON1left, type_specifier1right),
@ -2182,8 +2182,9 @@ end
logical_exp_cs1left, logical_exp_cs1right)) :: rest671)) => let val logical_exp_cs1left, logical_exp_cs1right)) :: rest671)) => let val
result = MlyValue.ocl_expression_cs (fn _ => let val (logical_exp_cs result = MlyValue.ocl_expression_cs (fn _ => let val (logical_exp_cs
as logical_exp_cs1) = logical_exp_cs1 () as logical_exp_cs1) = logical_exp_cs1 ()
in (trace low ("ocl_expression_cs..." ^ "\n");logical_exp_cs) in (Logger.debug3 ("ocl_expression_cs..." ^ "\n");logical_exp_cs)
end) end
)
in ( LrTable.NT 54, ( result, logical_exp_cs1left, in ( LrTable.NT 54, ( result, logical_exp_cs1left,
logical_exp_cs1right), rest671) logical_exp_cs1right), rest671)
end end
@ -2191,7 +2192,7 @@ end
let_exp_cs1right)) :: rest671)) => let val result = let_exp_cs1right)) :: rest671)) => let val result =
MlyValue.ocl_expression_cs (fn _ => let val (let_exp_cs as MlyValue.ocl_expression_cs (fn _ => let val (let_exp_cs as
let_exp_cs1) = let_exp_cs1 () let_exp_cs1) = let_exp_cs1 ()
in (trace low ("ocl_expression_cs..." ^ "\n");let_exp_cs) in (Logger.debug3 ("ocl_expression_cs..." ^ "\n");let_exp_cs)
end) end)
in ( LrTable.NT 54, ( result, let_exp_cs1left, let_exp_cs1right), in ( LrTable.NT 54, ( result, let_exp_cs1left, let_exp_cs1right),
rest671) rest671)
@ -2314,7 +2315,8 @@ end
identifier_cs1left, identifier_cs1right)) :: rest671)) => let val identifier_cs1left, identifier_cs1right)) :: rest671)) => let val
result = MlyValue.path_name_cs (fn _ => let val (identifier_cs as result = MlyValue.path_name_cs (fn _ => let val (identifier_cs as
identifier_cs1) = identifier_cs1 () identifier_cs1) = identifier_cs1 ()
in (trace low ("path_name finished..." ^ "\n");[identifier_cs]) in (Logger.debug3 ("path_name finished..." ^ "\n");[identifier_cs])
end) end)
in ( LrTable.NT 11, ( result, identifier_cs1left, identifier_cs1right in ( LrTable.NT 11, ( result, identifier_cs1left, identifier_cs1right
), rest671) ), rest671)
@ -2326,7 +2328,7 @@ path_name_head_cs1, path_name_head_cs1left, _)) :: rest671)) => let
path_name_head_cs as path_name_head_cs1) = path_name_head_cs1 () path_name_head_cs as path_name_head_cs1) = path_name_head_cs1 ()
val (identifier_cs as identifier_cs1) = identifier_cs1 () val (identifier_cs as identifier_cs1) = identifier_cs1 ()
in ( in (
trace low ("path_name generation ..." ^ "\n");path_name_head_cs@[identifier_cs] Logger.debug3 ("path_name generation ..." ^ "\n");path_name_head_cs@[identifier_cs]
) )
end) end)
in ( LrTable.NT 11, ( result, path_name_head_cs1left, in ( LrTable.NT 11, ( result, path_name_head_cs1left,
@ -2336,8 +2338,9 @@ end
simple_name1right)) :: rest671)) => let val result = simple_name1right)) :: rest671)) => let val result =
MlyValue.identifier_cs (fn _ => let val (simple_name as simple_name1) MlyValue.identifier_cs (fn _ => let val (simple_name as simple_name1)
= simple_name1 () = simple_name1 ()
in (trace low ("path_name generation..." ^ "\n");simple_name) in (Logger.debug3 ("path_name generation..." ^ "\n");simple_name)
end) end
)
in ( LrTable.NT 59, ( result, simple_name1left, simple_name1right), in ( LrTable.NT 59, ( result, simple_name1left, simple_name1right),
rest671) rest671)
end end
@ -2373,9 +2376,9 @@ end
_)) :: rest671)) => let val result = MlyValue.path_name_head_cs (fn _)) :: rest671)) => let val result = MlyValue.path_name_head_cs (fn
_ => let val (identifier_cs as identifier_cs1) = identifier_cs1 () _ => let val (identifier_cs as identifier_cs1) = identifier_cs1 ()
val DBL_COLON1 = DBL_COLON1 () val DBL_COLON1 = DBL_COLON1 ()
in (trace low ("path_name generation..." ^ "\n");[identifier_cs]) in (Logger.debug3 ("path_name generation..." ^ "\n");[identifier_cs])
end
) end)
in ( LrTable.NT 12, ( result, identifier_cs1left, DBL_COLON1right), in ( LrTable.NT 12, ( result, identifier_cs1left, DBL_COLON1right),
rest671) rest671)
end end
@ -2388,7 +2391,7 @@ path_name_head_cs1 ()
val (identifier_cs as identifier_cs1) = identifier_cs1 () val (identifier_cs as identifier_cs1) = identifier_cs1 ()
val DBL_COLON1 = DBL_COLON1 () val DBL_COLON1 = DBL_COLON1 ()
in ( in (
trace low ("path_name generation..." ^ "\n");path_name_head_cs@[identifier_cs] Logger.debug3 ("path_name generation..." ^ "\n");path_name_head_cs@[identifier_cs]
) )
end) end)
in ( LrTable.NT 12, ( result, path_name_head_cs1left, DBL_COLON1right in ( LrTable.NT 12, ( result, path_name_head_cs1left, DBL_COLON1right
@ -2400,7 +2403,7 @@ primitive_literal_exp_cs1right)) :: rest671)) => let val result =
MlyValue.literal_exp_cs (fn _ => let val (primitive_literal_exp_cs MlyValue.literal_exp_cs (fn _ => let val (primitive_literal_exp_cs
as primitive_literal_exp_cs1) = primitive_literal_exp_cs1 () as primitive_literal_exp_cs1) = primitive_literal_exp_cs1 ()
in ( in (
trace low ("primitive_literal_exp_cs..." ^ "\n");primitive_literal_exp_cs Logger.debug3 ("primitive_literal_exp_cs..." ^ "\n");primitive_literal_exp_cs
) )
end) end)
in ( LrTable.NT 62, ( result, primitive_literal_exp_cs1left, in ( LrTable.NT 62, ( result, primitive_literal_exp_cs1left,
@ -2423,8 +2426,8 @@ MlyValue.primitive_literal_exp_cs (fn _ => let val (
numeric_literal_exp_cs as numeric_literal_exp_cs1) = numeric_literal_exp_cs as numeric_literal_exp_cs1) =
numeric_literal_exp_cs1 () numeric_literal_exp_cs1 ()
in ( in (
trace low ("numeric_literal_exp_cs..." ^ "\n");numeric_literal_exp_cs) Logger.debug3 ("numeric_literal_exp_cs..." ^ "\n");numeric_literal_exp_cs
)
end) end)
in ( LrTable.NT 65, ( result, numeric_literal_exp_cs1left, in ( LrTable.NT 65, ( result, numeric_literal_exp_cs1left,
numeric_literal_exp_cs1right), rest671) numeric_literal_exp_cs1right), rest671)
@ -2436,8 +2439,8 @@ MlyValue.primitive_literal_exp_cs (fn _ => let val (
string_literal_exp_cs as string_literal_exp_cs1) = string_literal_exp_cs as string_literal_exp_cs1) =
string_literal_exp_cs1 () string_literal_exp_cs1 ()
in ( in (
trace low ("string_literal_exp_cs..." ^ "\n");string_literal_exp_cs) Logger.debug3 ("string_literal_exp_cs..." ^ "\n");string_literal_exp_cs
)
end) end)
in ( LrTable.NT 65, ( result, string_literal_exp_cs1left, in ( LrTable.NT 65, ( result, string_literal_exp_cs1left,
string_literal_exp_cs1right), rest671) string_literal_exp_cs1right), rest671)
@ -2458,7 +2461,7 @@ INTEGER_LITERAL1left, INTEGER_LITERAL1right)) :: rest671)) => let val
result = MlyValue.numeric_literal_exp_cs (fn _ => let val ( result = MlyValue.numeric_literal_exp_cs (fn _ => let val (
INTEGER_LITERAL as INTEGER_LITERAL1) = INTEGER_LITERAL1 () INTEGER_LITERAL as INTEGER_LITERAL1) = INTEGER_LITERAL1 ()
in ( in (
trace low ("INTEGER_LITERAL..." ^ "\n");Literal (INTEGER_LITERAL,Integer) Logger.debug3 ("INTEGER_LITERAL..." ^ "\n");Literal (INTEGER_LITERAL,Integer)
) )
end) end)
in ( LrTable.NT 66, ( result, INTEGER_LITERAL1left, in ( LrTable.NT 66, ( result, INTEGER_LITERAL1left,
@ -2500,8 +2503,9 @@ end
relational_exp_cs1left, relational_exp_cs1right)) :: rest671)) => let relational_exp_cs1left, relational_exp_cs1right)) :: rest671)) => let
val result = MlyValue.logical_exp_cs (fn _ => let val ( val result = MlyValue.logical_exp_cs (fn _ => let val (
relational_exp_cs as relational_exp_cs1) = relational_exp_cs1 () relational_exp_cs as relational_exp_cs1) = relational_exp_cs1 ()
in (trace low ("logical_exp_cs..." ^ "\n");relational_exp_cs) in (Logger.debug3 ("logical_exp_cs..." ^ "\n");relational_exp_cs)
end) end
)
in ( LrTable.NT 73, ( result, relational_exp_cs1left, in ( LrTable.NT 73, ( result, relational_exp_cs1left,
relational_exp_cs1right), rest671) relational_exp_cs1right), rest671)
end end
@ -2514,7 +2518,7 @@ relational_exp_cs1 ()
val (logical_exp_tail_cs_p as logical_exp_tail_cs_p1) = val (logical_exp_tail_cs_p as logical_exp_tail_cs_p1) =
logical_exp_tail_cs_p1 () logical_exp_tail_cs_p1 ()
in ( in (
trace low ("logical_exp_cs..." ^ "\n");OperationCall(relational_exp_cs,Boolean,[OclLibPackage,"Boolean",#1(logical_exp_tail_cs_p)],[(#2(logical_exp_tail_cs_p),Boolean)],Boolean) Logger.debug3 ("logical_exp_cs..." ^ "\n");OperationCall(relational_exp_cs,Boolean,[OclLibPackage,"Boolean",#1(logical_exp_tail_cs_p)],[(#2(logical_exp_tail_cs_p),Boolean)],Boolean)
) )
end) end)
in ( LrTable.NT 73, ( result, relational_exp_cs1left, in ( LrTable.NT 73, ( result, relational_exp_cs1left,
@ -2592,7 +2596,7 @@ end
additive_exp_cs1left, additive_exp_cs1right)) :: rest671)) => let val additive_exp_cs1left, additive_exp_cs1right)) :: rest671)) => let val
result = MlyValue.relational_exp_cs (fn _ => let val ( result = MlyValue.relational_exp_cs (fn _ => let val (
additive_exp_cs as additive_exp_cs1) = additive_exp_cs1 () additive_exp_cs as additive_exp_cs1) = additive_exp_cs1 ()
in (trace low ("additive_exp_cs..." ^ "\n");additive_exp_cs) in (Logger.debug3 ("additive_exp_cs..." ^ "\n");additive_exp_cs)
end) end)
in ( LrTable.NT 75, ( result, additive_exp_cs1left, in ( LrTable.NT 75, ( result, additive_exp_cs1left,
additive_exp_cs1right), rest671) additive_exp_cs1right), rest671)
@ -2605,7 +2609,7 @@ MlyValue.additive_exp_cs additive_exp_cs1, additive_exp_cs1left, _))
val (relational_exp_tail_cs as relational_exp_tail_cs1) = val (relational_exp_tail_cs as relational_exp_tail_cs1) =
relational_exp_tail_cs1 () relational_exp_tail_cs1 ()
in ( in (
trace low ("additive_exp_cs relational_exp_tail_cs ..." ^ "\n");OperationCall(additive_exp_cs,DummyT,[OclLibPackage,"DummyT",#1(relational_exp_tail_cs)],[(#2(relational_exp_tail_cs),DummyT)],Boolean) Logger.debug3 ("additive_exp_cs relational_exp_tail_cs ..." ^ "\n");OperationCall(additive_exp_cs,DummyT,[OclLibPackage,"DummyT",#1(relational_exp_tail_cs)],[(#2(relational_exp_tail_cs),DummyT)],Boolean)
) )
end) end)
in ( LrTable.NT 75, ( result, additive_exp_cs1left, in ( LrTable.NT 75, ( result, additive_exp_cs1left,
@ -2618,7 +2622,7 @@ MlyValue.relational_exp_tail_cs (fn _ => let val (rel_op as rel_op1)
= rel_op1 () = rel_op1 ()
val (additive_exp_cs as additive_exp_cs1) = additive_exp_cs1 () val (additive_exp_cs as additive_exp_cs1) = additive_exp_cs1 ()
in ( in (
trace low ("relational_exp_tail_cs..." ^ "\n");(rel_op, additive_exp_cs) Logger.debug3 ("relational_exp_tail_cs..." ^ "\n");(rel_op, additive_exp_cs)
) )
end) end)
in ( LrTable.NT 77, ( result, rel_op1left, additive_exp_cs1right), in ( LrTable.NT 77, ( result, rel_op1left, additive_exp_cs1right),
@ -2635,7 +2639,7 @@ end
| ( 113, ( ( _, ( MlyValue.REL_GT REL_GT1, REL_GT1left, REL_GT1right) | ( 113, ( ( _, ( MlyValue.REL_GT REL_GT1, REL_GT1left, REL_GT1right)
) :: rest671)) => let val result = MlyValue.rel_op (fn _ => let val ) :: rest671)) => let val result = MlyValue.rel_op (fn _ => let val
(REL_GT as REL_GT1) = REL_GT1 () (REL_GT as REL_GT1) = REL_GT1 ()
in (trace low (">..." ^ "\n");REL_GT) in (Logger.debug3 (">..." ^ "\n");REL_GT)
end) end)
in ( LrTable.NT 82, ( result, REL_GT1left, REL_GT1right), rest671) in ( LrTable.NT 82, ( result, REL_GT1left, REL_GT1right), rest671)
@ -2643,7 +2647,7 @@ end
| ( 114, ( ( _, ( MlyValue.REL_LT REL_LT1, REL_LT1left, REL_LT1right) | ( 114, ( ( _, ( MlyValue.REL_LT REL_LT1, REL_LT1left, REL_LT1right)
) :: rest671)) => let val result = MlyValue.rel_op (fn _ => let val ) :: rest671)) => let val result = MlyValue.rel_op (fn _ => let val
(REL_LT as REL_LT1) = REL_LT1 () (REL_LT as REL_LT1) = REL_LT1 ()
in (trace low ("<..." ^ "\n");REL_LT) in (Logger.debug3 ("<..." ^ "\n");REL_LT)
end) end)
in ( LrTable.NT 82, ( result, REL_LT1left, REL_LT1right), rest671) in ( LrTable.NT 82, ( result, REL_LT1left, REL_LT1right), rest671)
@ -2679,8 +2683,8 @@ multiplicative_exp_cs1right)) :: rest671)) => let val result =
MlyValue.additive_exp_cs (fn _ => let val (multiplicative_exp_cs as MlyValue.additive_exp_cs (fn _ => let val (multiplicative_exp_cs as
multiplicative_exp_cs1) = multiplicative_exp_cs1 () multiplicative_exp_cs1) = multiplicative_exp_cs1 ()
in ( in (
trace low ("multiplicative_exp_cs..." ^ "\n");multiplicative_exp_cs) Logger.debug3 ("multiplicative_exp_cs..." ^ "\n");multiplicative_exp_cs
)
end) end)
in ( LrTable.NT 79, ( result, multiplicative_exp_cs1left, in ( LrTable.NT 79, ( result, multiplicative_exp_cs1left,
multiplicative_exp_cs1right), rest671) multiplicative_exp_cs1right), rest671)
@ -2694,7 +2698,7 @@ multiplicative_exp_cs1) = multiplicative_exp_cs1 ()
val (additive_exp_tail_cs_p as additive_exp_tail_cs_p1) = val (additive_exp_tail_cs_p as additive_exp_tail_cs_p1) =
additive_exp_tail_cs_p1 () additive_exp_tail_cs_p1 ()
in ( in (
trace low ("multiplicative_exp_cs additive_exp_tail_cs_p..." ^ "\n");OperationCall (multiplicative_exp_cs,DummyT,[OclLibPackage,"DummyT",#1(additive_exp_tail_cs_p)],[(#2(additive_exp_tail_cs_p),DummyT)],DummyT) Logger.debug3 ("multiplicative_exp_cs additive_exp_tail_cs_p..." ^ "\n");OperationCall (multiplicative_exp_cs,DummyT,[OclLibPackage,"DummyT",#1(additive_exp_tail_cs_p)],[(#2(additive_exp_tail_cs_p),DummyT)],DummyT)
) )
end) end)
in ( LrTable.NT 79, ( result, multiplicative_exp_cs1left, in ( LrTable.NT 79, ( result, multiplicative_exp_cs1left,
@ -2756,7 +2760,7 @@ end
unary_exp_cs1left, unary_exp_cs1right)) :: rest671)) => let val unary_exp_cs1left, unary_exp_cs1right)) :: rest671)) => let val
result = MlyValue.multiplicative_exp_cs (fn _ => let val ( result = MlyValue.multiplicative_exp_cs (fn _ => let val (
unary_exp_cs as unary_exp_cs1) = unary_exp_cs1 () unary_exp_cs as unary_exp_cs1) = unary_exp_cs1 ()
in (trace low ("unary_exp_cs ..." ^ "\n");unary_exp_cs) in (Logger.debug3 ("unary_exp_cs ..." ^ "\n");unary_exp_cs)
end) end)
in ( LrTable.NT 83, ( result, unary_exp_cs1left, unary_exp_cs1right), in ( LrTable.NT 83, ( result, unary_exp_cs1left, unary_exp_cs1right),
rest671) rest671)
@ -2880,7 +2884,7 @@ rest671)) => let val result = MlyValue.postfix_exp_cs (fn _ => let
val (postfix_exp_tail_cs_p as postfix_exp_tail_cs_p1) = val (postfix_exp_tail_cs_p as postfix_exp_tail_cs_p1) =
postfix_exp_tail_cs_p1 () postfix_exp_tail_cs_p1 ()
in ( in (
trace low ("literal_call_exp_cs..." ^ "\n");nest_source ([primary_exp_cs]@postfix_exp_tail_cs_p) Logger.debug3 ("literal_call_exp_cs..." ^ "\n");nest_source ([primary_exp_cs]@postfix_exp_tail_cs_p)
) )
end) end)
in ( LrTable.NT 90, ( result, primary_exp_cs1left, in ( LrTable.NT 90, ( result, primary_exp_cs1left,
@ -2890,7 +2894,8 @@ end
literal_exp_cs1left, literal_exp_cs1right)) :: rest671)) => let val literal_exp_cs1left, literal_exp_cs1right)) :: rest671)) => let val
result = MlyValue.primary_exp_cs (fn _ => let val (literal_exp_cs as result = MlyValue.primary_exp_cs (fn _ => let val (literal_exp_cs as
literal_exp_cs1) = literal_exp_cs1 () literal_exp_cs1) = literal_exp_cs1 ()
in (trace low ("literal_call_exp_cs..." ^ "\n");literal_exp_cs) in (Logger.debug3 ("literal_call_exp_cs..." ^ "\n");literal_exp_cs)
end) end)
in ( LrTable.NT 93, ( result, literal_exp_cs1left, in ( LrTable.NT 93, ( result, literal_exp_cs1left,
literal_exp_cs1right), rest671) literal_exp_cs1right), rest671)
@ -2912,8 +2917,9 @@ end
=> let val result = MlyValue.primary_exp_cs (fn _ => let val ( => let val result = MlyValue.primary_exp_cs (fn _ => let val (
property_call_exp_cs as property_call_exp_cs1) = property_call_exp_cs1 property_call_exp_cs as property_call_exp_cs1) = property_call_exp_cs1
() ()
in (trace low ("property_call_exp_cs..." ^ "\n");property_call_exp_cs in (
) Logger.debug3 ("property_call_exp_cs..." ^ "\n");property_call_exp_cs)
end) end)
in ( LrTable.NT 93, ( result, property_call_exp_cs1left, in ( LrTable.NT 93, ( result, property_call_exp_cs1left,
property_call_exp_cs1right), rest671) property_call_exp_cs1right), rest671)
@ -2951,7 +2957,7 @@ postfix_exp_tail_cs1left, postfix_exp_tail_cs1right)) :: rest671)) =>
let val result = MlyValue.postfix_exp_tail_cs_p (fn _ => let val ( let val result = MlyValue.postfix_exp_tail_cs_p (fn _ => let val (
postfix_exp_tail_cs as postfix_exp_tail_cs1) = postfix_exp_tail_cs1 () postfix_exp_tail_cs as postfix_exp_tail_cs1) = postfix_exp_tail_cs1 ()
in ( in (
trace low ("end of recursion..." ^ Ocl2String.ocl2string false postfix_exp_tail_cs ^ "\n");[postfix_exp_tail_cs] Logger.debug3 ("end of recursion..." ^ Ocl2String.ocl2string false postfix_exp_tail_cs ^ "\n");[postfix_exp_tail_cs]
) )
end) end)
in ( LrTable.NT 91, ( result, postfix_exp_tail_cs1left, in ( LrTable.NT 91, ( result, postfix_exp_tail_cs1left,
@ -2966,7 +2972,7 @@ MlyValue.postfix_exp_tail_cs_p (fn _ => let val (postfix_exp_tail_cs
val (postfix_exp_tail_cs_p as postfix_exp_tail_cs_p1) = val (postfix_exp_tail_cs_p as postfix_exp_tail_cs_p1) =
postfix_exp_tail_cs_p1 () postfix_exp_tail_cs_p1 ()
in ( in (
trace low ("add_source ..." ^ "\n" ^ "done");([postfix_exp_tail_cs]@postfix_exp_tail_cs_p) Logger.debug3 ("add_source ..." ^ "\n" ^ "done");([postfix_exp_tail_cs]@postfix_exp_tail_cs_p)
) )
end) end)
in ( LrTable.NT 91, ( result, postfix_exp_tail_cs1left, in ( LrTable.NT 91, ( result, postfix_exp_tail_cs1left,
@ -3079,7 +3085,7 @@ iterator_name_cs as iterator_name_cs1) = iterator_name_cs1 ()
val (expression as expression1) = expression1 () val (expression as expression1) = expression1 ()
val PAREN_CLOSE1 = PAREN_CLOSE1 () val PAREN_CLOSE1 = PAREN_CLOSE1 ()
in ( in (
trace low ("arrow_property_call_cs: iterator with vars..." ^ "\n");Iterator (iterator_name_cs,iterator_vars_cs,Variable("dummy_source",DummyT),DummyT,expression,DummyT,DummyT) Logger.debug3 ("arrow_property_call_cs: iterator with vars..." ^ "\n");Iterator (iterator_name_cs,iterator_vars_cs,Variable("dummy_source",DummyT),DummyT,expression,DummyT,DummyT)
) )
end) end)
in ( LrTable.NT 95, ( result, iterator_name_cs1left, in ( LrTable.NT 95, ( result, iterator_name_cs1left,
@ -3093,7 +3099,7 @@ PAREN_CLOSE1right)) :: ( _, ( MlyValue.PAREN_OPEN PAREN_OPEN1, _, _))
val PAREN_OPEN1 = PAREN_OPEN1 () val PAREN_OPEN1 = PAREN_OPEN1 ()
val PAREN_CLOSE1 = PAREN_CLOSE1 () val PAREN_CLOSE1 = PAREN_CLOSE1 ()
in ( in (
trace low ("arrow_property_call_exp_cs..." ^ "\n");OperationCall (Variable ("dummy_source",DummyT),DummyT,(["arrow"]@[simple_name]),[],DummyT) Logger.debug3 ("arrow_property_call_exp_cs..." ^ "\n");OperationCall (Variable ("dummy_source",DummyT),DummyT,(["arrow"]@[simple_name]),[],DummyT)
) )
end) end)
in ( LrTable.NT 95, ( result, simple_name1left, PAREN_CLOSE1right), in ( LrTable.NT 95, ( result, simple_name1left, PAREN_CLOSE1right),
@ -3358,7 +3364,8 @@ simple_type_specifier_cs1, simple_type_specifier_cs1left,
simple_type_specifier_cs1right)) :: rest671)) => let val result = simple_type_specifier_cs1right)) :: rest671)) => let val result =
MlyValue.type_specifier (fn _ => let val (simple_type_specifier_cs MlyValue.type_specifier (fn _ => let val (simple_type_specifier_cs
as simple_type_specifier_cs1) = simple_type_specifier_cs1 () as simple_type_specifier_cs1) = simple_type_specifier_cs1 ()
in (trace low ("type_specifier ..." ^ "\n");simple_type_specifier_cs) in (
Logger.debug3 ("type_specifier ..." ^ "\n");simple_type_specifier_cs)
end) end)
in ( LrTable.NT 19, ( result, simple_type_specifier_cs1left, in ( LrTable.NT 19, ( result, simple_type_specifier_cs1left,
@ -3380,7 +3387,7 @@ end
MlyValue.simple_type_specifier_cs (fn _ => let val (simple_name as MlyValue.simple_type_specifier_cs (fn _ => let val (simple_name as
simple_name1) = simple_name1 () simple_name1) = simple_name1 ()
in ( in (
trace wgen ("simple_type_name_specifier_cs : " ^ simple_name ^ "\n");string_to_type simple_name Logger.debug3 ("simple_type_name_specifier_cs : " ^ simple_name ^ "\n");string_to_type simple_name
) )
end) end)
in ( LrTable.NT 52, ( result, simple_name1left, simple_name1right), in ( LrTable.NT 52, ( result, simple_name1left, simple_name1right),

1
su4sml/src/ocl_parser/parser.sml
View File

@ -49,7 +49,6 @@ structure OclParser : sig
val parse_contextlist: string -> (Context.context list * Rep_Core.Classifier list) val parse_contextlist: string -> (Context.context list * Rep_Core.Classifier list)
end = end =
struct struct
open Rep_Logger
open Context open Context
structure OclParserLrVals = structure OclParserLrVals =

181
su4sml/src/ocl_parser/preprocessor.sml
View File

@ -5,8 +5,8 @@
* preprocessor.sml --- * preprocessor.sml ---
* This file is part of su4sml. * This file is part of su4sml.
* *
* Copyright (c) 2005-2007, ETH Zurich, Switzerland * Copyright (c) 2005-2007 ETH Zurich, Switzerland
* 2008 Achim D. Brucker, Germany * 2008-2009 Achim D. Brucker, Germany
* *
* All rights reserved. * All rights reserved.
* *
@ -51,7 +51,6 @@ end
structure Preprocessor:PREPROCESSOR = structure Preprocessor:PREPROCESSOR =
struct struct
open Rep_Helper open Rep_Helper
open Rep_Logger
open Rep_Core open Rep_Core
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType
@ -153,56 +152,56 @@ fun fun_name (Varible (str,type)) =
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
fun embed_atPre_expressions_collpart (CollectionItem (term,typ)) = fun embed_atPre_expressions_collpart (CollectionItem (term,typ)) =
let let
val _ = trace function_calls ("Preprocessor.embed_atPre_expression_collpart CollectionItem(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expression_collpart CollectionItem(...)\n")
val res = (CollectionItem (embed_atPre_expressions term,typ)) val res = (CollectionItem (embed_atPre_expressions term,typ))
val _ = trace function_ends ("Preprocessor.embed_atPre_expression_collpart\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expression_collpart\n")
in in
res res
end end
| embed_atPre_expressions_collpart (CollectionRange (term1,term2,typ)) = | embed_atPre_expressions_collpart (CollectionRange (term1,term2,typ)) =
let let
val _ = trace function_calls ("Preprocessor.embed_atPre_expression_collpart CollectionRange(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expression_collpart CollectionRange(...)\n")
val res = (CollectionRange (embed_atPre_expressions term1, embed_atPre_expressions term2, typ)) val res = (CollectionRange (embed_atPre_expressions term1, embed_atPre_expressions term2, typ))
val _ = trace function_ends ("Preprocessor.embed_atPre_expression_collpart\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expression_collpart\n")
in in
res res
end end
and embed_atPre_expressions (Variable (str,typ)) = and embed_atPre_expressions (Variable (str,typ)) =
let let
val _ = trace function_calls ("Preprocessor.embed_atPre_expressions Variable(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions Variable(...)\n")
val res = (Variable (str,typ)) val res = (Variable (str,typ))
val _ = trace function_ends ("Preprocessor.embed_atPre_expressions\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions\n")
in in
res res
end end
| embed_atPre_expressions (Literal (str,typ)) = | embed_atPre_expressions (Literal (str,typ)) =
let let
val _ = trace function_calls ("Preprocessor.embed_atPre_expressions Literal(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions Literal(...)\n")
val res = (Literal (str,typ)) val res = (Literal (str,typ))
val _ = trace function_ends ("Preprocessor.embed_atPre_expressions\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions\n")
in in
res res
end end
| embed_atPre_expressions (CollectionLiteral (collpart,typ)) = | embed_atPre_expressions (CollectionLiteral (collpart,typ)) =
let let
val _ = trace function_calls ("Preprocessor.embed_atPre_expressions CollectionLiteral(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions CollectionLiteral(...)\n")
val res = (CollectionLiteral (List.map (embed_atPre_expressions_collpart) collpart,typ)) val res = (CollectionLiteral (List.map (embed_atPre_expressions_collpart) collpart,typ))
val _ = trace function_ends ("Preprocessor.embed_atPre_expressions\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions\n")
in in
res res
end end
| embed_atPre_expressions (If (cond,cond_type,then_e,then_type,else_e,else_type,res_type)) = | embed_atPre_expressions (If (cond,cond_type,then_e,then_type,else_e,else_type,res_type)) =
let let
val _ = trace function_calls ("Preprocessor.embed_atPre_expressions Variable(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions Variable(...)\n")
val res = (If (embed_atPre_expressions cond,cond_type,embed_atPre_expressions then_e,then_type,embed_atPre_expressions else_e,else_type,res_type)) val res = (If (embed_atPre_expressions cond,cond_type,embed_atPre_expressions then_e,then_type,embed_atPre_expressions else_e,else_type,res_type))
val _ = trace function_ends ("Preprocessor.embed_atPre_expressions\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions\n")
in in
res res
end end
| embed_atPre_expressions (AttributeCall (sterm,styp,p,res_typ)) = | embed_atPre_expressions (AttributeCall (sterm,styp,p,res_typ)) =
let let
val _ = trace function_calls ("Preprocessor.embed_atPre_expressions AttributeCall(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions AttributeCall(...)\n")
val res = val res =
if (List.last (p) = "atPre") if (List.last (p) = "atPre")
then (* atPre Call *) then (* atPre Call *)
@ -215,125 +214,125 @@ and embed_atPre_expressions (Variable (str,typ)) =
) )
else (* normal Call *) else (* normal Call *)
(AttributeCall (embed_atPre_expressions sterm,styp,p,res_typ)) (AttributeCall (embed_atPre_expressions sterm,styp,p,res_typ))
val _ = trace function_ends ("Preprocessor.embed_atPre_expressions\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions\n")
in in
res res
end end
| embed_atPre_expressions (OperationCall (sterm,styp,pa,para,res_typ)) = | embed_atPre_expressions (OperationCall (sterm,styp,pa,para,res_typ)) =
let let
val _ = trace function_calls ("Preprocessor.embed_atPre_expressions OperationCall(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions OperationCall(...)\n")
val atpre_para = List.map (fn (a,b) => (embed_atPre_expressions a,b)) para val atpre_para = List.map (fn (a,b) => (embed_atPre_expressions a,b)) para
val res = val res =
if (List.last (pa) = "atPre") if (List.last (pa) = "atPre")
then (OperationCall (OperationCall (embed_atPre_expressions sterm,styp,real_path pa,atpre_para,res_typ),DummyT,[OclLibPackage,"OclAny","atPre"],[],DummyT)) then (OperationCall (OperationCall (embed_atPre_expressions sterm,styp,real_path pa,atpre_para,res_typ),DummyT,[OclLibPackage,"OclAny","atPre"],[],DummyT))
else (OperationCall (embed_atPre_expressions sterm,styp,pa,atpre_para,res_typ)) else (OperationCall (embed_atPre_expressions sterm,styp,pa,atpre_para,res_typ))
val _ = trace function_ends ("Preprocessor.embed_atPre_expressions\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions\n")
in in
res res
end end
| embed_atPre_expressions (OperationWithType (sterm,stype,para_name,para_type,res_type)) = | embed_atPre_expressions (OperationWithType (sterm,stype,para_name,para_type,res_type)) =
let let
val _ = trace function_calls ("Preprocessor.embed_atPre_expressions OperationWithType(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions OperationWithType(...)\n")
val res = (OperationWithType (embed_atPre_expressions sterm,stype,para_name,para_type,res_type)) val res = (OperationWithType (embed_atPre_expressions sterm,stype,para_name,para_type,res_type))
val _ = trace function_ends ("Preprocessor.embed_atPre_expressions\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions\n")
in in
res res
end end
| embed_atPre_expressions (Let (var_name,var_type,rhs,rhs_type,in_e,in_type)) = | embed_atPre_expressions (Let (var_name,var_type,rhs,rhs_type,in_e,in_type)) =
let let
val _ = trace function_calls ("Preprocessor.embed_atPre_expressions Let(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions Let(...)\n")
val res = (Let (var_name,var_type,embed_atPre_expressions rhs,rhs_type,embed_atPre_expressions in_e,in_type)) val res = (Let (var_name,var_type,embed_atPre_expressions rhs,rhs_type,embed_atPre_expressions in_e,in_type))
val _ = trace function_ends ("Preprocessor.embed_atPre_expressions\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions\n")
in in
res res
end end
| embed_atPre_expressions (Iterator (name,iter_vars,sterm,stype,body_e,body_type,res_type)) = | embed_atPre_expressions (Iterator (name,iter_vars,sterm,stype,body_e,body_type,res_type)) =
let let
val _ = trace function_calls ("Preprocessor.embed_atPre_expressions Iterator(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions Iterator(...)\n")
val res = (Iterator (name,iter_vars,embed_atPre_expressions sterm,stype,embed_atPre_expressions body_e,body_type,res_type)) val res = (Iterator (name,iter_vars,embed_atPre_expressions sterm,stype,embed_atPre_expressions body_e,body_type,res_type))
val _ = trace function_ends ("Preprocessor.embed_atPre_expressions\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions\n")
in in
res res
end end
| embed_atPre_expressions (Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) = | embed_atPre_expressions (Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) =
let let
val _ = trace function_calls ("Preprocessor.embed_atPre_expressions Iterate(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expressions Iterate(...)\n")
val res = (Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,embed_atPre_expressions sterm,stype,embed_atPre_expressions bterm,btype,res_type)) val res = (Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,embed_atPre_expressions sterm,stype,embed_atPre_expressions bterm,btype,res_type))
val _ = trace function_ends ("Preprocessor.embed_atPre_expression\n") val _ = Logger.debug2 ("Preprocessor.embed_atPre_expression\n")
in in
res res
end end
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
fun embed_bound_variable (str,typ) (Variable(s,t)) = fun embed_bound_variable (str,typ) (Variable(s,t)) =
let let
val _ = trace function_calls ("Preprocessor.embed_bound_variable Variable(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable Variable(...)\n")
val _ = trace preprocessor ("1 Bound variable '" ^ s ^ "' in 'AttributeCall': " ^ Ocl2String.ocl2string false (Variable(s,t)) ^ "\n") val _ = Logger.debug3 ("1 Bound variable '" ^ s ^ "' in 'AttributeCall': " ^ Ocl2String.ocl2string false (Variable(s,t)) ^ "\n")
val res = val res =
if (str = s ) then if (str = s ) then
Variable(s,typ) Variable(s,typ)
else else
Variable(s,t) Variable(s,t)
val _ = trace function_ends ("Preprocessor.embed_bound_variable\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable\n")
in in
res res
end end
| embed_bound_variable (s,typ) (AttributeCall (sterm,styp,path,rtyp)) = | embed_bound_variable (s,typ) (AttributeCall (sterm,styp,path,rtyp)) =
let let
val _ = trace function_calls ("Preprocessor.embed_bound_variable AttributeCall(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable AttributeCall(...)\n")
val _ = trace preprocessor ("2 Bound variable '" ^ s ^ "' in 'AttributeCall': " ^ Ocl2String.ocl2string false (AttributeCall (sterm,styp,path,rtyp)) ^ "\n") val _ = Logger.debug3 ("2 Bound variable '" ^ s ^ "' in 'AttributeCall': " ^ Ocl2String.ocl2string false (AttributeCall (sterm,styp,path,rtyp)) ^ "\n")
val res = val res =
if (List.last path = s) then if (List.last path = s) then
(* embed variable *) (* embed variable *)
(Variable (s,typ)) (Variable (s,typ))
else else
(AttributeCall (embed_bound_variable (s,typ) sterm,styp,path,rtyp)) (AttributeCall (embed_bound_variable (s,typ) sterm,styp,path,rtyp))
val _ = trace function_ends ("Preprocessor.embed_bound_variable\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable\n")
in in
res res
end end
| embed_bound_variable (s,typ) (OperationCall (sterm,styp,path,args,rtyp)) = | embed_bound_variable (s,typ) (OperationCall (sterm,styp,path,args,rtyp)) =
let let
val _ = trace function_calls ("Preprocessor.embed_bound_variable AttributeCall(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable AttributeCall(...)\n")
val _ = trace preprocessor ("Bound variable '" ^ s ^ "' in 'OperationCall': " ^ Ocl2String.ocl2string false (OperationCall (sterm,styp,path,args,rtyp)) ^ "\n") val _ = Logger.debug3 ("Bound variable '" ^ s ^ "' in 'OperationCall': " ^ Ocl2String.ocl2string false (OperationCall (sterm,styp,path,args,rtyp)) ^ "\n")
val res = (OperationCall (embed_bound_variable (s,typ) sterm,styp,path,embed_bound_args (s,typ) args ,rtyp)) val res = (OperationCall (embed_bound_variable (s,typ) sterm,styp,path,embed_bound_args (s,typ) args ,rtyp))
val _ = trace function_ends ("Preprocessor.embed_bound_variable\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable\n")
in in
res res
end end
| embed_bound_variable (s,typ) (Iterator (name,iter_list,sterm,styp,expr,expr_typ,rtyp)) = | embed_bound_variable (s,typ) (Iterator (name,iter_list,sterm,styp,expr,expr_typ,rtyp)) =
let let
val _ = trace function_calls ("Preprocessor.embed_bound_variable AttributeCall(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable AttributeCall(...)\n")
val _ = trace preprocessor ("Bound variable '" ^ s ^ "' in 'Iterator': " ^ Ocl2String.ocl2string false (Iterator (name,iter_list,sterm,styp,expr,expr_typ,rtyp)) ^ "\n") val _ = Logger.debug3 ("Bound variable '" ^ s ^ "' in 'Iterator': " ^ Ocl2String.ocl2string false (Iterator (name,iter_list,sterm,styp,expr,expr_typ,rtyp)) ^ "\n")
val res = (Iterator (name,iter_list,embed_bound_variable (s,typ) sterm,styp,embed_bound_variables iter_list (embed_bound_variable (s,typ) expr),expr_typ,rtyp)) val res = (Iterator (name,iter_list,embed_bound_variable (s,typ) sterm,styp,embed_bound_variables iter_list (embed_bound_variable (s,typ) expr),expr_typ,rtyp))
val _ = trace function_ends ("Preprocessor.embed_bound_variable\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable\n")
in in
res res
end end
| embed_bound_variable (s,typ) (Iterate (iter_vars,acc_name,acc_type,acc_term,sterm,stype,bterm,btype,res_type)) = | embed_bound_variable (s,typ) (Iterate (iter_vars,acc_name,acc_type,acc_term,sterm,stype,bterm,btype,res_type)) =
let let
val _ = trace function_calls ("Preprocessor.embed_bound_variable AttributeCall(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable AttributeCall(...)\n")
val _ = trace medium ("Bound variable '" ^ s ^ "' in 'Iterate': " ^ Ocl2String.ocl2string false (Iterate (iter_vars,acc_name,acc_type,acc_term,sterm,stype,bterm,btype,res_type)) ^ "\n") val _ = Logger.debug1 ("Bound variable '" ^ s ^ "' in 'Iterate': " ^ Ocl2String.ocl2string false (Iterate (iter_vars,acc_name,acc_type,acc_term,sterm,stype,bterm,btype,res_type)) ^ "\n")
val res = (Iterate (iter_vars,acc_name,acc_type,acc_term,embed_bound_variable (s,typ) sterm,stype,embed_bound_variable (s,typ) bterm,btype,res_type)) val res = (Iterate (iter_vars,acc_name,acc_type,acc_term,embed_bound_variable (s,typ) sterm,stype,embed_bound_variable (s,typ) bterm,btype,res_type))
val _ = trace function_ends ("Preprocessor.embed_bound_variable\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable\n")
in in
res res
end end
| embed_bound_variable (s,typ) (Let (var_name,var_type,rhs,rhs_type,in_e,in_type)) = | embed_bound_variable (s,typ) (Let (var_name,var_type,rhs,rhs_type,in_e,in_type)) =
let let
val _ = trace function_calls ("Preprocessor.embed_bound_variable AttributeCall(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable AttributeCall(...)\n")
val _ = trace preprocessor ("Bound variable '" ^ s ^ "' in 'Let': " ^ Ocl2String.ocl2string false (Let (var_name,var_type,rhs,rhs_type,in_e,in_type)) ^ "\n") val _ = Logger.debug3 ("Bound variable '" ^ s ^ "' in 'Let': " ^ Ocl2String.ocl2string false (Let (var_name,var_type,rhs,rhs_type,in_e,in_type)) ^ "\n")
val embed_in_e = embed_bound_variable (var_name,var_type) in_e val embed_in_e = embed_bound_variable (var_name,var_type) in_e
val res = (Let (var_name,var_type,embed_bound_variable (s,typ) rhs,rhs_type,embed_bound_variable (s,typ) embed_in_e,in_type)) val res = (Let (var_name,var_type,embed_bound_variable (s,typ) rhs,rhs_type,embed_bound_variable (s,typ) embed_in_e,in_type))
val _ = trace function_ends ("Preprocessor.embed_bound_variable\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable\n")
in in
res res
end end
| embed_bound_variable (s,typ) (If (cond,cond_type,then_e,then_type,else_e,else_type,res_type)) = | embed_bound_variable (s,typ) (If (cond,cond_type,then_e,then_type,else_e,else_type,res_type)) =
let let
val _ = trace function_calls ("Preprocessor.embed_bound_variable AttributeCall(...)\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable AttributeCall(...)\n")
val _ = trace preprocessor ("Bound variable '" ^ s ^ "' in 'If' ..." ^ "\n") val _ = Logger.debug3 ("Bound variable '" ^ s ^ "' in 'If' ..." ^ "\n")
val res = (If (embed_bound_variable (s,typ) cond,cond_type,embed_bound_variable (s,typ) then_e,then_type,embed_bound_variable (s,typ) else_e,else_type,res_type)) val res = (If (embed_bound_variable (s,typ) cond,cond_type,embed_bound_variable (s,typ) then_e,then_type,embed_bound_variable (s,typ) else_e,else_type,res_type))
val _ = trace function_ends ("Preprocessor.embed_bound_variable\n") val _ = Logger.debug2 ("Preprocessor.embed_bound_variable\n")
in in
res res
end end
@ -392,14 +391,14 @@ and generate_variables (Literal (paras)) path meth_name model = Literal (paras)
(If (generate_variables cond path meth_name model,cond_type,generate_variables then_e path meth_name model,then_type,generate_variables else_e path meth_name model,else_type,res_type)) (If (generate_variables cond path meth_name model,cond_type,generate_variables then_e path meth_name model,then_type,generate_variables else_e path meth_name model,else_type,res_type))
| generate_variables (AttributeCall (src,src_type,["result"],_)) path meth_name model = | generate_variables (AttributeCall (src,src_type,["result"],_)) path meth_name model =
let let
val _ = trace function_calls ("Preprocessor.generate_variables: AttributeCall\n") val _ = Logger.debug2 ("Preprocessor.generate_variables: AttributeCall\n")
val new_src = generate_variables src path meth_name model val new_src = generate_variables src path meth_name model
val _ = List.app (print o (fn x => x^"\n") o string_of_path o name_of ) model val _ = List.app (print o (fn x => x^"\n") o string_of_path o name_of ) model
val classifier = class_of path (model,[]) val classifier = class_of path (model,[])
val _ = trace low "classifier found\n" val _ = Logger.debug4 "classifier found\n"
val meth = get_operation meth_name classifier (model,[]) val meth = get_operation meth_name classifier (model,[])
val res = (Variable ("result",(#result (meth)))) val res = (Variable ("result",(#result (meth))))
val _ = trace function_ends ("Preprocessor.generate_variables\n") val _ = Logger.debug2 ("Preprocessor.generate_variables\n")
in in
res res
end end
@ -407,21 +406,21 @@ and generate_variables (Literal (paras)) path meth_name model = Literal (paras)
(AttributeCall (generate_variables sterm path meth_name model,styp,p,res_typ)) (AttributeCall (generate_variables sterm path meth_name model,styp,p,res_typ))
| generate_variables (OperationCall (sterm,styp,pa,paras,res_typ)) path meth_name model = | generate_variables (OperationCall (sterm,styp,pa,paras,res_typ)) path meth_name model =
let let
val _ = trace function_calls ("Preprocessor.generate_variables \n") val _ = Logger.debug2 ("Preprocessor.generate_variables \n")
val new_para_terms = List.map (fn (a,b) => generate_variables (a) path meth_name model) paras val new_para_terms = List.map (fn (a,b) => generate_variables (a) path meth_name model) paras
val new_paras = List.map (fn a => (a, type_of_term a)) new_para_terms val new_paras = List.map (fn a => (a, type_of_term a)) new_para_terms
val res = val res =
(OperationCall (generate_variables sterm path meth_name model,styp,pa,new_paras,res_typ)) (OperationCall (generate_variables sterm path meth_name model,styp,pa,new_paras,res_typ))
val _ = trace function_ends ("Preprocessor.generate_variables\n") val _ = Logger.debug2 ("Preprocessor.generate_variables\n")
in in
res res
end end
| generate_variables (OperationWithType (sterm,stype,para_name,para_type,res_typ)) path meth_name model = | generate_variables (OperationWithType (sterm,stype,para_name,para_type,res_typ)) path meth_name model =
let let
val _ = trace function_calls ("Preprocessor.generate_variables \n") val _ = Logger.debug2 ("Preprocessor.generate_variables \n")
val res = val res =
(OperationWithType (generate_variables sterm path meth_name model,stype,para_name,para_type,res_typ)) (OperationWithType (generate_variables sterm path meth_name model,stype,para_name,para_type,res_typ))
val _ = trace function_ends ("Preprocessor.generate_variables\n") val _ = Logger.debug2 ("Preprocessor.generate_variables\n")
in in
res res
end end
@ -441,27 +440,27 @@ fun fetch (x,((y1,y2)::tail)) =
fun check_for_self_paras arg_list typ [] model = [] fun check_for_self_paras arg_list typ [] model = []
| check_for_self_paras arg_list typ ((term,t)::tail) model = | check_for_self_paras arg_list typ ((term,t)::tail) model =
let let
val _ = trace function_calls ("Preprocessor.check_for_self_paras\n") val _ = Logger.debug2 ("Preprocessor.check_for_self_paras\n")
val res = ((check_for_self arg_list typ term model),t)::(check_for_self_paras arg_list typ tail model) val res = ((check_for_self arg_list typ term model),t)::(check_for_self_paras arg_list typ tail model)
val _ = trace function_ends ("Preprocessor.check_for_self_paras\n") val _ = Logger.debug2 ("Preprocessor.check_for_self_paras\n")
in in
res res
end end
and check_for_self_collpart arg_list typ model (CollectionItem (term,ctyp)) = and check_for_self_collpart arg_list typ model (CollectionItem (term,ctyp)) =
let let
val _ = trace function_calls ("Preprocessor.check_for_self_collpart CollectionItem(...)\n") val _ = Logger.debug2 ("Preprocessor.check_for_self_collpart CollectionItem(...)\n")
val res = (CollectionItem (check_for_self arg_list typ term model,ctyp)) val res = (CollectionItem (check_for_self arg_list typ term model,ctyp))
val _ = trace function_ends ("Preprocessor.check_for_self_collpart\n") val _ = Logger.debug2 ("Preprocessor.check_for_self_collpart\n")
in in
res res
end end
| check_for_self_collpart arg_list typ model (CollectionRange (term1,term2,ctyp)) = | check_for_self_collpart arg_list typ model (CollectionRange (term1,term2,ctyp)) =
let let
val _ = trace function_calls ("Preprocessor.check_for_self_collpart CollectionRange(...)\n") val _ = Logger.debug2 ("Preprocessor.check_for_self_collpart CollectionRange(...)\n")
val res = (CollectionRange (check_for_self arg_list typ term1 model, val res = (CollectionRange (check_for_self arg_list typ term1 model,
check_for_self arg_list typ term2 model, ctyp)) check_for_self arg_list typ term2 model, ctyp))
val _ = trace function_ends ("Preprocessor.check_for_self_collpart\n") val _ = Logger.debug2 ("Preprocessor.check_for_self_collpart\n")
in in
res res
end end
@ -469,35 +468,35 @@ and check_for_self_collpart arg_list typ model (CollectionItem (term,ctyp)) =
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
and check_for_self arg_list typ (AttributeCall (Variable("dummy_source",_),_,path,_)) model= and check_for_self arg_list typ (AttributeCall (Variable("dummy_source",_),_,path,_)) model=
let let
val _ = trace function_calls ("Preprocessor.check_for_self: dummy_source AttributeCall\n") val _ = Logger.debug2 ("Preprocessor.check_for_self: dummy_source AttributeCall\n")
val test = (member (List.last path) (List.map (#1) arg_list)) val test = (member (List.last path) (List.map (#1) arg_list))
val _ = trace preprocessor ("member? "^ Bool.toString (test) ^ "\n") val _ = Logger.debug3 ("member? "^ Bool.toString (test) ^ "\n")
val res = val res =
if (List.last path = "self") then if (List.last path = "self") then
(* 'self' is writen in the ocl file *) (* 'self' is writen in the ocl file *)
(Variable ("self",typ)) (Variable ("self",typ))
else else
(AttributeCall (Variable ("self",typ),DummyT,path,DummyT)) (AttributeCall (Variable ("self",typ),DummyT,path,DummyT))
val _ = trace function_ends ("Preprocessor.check_for_self\n") val _ = Logger.debug2 ("Preprocessor.check_for_self\n")
in in
res res
end end
| check_for_self arg_list typ (CollectionLiteral (collpart,ctyp)) model = | check_for_self arg_list typ (CollectionLiteral (collpart,ctyp)) model =
let let
val _ = trace function_calls ("Preprocessor.check_for_self: dummy_source CollectionLiteral\n") val _ = Logger.debug2 ("Preprocessor.check_for_self: dummy_source CollectionLiteral\n")
val res = (CollectionLiteral (List.map (check_for_self_collpart arg_list typ model) collpart,ctyp)) val res = (CollectionLiteral (List.map (check_for_self_collpart arg_list typ model) collpart,ctyp))
val _ = trace function_ends ("Preprocessor.check_for_self\n") val _ = Logger.debug2 ("Preprocessor.check_for_self\n")
in in
res res
end end
| check_for_self arg_list typ (AttributeCall (source_term,source_typ,path,ret_typ)) model = | check_for_self arg_list typ (AttributeCall (source_term,source_typ,path,ret_typ)) model =
let let
val _ = trace function_calls ("Preprocessor.check_for_self: complex AttributeCall\n") val _ = Logger.debug2 ("Preprocessor.check_for_self: complex AttributeCall\n")
val res = (AttributeCall (check_for_self arg_list typ source_term model,source_typ,path,ret_typ)) val res = (AttributeCall (check_for_self arg_list typ source_term model,source_typ,path,ret_typ))
val _ = trace function_ends ("Preprocessor.check_for_self\n") val _ = Logger.debug2 ("Preprocessor.check_for_self\n")
in in
res res
end end
@ -505,7 +504,7 @@ and check_for_self arg_list typ (AttributeCall (Variable("dummy_source",_),_,pat
| check_for_self arg_list typ (OperationCall (Variable ("dummy_source",_),source_type,path,paras,ret_typ)) model = | check_for_self arg_list typ (OperationCall (Variable ("dummy_source",_),source_type,path,paras,ret_typ)) model =
let let
val test = (member (List.last path) (List.map (#1) arg_list)) val test = (member (List.last path) (List.map (#1) arg_list))
val _ = trace preprocessor ("member2? "^ Bool.toString (test) ^ "\n") val _ = Logger.debug3 ("member2? "^ Bool.toString (test) ^ "\n")
in in
if (member (List.last path) (List.map (#1) arg_list)) if (member (List.last path) (List.map (#1) arg_list))
then then
@ -517,46 +516,46 @@ and check_for_self arg_list typ (AttributeCall (Variable("dummy_source",_),_,pat
end end
| check_for_self arg_list typ (OperationCall (source_term,source_typ,path,paras,ret_typ)) model = | check_for_self arg_list typ (OperationCall (source_term,source_typ,path,paras,ret_typ)) model =
let let
val _ = trace function_calls ("Preprocessor.check_for_self complex OperationCall\n") val _ = Logger.debug2 ("Preprocessor.check_for_self complex OperationCall\n")
val res = (OperationCall (check_for_self arg_list typ source_term model ,source_typ,path,check_for_self_paras arg_list typ paras model,ret_typ)) val res = (OperationCall (check_for_self arg_list typ source_term model ,source_typ,path,check_for_self_paras arg_list typ paras model,ret_typ))
val _ = trace function_ends ("Preprocessor.check_for_self\n") val _ = Logger.debug2 ("Preprocessor.check_for_self\n")
in in
res res
end end
| check_for_self arg_list typ (Iterator (name,iter_var,sterm,styp,expr,expr_typ,res_typ)) model = | check_for_self arg_list typ (Iterator (name,iter_var,sterm,styp,expr,expr_typ,res_typ)) model =
let let
val _ = trace function_calls ("Preprocessor.check_for_self: Iterator(...)\n") val _ = Logger.debug2 ("Preprocessor.check_for_self: Iterator(...)\n")
val res = (Iterator (name,iter_var,(check_for_self arg_list typ sterm model),styp,(check_for_self arg_list typ expr model),expr_typ,res_typ)) val res = (Iterator (name,iter_var,(check_for_self arg_list typ sterm model),styp,(check_for_self arg_list typ expr model),expr_typ,res_typ))
val _ = trace function_ends ("Preprocessor.check_for_self\n") val _ = Logger.debug2 ("Preprocessor.check_for_self\n")
in in
res res
end end
| check_for_self arg_list typ (Iterate (iter_vars,acc_name,acc_type,acc_term,sterm,stype,bterm,btype,res_type)) model = | check_for_self arg_list typ (Iterate (iter_vars,acc_name,acc_type,acc_term,sterm,stype,bterm,btype,res_type)) model =
let let
val _ = trace function_calls ("Preprocessor.check_for_self Iterate \n") val _ = Logger.debug2 ("Preprocessor.check_for_self Iterate \n")
val res = (Iterate (iter_vars,acc_name,acc_type,acc_term,(check_for_self arg_list typ sterm model),stype,(check_for_self arg_list typ bterm model),btype,res_type)) val res = (Iterate (iter_vars,acc_name,acc_type,acc_term,(check_for_self arg_list typ sterm model),stype,(check_for_self arg_list typ bterm model),btype,res_type))
val _ = trace function_ends("Preprocessor.check_for_self\n") val _ = Logger.debug2("Preprocessor.check_for_self\n")
in in
res res
end end
| check_for_self arg_list typ (Let (str,ttyp,rhs_term,rhs_typ,in_term,in_typ)) model = | check_for_self arg_list typ (Let (str,ttyp,rhs_term,rhs_typ,in_term,in_typ)) model =
let let
val _ = trace function_calls ("Preprocessor.check_for_self Let (...)\n") val _ = Logger.debug2 ("Preprocessor.check_for_self Let (...)\n")
val self_rhs_term = check_for_self arg_list typ rhs_term model val self_rhs_term = check_for_self arg_list typ rhs_term model
val self_in_term = check_for_self arg_list typ in_term model val self_in_term = check_for_self arg_list typ in_term model
val res = (Let (str,ttyp,self_rhs_term,rhs_typ,self_in_term,in_typ)) val res = (Let (str,ttyp,self_rhs_term,rhs_typ,self_in_term,in_typ))
val _ = trace function_ends ("Preprocessor.check_for_self\n") val _ = Logger.debug2 ("Preprocessor.check_for_self\n")
in in
res res
end end
| check_for_self arg_list typ (If (cond,cond_typ,expr1,typ1,expr2,typ2,res_typ)) model = | check_for_self arg_list typ (If (cond,cond_typ,expr1,typ1,expr2,typ2,res_typ)) model =
let let
val _ = trace function_calls ("Preprocessor.check_for_self If (...)\n") val _ = Logger.debug2 ("Preprocessor.check_for_self If (...)\n")
val self_cond = check_for_self arg_list typ cond model val self_cond = check_for_self arg_list typ cond model
val self_expr1 = check_for_self arg_list typ expr1 model val self_expr1 = check_for_self arg_list typ expr1 model
val self_expr2 = check_for_self arg_list typ expr2 model val self_expr2 = check_for_self arg_list typ expr2 model
val res = (If (self_cond,cond_typ,self_expr1,typ1,self_expr2,typ2,res_typ)) val res = (If (self_cond,cond_typ,self_expr1,typ1,self_expr2,typ2,res_typ))
val _ = trace function_ends ("Preprocessor.check_for_self\n") val _ = Logger.debug2 ("Preprocessor.check_for_self\n")
in in
res res
end end
@ -720,10 +719,10 @@ and prefix_OperationWithType prefix (Variable (str,typ)) = (Variable (str,typ))
fun preprocess_context (Cond (path,op_name,op_sign,result_type,cond,pre_name,expr)) model = fun preprocess_context (Cond (path,op_name,op_sign,result_type,cond,pre_name,expr)) model =
let let
(* embed 'result' variable *) (* embed 'result' variable *)
val _ = trace function_calls ("Preprocessor.preprocess_context Cond(...)\n") val _ = Logger.debug2 ("Preprocessor.preprocess_context Cond(...)\n")
val _ = trace preprocessor ("Embed result variable \n") val _ = Logger.debug3 ("Embed result variable \n")
val vexpr = generate_variables expr path op_name model val vexpr = generate_variables expr path op_name model
val _ = trace preprocessor ("Variable 'result' embeded ... \n") val _ = Logger.debug3 ("Variable 'result' embeded ... \n")
(* embed method arguments *) (* embed method arguments *)
val class = class_of_type (Classifier (path)) (model,[]) val class = class_of_type (Classifier (path)) (model,[])
val prfx = package_of class val prfx = package_of class
@ -734,35 +733,35 @@ fun preprocess_context (Cond (path,op_name,op_sign,result_type,cond,pre_name,exp
val pexpr = embed_atPre_expressions eexpr val pexpr = embed_atPre_expressions eexpr
val res = val res =
(Cond (path,op_name,prefixed_op_sign,prefixed_result_type,cond,pre_name,(check_for_self prefixed_op_sign (Classifier (path)) pexpr model))) (Cond (path,op_name,prefixed_op_sign,prefixed_result_type,cond,pre_name,(check_for_self prefixed_op_sign (Classifier (path)) pexpr model)))
val _ = trace function_ends ("Preprocessor.preprocess_context\n") val _ = Logger.debug2 ("Preprocessor.preprocess_context\n")
in in
res res
end end
| preprocess_context (Inv (path,string,term)) model = | preprocess_context (Inv (path,string,term)) model =
let let
val _ = trace function_calls ("Preprocessor.preprocess_context Inv (...)\n") val _ = Logger.debug2 ("Preprocessor.preprocess_context Inv (...)\n")
(* embed '@pre'-expressions *) (* embed '@pre'-expressions *)
val pexpr = embed_atPre_expressions term val pexpr = embed_atPre_expressions term
val res = (Inv (path,string,(check_for_self [] (Classifier (path)) pexpr model))) val res = (Inv (path,string,(check_for_self [] (Classifier (path)) pexpr model)))
val _ = trace function_ends ("Preprocessor.preprocess_context\n") val _ = Logger.debug2 ("Preprocessor.preprocess_context\n")
in in
res res
end end
| preprocess_context (Attr (path,typ,aoa,expr)) model = | preprocess_context (Attr (path,typ,aoa,expr)) model =
let let
val _ = trace function_calls ("Preprocessor.preprocess_context Attr(...)\n") val _ = Logger.debug2 ("Preprocessor.preprocess_context Attr(...)\n")
(* embed '@pre'-expressions *) (* embed '@pre'-expressions *)
val pexpr = embed_atPre_expressions expr val pexpr = embed_atPre_expressions expr
val res = (Attr (path,typ,aoa,check_for_self [] (Classifier (path)) pexpr model)) val res = (Attr (path,typ,aoa,check_for_self [] (Classifier (path)) pexpr model))
val _ = trace function_ends ("Preprocessor.preprocess_context\n") val _ = Logger.debug2 ("Preprocessor.preprocess_context\n")
in in
res res
end end
| preprocess_context c model = | preprocess_context c model =
let let
val _ = trace function_calls ("Preprocessor.preprocess_context: others" ^ "\n") val _ = Logger.debug2 ("Preprocessor.preprocess_context: others" ^ "\n")
val res = c val res = c
val _ = trace function_ends ("Preprocessor.preprocess_context\n") val _ = Logger.debug2 ("Preprocessor.preprocess_context\n")
in in
res res
end end
@ -771,9 +770,9 @@ fun preprocess_context (Cond (path,op_name,op_sign,result_type,cond,pre_name,exp
fun preprocess_context_list [] model = [] fun preprocess_context_list [] model = []
| preprocess_context_list (h::context_list_tail) model = | preprocess_context_list (h::context_list_tail) model =
let let
val _ = trace function_calls ("Preprocessor.preprocess_context_list\n") val _ = Logger.debug2 ("Preprocessor.preprocess_context_list\n")
val res = (preprocess_context h model)::(preprocess_context_list context_list_tail model) val res = (preprocess_context h model)::(preprocess_context_list context_list_tail model)
val _ = trace function_ends ("Preprocessor.preprocess_context_list\n") val _ = Logger.debug2 ("Preprocessor.preprocess_context_list\n")
in in
res res
end end

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

@ -6,7 +6,7 @@
* This file is part of su4sml. * This file is part of su4sml.
* *
* Copyright (c) 2005-2007 ETH Zurich, Switzerland * Copyright (c) 2005-2007 ETH Zurich, Switzerland
* 2008 Achim D. Brucker, Germany * 2008-2009 Achim D. Brucker, Germany
* *
* All rights reserved. * All rights reserved.
* *
@ -73,7 +73,6 @@ end
structure TypeChecker:TYPECHECKER = structure TypeChecker:TYPECHECKER =
struct struct
open Rep_Logger
open Rep_Core open Rep_Core
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType
@ -127,7 +126,7 @@ fun FromSet_desugarator rterm path attr_or_meth rargs (model as (cls,assocs):Rep
then (* OperationCall *) then (* OperationCall *)
let let
(* check 'fromSet' *) (* check 'fromSet' *)
val _ = trace type_checker ("==> FromSet-desugarator: operation ... \n") val _ = Logger.debug3 ("==> FromSet-desugarator: operation ... \n")
val new_type = type_of_template_parameter (type_of_term rterm) val new_type = type_of_template_parameter (type_of_term rterm)
val iterVar = (("anonIterVar_" ^ (varcounter.nextStr())),new_type) val iterVar = (("anonIterVar_" ^ (varcounter.nextStr())),new_type)
val class = class_of_term (Variable (iterVar)) model val class = class_of_term (Variable (iterVar)) model
@ -146,7 +145,7 @@ fun FromSet_desugarator rterm path attr_or_meth rargs (model as (cls,assocs):Rep
else (* AttributeCall *) else (* AttributeCall *)
let let
(* check 'fromSet' *) (* check 'fromSet' *)
val _ = trace type_checker ("==> FromSet-desugarator: attribute/assocend ... \n") val _ = Logger.debug3 ("==> FromSet-desugarator: attribute/assocend ... \n")
val new_type = type_of_template_parameter (type_of_term rterm) val new_type = type_of_template_parameter (type_of_term rterm)
val iterVar = (("anonIterVar_" ^ (varcounter.nextStr())),new_type) val iterVar = (("anonIterVar_" ^ (varcounter.nextStr())),new_type)
val class = class_of_term (Variable (iterVar)) model val class = class_of_term (Variable (iterVar)) model
@ -158,7 +157,7 @@ fun FromSet_desugarator rterm path attr_or_meth rargs (model as (cls,assocs):Rep
let let
val insert_term = upcast_att_aend attrs_or_assocs (Variable iterVar) model val insert_term = upcast_att_aend attrs_or_assocs (Variable iterVar) model
val it_type = type_of_term insert_term val it_type = type_of_term insert_term
val _ = trace development ("association type " ^ string_of_OclType it_type ^ "\n") val _ = Logger.debug4 ("association type " ^ string_of_OclType it_type ^ "\n")
(* special case *) (* special case *)
(* if it is an attribute, there needs to be added a collection type constructor *) (* if it is an attribute, there needs to be added a collection type constructor *)
@ -193,13 +192,13 @@ fun FromSet_desugarator rterm path attr_or_meth rargs (model as (cls,assocs):Rep
fun AsSet_desugarator rterm path attr_or_meth rargs (model as (cls,assocs)) = fun AsSet_desugarator rterm path attr_or_meth rargs (model as (cls,assocs)) =
let let
val _ = if isColl_Type (type_of_term rterm) then print "\n error in AsSet_Desugarotr\n" else () val _ = if isColl_Type (type_of_term rterm) then print "\n error in AsSet_Desugarotr\n" else ()
val _ = (trace function_calls ("TypeChecker.AsSet_desugarator class= " ^ (string_of_OclType (type_of_term rterm)) ^ " , attr\n")) val _ = (Logger.debug2 ("TypeChecker.AsSet_desugarator class= " ^ (string_of_OclType (type_of_term rterm)) ^ " , attr\n"))
val res = if (attr_or_meth = 0) val res = if (attr_or_meth = 0)
then (* OperationCall *) then (* OperationCall *)
let let
val _ = trace type_checker ("==> AsSet-desugarator: operation ... \n") val _ = Logger.debug3 ("==> AsSet-desugarator: operation ... \n")
val rtyp = Set(type_of_term rterm) val rtyp = Set(type_of_term rterm)
val _ = trace type_checker ("Type of source term " ^ string_of_OclType rtyp ^ " ---> try Set(" ^ string_of_OclType rtyp ^ ")\n") val _ = Logger.debug3 ("Type of source term " ^ string_of_OclType rtyp ^ " ---> try Set(" ^ string_of_OclType rtyp ^ ")\n")
val class = class_of_term (Variable ("anonIterVar_" ^ (varcounter.nextStr()),rtyp)) model val class = class_of_term (Variable ("anonIterVar_" ^ (varcounter.nextStr()),rtyp)) model
val ops = get_overloaded_methods class (List.last path) model val ops = get_overloaded_methods class (List.last path) model
val new_rterm = CollectionLiteral([CollectionItem(rterm,type_of_term rterm)],rtyp) val new_rterm = CollectionLiteral([CollectionItem(rterm,type_of_term rterm)],rtyp)
@ -215,14 +214,14 @@ in
end end
else (* AttributeCall *) else (* AttributeCall *)
let let
val _ = trace type_checker ("==> AsSet-desugarator: attribute/assocend\n") val _ = Logger.debug3 ("==> AsSet-desugarator: attribute/assocend\n")
val rtyp = Set(type_of_term rterm) val rtyp = Set(type_of_term rterm)
val _ = trace type_checker (string_of_OclType rtyp ^ "\n") val _ = Logger.debug3 (string_of_OclType rtyp ^ "\n")
val class = class_of_term (Variable ("anonIterVar_" ^ (varcounter.nextStr()),Set(rtyp))) model val class = class_of_term (Variable ("anonIterVar_" ^ (varcounter.nextStr()),Set(rtyp))) model
val attrs = get_overloaded_attrs_or_assocends class (List.last path) model val attrs = get_overloaded_attrs_or_assocends class (List.last path) model
(* source term is a dummy-Term *) (* source term is a dummy-Term *)
val new_rterm = CollectionLiteral([CollectionItem(rterm,type_of_term rterm)],rtyp) val new_rterm = CollectionLiteral([CollectionItem(rterm,type_of_term rterm)],rtyp)
val _ = trace type_checker ("'AsSetError' ... \n") val _ = Logger.debug3 ("'AsSetError' ... \n")
in in
if (List.length attrs = 0) if (List.length attrs = 0)
then then
@ -230,7 +229,7 @@ in
else else
upcast_att_aend attrs new_rterm model upcast_att_aend attrs new_rterm model
end end
val _ = trace function_ends ("TypeChecker.AsSet_desugarator class= " ^ (string_of_OclType (type_of_term rterm)) ^ " , attr\n") val _ = Logger.debug2 ("TypeChecker.AsSet_desugarator class= " ^ (string_of_OclType (type_of_term rterm)) ^ " , attr\n")
in in
res res
end end
@ -243,17 +242,17 @@ in
(* RETURN: CollectionPart *) (* RETURN: CollectionPart *)
fun resolve_CollectionPart model (CollectionItem (term,typ)) = fun resolve_CollectionPart model (CollectionItem (term,typ)) =
let let
val _ = trace function_calls ("TypeChecker.resolve_CollectionPart " ^ (ocl2string false term) ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_CollectionPart " ^ (ocl2string false term) ^ "\n")
val rterm = resolve_OclTerm term model val rterm = resolve_OclTerm term model
val rtyp = type_of_term rterm val rtyp = type_of_term rterm
val res = (CollectionItem (rterm,rtyp)) val res = (CollectionItem (rterm,rtyp))
val _ = trace function_ends ("TypeChecker.resolve_CollectionPart " ^ (ocl2string false term) ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_CollectionPart " ^ (ocl2string false term) ^ "\n")
in in
res res
end end
| resolve_CollectionPart model (CollectionRange (term1,term2,typ)) = | resolve_CollectionPart model (CollectionRange (term1,term2,typ)) =
let let
val _ = trace function_calls ("TypeChecker.resolve_CollectionPart " ^ (ocl2string false term1) ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_CollectionPart " ^ (ocl2string false term1) ^ "\n")
val rterm1 = resolve_OclTerm term1 model val rterm1 = resolve_OclTerm term1 model
val rtyp1 = type_of_term rterm1 val rtyp1 = type_of_term rterm1
val rterm2 = resolve_OclTerm term2 model val rterm2 = resolve_OclTerm term2 model
@ -263,14 +262,14 @@ fun resolve_CollectionPart model (CollectionItem (term,typ)) =
(CollectionRange (rterm1,rterm2,rtyp1)) (CollectionRange (rterm1,rterm2,rtyp1))
else else
raise (TC_CollectionRangeError ((CollectionRange (term1,term2,typ)),("Begin and end of Range not of same type.\n"))) raise (TC_CollectionRangeError ((CollectionRange (term1,term2,typ)),("Begin and end of Range not of same type.\n")))
val _ = trace function_ends ("TypeChecker.resolve_CollectionPart " ^ (ocl2string false term1) ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_CollectionPart " ^ (ocl2string false term1) ^ "\n")
in in
res res
end end
and resolve_CollectionLiteral (CollectionLiteral (part_list,typ)) model = and resolve_CollectionLiteral (CollectionLiteral (part_list,typ)) model =
let let
val _ = trace function_calls ("TypeChecker.resolve_CollectionLiteral\n ") val _ = Logger.debug2 ("TypeChecker.resolve_CollectionLiteral\n ")
val rpart_list = List.map (resolve_CollectionPart model) part_list val rpart_list = List.map (resolve_CollectionPart model) part_list
val tlist = List.map (type_of_CollPart) rpart_list val tlist = List.map (type_of_CollPart) rpart_list
val res = val res =
@ -279,7 +278,7 @@ and resolve_CollectionLiteral (CollectionLiteral (part_list,typ)) model =
rpart_list rpart_list
else else
raise TC_wrongCollectionLiteral ((CollectionLiteral (part_list,typ)),"Not all Literals have the same type.\n") raise TC_wrongCollectionLiteral ((CollectionLiteral (part_list,typ)),"Not all Literals have the same type.\n")
val _ = trace function_ends ("TypeChecker.resolve_CollectionLiteral\n ") val _ = Logger.debug2 ("TypeChecker.resolve_CollectionLiteral\n ")
in in
res res
end end
@ -297,17 +296,17 @@ and resolve_arguments [] model = []
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
and resolve_OclTerm (Literal (s,typ)) model = and resolve_OclTerm (Literal (s,typ)) model =
let let
val _ = trace function_calls ("TypeChecker.resolve_OclTerm Literal " ^ ocl2string false (Literal(s,typ)) ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm Literal " ^ ocl2string false (Literal(s,typ)) ^ "\n")
val _ = trace medium ("RESOLVE Literal: " ^ s ^ "\n") val _ = Logger.debug2 ("RESOLVE Literal: " ^ s ^ "\n")
val res = (Literal (s,typ)) val res = (Literal (s,typ))
val _ = trace function_ends ("TypeChecker.resolve_OclTerm Literal " ^ ocl2string false (Literal(s,typ)) ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm Literal " ^ ocl2string false (Literal(s,typ)) ^ "\n")
in in
res res
end end
(* TupleLiteral *) (* TupleLiteral *)
| resolve_OclTerm (Tuple(x)) model = | resolve_OclTerm (Tuple(x)) model =
let let
val _ = trace function_calls ("TypeChecker.resolve_OclTerm TupleLiteral " ^ ocl2string false (Tuple(x)) ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm TupleLiteral " ^ ocl2string false (Tuple(x)) ^ "\n")
val res = Tuple (List.map (fn (a,b,c) => val res = Tuple (List.map (fn (a,b,c) =>
let let
val rterm = resolve_OclTerm b model val rterm = resolve_OclTerm b model
@ -315,24 +314,24 @@ and resolve_OclTerm (Literal (s,typ)) model =
in in
(a,rterm,rtype) (a,rterm,rtype)
end) x) end) x)
val _ = trace function_ends ("TypeChecker.resolve_OclTerm\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm\n")
in in
res res
end end
(* Variable *) (* Variable *)
| resolve_OclTerm (Variable ("self",typ)) model = | resolve_OclTerm (Variable ("self",typ)) model =
let let
val _ = trace function_calls ("TypeChecker.resolve_OclTerm Variable " ^ ocl2string false (Variable("self",typ)) ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm Variable " ^ ocl2string false (Variable("self",typ)) ^ "\n")
val res = (Variable ("self",typ)) val res = (Variable ("self",typ))
val _ = trace function_ends ("TypeChecker.resolve_OclTerm Variable " ^ ocl2string false (Variable("self",typ)) ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm Variable " ^ ocl2string false (Variable("self",typ)) ^ "\n")
in in
res res
end end
| resolve_OclTerm (Variable (name,typ)) model = | resolve_OclTerm (Variable (name,typ)) model =
let let
val _ = trace function_calls ("TypeChecker.resolve_OclTerm Variable " ^ ocl2string false (Variable(name,typ)) ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm Variable " ^ ocl2string false (Variable(name,typ)) ^ "\n")
val res = Variable (name,typ) val res = Variable (name,typ)
val _ = trace function_ends ("TypeChecker.resolve_OclTerm Variable " ^ ocl2string false (Variable(name,typ)) ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm Variable " ^ ocl2string false (Variable(name,typ)) ^ "\n")
in in
res res
end end
@ -343,20 +342,20 @@ and resolve_OclTerm (Literal (s,typ)) model =
(* self.self -> self *) (* self.self -> self *)
| resolve_OclTerm (AttributeCall (term,_,["self"],_)) model = | resolve_OclTerm (AttributeCall (term,_,["self"],_)) model =
let let
val _ = trace function_calls ("TypeChecker.resolve_OclTerm, AttributeCall, self, " ^ ocl2string false term ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm, AttributeCall, self, " ^ ocl2string false term ^ "\n")
val res = (resolve_OclTerm term model) val res = (resolve_OclTerm term model)
val _ = trace function_ends ("TypeChecker.resolve_OclTerm, AttributeCall, self " ^ ocl2string false term ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm, AttributeCall, self " ^ ocl2string false term ^ "\n")
in in
res res
end end
| resolve_OclTerm (AttributeCall (term,_,attr_path,_)) (model as (cls,assocs)) = | resolve_OclTerm (AttributeCall (term,_,attr_path,_)) (model as (cls,assocs)) =
let let
val _ = trace function_calls ("TypeChecker.resolve_OclTerm, AttributeCall, attribute name = " ^ (List.last attr_path) ^ ", " ^ ocl2string true term ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm, AttributeCall, attribute name = " ^ (List.last attr_path) ^ ", " ^ ocl2string true term ^ "\n")
(* resolve source term *) (* resolve source term *)
val rterm = resolve_OclTerm term model val rterm = resolve_OclTerm term model
val _ = trace wgen ("res AttCall : arrow or not " ^ List.hd (attr_path) ^ "\n") val _ = Logger.debug3 ("res AttCall : arrow or not " ^ List.hd (attr_path) ^ "\n")
val _ = trace wgen ("res AttCall (" ^ (List.last attr_path) ^ ") : rterm = " ^ Ocl2String.ocl2string false rterm ^ "\n") val _ = Logger.debug3 ("res AttCall (" ^ (List.last attr_path) ^ ") : rterm = " ^ Ocl2String.ocl2string false rterm ^ "\n")
val _ = trace wgen ("res AttCall (" ^ (List.last attr_path) ^ ") : rtype = " ^ string_of_OclType (type_of_term rterm) ^ "\n") val _ = Logger.debug3 ("res AttCall (" ^ (List.last attr_path) ^ ") : rtype = " ^ string_of_OclType (type_of_term rterm) ^ "\n")
val res = val res =
let let
in in
@ -371,16 +370,16 @@ and resolve_OclTerm (Literal (s,typ)) model =
( (
( (
let let
val _ = trace type_checker ("==> 2-dim Inheritance check: attribute/assocend\n") val _ = Logger.debug3 ("==> 2-dim Inheritance check: attribute/assocend\n")
val rtyp = type_of_term rterm val rtyp = type_of_term rterm
val _ = trace type_checker (string_of_OclType rtyp ^"\n") val _ = Logger.debug3 (string_of_OclType rtyp ^"\n")
val templ_type = type_of_template_parameter rtyp val templ_type = type_of_template_parameter rtyp
val pclass = class_of_term (Variable ("x",templ_type)) model val pclass = class_of_term (Variable ("x",templ_type)) model
val ntempl_type = type_of_parent pclass val ntempl_type = type_of_parent pclass
val new_type = substitute_templ_para rtyp ntempl_type val new_type = substitute_templ_para rtyp ntempl_type
val new_class = class_of_term (Variable ("x",new_type)) model val new_class = class_of_term (Variable ("x",new_type)) model
val attrs = get_overloaded_attrs_or_assocends new_class (List.last attr_path) model val attrs = get_overloaded_attrs_or_assocends new_class (List.last attr_path) model
val _ = trace type_checker ("parent type of term:" ^ string_of_OclType new_type ^ "\n") val _ = Logger.debug3 ("parent type of term:" ^ string_of_OclType new_type ^ "\n")
in in
if (List.length attrs = 0) if (List.length attrs = 0)
then raise TC_DesugaratorCall (rterm,attr_path,1,[],model) then raise TC_DesugaratorCall (rterm,attr_path,1,[],model)
@ -392,7 +391,7 @@ and resolve_OclTerm (Literal (s,typ)) model =
| Empty => AsSet_desugarator rterm attr_path 1 [] model | Empty => AsSet_desugarator rterm attr_path 1 [] model
) )
end end
val _ = trace function_ends ("TypeChecker.resolve_OclTerm \n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm \n")
in in
res res
end end
@ -406,18 +405,18 @@ and resolve_OclTerm (Literal (s,typ)) model =
| attributes_to_path (AttributeCall(term,_,[correct_package_part],res_typ)) = | attributes_to_path (AttributeCall(term,_,[correct_package_part],res_typ)) =
(correct_package_part)::(attributes_to_path term) (correct_package_part)::(attributes_to_path term)
(* prefix type of iterator variable *) (* prefix type of iterator variable *)
val _ = trace function_calls ("TypeChecker.resolve_OclTerm, OperationCallWithType = oclIsTypeOf, " ^ ocl2string true term ^"\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm, OperationCallWithType = oclIsTypeOf, " ^ ocl2string true term ^"\n")
val rterm = resolve_OclTerm term model val rterm = resolve_OclTerm term model
val _ = trace type_checker ("res OpCall: oclIsTypeOf 2: " ^ "\n") val _ = Logger.debug3 ("res OpCall: oclIsTypeOf 2: " ^ "\n")
val rtyp = type_of_term rterm val rtyp = type_of_term rterm
val _ = trace type_checker ("res OpCall: oclIsTypeOf 3: " ^ "\n") val _ = Logger.debug3 ("res OpCall: oclIsTypeOf 3: " ^ "\n")
val path = (attributes_to_path source)@[string_path] val path = (attributes_to_path source)@[string_path]
val _ = trace type_checker ("Path of the given type: " ^ string_of_path (path) ^ "\n") val _ = Logger.debug3 ("Path of the given type: " ^ string_of_path (path) ^ "\n")
val typ = type_of_path path model val typ = type_of_path path model
handle GetClassifierError s => raise TC_OperationWithTypeError ("Wrong or ommited package in a OperationWithType call. Please ajust the the package of the type.\n" ^ "OclTerm is: " ^ ocl2string true opcall ^ "\n") handle GetClassifierError s => raise TC_OperationWithTypeError ("Wrong or ommited package in a OperationWithType call. Please ajust the the package of the type.\n" ^ "OclTerm is: " ^ ocl2string true opcall ^ "\n")
val _ = trace type_checker ("res OpCall: oclTypeOf 4:" ^ "... " ^ "\n") val _ = Logger.debug3 ("res OpCall: oclTypeOf 4:" ^ "... " ^ "\n")
val res = OperationWithType (rterm,rtyp,"oclIsTypeOf",typ,Boolean) val res = OperationWithType (rterm,rtyp,"oclIsTypeOf",typ,Boolean)
val _ = trace function_ends ("TypeChecker.resolve_OclTerm\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm\n")
in in
res res
end end
@ -429,18 +428,18 @@ let
| attributes_to_path (AttributeCall(term,_,[correct_package_part],res_typ)) = | attributes_to_path (AttributeCall(term,_,[correct_package_part],res_typ)) =
(correct_package_part)::(attributes_to_path term) (correct_package_part)::(attributes_to_path term)
(* prefix type of iterator variable *) (* prefix type of iterator variable *)
val _ = trace function_calls ("TypeChecker.resolve_OclTerm, OperationCallWithType = oclIsTypeOf, " ^ ocl2string true term ^"\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm, OperationCallWithType = oclIsTypeOf, " ^ ocl2string true term ^"\n")
val rterm = resolve_OclTerm term model val rterm = resolve_OclTerm term model
val _ = trace type_checker ("res OpCall: oclIsTypeOf 2: " ^ "\n") val _ = Logger.debug3 ("res OpCall: oclIsTypeOf 2: " ^ "\n")
val rtyp = type_of_term rterm val rtyp = type_of_term rterm
val _ = trace type_checker ("res OpCall: oclIsTypeOf 3: " ^ "\n") val _ = Logger.debug3 ("res OpCall: oclIsTypeOf 3: " ^ "\n")
val path = (attributes_to_path source)@[string_path] val path = (attributes_to_path source)@[string_path]
val _ = trace type_checker ("Path of the given type: " ^ string_of_path (path) ^ "\n") val _ = Logger.debug3 ("Path of the given type: " ^ string_of_path (path) ^ "\n")
val typ = type_of_path path model val typ = type_of_path path model
handle GetClassifierError s => raise TC_OperationWithTypeError ("Wrong or ommited package in a OperationWithType call. Please ajust the the package of the type.\n" ^ "OclTerm is: " ^ ocl2string true opcall ^ "\n") handle GetClassifierError s => raise TC_OperationWithTypeError ("Wrong or ommited package in a OperationWithType call. Please ajust the the package of the type.\n" ^ "OclTerm is: " ^ ocl2string true opcall ^ "\n")
val _ = trace type_checker ("res OpCall: oclTypeOf 4:" ^ "... " ^ "\n") val _ = Logger.debug3 ("res OpCall: oclTypeOf 4:" ^ "... " ^ "\n")
val res = OperationWithType (rterm,rtyp,"oclIsKindOf",typ,Boolean) val res = OperationWithType (rterm,rtyp,"oclIsKindOf",typ,Boolean)
val _ = trace function_ends ("TypeChecker.resolve_OclTerm\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm\n")
in in
res res
end end
@ -452,43 +451,43 @@ let
| attributes_to_path (AttributeCall(term,_,[correct_package_part],res_typ)) = | attributes_to_path (AttributeCall(term,_,[correct_package_part],res_typ)) =
(correct_package_part)::(attributes_to_path term) (correct_package_part)::(attributes_to_path term)
(* prefix type of iterator variable *) (* prefix type of iterator variable *)
val _ = trace function_calls ("TypeChecker.resolve_OclTerm, OperationCallWithType = oclIsTypeOf, " ^ ocl2string true term ^"\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm, OperationCallWithType = oclIsTypeOf, " ^ ocl2string true term ^"\n")
val rterm = resolve_OclTerm term model val rterm = resolve_OclTerm term model
val _ = trace type_checker ("res OpCall: oclIsTypeOf 2: " ^ "\n") val _ = Logger.debug3 ("res OpCall: oclIsTypeOf 2: " ^ "\n")
val rtyp = type_of_term rterm val rtyp = type_of_term rterm
val _ = trace type_checker ("res OpCall: oclIsTypeOf 3: " ^ "\n") val _ = Logger.debug3 ("res OpCall: oclIsTypeOf 3: " ^ "\n")
val path = (attributes_to_path source)@[string_path] val path = (attributes_to_path source)@[string_path]
val _ = trace type_checker ("Path of the given type: " ^ string_of_path (path) ^ "\n") val _ = Logger.debug3 ("Path of the given type: " ^ string_of_path (path) ^ "\n")
val typ = type_of_path path model val typ = type_of_path path model
handle GetClassifierError s => raise TC_OperationWithTypeError ("Wrong or ommited package in a OperationWithType call. Please ajust the the package of the type.\n" ^ "OclTerm is: " ^ ocl2string true opcall ^ "\n") handle GetClassifierError s => raise TC_OperationWithTypeError ("Wrong or ommited package in a OperationWithType call. Please ajust the the package of the type.\n" ^ "OclTerm is: " ^ ocl2string true opcall ^ "\n")
val _ = trace type_checker ("res OpCall: oclTypeOf 4:" ^ "... " ^ "\n") val _ = Logger.debug3 ("res OpCall: oclTypeOf 4:" ^ "... " ^ "\n")
val res = OperationWithType (rterm,rtyp,"oclAsType",typ,typ) val res = OperationWithType (rterm,rtyp,"oclAsType",typ,typ)
val _ = trace function_ends ("TypeChecker.resolve_OclTerm\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm\n")
in in
res res
end end
(* HARD CODED STUFF *) (* HARD CODED STUFF *)
| resolve_OclTerm (OperationCall (term,typ,[OclLibPackage,"OclAny","atPre"],[],_)) model = | resolve_OclTerm (OperationCall (term,typ,[OclLibPackage,"OclAny","atPre"],[],_)) model =
let let
val _ = trace function_calls ("TypeChecker.resolve_OclTerm, OperationCall atPre, " ^ ocl2string true term ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm, OperationCall atPre, " ^ ocl2string true term ^ "\n")
(* resolve source term *) (* resolve source term *)
val rterm = resolve_OclTerm term model val rterm = resolve_OclTerm term model
val rtyp = type_of_term rterm val rtyp = type_of_term rterm
val _ = trace type_checker ("res OpCall: Type of source : " ^ string_of_OclType rtyp ^ "\n") val _ = Logger.debug3 ("res OpCall: Type of source : " ^ string_of_OclType rtyp ^ "\n")
val res = OperationCall (rterm,rtyp,[OclLibPackage,"OclAny","atPre"],[],rtyp) val res = OperationCall (rterm,rtyp,[OclLibPackage,"OclAny","atPre"],[],rtyp)
val _ = trace function_ends ("TypeChecker.resovle_OclTerm\n") val _ = Logger.debug2 ("TypeChecker.resovle_OclTerm\n")
in in
res res
end end
| resolve_OclTerm (OperationCall (term,typ,meth_path,args,res_typ)) (model as (cls,assocs)) = | resolve_OclTerm (OperationCall (term,typ,meth_path,args,res_typ)) (model as (cls,assocs)) =
let let
val _ = trace function_calls ("TypeChecker.resolve_OclTerm, OperatioCall: name = " ^ (List.last (meth_path)) ^ ", " ^ ocl2string true term ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm, OperatioCall: name = " ^ (List.last (meth_path)) ^ ", " ^ ocl2string true term ^ "\n")
(* resolve source term *) (* resolve source term *)
val rterm = resolve_OclTerm term model val rterm = resolve_OclTerm term model
val _ = trace type_checker ("res OpCall: Type of source : " ^ string_of_OclType (type_of_term rterm) ^ "\n") val _ = Logger.debug3 ("res OpCall: Type of source : " ^ string_of_OclType (type_of_term rterm) ^ "\n")
(* resolve arguments *) (* resolve arguments *)
val rargs = resolve_arguments args model val rargs = resolve_arguments args model
val _ = trace type_checker ("res OpCall: args resolved ...\n") val _ = Logger.debug3 ("res OpCall: args resolved ...\n")
val res = val res =
let let
in in
@ -502,17 +501,17 @@ let
( (
( (
let let
val _ = trace type_checker ("==> no 2-dim Inheritance check: attribute/assocend\n") val _ = Logger.debug3 ("==> no 2-dim Inheritance check: attribute/assocend\n")
val rtyp = type_of_term rterm val rtyp = type_of_term rterm
val _ = trace type_checker (string_of_OclType rtyp ^ "\n") val _ = Logger.debug3 (string_of_OclType rtyp ^ "\n")
val templ_type = type_of_template_parameter rtyp val templ_type = type_of_template_parameter rtyp
val pclass = class_of_term (Variable ("x",templ_type)) model val pclass = class_of_term (Variable ("x",templ_type)) model
val ntempl_type = type_of_parent pclass val ntempl_type = type_of_parent pclass
val _ = trace type_checker (string_of_OclType ntempl_type ^ "\n") val _ = Logger.debug3 (string_of_OclType ntempl_type ^ "\n")
val new_type = substitute_templ_para rtyp ntempl_type val new_type = substitute_templ_para rtyp ntempl_type
val new_class = class_of_term (Variable ("x",new_type)) model val new_class = class_of_term (Variable ("x",new_type)) model
val ops = get_overloaded_methods new_class (List.last meth_path) model val ops = get_overloaded_methods new_class (List.last meth_path) model
val _ = trace type_checker ("parent type of term: " ^ string_of_OclType new_type ^ "\n") val _ = Logger.debug3 ("parent type of term: " ^ string_of_OclType new_type ^ "\n")
in in
if (List.length ops = 0) if (List.length ops = 0)
then raise TC_DesugaratorCall (rterm, meth_path, 0, rargs, model) then raise TC_DesugaratorCall (rterm, meth_path, 0, rargs, model)
@ -524,7 +523,7 @@ let
| Empty => AsSet_desugarator rterm meth_path 0 rargs model | Empty => AsSet_desugarator rterm meth_path 0 rargs model
) )
end end
val _ = trace function_ends ("TypeChecker.resolve_OclTerm\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm\n")
in in
res res
end end
@ -532,37 +531,37 @@ let
| resolve_OclTerm (Iterator (name,iter_vars,source_term,_,expr,expr_typ,res_typ)) (model as (cls,assocs)) = | resolve_OclTerm (Iterator (name,iter_vars,source_term,_,expr,expr_typ,res_typ)) (model as (cls,assocs)) =
let let
(* resolve source term, type *) (* resolve source term, type *)
val _ = trace function_calls ("TypeChecker.resolve_OclTerm, Itertor: name = " ^ name ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm, Itertor: name = " ^ name ^ "\n")
val rterm = resolve_OclTerm source_term model val rterm = resolve_OclTerm source_term model
val rtyp = type_of_term rterm val rtyp = type_of_term rterm
val _ = trace type_checker ("res Iter (" ^ name ^ "): source type " ^ string_of_OclType (type_of_term rterm) ^ "\n\n") val _ = Logger.debug3 ("res Iter (" ^ name ^ "): source type " ^ string_of_OclType (type_of_term rterm) ^ "\n\n")
(* get source classifier *) (* get source classifier *)
val source_class = class_of_term rterm model val source_class = class_of_term rterm model
val _ = trace type_checker ("res Iter (" ^ name ^ "): type of classifier: " ^ string_of_OclType (type_of source_class) ^ "\n") val _ = Logger.debug3 ("res Iter (" ^ name ^ "): type of classifier: " ^ string_of_OclType (type_of source_class) ^ "\n")
(* prefix types *) (* prefix types *)
val prfx = (package_of_template_parameter (type_of source_class)) val prfx = (package_of_template_parameter (type_of source_class))
val _ = trace type_checker ("res Iter (" ^ name ^ "): Type prefixed ... \n") val _ = Logger.debug3 ("res Iter (" ^ name ^ "): Type prefixed ... \n")
val piter_vars = List.map (fn (a,b) => (a,prefix_type prfx b)) iter_vars val piter_vars = List.map (fn (a,b) => (a,prefix_type prfx b)) iter_vars
val piter_types = List.map (fn (a,b) => b) piter_vars val piter_types = List.map (fn (a,b) => b) piter_vars
val _ = trace type_checker ("res Iter (" ^ name ^ "): first iter types: " ^ string_of_OclType (List.hd piter_types) ^ "\n") val _ = Logger.debug3 ("res Iter (" ^ name ^ "): first iter types: " ^ string_of_OclType (List.hd piter_types) ^ "\n")
(* check if iterator types correspond to source type *) (* check if iterator types correspond to source type *)
val static_iter_type = type_of_template_parameter (type_of (source_class)) val static_iter_type = type_of_template_parameter (type_of (source_class))
val _ = trace type_checker ("Length of iter_types: " ^ Int.toString (List.length piter_types) ^ "\n") val _ = Logger.debug3 ("Length of iter_types: " ^ Int.toString (List.length piter_types) ^ "\n")
val _ = trace type_checker ("parent of classifier: " ^ string_of_OclType (type_of_parent source_class) ^ "\n") val _ = Logger.debug3 ("parent of classifier: " ^ string_of_OclType (type_of_parent source_class) ^ "\n")
val _ = trace type_checker ("static iter type : " ^ string_of_OclType static_iter_type ^ " \n") val _ = Logger.debug3 ("static iter type : " ^ string_of_OclType static_iter_type ^ " \n")
val _ = trace type_checker ("iter types: " ^ string_of_OclType (List.hd piter_types) ^ "\n") val _ = Logger.debug3 ("iter types: " ^ string_of_OclType (List.hd piter_types) ^ "\n")
val h2 = List.map (fn a => conforms_to a static_iter_type model) (piter_types) val h2 = List.map (fn a => conforms_to a static_iter_type model) (piter_types)
val check = List.all (fn a => a=true) h2 val check = List.all (fn a => a=true) h2
val res = val res =
if (check) then if (check) then
let let
val _ = trace type_checker ("res Iter: types conforms \n") val _ = Logger.debug3 ("res Iter: types conforms \n")
val bound_expr = embed_bound_variables piter_vars expr val bound_expr = embed_bound_variables piter_vars expr
val _ = trace type_checker ("res Iter: term : " ^ Ocl2String.ocl2string false bound_expr ^ "\n") val _ = Logger.debug3 ("res Iter: term : " ^ Ocl2String.ocl2string false bound_expr ^ "\n")
val rexpr = resolve_OclTerm bound_expr model val rexpr = resolve_OclTerm bound_expr model
val _ = trace type_checker (" manuel " ^ string_of_OclType (type_of_term rexpr) ^ "\n") val _ = Logger.debug3 (" manuel " ^ string_of_OclType (type_of_term rexpr) ^ "\n")
val _ = trace type_checker (" ma " ^ string_of_OclType (Set(static_iter_type)) ^ "\n") val _ = Logger.debug3 (" ma " ^ string_of_OclType (Set(static_iter_type)) ^ "\n")
val _ = trace type_checker ("res Iter: Iterator name = " ^ name ^ " \n\n\n") val _ = Logger.debug3 ("res Iter: Iterator name = " ^ name ^ " \n\n\n")
in in
( (
case name of case name of
@ -585,7 +584,7 @@ let
end end
else else
raise TC_IteratorTypeMissMatch (Iterator (name,iter_vars,source_term,DummyT,expr,expr_typ,res_typ),("Iterator variable doesn't conform to choosen set \n")) raise TC_IteratorTypeMissMatch (Iterator (name,iter_vars,source_term,DummyT,expr,expr_typ,res_typ),("Iterator variable doesn't conform to choosen set \n"))
val _ = trace function_ends ("TypeChecker.resolve_OclTerm\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm\n")
in in
res res
end end
@ -593,25 +592,25 @@ let
| resolve_OclTerm (Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) (model as (cls,assocs)) = | 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 let
(* resolve source term, type *) (* resolve source term, type *)
val _ = trace function_calls ("TypeChecker.resolve_OclTerm, Iterate: accumulator " ^ acc_var_name ^ "\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm, Iterate: accumulator " ^ acc_var_name ^ "\n")
val rterm = resolve_OclTerm sterm model val rterm = resolve_OclTerm sterm model
val rtyp = type_of_term rterm val rtyp = type_of_term rterm
val _ = trace medium ("res Iterate: source type " ^ string_of_OclType (type_of_term rterm) ^ "\n\n") val _ = Logger.debug2 ("res Iterate: source type " ^ string_of_OclType (type_of_term rterm) ^ "\n\n")
(* get source classifier *) (* get source classifier *)
val source_class = class_of_term rterm model val source_class = class_of_term rterm model
val _ = trace medium ("res Iterate: type of classifier: " ^ string_of_OclType (type_of source_class) ^ "\n") val _ = Logger.debug2 ("res Iterate: type of classifier: " ^ string_of_OclType (type_of source_class) ^ "\n")
(* prefix types *) (* prefix types *)
val prfx = (package_of_template_parameter (type_of source_class)) val prfx = (package_of_template_parameter (type_of source_class))
val _ = trace medium ("res Iterate: Type prefixed ... \n") val _ = Logger.debug2 ("res Iterate: Type prefixed ... \n")
val piter_vars = List.map (fn (a,b) => (a,prefix_type prfx b)) iter_vars val piter_vars = List.map (fn (a,b) => (a,prefix_type prfx b)) iter_vars
val piter_types = List.map (fn (a,b) => b) piter_vars val piter_types = List.map (fn (a,b) => b) piter_vars
val _ = trace medium ("res Iterate: first iter types: " ^ string_of_OclType (List.hd piter_types) ^ "\n") val _ = Logger.debug2 ("res Iterate: first iter types: " ^ string_of_OclType (List.hd piter_types) ^ "\n")
(* check if iterator types correspond to source type *) (* check if iterator types correspond to source type *)
val static_iter_type = type_of_template_parameter (type_of (source_class)) val static_iter_type = type_of_template_parameter (type_of (source_class))
val _ = trace medium ("Length of iter_types: " ^ Int.toString (List.length piter_types) ^ "\n") val _ = Logger.debug2 ("Length of iter_types: " ^ Int.toString (List.length piter_types) ^ "\n")
val _ = trace medium ("parent of classifier: " ^ string_of_OclType (type_of_parent source_class) ^ "\n") val _ = Logger.debug2 ("parent of classifier: " ^ string_of_OclType (type_of_parent source_class) ^ "\n")
val _ = trace medium ("\nstatic iter type : " ^ string_of_OclType static_iter_type ^ " \n") val _ = Logger.debug2 ("\nstatic iter type : " ^ string_of_OclType static_iter_type ^ " \n")
val _ = trace medium ("iter types: " ^ string_of_OclType (List.hd piter_types) ^ "\n") val _ = Logger.debug2 ("iter types: " ^ string_of_OclType (List.hd piter_types) ^ "\n")
val h2 = List.map (fn a => conforms_to a static_iter_type model) (piter_types) val h2 = List.map (fn a => conforms_to a static_iter_type model) (piter_types)
val check = List.all (fn a => a=true) h2 val check = List.all (fn a => a=true) h2
(* check if initial value of accumulator has correct type *) (* check if initial value of accumulator has correct type *)
@ -621,14 +620,14 @@ let
if (check) then if (check) then
if (racc_var_type = acc_var_type) then if (racc_var_type = acc_var_type) then
let let
val _ = trace medium ("res Iterate: types conforms \n") val _ = Logger.debug2 ("res Iterate: types conforms \n")
val bound_expr = embed_bound_variables piter_vars bterm val bound_expr = embed_bound_variables piter_vars bterm
val bound_expr2 = embed_bound_variables [(acc_var_name,acc_var_type)] bound_expr val bound_expr2 = embed_bound_variables [(acc_var_name,acc_var_type)] bound_expr
val _ = trace medium ("myres Iterate: term : " ^ Ocl2String.ocl2string false bound_expr2 ^ "\n") val _ = Logger.debug2 ("myres Iterate: term : " ^ Ocl2String.ocl2string false bound_expr2 ^ "\n")
val rexpr = resolve_OclTerm bound_expr2 model val rexpr = resolve_OclTerm bound_expr2 model
val _ = trace medium (" manuel " ^ string_of_OclType (type_of_term rexpr) ^ "\n") val _ = Logger.debug2 (" manuel " ^ string_of_OclType (type_of_term rexpr) ^ "\n")
val _ = trace medium (" ma " ^ string_of_OclType (Set(static_iter_type)) ^ "\n") val _ = Logger.debug2 (" ma " ^ string_of_OclType (Set(static_iter_type)) ^ "\n")
val _ = trace medium ("res Iterate: \n\n\n") val _ = Logger.debug2 ("res Iterate: \n\n\n")
in in
Iterate(piter_vars,acc_var_name,racc_var_type,racc_var_term,rterm,rtyp,rexpr,type_of_term rexpr,racc_var_type) Iterate(piter_vars,acc_var_name,racc_var_type,racc_var_term,rterm,rtyp,rexpr,type_of_term rexpr,racc_var_type)
end end
@ -636,21 +635,21 @@ let
raise TC_IterateAccumulatorTypeError ("Type of accumulator does not conform to type of expression of accumulator") raise TC_IterateAccumulatorTypeError ("Type of accumulator does not conform to type of expression of accumulator")
else else
raise TC_IterateTypeMissMatch ("Iterate variables doesn't conform to choosen set \n") raise TC_IterateTypeMissMatch ("Iterate variables doesn't conform to choosen set \n")
val _ = trace function_ends ("TypeChecker.resolve_OclTerm\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm\n")
in in
res res
end end
| resolve_OclTerm (CollectionLiteral ([],typ)) model = | resolve_OclTerm (CollectionLiteral ([],typ)) model =
let let
val _ = trace function_calls ("TypeChecker.resolve_OclTerm CollectionLiteral\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm CollectionLiteral\n")
val res = CollectionLiteral ([],typ) val res = CollectionLiteral ([],typ)
val _ = trace function_ends ("TypeChecker.resolve_OclTerm\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm\n")
in in
res res
end end
| resolve_OclTerm (CollectionLiteral (coll_parts,temp_typ)) model = | resolve_OclTerm (CollectionLiteral (coll_parts,temp_typ)) model =
let let
val _ = trace function_calls ("TypeChecker.resolve_OclTerm CollectionLiteral\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm CollectionLiteral\n")
val r_coll_parts = List.map (resolve_CollectionPart model) coll_parts val r_coll_parts = List.map (resolve_CollectionPart model) coll_parts
val typ = type_of_CollPart (List.hd r_coll_parts) val typ = type_of_CollPart (List.hd r_coll_parts)
val res = val res =
@ -658,25 +657,25 @@ let
(CollectionLiteral (r_coll_parts,substitute_templ_para temp_typ typ)) (CollectionLiteral (r_coll_parts,substitute_templ_para temp_typ typ))
else else
raise (TC_wrongCollectionLiteral ((CollectionLiteral (coll_parts,temp_typ)), ("not all Literals have type of Collection"))) raise (TC_wrongCollectionLiteral ((CollectionLiteral (coll_parts,temp_typ)), ("not all Literals have type of Collection")))
val _ = trace function_ends ("TypeChecker.resolve_OclTerm\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm\n")
in in
res res
end end
| resolve_OclTerm (Let (str,typ,rhs_term,_,in_term,_)) model = | resolve_OclTerm (Let (str,typ,rhs_term,_,in_term,_)) model =
let let
val _ = trace function_calls ("TypeChecker.resolve_OclTerm a Let-Expression \n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm a Let-Expression \n")
val rrhs_term = resolve_OclTerm rhs_term model val rrhs_term = resolve_OclTerm rhs_term model
val rrhs_typ = type_of_term rrhs_term val rrhs_typ = type_of_term rrhs_term
val rin_term = resolve_OclTerm in_term model val rin_term = resolve_OclTerm in_term model
val rin_typ = type_of_term rin_term val rin_typ = type_of_term rin_term
val res = (Let (str,typ,rrhs_term,rrhs_typ,rin_term,rin_typ)) val res = (Let (str,typ,rrhs_term,rrhs_typ,rin_term,rin_typ))
val _ = trace function_ends ("TypeChecker.resolve_OclTerm") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm")
in in
res res
end end
| resolve_OclTerm (If (cond_term,cond_typ,if_expr,if_typ,else_expr,else_typ,ret_typ)) model = | resolve_OclTerm (If (cond_term,cond_typ,if_expr,if_typ,else_expr,else_typ,ret_typ)) model =
let let
val _ = trace function_calls ("TypeChecker.resolve_OclTerm a If-Expression \n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm a If-Expression \n")
val rterm = resolve_OclTerm cond_term model val rterm = resolve_OclTerm cond_term model
val rtyp = type_of_term rterm val rtyp = type_of_term rterm
@ -695,7 +694,7 @@ let
raise TC_TypeCheckerResolveIfError (If (cond_term,cond_typ,if_expr,if_typ,else_expr,else_typ,ret_typ),("Types of if-expression and else-expression don't conform each other \n")) raise TC_TypeCheckerResolveIfError (If (cond_term,cond_typ,if_expr,if_typ,else_expr,else_typ,ret_typ),("Types of if-expression and else-expression don't conform each other \n"))
else else
raise TC_TypeCheckerResolveIfError (If (cond_term,cond_typ,if_expr,if_typ,else_expr,else_typ,ret_typ),("Type of condition is not Boolean. \n")) raise TC_TypeCheckerResolveIfError (If (cond_term,cond_typ,if_expr,if_typ,else_expr,else_typ,ret_typ),("Type of condition is not Boolean. \n"))
val _ = trace function_ends ("TypeChecker.resolve_OclTerm\n") val _ = Logger.debug2 ("TypeChecker.resolve_OclTerm\n")
in in
res res
end end
@ -704,14 +703,14 @@ let
(* RETURN: context option *) (* RETURN: context option *)
fun check_context (Cond (path,op_name,op_sign,result_type,cond,pre_name,expr)) (model as (cls,assocs)) = fun check_context (Cond (path,op_name,op_sign,result_type,cond,pre_name,expr)) (model as (cls,assocs)) =
let let
val _ = trace function_calls ("TypeChecker.check_context Cond(...)\n") val _ = Logger.debug2 ("TypeChecker.check_context Cond(...)\n")
val _ = trace type_checker ("pre/post/body : " ^ Ocl2String.ocl2string false expr ^ "\n") val _ = Logger.debug3 ("pre/post/body : " ^ Ocl2String.ocl2string false expr ^ "\n")
val classifier = class_of_type (Classifier (path)) model val classifier = class_of_type (Classifier (path)) model
val oper = get_operation op_name classifier model val oper = get_operation op_name classifier model
val check1 = (op_sign = (#arguments oper)) val check1 = (op_sign = (#arguments oper))
val check2 = (result_type = (#result oper)) val check2 = (result_type = (#result oper))
val _ = trace type_checker ("check1 = " ^ Bool.toString check1 ^ ", check2 = " ^ Bool.toString check2 ^ "\n") val _ = Logger.debug3 ("check1 = " ^ Bool.toString check1 ^ ", check2 = " ^ Bool.toString check2 ^ "\n")
val _ = List.map (fn (a,b) => (trace type_checker (a ^ ":" ^ (string_of_OclType b) ^ " "))) op_sign val _ = List.map (fn (a,b) => (Logger.debug3 (a ^ ":" ^ (string_of_OclType b) ^ " "))) op_sign
val res = val res =
if check1 andalso check2 if check1 andalso check2
then then
@ -720,25 +719,25 @@ fun check_context (Cond (path,op_name,op_sign,result_type,cond,pre_name,expr)) (
(* NONE *) (* NONE *)
raise TC_WrongContextChecked (Cond (path,op_name,op_sign,result_type,cond,pre_name,expr)) raise TC_WrongContextChecked (Cond (path,op_name,op_sign,result_type,cond,pre_name,expr))
val _ = trace function_ends ("TypeChecker.check_context Cond(...)\n\n\n") val _ = Logger.debug2 ("TypeChecker.check_context Cond(...)\n\n\n")
in in
res res
end end
| check_context (Attr (path,typ,attrorassoc,expr)) (model as (cls,assocs)) = | check_context (Attr (path,typ,attrorassoc,expr)) (model as (cls,assocs)) =
let let
val _ = trace function_calls ("TypeChecker.check_context Attr(..._)\n") val _ = Logger.debug2 ("TypeChecker.check_context Attr(..._)\n")
val _ = trace type_checker ("init/derive : " ^ Ocl2String.ocl2string false expr ^ "\n") val _ = Logger.debug3 ("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)) model
val _ = trace type_checker ( "classifier found ... " ^ "\n") val _ = Logger.debug3 ( "classifier found ... " ^ "\n")
val attr_list = attributes_of classifier val attr_list = attributes_of classifier
val _ = trace type_checker ( "attr_list found ... " ^ "\n") val _ = Logger.debug3 ( "attr_list found ... " ^ "\n")
val attr = valOf (get_attribute (List.last path) attr_list) val attr = valOf (get_attribute (List.last path) attr_list)
val _ = trace type_checker ( "attribute found ... " ^ "\n") val _ = Logger.debug3 ( "attribute found ... " ^ "\n")
val res = val res =
if (typ = #attr_type attr) if (typ = #attr_type attr)
then then
let let
val _ = trace type_checker (" ... " ^ "\n") val _ = Logger.debug3 (" ... " ^ "\n")
in in
(SOME ((Attr (path,(#attr_type attr),attrorassoc,resolve_OclTerm expr model)))) (SOME ((Attr (path,(#attr_type attr),attrorassoc,resolve_OclTerm expr model))))
end end
@ -746,16 +745,16 @@ fun check_context (Cond (path,op_name,op_sign,result_type,cond,pre_name,expr)) (
(* NONE *) (* NONE *)
raise TC_WrongContextChecked (Attr (path,typ,attrorassoc,expr)) raise TC_WrongContextChecked (Attr (path,typ,attrorassoc,expr))
val _ = trace function_ends ("TypeChecker.check_context\n\n\n") val _ = Logger.debug2 ("TypeChecker.check_context\n\n\n")
in in
res res
end end
| check_context (Inv (path,name,expr)) model = | check_context (Inv (path,name,expr)) model =
let let
val _ = trace function_calls ("TypeChecker.check_context Inv(...)\n") val _ = Logger.debug2 ("TypeChecker.check_context Inv(...)\n")
val _ = trace type_checker ("inv : " ^ Ocl2String.ocl2string false expr ^ "\n") val _ = Logger.debug3 ("inv : " ^ Ocl2String.ocl2string false expr ^ "\n")
val res = (SOME (Inv (path,name, resolve_OclTerm expr model))) val res = (SOME (Inv (path,name, resolve_OclTerm expr model)))
val _ = trace function_ends ("TypeChecker.check_context\n\n\n") val _ = Logger.debug2 ("TypeChecker.check_context\n\n\n")
in in
res res
end end
@ -769,88 +768,78 @@ fun check_context_list [] model = []
| check_context_list (h::context_list_tail) model = | check_context_list (h::context_list_tail) model =
((check_context h model ((check_context h model
handle TC_wrongCollectionLiteral (term,mes) => handle TC_wrongCollectionLiteral (term,mes) =>
let let
val s1 = ("wrongCollectionLiteral:\n") val s1 = ("wrongCollectionLiteral:\n")
val s2 = ("Error Message: " ^ mes ^ "\n") val s2 = ("Error Message: " ^ mes ^ "\n")
val s3 = ("In Term: " ^ Ocl2String.ocl2string false term ^ "\n") val s3 = ("In Term: " ^ Ocl2String.ocl2string false term ^ "\n")
val _ = trace exce (s1^s2^s3) in
in Logger.errorExn (TC_WrongContextChecked h) (s1^s2^s3)
raise TC_WrongContextChecked h end
end | TC_CollectionRangeError (part,mes) =>
| TC_CollectionRangeError (part,mes) => let
let
val s1 = ("CollectionRangeError:\n") val s1 = ("CollectionRangeError:\n")
val s2 = ("Error Message: " ^ mes ^ "\n") val s2 = ("Error Message: " ^ mes ^ "\n")
val _ = trace exce (s1^s2) in
in Logger.errorExn (TC_WrongContextChecked h) (s1^s2)
raise TC_WrongContextChecked h end
end | TC_IteratorTypeMissMatch (term,mes) =>
| TC_IteratorTypeMissMatch (term,mes) => let
let
val s1 = ("IteratorTypeMissMatch:\n") val s1 = ("IteratorTypeMissMatch:\n")
val s2 = ("Error Message: " ^ mes ^ "\n") val s2 = ("Error Message: " ^ mes ^ "\n")
val s3 = ("In Term: " ^ Ocl2String.ocl2string false term ^ "\n") val s3 = ("In Term: " ^ Ocl2String.ocl2string false term ^ "\n")
val _ = trace exce (s1^s2^s3)
in in
raise TC_WrongContextChecked h Logger.errorExn (TC_WrongContextChecked h) (s1^s2^s3)
end end
| TC_NoSuchIteratorNameError (term,mes) => | TC_NoSuchIteratorNameError (term,mes) =>
let let
val s1 = ("NoSuchIteratorNameError:\n") val s1 = ("NoSuchIteratorNameError:\n")
val s2 = ("Error Message: " ^ mes ^ "\n") val s2 = ("Error Message: " ^ mes ^ "\n")
val s3 = ("In Term: " ^ Ocl2String.ocl2string false term ^ "\n") val s3 = ("In Term: " ^ Ocl2String.ocl2string false term ^ "\n")
val _ = trace exce (s1^s2^s3)
in in
raise TC_WrongContextChecked h Logger.errorExn (TC_WrongContextChecked h) (s1^s2^s3)
end end
| TC_TypeCheckerResolveIfError (term,mes) => | TC_TypeCheckerResolveIfError (term,mes) =>
let let
val s1 = ("TypeCheckerResolveIfError:\n") val s1 = ("TypeCheckerResolveIfError:\n")
val s2 = ("Error Message: " ^ mes ^ "\n") val s2 = ("Error Message: " ^ mes ^ "\n")
val s3 = ("In Term: " ^ Ocl2String.ocl2string false term ^ "\n") val s3 = ("In Term: " ^ Ocl2String.ocl2string false term ^ "\n")
val _ = trace exce (s1^s2^s3)
in in
raise TC_WrongContextChecked h Logger.errorExn (TC_WrongContextChecked h) (s1^s2^s3)
end end
| TC_NotYetSupportedError mes => | TC_NotYetSupportedError mes =>
let let
val s1 = ("TC_NotYetSupportedError:\n") val s1 = ("TC_NotYetSupportedError:\n")
val s2 = ("Error Message: " ^ mes ^ "\n") val s2 = ("Error Message: " ^ mes ^ "\n")
val _ = trace exce (s1^s2)
in in
raise TC_WrongContextChecked h Logger.errorExn (TC_WrongContextChecked h) (s1^s2)
end end
| TC_OperationWithTypeError mes => | TC_OperationWithTypeError mes =>
let let
val s1 = ("TC_OperationWithType:\n") val s1 = ("TC_OperationWithType:\n")
val s2 = ("Error Message: " ^ mes ^ "\n") val s2 = ("Error Message: " ^ mes ^ "\n")
val _ = trace exce (s1^s2)
in in
raise TC_WrongContextChecked h Logger.errorExn (TC_WrongContextChecked h) (s1^s2)
end end
| TC_NoSuchAttributeError mes => | TC_NoSuchAttributeError mes =>
let let
val s1 = ("TC_NoSuchAttributeError:\n") val s1 = ("TC_NoSuchAttributeError:\n")
val s2 = ("Error Message: " ^ mes ^ "\n") val s2 = ("Error Message: " ^ mes ^ "\n")
val _ = trace exce (s1^s2)
in in
raise TC_WrongContextChecked h Logger.errorExn (TC_WrongContextChecked h) (s1^s2)
end end
| GetClassifierError mes => | GetClassifierError mes =>
let let
val s1 = ("GetClassifierError:\n") val s1 = ("GetClassifierError:\n")
val s2 = ("Error Message: " ^ mes ^ "\n") val s2 = ("Error Message: " ^ mes ^ "\n")
val _ = trace exce (s1^s2)
in in
raise TC_WrongContextChecked h Logger.errorExn (TC_WrongContextChecked h) (s1^s2)
end end
| TC_NoSuchOperationError mes => | TC_NoSuchOperationError mes =>
let let
val s1 = ("TC_NoSuchOperationError:\n") val s1 = ("TC_NoSuchOperationError:\n")
val s2 = ("Error Message: " ^ mes ^ "\n") val s2 = ("Error Message: " ^ mes ^ "\n")
val _ = trace exce (s1^s2)
in in
raise TC_WrongContextChecked h Logger.errorExn (TC_WrongContextChecked h) (s1^s2)
end end
)::(check_context_list context_list_tail model)) )::(check_context_list context_list_tail model))
handle TC_WrongContextChecked h => handle TC_WrongContextChecked h =>
@ -858,9 +847,8 @@ fun check_context_list [] model = []
val s1 = ("\n\n#################################################\n") val s1 = ("\n\n#################################################\n")
val s2 = ("WrongContextChecked:\n") val s2 = ("WrongContextChecked:\n")
val s3 = ("In Context: " ^ (cxt_list2string [h]) ^ "\n") val s3 = ("In Context: " ^ (cxt_list2string [h]) ^ "\n")
val _ = trace exce (s1^s2^s3)
in in
raise TC_RootError ("Something went wrong!\n") Logger.errorExn (TC_RootError "Something went wrong!\n") (s1^s2^s3)
end end
end end

255
su4sml/src/rep_core.sml
View File

@ -6,7 +6,7 @@
* This file is part of su4sml. * This file is part of su4sml.
* *
* Copyright (c) 2005-2007 ETH Zurich, Switzerland * Copyright (c) 2005-2007 ETH Zurich, Switzerland
* 2008 Achim D. Brucker, Germany * 2008-2009 Achim D. Brucker, Germany
* *
* All rights reserved. * All rights reserved.
* *
@ -865,7 +865,6 @@ end
structure Rep_Core : REP_CORE = structure Rep_Core : REP_CORE =
struct struct
open Rep_Helper open Rep_Helper
open Rep_Logger
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType
open XMI_DataTypes open XMI_DataTypes
@ -1075,9 +1074,9 @@ fun local_operations_of (Class{operations,...}) = operations
fun local_attributes_of (Class{attributes,...}) = attributes fun local_attributes_of (Class{attributes,...}) = attributes
| local_attributes_of (AssociationClass{attributes,...}) = attributes | local_attributes_of (AssociationClass{attributes,...}) = attributes
| local_attributes_of (Interface{...}) = | local_attributes_of (Interface{...}) =
error "in Rep.local_attributes_of: argument is Interface" Logger.error "in Rep.local_attributes_of: argument is Interface"
| local_attributes_of (Enumeration{...}) = | local_attributes_of (Enumeration{...}) =
error "in Rep.local_attributes_of: argument is Enumeration" Logger.error "in Rep.local_attributes_of: argument is Enumeration"
| local_attributes_of (Primitive{...}) = [] | local_attributes_of (Primitive{...}) = []
| local_attributes_of (Template{parameter,classifier}) = raise AttributeNotFoundError ("..._attributes_of a template not possible.\n") | local_attributes_of (Template{parameter,classifier}) = raise AttributeNotFoundError ("..._attributes_of a template not possible.\n")
@ -1087,7 +1086,7 @@ fun attributes_of class = local_attributes_of class
fun class_of_design_model path (model as (clist,alist)) = fun class_of_design_model path (model as (clist,alist)) =
let let
val _ = trace rep_core ("path of class = " ^ (String.concat (path)) ^ "\n") val _ = Logger.debug3 ("path of class = " ^ (String.concat (path)) ^ "\n")
in in
if (List.hd (path) = "holOclLib") if (List.hd (path) = "holOclLib")
then raise HOLOCL_ClassifierError ("You try to access an HOLOCL Classifier "^(string_of_path path) ^" which is not part of the model.\n") then raise HOLOCL_ClassifierError ("You try to access an HOLOCL Classifier "^(string_of_path path) ^" which is not part of the model.\n")
@ -1099,14 +1098,14 @@ fun class_of_design_model path (model as (clist,alist)) =
fun type_of_parent (Class {parent,...}) = fun type_of_parent (Class {parent,...}) =
let let
val _ = trace development ("type_of_parent : Class{parent,...} \n") val _ = Logger.debug4 ("type_of_parent : Class{parent,...} \n")
in in
Option.valOf(parent) Option.valOf(parent)
handle Option.Option => OclAny handle Option.Option => OclAny
end end
| type_of_parent (AssociationClass {parent,...}) = | type_of_parent (AssociationClass {parent,...}) =
let let
val _ = trace development ("type_of_parent : AssociationClass{parent,...} \n") val _ = Logger.debug4 ("type_of_parent : AssociationClass{parent,...} \n")
in in
Option.valOf(parent) Option.valOf(parent)
handle Option.Option => OclAny handle Option.Option => OclAny
@ -1200,7 +1199,7 @@ fun type_of_path ["Integer"] (model:transform_model) = Integer
fun class_of_term source (c:Classifier list, a:association list) = fun class_of_term source (c:Classifier list, a:association list) =
let let
val typ = type_of_term (source) val typ = type_of_term (source)
val _ = trace rep_core ("type_of_term term = " ^ (string_of_OclType typ) ^ "\n") val _ = Logger.debug3 ("type_of_term term = " ^ (string_of_OclType typ) ^ "\n")
fun class_of_t typ m = fun class_of_t typ m =
hd (List.filter (fn a => if ((type_of a) = typ) then true else false) m) hd (List.filter (fn a => if ((type_of a) = typ) then true else false) m)
fun substitute_classifier typ classifier = fun substitute_classifier typ classifier =
@ -1208,7 +1207,7 @@ fun class_of_term source (c:Classifier list, a:association list) =
fun substitute_args typ [] = [] fun substitute_args typ [] = []
| substitute_args typ ((s,t)::tail) = | substitute_args typ ((s,t)::tail) =
let let
val _ = trace low ("substitute argument : " ^ (string_of_OclType typ) val _ = Logger.debug4 ("substitute argument : " ^ (string_of_OclType typ)
^" template parameter of " ^ (string_of_OclType t) ^ " \n") ^" template parameter of " ^ (string_of_OclType t) ^ " \n")
in in
(s,substitute_typ typ t)::(substitute_args typ tail) (s,substitute_typ typ t)::(substitute_args typ tail)
@ -1224,10 +1223,9 @@ fun class_of_term source (c:Classifier list, a:association list) =
and substitute_operations typ [] = [] and substitute_operations typ [] = []
| substitute_operations typ ((oper:operation)::tail) = | substitute_operations typ ((oper:operation)::tail) =
let let
val _ = trace low ("substitute operation : " ^ (#name oper) ^ " ... \n") val _ = Logger.debug4 ("substitute operation : " ^ (#name oper) ^ " ... \n")
val args = substitute_args typ (#arguments oper) val args = substitute_args typ (#arguments oper)
val res = substitute_typ typ (#result oper) val res = substitute_typ typ (#result oper)
val _ = trace 100 ("check\n")
in in
({ ({
name = #name oper, name = #name oper,
@ -1244,7 +1242,7 @@ fun class_of_term source (c:Classifier list, a:association list) =
end end
and substitute_typ typ templ_type = and substitute_typ typ templ_type =
let let
val _ = trace low ("substitute type : " ^ (string_of_OclType typ) ^ " instead of " ^ (string_of_OclType templ_type) ^ " \n") val _ = Logger.debug4 ("substitute type : " ^ (string_of_OclType typ) ^ " instead of " ^ (string_of_OclType templ_type) ^ " \n")
in in
case templ_type of case templ_type of
(* innerst type *) (* innerst type *)
@ -1273,15 +1271,15 @@ fun class_of_term source (c:Classifier list, a:association list) =
(* else error *) (* else error *)
| _ => raise TemplateInstantiationError ("Template type not of type: Sequence, Set, OrderedSet, Collection or Bag") | _ => raise TemplateInstantiationError ("Template type not of type: Sequence, Set, OrderedSet, Collection or Bag")
end end
val _ = trace rep_core ("substitute classifier: parameter type: " ^ string_of_OclType typ ^ " template type: " ^ string_of_OclType (type_of classifier) ^ "\n") val _ = Logger.debug3 ("substitute classifier: parameter type: " ^ string_of_OclType typ ^ " template type: " ^ string_of_OclType (type_of classifier) ^ "\n")
(* val typ = parameter type *) (* val typ = parameter type *)
val styp = substitute_typ typ (type_of classifier) val styp = substitute_typ typ (type_of classifier)
val _ = trace rep_core ("substitute_classifier: end substitute_type \n") val _ = Logger.debug3 ("substitute_classifier: end substitute_type \n")
val ops = substitute_operations typ (local_operations_of classifier) val ops = substitute_operations typ (local_operations_of classifier)
val _ = trace 100 ("substitute parent.\n") val _ = Logger.debug4 ("substitute parent.\n")
val sparent = substitute_parent (type_of classifier) typ val sparent = substitute_parent (type_of classifier) typ
val _ = trace 100 ("end substitute parent.\n") val _ = Logger.debug4 ("end substitute parent.\n")
in in
(Class (Class
{ {
@ -1310,7 +1308,7 @@ fun class_of_term source (c:Classifier list, a:association list) =
fun templ_of temp_typ para_typ [] = raise TemplateInstantiationError ("Error during instantiating a template" ^ "\n") fun templ_of temp_typ para_typ [] = raise TemplateInstantiationError ("Error during instantiating a template" ^ "\n")
| templ_of temp_typ para_typ (Template{parameter,classifier}::tail) = | templ_of temp_typ para_typ (Template{parameter,classifier}::tail) =
let let
val _ = trace low ("Instantiate Template for classifier: " ^ (string_of_OclType (type_of classifier)) ^ "\n") val _ = Logger.debug4 ("Instantiate Template for classifier: " ^ (string_of_OclType (type_of classifier)) ^ "\n")
in in
if ((type_of classifier) = temp_typ) then if ((type_of classifier) = temp_typ) then
substitute_classifier para_typ classifier substitute_classifier para_typ classifier
@ -1319,11 +1317,11 @@ fun class_of_term source (c:Classifier list, a:association list) =
end end
| templ_of temp_typ para_typ (h::tail) = | templ_of temp_typ para_typ (h::tail) =
let let
val _ = trace development ("shit") val _ = Logger.debug4 ("shit")
in in
templ_of temp_typ para_typ tail templ_of temp_typ para_typ tail
end end
val _ = trace rep_core ("Now dispatch type ...\n") val _ = Logger.debug3 ("Now dispatch type ...\n")
in in
case typ of case typ of
(* Primitive types of lib *) (* Primitive types of lib *)
@ -1341,29 +1339,29 @@ fun class_of_term source (c:Classifier list, a:association list) =
| OclVoid => class_of_t OclVoid c | OclVoid => class_of_t OclVoid c
| OclAny => | OclAny =>
let let
val _ = trace rep_core ("type is OclAny") val _ = Logger.debug3 ("type is OclAny")
in in
class_of_t OclAny c class_of_t OclAny c
end end
(* Model types *) (* Model types *)
| Classifier (path) => | Classifier (path) =>
let let
val _ = trace development ("class_of_term: Classifier ("^(string_of_path path)^")\n") val _ = Logger.debug4 ("class_of_term: Classifier ("^(string_of_path path)^")\n")
val res = class_of_t (Classifier (path)) c val res = class_of_t (Classifier (path)) c
val _ = trace development ("found: "^(string_of_path (name_of res)) ^"\n") val _ = Logger.debug4 ("found: "^(string_of_path (name_of res)) ^"\n")
in in
(*class_of_t (Classifier (path)) model*) (*class_of_t (Classifier (path)) model*)
res res
end end
| DummyT => | DummyT =>
let let
val _ = trace development ("GetClassifierError: DummyT \n") val _ = Logger.debug4 ("GetClassifierError: DummyT \n")
in in
raise GetClassifierError ("No classifier of type: 'DummyT' \n") raise GetClassifierError ("No classifier of type: 'DummyT' \n")
end end
| TemplateParameter (string) => | TemplateParameter (string) =>
let let
val _ = trace development ("GetClassifierError: TemplateParameter ("^ string ^") \n") val _ = Logger.debug4 ("GetClassifierError: TemplateParameter ("^ string ^") \n")
in in
raise GetClassifierError ("No classifier of type: 'TemplateParameter (string)' \n") raise GetClassifierError ("No classifier of type: 'TemplateParameter (string)' \n")
end end
@ -1371,14 +1369,14 @@ fun class_of_term source (c:Classifier list, a:association list) =
fun class_of (name:Path) (model as (clist,alist)) = fun class_of (name:Path) (model as (clist,alist)) =
let let
val _ = trace rep_core ("top level package: " ^ (List.hd (name)) ^ "\n") val _ = Logger.debug3 ("top level package: " ^ (List.hd (name)) ^ "\n")
val _ = trace rep_core ("remaining package: " ^ (String.concat (List.tl name)) ^ "\n") val _ = Logger.debug3 ("remaining package: " ^ (String.concat (List.tl name)) ^ "\n")
in in
class_of_term (Variable("x",type_of_path name model)) model class_of_term (Variable("x",type_of_path name model)) model
handle TemplateInstantiationError s => handle TemplateInstantiationError s =>
let let
val _ = trace rep_core ("The path of the template parameter is not in the desing model.\n") val _ = Logger.debug3 ("The path of the template parameter is not in the desing model.\n")
val _ = trace rep_core ("Path = " ^ s ^ "\n") val _ = Logger.debug3 ("Path = " ^ s ^ "\n")
in in
raise TemplateError ("shit\n") raise TemplateError ("shit\n")
end end
@ -1386,9 +1384,9 @@ fun class_of (name:Path) (model as (clist,alist)) =
fun class_of_type (typ:OclType) (model:transform_model) = fun class_of_type (typ:OclType) (model:transform_model) =
let let
val _ = trace rep_core ("Rep_Core.class_of_type\n") val _ = Logger.debug3 ("Rep_Core.class_of_type\n")
val res = class_of_term (Variable ("x",typ)) model val res = class_of_term (Variable ("x",typ)) model
val _ = trace rep_core ("Rep_Core.class_of_type\n") val _ = Logger.debug3 ("Rep_Core.class_of_type\n")
in in
res res
end end
@ -1432,7 +1430,7 @@ fun type_equals Integer (Classifier ([OclLibPackage,"Real"])) = true
fun conforms_to_up _ OclAny (_:transform_model) = true fun conforms_to_up _ OclAny (_:transform_model) = true
| conforms_to_up (Set(T1)) (Collection(T2)) model = | conforms_to_up (Set(T1)) (Collection(T2)) model =
let let
val _ = trace low ("conforms_to_up: set -> collection \n") val _ = Logger.debug4 ("conforms_to_up: set -> collection \n")
in in
if (conforms_to T1 T2 model) then if (conforms_to T1 T2 model) then
true true
@ -1441,7 +1439,7 @@ fun conforms_to_up _ OclAny (_:transform_model) = true
end end
| conforms_to_up (Bag(T1)) (Collection(T2)) model = | conforms_to_up (Bag(T1)) (Collection(T2)) model =
let let
val _ = trace low ("conforms_to_up: bag -> collection \n") val _ = Logger.debug4 ("conforms_to_up: bag -> collection \n")
in in
if (conforms_to T1 T2 model) then if (conforms_to T1 T2 model) then
true true
@ -1450,7 +1448,7 @@ fun conforms_to_up _ OclAny (_:transform_model) = true
end end
| conforms_to_up (Sequence(T1)) (Collection(T2)) model = | conforms_to_up (Sequence(T1)) (Collection(T2)) model =
let let
val _ = trace low ("conforms_to_up: sequence -> collection \n") val _ = Logger.debug4 ("conforms_to_up: sequence -> collection \n")
in in
if (conforms_to T1 T2 model) then if (conforms_to T1 T2 model) then
true true
@ -1459,7 +1457,7 @@ fun conforms_to_up _ OclAny (_:transform_model) = true
end end
| conforms_to_up (OrderedSet(T1)) (Collection(T2)) model = | conforms_to_up (OrderedSet(T1)) (Collection(T2)) model =
let let
val _ = trace low ("conforms_to_up: orderedset -> collection \n") val _ = Logger.debug4 ("conforms_to_up: orderedset -> collection \n")
in in
if (conforms_to T1 T2 model) then if (conforms_to T1 T2 model) then
true true
@ -1470,7 +1468,7 @@ fun conforms_to_up _ OclAny (_:transform_model) = true
let let
val class = class_of_type typ1 model val class = class_of_type typ1 model
val parents_types = type_of_parents (class) model val parents_types = type_of_parents (class) model
val _ = trace low ("conforms_to_up: ... \n") val _ = Logger.debug4 ("conforms_to_up: ... \n")
in in
member (typ2) (parents_types) member (typ2) (parents_types)
end end
@ -1479,7 +1477,7 @@ and
(* RETRUN: Boolean *) (* RETRUN: Boolean *)
conforms_to x y (model:transform_model) = conforms_to x y (model:transform_model) =
let let
val _ = trace low ("conforms_to: " ^ string_of_OclType x ^ " -> " ^ string_of_OclType y ^ " ? \n") val _ = Logger.debug4 ("conforms_to: " ^ string_of_OclType x ^ " -> " ^ string_of_OclType y ^ " ? \n")
in in
if (x = y) then if (x = y) then
true true
@ -1505,9 +1503,9 @@ fun parent_name_of (C as Class{parent,...}) =
(case parent of NONE => name_of OclAnyAC (case parent of NONE => name_of OclAnyAC
| SOME p => path_of_OclType p ) | SOME p => path_of_OclType p )
| parent_name_of (Interface{...}) = | parent_name_of (Interface{...}) =
error "in Rep.parent_name_of: unsupported argument type Interface" Logger.error "in Rep.parent_name_of: unsupported argument type Interface"
| parent_name_of (E as Enumeration{parent,...}) = | parent_name_of (E as Enumeration{parent,...}) =
(case parent of NONE => error ("in Rep.parent_name_of: Enumeration "^ (case parent of NONE => Logger.error ("in Rep.parent_name_of: Enumeration "^
((string_of_path o name_of) E) ((string_of_path o name_of) E)
^" has no parent") ^" has no parent")
| SOME p => path_of_OclType p ) | SOME p => path_of_OclType p )
@ -1516,7 +1514,7 @@ fun parent_name_of (C as Class{parent,...}) =
(* error ("Primitive "^((string_of_path o name_of) D)^" has no parent") *) (* error ("Primitive "^((string_of_path o name_of) D)^" has no parent") *)
| SOME p => path_of_OclType p ) | SOME p => path_of_OclType p )
| parent_name_of (Template _) = | parent_name_of (Template _) =
error "in Rep.parent_name_of: unsupported argument type Template" Logger.error "in Rep.parent_name_of: unsupported argument type Template"
fun sig_conforms_to [] [] model = true fun sig_conforms_to [] [] model = true
| sig_conforms_to [] list model = | sig_conforms_to [] list model =
@ -1645,7 +1643,7 @@ fun isValueType Integer = true
| isValueType (Classifier s) = false | isValueType (Classifier s) = false
| isValueType DummyT = false | isValueType DummyT = false
| isValueType OclVoid = false | isValueType OclVoid = false
| isValueType t = error ("Error in isValueType(_,"^(string_of_OclType t)^")") | isValueType t = Logger.error ("Error in isValueType(_,"^(string_of_OclType t)^")")
@ -1695,7 +1693,7 @@ fun parent_of_template (cl as Class{parent,...}:Classifier) (model:transform_mod
fun parents_of_help (C:Classifier) (model:transform_model) = fun parents_of_help (C:Classifier) (model:transform_model) =
let let
val this_type = type_of C val this_type = type_of C
val _ = trace rep_core ("type of C = " ^ (string_of_OclType this_type) ^ "\n") val _ = Logger.debug3 ("type of C = " ^ (string_of_OclType this_type) ^ "\n")
in in
case this_type of case this_type of
OclAny => [] OclAny => []
@ -1765,9 +1763,9 @@ fun parents_of_help (C:Classifier) (model:transform_model) =
end end
| some_type => | some_type =>
let let
val _ = trace rep_core ("parent_of_template \n") val _ = Logger.debug3 ("parent_of_template \n")
val parent = parent_of_template C model val parent = parent_of_template C model
val _ = trace rep_core ("parent_of_template end, classifier = " val _ = Logger.debug3 ("parent_of_template end, classifier = "
^ (String.concat (name_of parent)) ^ "\n") ^ (String.concat (name_of parent)) ^ "\n")
in in
[parent]@(parents_of_help parent model) [parent]@(parents_of_help parent model)
@ -1780,7 +1778,7 @@ fun parent_of (C:Classifier) model = parent_of_template C model
fun parents_of (C:Classifier) model = fun parents_of (C:Classifier) model =
let let
val _ = trace rep_core ("parents_of ... \n") val _ = Logger.debug3 ("parents_of ... \n")
val helper = (parents_of_help C model) val helper = (parents_of_help C model)
in in
(if (helper = []) (if (helper = [])
@ -1832,50 +1830,50 @@ fun incomingAendsOfAssociation name allAssociations associationPath =
fun local_associationends_of (all_associations:association list) (Class{name,associations,...}):associationend list = fun local_associationends_of (all_associations:association list) (Class{name,associations,...}):associationend list =
let let
val _ = trace rep_core ("local_associationends_of 1 ... \n") val _ = Logger.debug3 ("local_associationends_of 1 ... \n")
val _ = trace rep_core ("classifier = " ^ (string_of_OclType name) ^ "\n") val _ = Logger.debug3 ("classifier = " ^ (string_of_OclType name) ^ "\n")
val oppAends = List.concat (List.map (fn a => val oppAends = List.concat (List.map (fn a =>
let let
val _ = trace rep_core ("Association path = ") val _ = Logger.debug3 ("Association path = ")
val _ = trace rep_core (string_of_path a ^ "\n") val _ = Logger.debug3 (string_of_path a ^ "\n")
in in
(oppositeAendsOfAssociation name all_associations a) (oppositeAendsOfAssociation name all_associations a)
end end
) associations) ) associations)
val _ = trace rep_core ("local_associationends_of 2 ... \n") val _ = Logger.debug3 ("local_associationends_of 2 ... \n")
val selfAends = map (incomingAendsOfAssociation name all_associations) associations val selfAends = map (incomingAendsOfAssociation name all_associations) associations
val _ = trace rep_core ("local_associationends_of 3 ... \n") val _ = Logger.debug3 ("local_associationends_of 3 ... \n")
val filteredSelfAends = List.concat (List.filter (fn x => length x >= 2) selfAends) val filteredSelfAends = List.concat (List.filter (fn x => length x >= 2) selfAends)
val _ = trace rep_core ("local_associationends_of 4 ... \n") val _ = Logger.debug3 ("local_associationends_of 4 ... \n")
in in
oppAends@filteredSelfAends oppAends@filteredSelfAends
end end
| local_associationends_of all_associations (AssociationClass{name,associations,association,...}) = | local_associationends_of all_associations (AssociationClass{name,associations,association,...}) =
(* association only contains endpoints to the other, pure classes *) (* association only contains endpoints to the other, pure classes *)
let let
val _ = trace rep_core ("local_associationends_of 1 AssoCl ... \n") val _ = Logger.debug3 ("local_associationends_of 1 AssoCl ... \n")
val assocs = if List.exists (fn x => x = association ) associations val assocs = if List.exists (fn x => x = association ) associations
then associations then associations
else association::associations else association::associations
val _ = trace rep_core ("local_associationends_of 2 AssoCl ... \n") val _ = Logger.debug3 ("local_associationends_of 2 AssoCl ... \n")
val oppAends = List.concat (map (oppositeAendsOfAssociation name all_associations) assocs) val oppAends = List.concat (map (oppositeAendsOfAssociation name all_associations) assocs)
val _ = trace rep_core ("local_associationends_of 3 AssoCl ... \n") val _ = Logger.debug3 ("local_associationends_of 3 AssoCl ... \n")
val selfAends = map (incomingAendsOfAssociation name all_associations) associations val selfAends = map (incomingAendsOfAssociation name all_associations) associations
val _ = trace rep_core ("local_associationends_of 4 AssoCl ... \n") val _ = Logger.debug3 ("local_associationends_of 4 AssoCl ... \n")
val filteredSelfAends = List.concat (List.filter (fn x => length x >= 2) selfAends) val filteredSelfAends = List.concat (List.filter (fn x => length x >= 2) selfAends)
val _ = trace rep_core ("local_associationends_of 5 AssoCl ... \n") val _ = Logger.debug3 ("local_associationends_of 5 AssoCl ... \n")
in in
oppAends@filteredSelfAends oppAends@filteredSelfAends
end end
| local_associationends_of all_associations (Primitive{name,associations,...}) = [] | local_associationends_of all_associations (Primitive{name,associations,...}) = []
(* let (* let
val _ = trace rep_core ("local_associationends_of 1 Primi... \n") val _ = Logger.debug3 ("local_associationends_of 1 Primi... \n")
val oppAends = List.concat (map (oppositeAendsOfAssociation name all_associations) associations) val oppAends = List.concat (map (oppositeAendsOfAssociation name all_associations) associations)
val _ = trace rep_core ("local_associationends_of 2 primi ... \n") val _ = Logger.debug3 ("local_associationends_of 2 primi ... \n")
val selfAends = map (incomingAendsOfAssociation name all_associations) associations val selfAends = map (incomingAendsOfAssociation name all_associations) associations
val _ = trace rep_core ("local_associationends_of 3 primi ... \n") val _ = Logger.debug3 ("local_associationends_of 3 primi ... \n")
val filteredSelfAends = List.concat (List.filter (fn x => length x >= 2) selfAends) val filteredSelfAends = List.concat (List.filter (fn x => length x >= 2) selfAends)
val _ = trace rep_core ("local_associationends_of 4 primi ... \n") val _ = Logger.debug3 ("local_associationends_of 4 primi ... \n")
in in
oppAends@filteredSelfAends oppAends@filteredSelfAends
end *) end *)
@ -1886,22 +1884,22 @@ fun associationends_of assocs classes = local_associationends_of assocs classes
(* get all inherited operations of a classifier, without the local operations *) (* get all inherited operations of a classifier, without the local operations *)
fun inherited_operations_of class (model as (clist,alist)) = fun inherited_operations_of class (model as (clist,alist)) =
let let
val _ = trace rep_core ("inh ops 0\n") val _ = Logger.debug3 ("inh ops 0\n")
val c_parents = parents_of class model val c_parents = parents_of class model
val _ = trace rep_core ("inh ops: parents = " ^ (String.concat (List.map (fn a => (string_of_path (name_of a))) c_parents)) ^ " \n") val _ = Logger.debug3 ("inh ops: parents = " ^ (String.concat (List.map (fn a => (string_of_path (name_of a))) c_parents)) ^ " \n")
val ops_of_par = (List.map (operations_of) c_parents) val ops_of_par = (List.map (operations_of) c_parents)
val _ = trace rep_core ("inh ops 2\n") val _ = Logger.debug3 ("inh ops 2\n")
in in
List.foldr (fn (a,b) => embed_local_operations a b model) (List.last (ops_of_par)) ops_of_par List.foldr (fn (a,b) => embed_local_operations a b model) (List.last (ops_of_par)) ops_of_par
end end
fun inherited_attributes_of class (model as (clist,alist)) = fun inherited_attributes_of class (model as (clist,alist)) =
let let
val _ = trace rep_core ("inh att 0\n") val _ = Logger.debug3 ("inh att 0\n")
val c_parents = parents_of class model val c_parents = parents_of class model
val _ = trace rep_core ("inh att 0\n") val _ = Logger.debug3 ("inh att 0\n")
val atts_of_par = (List.map (attributes_of) c_parents) val atts_of_par = (List.map (attributes_of) c_parents)
val _ = trace rep_core ("inh att 0\n") val _ = Logger.debug3 ("inh att 0\n")
in in
if (List.length(atts_of_par) = 0) if (List.length(atts_of_par) = 0)
then [] then []
@ -1910,12 +1908,12 @@ fun inherited_attributes_of class (model as (clist,alist)) =
fun inherited_associationends_of class (model as (clist,alist)) = fun inherited_associationends_of class (model as (clist,alist)) =
let let
val _ = trace rep_core ("inh assoEnd 0\n") val _ = Logger.debug3 ("inh assoEnd 0\n")
val c_parents = parents_of class model val c_parents = parents_of class model
val _ = trace rep_core ("inh assoEnd 1: parents = " ^ (String.concat (List.map (fn a => string_of_path (name_of a)) (c_parents))) ^ "\n") val _ = Logger.debug3 ("inh assoEnd 1: parents = " ^ (String.concat (List.map (fn a => string_of_path (name_of a)) (c_parents))) ^ "\n")
val assE_of_par = (List.map (associationends_of alist) c_parents) val assE_of_par = (List.map (associationends_of alist) c_parents)
val _ = trace rep_core ("inh assoEnd 2\n") val _ = Logger.debug3 ("inh assoEnd 2\n")
val _ = trace rep_core ("inh assoEnd 3: assocEnds of parents: " ^ (String.concat (List.map (fn a => (name_of_aend a)) (List.concat assE_of_par))) ^ "\n") val _ = Logger.debug3 ("inh assoEnd 3: assocEnds of parents: " ^ (String.concat (List.map (fn a => (name_of_aend a)) (List.concat assE_of_par))) ^ "\n")
in in
if (List.length(assE_of_par) = 0) if (List.length(assE_of_par) = 0)
then [] then []
@ -1926,9 +1924,9 @@ fun inherited_associationends_of class (model as (clist,alist)) =
fun all_operations_of class model = fun all_operations_of class model =
let let
val lo = local_operations_of class val lo = local_operations_of class
val _ = trace rep_core ("all ops of classifier : "^ (string_of_path (name_of class)) ^ "\n") val _ = Logger.debug3 ("all ops of classifier : "^ (string_of_path (name_of class)) ^ "\n")
val io = inherited_operations_of class model val io = inherited_operations_of class model
val _ = trace rep_core ("all ops 2\n") val _ = Logger.debug3 ("all ops 2\n")
in in
embed_local_operations lo io model embed_local_operations lo io model
end end
@ -1936,9 +1934,9 @@ fun all_operations_of class model =
fun all_attributes_of class model = fun all_attributes_of class model =
let let
val la = local_attributes_of class val la = local_attributes_of class
val _ = trace rep_core ("all atts of classifier : "^ (string_of_path (name_of class)) ^ "\n") val _ = Logger.debug3 ("all atts of classifier : "^ (string_of_path (name_of class)) ^ "\n")
val ia = inherited_attributes_of class model val ia = inherited_attributes_of class model
val _ = trace rep_core ("all atts 2\n") val _ = Logger.debug3 ("all atts 2\n")
in in
embed_local_attributes la ia model embed_local_attributes la ia model
end end
@ -1946,11 +1944,11 @@ fun all_attributes_of class model =
fun all_associationends_of class (model as (clist,alist)) = fun all_associationends_of class (model as (clist,alist)) =
let let
val la = local_associationends_of alist class val la = local_associationends_of alist class
val _ = trace rep_core ("all assocEnds of classifier : " ^ (String.concat (name_of class)) ^ "\n") val _ = Logger.debug3 ("all assocEnds of classifier : " ^ (String.concat (name_of class)) ^ "\n")
val _ = trace rep_core ("name of loacal assends: " ^ (String.concat (List.map (fn a => (name_of_aend a)) la)) ^ "\n") val _ = Logger.debug3 ("name of loacal assends: " ^ (String.concat (List.map (fn a => (name_of_aend a)) la)) ^ "\n")
val ia = inherited_associationends_of class model val ia = inherited_associationends_of class model
val _ = trace rep_core ("name of inherited assends: " ^ (String.concat (List.map (fn a => (name_of_aend a)) ia)) ^ "\n") val _ = Logger.debug3 ("name of inherited assends: " ^ (String.concat (List.map (fn a => (name_of_aend a)) ia)) ^ "\n")
val _ = trace rep_core ("all assocEnds \n") val _ = Logger.debug3 ("all assocEnds \n")
in in
embed_local_assocEnds la ia model embed_local_assocEnds la ia model
end end
@ -2258,12 +2256,12 @@ fun normalize (all_associations:association list)
invariant,stereotypes,interfaces,thyname, invariant,stereotypes,interfaces,thyname,
visibility,activity_graphs})):Classifier = visibility,activity_graphs})):Classifier =
let let
val _ = trace function_calls ("Rep_Core:normalize: class\n") val _ = Logger.debug2 ("Rep_Core:normalize: class\n")
val _ = trace function_arguments val _ = Logger.debug2
("number of associations: "^(Int.toString(List.length ("number of associations: "^(Int.toString(List.length
associations) associations)
)^"\n") )^"\n")
val _ = map (trace function_arguments o (fn x => val _ = map (Logger.debug2 o (fn x =>
"association path: "^x^"\n") "association path: "^x^"\n")
o string_of_path) associations o string_of_path) associations
fun mapPath (aend1,aend2) = (aend1,path_of_aend aend2) fun mapPath (aend1,aend2) = (aend1,path_of_aend aend2)
@ -2271,7 +2269,7 @@ fun normalize (all_associations:association list)
(* val aendPathPairs = map mapPath (bidirectionalPairs name all_associations (* val aendPathPairs = map mapPath (bidirectionalPairs name all_associations
associations)*) associations)*)
val aendPathPairs = bidirectionalPairs name all_associations associations val aendPathPairs = bidirectionalPairs name all_associations associations
val _ = trace function_ends ("Rep_Core: end normalize \n") val _ = Logger.debug2 ("Rep_Core: end normalize \n")
in in
Class {name = name, Class {name = name,
parent = parent, parent = parent,
@ -2298,8 +2296,8 @@ fun normalize (all_associations:association list)
thyname,visibility, activity_graphs})) = thyname,visibility, activity_graphs})) =
(* FIXME: how to handle AssociationClass.association? *) (* FIXME: how to handle AssociationClass.association? *)
let let
val _ = trace function_calls ("Rep_Core.normalize AssociationClass\n") val _ = Logger.debug2 ("Rep_Core.normalize AssociationClass\n")
val _ = trace function_arguments val _ = Logger.debug2
("number of associations: "^ ("number of associations: "^
(Int.toString (List.length associations ))^"\n") (Int.toString (List.length associations ))^"\n")
fun mapPath (aend1,aend2) = (aend1,path_of_aend aend2) fun mapPath (aend1,aend2) = (aend1,path_of_aend aend2)
@ -2326,7 +2324,7 @@ fun normalize (all_associations:association list)
associations = [], associations = [],
visibility=visibility, visibility=visibility,
association = [] (* FIXME? *)} association = [] (* FIXME? *)}
val _ = trace function_ends ("Rep_Core.normalize") val _ = Logger.debug2 ("Rep_Core.normalize")
in in
res res
end end
@ -2532,7 +2530,7 @@ fun update_thyname tname (Class{name,parent,attributes,operations,invariant,
interfaces=interfaces, interfaces=interfaces,
thyname=(SOME tname)} thyname=(SOME tname)}
| update_thyname _ (Template T) = | update_thyname _ (Template T) =
error ("in update_thyname: Template does not have a theory") Logger.error ("in update_thyname: Template does not have a theory")
fun update_invariant invariant' (Class{name,parent,attributes,operations, fun update_invariant invariant' (Class{name,parent,attributes,operations,
invariant,stereotypes,interfaces, invariant,stereotypes,interfaces,
@ -2596,7 +2594,7 @@ fun update_invariant invariant' (Class{name,parent,attributes,operations,
interfaces=interfaces, interfaces=interfaces,
thyname=thyname} thyname=thyname}
| update_invariant _ (Template T) = | update_invariant _ (Template T) =
error ("in update_invariant: Template does not have an invariant") Logger.error ("in update_invariant: Template does not have an invariant")
fun update_operations operations' (Class{name,parent,attributes,invariant, fun update_operations operations' (Class{name,parent,attributes,invariant,
@ -2663,7 +2661,7 @@ fun update_operations operations' (Class{name,parent,attributes,invariant,
interfaces=interfaces, interfaces=interfaces,
thyname=thyname} thyname=thyname}
| update_operations _ (Template T) = | update_operations _ (Template T) =
error ("in update_operations: Template does not have operations") Logger.error ("in update_operations: Template does not have operations")
fun update_precondition pre' ({name,precondition,postcondition,body,arguments, fun update_precondition pre' ({name,precondition,postcondition,body,arguments,
@ -2703,7 +2701,7 @@ fun visibility_of (Class{visibility,...}) = visibility
fun short_name_of C = case (name_of C) of fun short_name_of C = case (name_of C) of
[] => error "in Rep.short_name_of: empty type" [] => Logger.error "in Rep.short_name_of: empty type"
| p => (hd o rev) p | p => (hd o rev) p
fun stereotypes_of (Class{stereotypes,...}) = stereotypes fun stereotypes_of (Class{stereotypes,...}) = stereotypes
@ -2711,7 +2709,7 @@ fun stereotypes_of (Class{stereotypes,...}) = stereotypes
| stereotypes_of (Interface{stereotypes,...}) = stereotypes | stereotypes_of (Interface{stereotypes,...}) = stereotypes
| stereotypes_of (Enumeration{stereotypes,...}) = stereotypes | stereotypes_of (Enumeration{stereotypes,...}) = stereotypes
| stereotypes_of (Primitive{stereotypes,...}) = stereotypes | stereotypes_of (Primitive{stereotypes,...}) = stereotypes
| stereotypes_of (Template _) = error "in Rep.stereotypes_of: \ | stereotypes_of (Template _) = Logger.error "in Rep.stereotypes_of: \
\unsupported argument type Template" \unsupported argument type Template"
@ -2758,7 +2756,7 @@ fun substitute_package [] tpackage [] = raise Rep_CoreError ("Not possible to su
fun parent_short_name_of C = fun parent_short_name_of C =
(case (parent_name_of C) of (case (parent_name_of C) of
[] => error "in Rep.parent_short_name_of: empty type" [] => Logger.error "in Rep.parent_short_name_of: empty type"
| p => (hd o rev) p) | p => (hd o rev) p)
fun parent_package_of (Class{parent,...}) = fun parent_package_of (Class{parent,...}) =
@ -2776,9 +2774,9 @@ fun parent_package_of (Class{parent,...}) =
else [] else []
end) end)
| parent_package_of (Interface{...}) = | parent_package_of (Interface{...}) =
error "in Rep.parent_package_of: unsupported argument type Interface" Logger.error "in Rep.parent_package_of: unsupported argument type Interface"
| parent_package_of (E as Enumeration{parent,...}) = | parent_package_of (E as Enumeration{parent,...}) =
(case parent of NONE => error ("in Rep.parent_package_of: Enumeration "^ (case parent of NONE => Logger.error ("in Rep.parent_package_of: Enumeration "^
(string_of_path o name_of) E^ (string_of_path o name_of) E^
" has no parent") " has no parent")
| SOME q => let val p = path_of_OclType q in | SOME q => let val p = path_of_OclType q in
@ -2788,14 +2786,14 @@ fun parent_package_of (Class{parent,...}) =
end ) end )
| parent_package_of (Primitive{parent,...}) = | parent_package_of (Primitive{parent,...}) =
(case parent of NONE => package_of OclAnyC (case parent of NONE => package_of OclAnyC
(* NONE => error "Primitive has no parent" *) (* NONE => Logger.error "Primitive has no parent" *)
| SOME q => let val p = path_of_OclType q in | SOME q => let val p = path_of_OclType q in
if (length p) > 1 if (length p) > 1
then (take (((length p) -1),p)) then (take (((length p) -1),p))
else [] else []
end) end)
| parent_package_of (Template{...}) = | parent_package_of (Template{...}) =
error "in Rep.parent_package_of: unsupported argument type Template" Logger.error "in Rep.parent_package_of: unsupported argument type Template"
(* Get parent interfaces of a Classifier. *) (* Get parent interfaces of a Classifier. *)
@ -2804,7 +2802,7 @@ fun parent_interfaces_of (Interface{parents,...}) = parents
| parent_interfaces_of (AssociationClass{interfaces,...}) = interfaces | parent_interfaces_of (AssociationClass{interfaces,...}) = interfaces
| parent_interfaces_of (Enumeration{interfaces,...}) = interfaces | parent_interfaces_of (Enumeration{interfaces,...}) = interfaces
| parent_interfaces_of (Primitive{interfaces,...}) = interfaces | parent_interfaces_of (Primitive{interfaces,...}) = interfaces
| parent_interfaces_of (Template{...}) = error "parent_interfaces_of <Template> not supported" | parent_interfaces_of (Template{...}) = Logger.error "parent_interfaces_of <Template> not supported"
@ -2818,7 +2816,7 @@ fun p_invariant_of (Class{invariant,...}) = invariant
| p_invariant_of (Interface{invariant,...}) = invariant | p_invariant_of (Interface{invariant,...}) = invariant
| p_invariant_of (Enumeration{invariant,...}) = invariant | p_invariant_of (Enumeration{invariant,...}) = invariant
| p_invariant_of (Primitive{invariant,...}) = invariant | p_invariant_of (Primitive{invariant,...}) = invariant
| p_invariant_of (Template _) = error "in Rep.p_invariant_of: \ | p_invariant_of (Template _) = Logger.error "in Rep.p_invariant_of: \
\unsupported argument type Template" \unsupported argument type Template"
fun invariant_of C = fun invariant_of C =
@ -2847,29 +2845,29 @@ fun name_of_ae ({name,...}:associationend) = name
fun thy_name_of (C as Class{thyname,...}) = fun thy_name_of (C as Class{thyname,...}) =
(case thyname of SOME tname => tname (case thyname of SOME tname => tname
| NONE => error ("Class "^((string_of_path o name_of) C)^ | NONE => Logger.error ("Class "^((string_of_path o name_of) C)^
" has no thyname")) " has no thyname"))
| thy_name_of (AC as AssociationClass{thyname,...}) = | thy_name_of (AC as AssociationClass{thyname,...}) =
(case thyname of SOME tname => tname (case thyname of SOME tname => tname
| NONE => error ("AssociationClass "^((string_of_path o | NONE => Logger.error ("AssociationClass "^((string_of_path o
name_of) AC)^ name_of) AC)^
" has no thyname")) " has no thyname"))
| thy_name_of (I as Interface{thyname,...}) = | thy_name_of (I as Interface{thyname,...}) =
(case thyname of SOME tname => tname (case thyname of SOME tname => tname
| NONE => error ("Interface "^((string_of_path o | NONE => Logger.error ("Interface "^((string_of_path o
name_of) I) name_of) I)
^" has no thyname")) ^" has no thyname"))
| thy_name_of (E as Enumeration{thyname,...}) = | thy_name_of (E as Enumeration{thyname,...}) =
(case thyname of SOME tname => tname (case thyname of SOME tname => tname
| NONE => error ("Enumeration "^((string_of_path o | NONE => Logger.error ("Enumeration "^((string_of_path o
name_of) E) name_of) E)
^" has no thyname")) ^" has no thyname"))
| thy_name_of (P as Primitive{thyname,...}) = | thy_name_of (P as Primitive{thyname,...}) =
(case thyname of SOME tname => tname (case thyname of SOME tname => tname
| NONE => error ("Primitive "^((string_of_path o | NONE => Logger.error ("Primitive "^((string_of_path o
name_of) P)^ name_of) P)^
" has no thyname")) " has no thyname"))
| thy_name_of (Template _) = error "in Rep.thy_name_of: \ | thy_name_of (Template _) = Logger.error "in Rep.thy_name_of: \
\unsupported argument type Template" \unsupported argument type Template"
@ -3326,7 +3324,7 @@ fun connected_classifiers_of (all_associations:association list)
fun upcastable_args [] [] model = true fun upcastable_args [] [] model = true
| upcastable_args ((str,typ)::tail) ((term,ttyp)::args) model = | upcastable_args ((str,typ)::tail) ((term,ttyp)::args) model =
let let
val _ = trace low ("must conform to: " ^ (string_of_OclType typ) ^ "\n") val _ = Logger.debug4 ("must conform to: " ^ (string_of_OclType typ) ^ "\n")
in in
if (conforms_to (type_of_term term) typ model) then if (conforms_to (type_of_term term) typ model) then
true true
@ -3341,7 +3339,7 @@ fun upcastable_args [] [] model = true
fun upcast_args [] [] model = [] fun upcast_args [] [] model = []
| upcast_args ((str,typ)::tail) ((term,_)::args) model = | upcast_args ((str,typ)::tail) ((term,_)::args) model =
let let
val _ = trace low ("interfere args" ^ "\n") val _ = Logger.debug4 ("interfere args" ^ "\n")
in in
if (type_equals typ (type_of_term term)) then if (type_equals typ (type_of_term term)) then
(term,type_of_term term)::(upcast_args tail args model) (term,type_of_term term)::(upcast_args tail args model)
@ -3362,17 +3360,17 @@ fun upcast_type t1 t2 model =
(* RETURN: OclTerm *) (* RETURN: OclTerm *)
fun upcast_op [] source args model = fun upcast_op [] source args model =
let let
val _ = trace development ("UpcastingError ... \n") val _ = Logger.debug4 ("UpcastingError ... \n")
in in
raise UpcastingError ("interefere_methods: No operation signature matches given types.") raise UpcastingError ("interefere_methods: No operation signature matches given types.")
end end
| upcast_op ((class,meth)::class_meth_list) source args model = | upcast_op ((class,meth)::class_meth_list) source args model =
let let
val _ = trace low ("Interfere method : name : '" ^ name_of_op meth ^ "'\n") val _ = Logger.debug4 ("Interfere method : name : '" ^ name_of_op meth ^ "'\n")
val check_source = conforms_to (type_of_term source) (type_of class) model val check_source = conforms_to (type_of_term source) (type_of class) model
val check_args = upcastable_args (#arguments meth) args model val check_args = upcastable_args (#arguments meth) args model
val _ = trace low ("Upcastable ? : Source conforms : " ^ Bool.toString check_source ^ " Args conforms : " ^ Bool.toString check_args ^ "\n") val _ = Logger.debug4 ("Upcastable ? : Source conforms : " ^ Bool.toString check_source ^ " Args conforms : " ^ Bool.toString check_args ^ "\n")
val _ = trace low ("Return type of method : " ^ string_of_OclType (result_of_op meth) ^ "\n\n") val _ = Logger.debug4 ("Return type of method : " ^ string_of_OclType (result_of_op meth) ^ "\n\n")
in in
if (check_source andalso check_args) then if (check_source andalso check_args) then
(* signature matches given types *) (* signature matches given types *)
@ -3385,7 +3383,7 @@ fun upcast_op [] source args model =
fun upcast_att (class,attr:attribute) source (model:transform_model) = fun upcast_att (class,attr:attribute) source (model:transform_model) =
let let
val check_source = conforms_to (type_of_term source) (type_of class) model 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") val _ = Logger.debug4 ("interfere attribute: check_source "^ Bool.toString check_source ^ "\n\n")
in in
if check_source then if check_source then
(* signature matches given types *) (* signature matches given types *)
@ -3398,8 +3396,8 @@ fun upcast_att (class,attr:attribute) source (model:transform_model) =
fun upcast_aend (class,assocend:associationend) source (model:transform_model) = fun upcast_aend (class,assocend:associationend) source (model:transform_model) =
let let
val check_source = conforms_to (type_of_term source) (type_of class) model 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 _ = Logger.debug4 ("Interfere assocend: check_source " ^ Bool.toString check_source ^ "\n")
val _ = trace low ("type of assoc " ^ string_of_OclType (convert_aend_type assocend) ^ "\n") val _ = Logger.debug4 ("type of assoc " ^ string_of_OclType (convert_aend_type assocend) ^ "\n")
in in
if check_source then if check_source then
(* billk_tag *) (* billk_tag *)
@ -3464,12 +3462,12 @@ fun end_of_recursion classifier =
fun get_overloaded_methods class op_name model = fun get_overloaded_methods class op_name model =
let let
val _ = trace rep_core ("get_overloaded_methods, look for operation = " ^ op_name ^ "\n") val _ = Logger.debug3 ("get_overloaded_methods, look for operation = " ^ op_name ^ "\n")
val parents = parents_of class model val parents = parents_of class model
val loc_ops = List.map (fn a => (class,a)) (local_operations_of class) val loc_ops = List.map (fn a => (class,a)) (local_operations_of class)
val cl_op_list = (loc_ops)@(List.concat (List.map (fn a => (List.map (fn b => (a,b)) (all_operations_of a model))) parents)) val cl_op_list = (loc_ops)@(List.concat (List.map (fn a => (List.map (fn b => (a,b)) (all_operations_of a model))) parents))
val cls_ops = List.filter (fn (a,b) => if (name_of_op b = op_name) then true else false) cl_op_list val cls_ops = List.filter (fn (a,b) => if (name_of_op b = op_name) then true else false) cl_op_list
val _ = trace rep_core ("number of overloaded operations found = " ^ Int.toString(List.length(cls_ops)) ^ "\n") val _ = Logger.debug3 ("number of overloaded operations found = " ^ Int.toString(List.length(cls_ops)) ^ "\n")
in in
cls_ops cls_ops
end end
@ -3480,14 +3478,14 @@ fun last_implementation_of_op class op_name model =
fun get_overloaded_methods class op_name ([],_) = raise NoModelReferenced ("in 'get_overloaded_methods' ...\n") fun get_overloaded_methods class op_name ([],_) = raise NoModelReferenced ("in 'get_overloaded_methods' ...\n")
| get_overloaded_methods class op_name (model as (classifiers,associations)) = | get_overloaded_methods class op_name (model as (classifiers,associations)) =
let let
val _ = trace function_calls "get_overloaded_methods\n" val _ = Logger.debug2 "get_overloaded_methods\n"
val _ = trace low("\n") val _ = Logger.debug4("\n")
val ops = local_operations_of class val ops = local_operations_of class
val _ = trace low("Look for methods for classifier: " ^ string_of_OclType (type_of class) ^ "\n") val _ = Logger.debug4("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 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 _ = Logger.debug4("operation name : " ^ op_name ^ " Found " ^ Int.toString (List.length ops2) ^ " method(s) \n")
val parent = parent_of class model val parent = parent_of class model
val _ = trace low("Parent class : " ^ string_of_OclType (type_of parent) ^ "\n\n") val _ = Logger.debug4("Parent class : " ^ string_of_OclType (type_of parent) ^ "\n\n")
val cl_op = List.map (fn a => (class,a)) ops2 val cl_op = List.map (fn a => (class,a)) ops2
in in
if (class = class_of_type OclAny model) if (class = class_of_type OclAny model)
@ -3514,7 +3512,7 @@ fun get_overloaded_methods class op_name ([],_) = raise NoModelReferenced ("in '
fun get_overloaded_attrs_or_assocends class attr_name (model as (clist,alist)) = fun get_overloaded_attrs_or_assocends class attr_name (model as (clist,alist)) =
let let
val _ = trace function_calls val _ = Logger.debug2
("Rep_Core.get_overloaded_attrs_or_assocends, look for attr_or_assoc = " ("Rep_Core.get_overloaded_attrs_or_assocends, look for attr_or_assoc = "
^ attr_name ^ attr_name
^ "\n") ^ "\n")
@ -3524,7 +3522,7 @@ fun get_overloaded_attrs_or_assocends class attr_name (model as (clist,alist)) =
val cl_att_list = (loc_atts)@(List.concat (List.map (fn a => (List.map (fn b => (a,b)) (all_attributes_of a model))) parents)) val cl_att_list = (loc_atts)@(List.concat (List.map (fn a => (List.map (fn b => (a,b)) (all_attributes_of a model))) parents))
val cls_atts = List.filter (fn (a,b) => if (name_of_att b = attr_name) then true else false) cl_att_list val cls_atts = List.filter (fn (a,b) => if (name_of_att b = attr_name) then true else false) cl_att_list
(* Associations *) (* Associations *)
val _ = trace rep_core ("middle get_overloaded_attrs_or_assocends \n") val _ = Logger.debug3 ("middle get_overloaded_attrs_or_assocends \n")
val loc_assE = List.map (fn a => (class,a)) (local_associationends_of alist class) val loc_assE = List.map (fn a => (class,a)) (local_associationends_of alist class)
val cl_assE_list = (loc_assE)@(List.concat (List.map (fn a => (List.map (fn b => (a,b)) (all_associationends_of a model))) parents)) val cl_assE_list = (loc_assE)@(List.concat (List.map (fn a => (List.map (fn b => (a,b)) (all_associationends_of a model))) parents))
val cls_assEs = List.filter (fn (a,b) => if (name_of_aend b = attr_name) then true else false) cl_assE_list val cls_assEs = List.filter (fn (a,b) => if (name_of_aend b = attr_name) then true else false) cl_assE_list
@ -3551,7 +3549,7 @@ fun get_overloaded_attrs_or_assocends class attr_name (model as (clist,alist)) =
else else
raise AttributeAssocEndNameClash ("Attributes and AssocEnd in same inheritance tree are named equal.\n") raise AttributeAssocEndNameClash ("Attributes and AssocEnd in same inheritance tree are named equal.\n")
) )
val _ = trace function_ends ("Rep_Core.get_overloaded_attrs_or_assocends\n") val _ = Logger.debug2 ("Rep_Core.get_overloaded_attrs_or_assocends\n")
in in
res res
end end
@ -3559,29 +3557,29 @@ fun get_overloaded_attrs_or_assocends class attr_name (model as (clist,alist)) =
fun get_meth source op_name args (model as (classifiers,associations))= fun get_meth source op_name args (model as (classifiers,associations))=
(* object type *) (* object type *)
let let
val _ = trace function_calls ("Rep_Core: get_meth: Type of Classifier : " ^ string_of_OclType (type_of_term source ) ^ "\n") val _ = Logger.debug2 ("Rep_Core: get_meth: Type of Classifier : " ^ string_of_OclType (type_of_term source ) ^ "\n")
val class = class_of_term source model val class = class_of_term source model
val meth_list = get_overloaded_methods class op_name model val meth_list = get_overloaded_methods class op_name model
val res = upcast_op meth_list source args model val res = upcast_op meth_list source args model
val _ = trace function_ends ("Rep_Core: overloaded methods found: " ^ Int.toString (List.length meth_list) ^ "\n") val _ = Logger.debug2 ("Rep_Core: overloaded methods found: " ^ Int.toString (List.length meth_list) ^ "\n")
in in
res res
end end
fun get_attr_or_assoc source attr_name (model as (classifiers,associations)) = fun get_attr_or_assoc source attr_name (model as (classifiers,associations)) =
let let
val _ = trace function_calls ("Rep_Core.get_attr_or_assoc\n") val _ = Logger.debug2 ("Rep_Core.get_attr_or_assoc\n")
val _ = trace rep_core ("GET ATTRIBUTES OR ASSOCENDS: source term.\n") val _ = Logger.debug3 ("GET ATTRIBUTES OR ASSOCENDS: source term.\n")
val class = class_of_term source model val class = class_of_term source model
val attr_or_assocend_list = get_overloaded_attrs_or_assocends class attr_name model val attr_or_assocend_list = get_overloaded_attrs_or_assocends class attr_name model
val res = val res =
let let
val x = upcast_att_aend attr_or_assocend_list source model val x = upcast_att_aend attr_or_assocend_list source model
val _ = trace rep_core ("Return type of attribute: " ^ string_of_OclType (type_of_term x) ^ "\n\n") val _ = Logger.debug3 ("Return type of attribute: " ^ string_of_OclType (type_of_term x) ^ "\n\n")
in in
x x
end end
val _ = trace function_ends ("Rep_Core.end get_attr_or_assoc\n") val _ = Logger.debug2 ("Rep_Core.end get_attr_or_assoc\n")
in in
res res
end end
@ -3693,7 +3691,6 @@ fun string_to_type "Integer" = Integer
val cons = (#1 tokens) val cons = (#1 tokens)
(* delete first "(" and last ")" element *) (* delete first "(" and last ")" element *)
val tail = List.tl (real_path (#2 tokens)) val tail = List.tl (real_path (#2 tokens))
val _ = trace important ("tail "^ (String.implode tail) ^ "\n")
in in
string_to_cons (String.implode cons) (string_to_type (String.implode tail)) string_to_cons (String.implode cons) (string_to_type (String.implode tail))
end end

256
su4sml/src/rep_logger.sml
View File

@ -2,10 +2,11 @@
* su4sml --- a SML repository for managing (Secure)UML/OCL models * su4sml --- a SML repository for managing (Secure)UML/OCL models
* http://projects.brucker.ch/su4sml/ * http://projects.brucker.ch/su4sml/
* *
* library.sml --- * logger.sml ---
* This file is part of su4sml. * This file is part of su4sml.
* *
* Copyright (c) 2005-2007, ETH Zurich, Switzerland * Copyright (c) 2005-2007 ETH Zurich, Switzerland
* 2008-2009 Achim D. Brucker, Germany
* *
* All rights reserved. * All rights reserved.
* *
@ -38,46 +39,130 @@
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************) ******************************************************************************)
(* $Id$ *) (* $Id$ *)
signature LOGGER =
sig
type log_level
val set_log_level : log_level -> unit
val get_log_level : unit -> log_level
val set_strict_logging : bool -> unit
val get_strict_logging : unit -> bool
val ERROR : log_level
val WARN : log_level
val INFO : log_level
val DEBUG_1 : log_level
val DEBUG_2 : log_level
val DEBUG_3 : log_level
val DEBUG_4 : log_level
val DEBUG_5 : log_level
val get_log_level_str : unit -> string
val error: string -> 'a
val errorExn: exn -> string -> 'a
val warn: string -> unit
val info: string -> unit
val debug1: string -> unit
val debug2: string -> unit
val debug3: string -> unit
val debug4: string -> unit
val debug5: string -> unit
end
structure Logger:>LOGGER =
struct
type log_level = int
fun std_output s = print s
fun std_error s = (TextIO.output (TextIO.stdErr, s); TextIO.flushOut TextIO.stdErr )
infix 1 |>
fun x |> f = f x
val ERROR = 0
val WARN = 10
val INFO = 20
val DEBUG_1 = 30
val DEBUG_2 = 40
val DEBUG_3 = 50
val DEBUG_4 = 60
val DEBUG_5 = 70
val logLevel = ref WARN
fun set_log_level l = (logLevel := l;())
fun get_log_level () = !logLevel
val strictLogging = ref false
fun set_strict_logging l = (strictLogging := l;())
fun get_strict_logging () = !strictLogging
fun get_log_level_str () = case !logLevel of
0 => "error"
| 10 => "warn"
| 20 => "info"
| 30 => "debug 1"
| 40 => "debug 2"
| 50 => "debug 3"
| 60 => "debug 4"
| _ => "debug 5"
fun separate s (x :: (xs as _ :: _)) = x :: s :: separate s xs
| separate _ xs = xs;
fun space_implode a bs = String.concat (separate a bs)
fun space_explode _ "" = []
| space_explode sep s = String.fields (fn c => str c = sep) s
val split_lines = space_explode "\n"
val cat_lines = space_implode "\n"
fun prefix_lines "" txt = txt
| prefix_lines prfx txt = txt |> split_lines |> map (fn s => prfx ^ s) |> cat_lines;
fun prefix prfx s = prfx ^ s
fun suffix sffx s = s ^ sffx
fun mk_error_string s = s |> prefix_lines "*** " |> suffix "\n"
fun mk_warn_string s = s |> prefix_lines "### " |> suffix "\n"
fun mk_info_string s = s |> prefix_lines "+++ " |> suffix "\n"
fun mk_debug_string s = s |> prefix_lines "::: " |> suffix "\n"
fun trace log msg = if (!strictLogging andalso log = !logLevel) orelse (not (!strictLogging) andalso log <= !logLevel)
then print msg
else ()
fun error s = ((print o mk_error_string) s; raise Fail s)
fun errorExn ex s = ((print o mk_error_string) s; raise ex)
fun warn msg = msg |> mk_warn_string |> trace WARN
fun info msg = msg |> mk_info_string |> trace INFO
fun debug1 msg = msg |> mk_debug_string |> trace DEBUG_1
fun debug2 msg = msg |> mk_debug_string |> trace DEBUG_2
fun debug3 msg = msg |> mk_debug_string |> trace DEBUG_3
fun debug4 msg = msg |> mk_debug_string |> trace DEBUG_4
fun debug5 msg = msg |> mk_debug_string |> trace DEBUG_5
(*
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
(*
signature REP_LOGGER = signature REP_LOGGER =
sig sig
val trace : int -> string -> unit end
val init_offset : unit -> unit structure Rep_Logger:>REP_LOGGER =
val error : string -> 'a
val error_msg : string -> unit
val print_stderr : TextIO.vector -> unit
val warn : string -> unit
val info : string -> unit
val log_level : int ref
val line_offset : int ref
(**
* log_levels
*)
val zero : int
val exce : int
val high : int
val medium : int
val function_calls : int
val function_ends : int
val function_arguments : int
val important : int
val wgen : int
val type_checker : int
val preprocessor : int
val rep_core : int
val low : int
val development : int
val isa_metho : int
val su4sml_home : unit -> string
end
structure Rep_Logger:REP_LOGGER =
struct struct
open Rep_Helper open Rep_Helper
(* minimal tracing support (modifed version of ocl_parser tracing *) (* minimal tracing support (modifed version of ocl_parser tracing *)
val log_level = ref 6 val log_level = ref 6
@ -134,15 +219,9 @@ fun embed_newline s =
fun trace lev s = fun trace lev s =
case lev of case lev of
6 => 6 =>
let
val s1 = ("\n\n\n##################################################\n")
val s2 = ("############## EXCEPTION MESSAGE ################\n")
val s3 = ("##################################################\n\n")
in
if (lev <= !log_level ) if (lev <= !log_level )
then print(s1^s2^s3^(embed_newline s)) then print(embed_newline s)
else () else ()
end
| 25 => | 25 =>
let let
val _ = if (lev <= !log_level ) val _ = if (lev <= !log_level )
@ -175,89 +254,6 @@ fun trace lev s =
else () else ()
) )
(* HOLOCL_HOME resp. SU4SML_HOME should point to the top-level directory *)
(* 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 => (case OS.Process.getEnv "UML2CDL_HOME" of
SOME p => p^"../../../src"
| NONE => ".")
)
fun filter (pred: 'a->bool) : 'a list -> 'a list =
let fun filt [] = []
| filt (x :: xs) = if pred x then x :: filt xs else filt xs
in filt end;
fun real_path x = List.rev (List.tl (List.rev x))
fun optlist2list [] = []
| optlist2list (h::tail) =
(
case h of
NONE => optlist2list (tail)
| SOME (e) => (e::(optlist2list tail))
)
fun exists (pred: 'a -> bool) : 'a list -> bool =
let fun boolf [] = false
| boolf (x :: xs) = pred x orelse boolf xs
in boolf end;
fun append xs ys = xs @ ys;
fun find _ [] = Option.NONE
| find p (x :: xs) = if p x then Option.SOME x else find p xs;
fun swap1 f a b c = f c b a
(* fun getenv var =
(case OS.Process.getEnv var of
NONE => ""
| SOME txt => txt);
*)
(*
fun print_depth n =
(Control.Print.printDepth := n div 2;
Control.Print.printLength := n);
*)
val cd = OS.FileSys.chDir
val pwd = OS.FileSys.getDir
(* use Option.map instead
fun ap_some f (SOME x) = SOME(f x)
|ap_some f NONE = NONE
*)
fun separate s (x :: (xs as _ :: _)) = x :: s :: separate s xs
| separate _ xs = xs;
(* fun suffix sfx s = s ^ sfx;*)
fun space_implode a bs = implode (separate a bs);
fun print_stderr s = (TextIO.output (TextIO.stdErr, s); TextIO.flushOut TextIO.stdErr);
exception ERROR;
(** output an informational message about what is going on. *)
fun info s = print (s^"\n")
(** output a warning that something is wrong,
* but it is dealt with somehow. *)
fun warn s = print ("Warning: "^s^"\n")
(** output an error message *)
fun error_msg s = print (s^"\n")
(** output an error message and Fail *)
fun error s = (print (s^"\n"); raise Fail s)
end end
*)

4
su4sml/src/rep_ocl.sml
View File

@ -5,7 +5,8 @@
* rep_ocl.sml --- * rep_ocl.sml ---
* This file is part of su4sml. * This file is part of su4sml.
* *
* Copyright (c) 2005-2007, ETH Zurich, Switzerland * Copyright (c) 2005-2007 ETH Zurich, Switzerland
* 2008-2009 Achim D. Brucker, Germany
* *
* All rights reserved. * All rights reserved.
* *
@ -136,7 +137,6 @@ end
structure Rep_OclType : REP_OCL_TYPE = structure Rep_OclType : REP_OCL_TYPE =
struct struct
open Rep_Helper open Rep_Helper
open Rep_Logger
type Path = string list type Path = string list

139
su4sml/src/rep_parser.sml
View File

@ -5,7 +5,8 @@
* rep_parser.sml --- an xmi-parser for the import interface for su4sml * rep_parser.sml --- an xmi-parser for the import interface for su4sml
* This file is part of su4sml. * This file is part of su4sml.
* *
* Copyright (c) 2005-2007, ETH Zurich, Switzerland * Copyright (c) 2005-2007 ETH Zurich, Switzerland
* 2008-2009 Achim D. Brucker, Germany
* *
* All rights reserved. * All rights reserved.
* *
@ -45,11 +46,10 @@ structure RepParser :
val transformXMI_ext : XMI.XmiContent -> Rep.transform_model val transformXMI_ext : XMI.XmiContent -> Rep.transform_model
val readFile : string -> Rep.Model val readFile : string -> Rep.Model
val importArgoUML : string -> Rep.Model val importArgoUML : string -> Rep.Model
val test: (string * string list) -> OS.Process.status (* val test: (string * string list) -> OS.Process.status *)
(* generic exception if something is wrong *) (* generic exception if something is wrong *)
end = end =
struct struct
open Rep_Logger
open Xmi_IDTable open Xmi_IDTable
@ -179,7 +179,7 @@ fun transform_expression t (XMI.LiteralExp {symbol,expression_type}) =
find_classifier_type t expression_type find_classifier_type t expression_type
) )
end end
| transform_expression t _ = error "unsupported OCL expression type" | transform_expression t _ = Logger.error "unsupported OCL expression type"
and transform_collection_part t (XMI.CollectionItem {item,expression_type}) = and transform_collection_part t (XMI.CollectionItem {item,expression_type}) =
Rep_OclTerm.CollectionItem (transform_expression t item, Rep_OclTerm.CollectionItem (transform_expression t item,
find_classifier_type t expression_type) find_classifier_type t expression_type)
@ -195,7 +195,7 @@ fun transform_constraint t ({xmiid,name,body,...}:XMI.Constraint) =
| NONE => NONE | NONE => NONE
in in
(n_name,transform_expression t body) (n_name,transform_expression t body)
handle ex => (print ("Warning: in RepParser.transform_constraint: \ handle ex => (Logger.warn ("Warning: in RepParser.transform_constraint: \
\Could not parse Constraint: "^General.exnMessage ex^"\n"^ \Could not parse Constraint: "^General.exnMessage ex^"\n"^
"using the trivial constraint 'true' instead"); "using the trivial constraint 'true' instead");
(NONE, triv_expr)) (NONE, triv_expr))
@ -211,7 +211,7 @@ fun transform_bodyconstraint result_type t ({xmiid,name,body,...}:XMI.Constraint
equal,[(body,body_type)], equal,[(body,body_type)],
Rep_OclType.Boolean)) Rep_OclType.Boolean))
end end
handle ex => (print ("Warning: in RepParser.transform_bodyconstraint: \ handle ex => (Logger.warn ("Warning: in RepParser.transform_bodyconstraint: \
\Could not parse Constraint: "^ \Could not parse Constraint: "^
General.exnMessage ex^"\n"^ General.exnMessage ex^"\n"^
"using the trivial constraint 'true' instead"); "using the trivial constraint 'true' instead");
@ -219,7 +219,7 @@ fun transform_bodyconstraint result_type t ({xmiid,name,body,...}:XMI.Constraint
fun transform_parameter t {xmiid,name,kind,type_id} = fun transform_parameter t {xmiid,name,kind,type_id} =
(name, find_classifier_type t type_id (name, find_classifier_type t type_id
handle _ => (warn ("no type found for parameter '"^name^ handle _ => (Logger.warn ("no type found for parameter '"^name^
"', defaulting to OclVoid"); "', defaulting to OclVoid");
Rep_OclType.OclVoid) Rep_OclType.OclVoid)
) )
@ -228,11 +228,11 @@ fun transform_operation t {xmiid,name,isQuery,parameter,visibility,
constraints,ownerScope} = constraints,ownerScope} =
let val result_type = ( let val result_type = (
case filter (fn x => #kind x = XMI.Return) parameter case filter (fn x => #kind x = XMI.Return) parameter
of [] => (warn ("no return type found for operation '"^name^ of [] => (Logger.warn ("no return type found for operation '"^name^
"', defaulting to OclVoid"); "', defaulting to OclVoid");
Rep_OclType.OclVoid) Rep_OclType.OclVoid)
| [x] => (find_classifier_type t (#type_id x) | [x] => (find_classifier_type t (#type_id x)
handle _ => (warn ("return parameter for \ handle _ => (Logger.warn ("return parameter for \
\operation '"^name^ \operation '"^name^
"' has no declared type, \ "' has no declared type, \
\defaulting to OclVoid"); \defaulting to OclVoid");
@ -240,12 +240,12 @@ fun transform_operation t {xmiid,name,isQuery,parameter,visibility,
| x::y::_ => | x::y::_ =>
let let
val ret_type = find_classifier_type t (#type_id x) val ret_type = find_classifier_type t (#type_id x)
handle _ => (warn ("return parameter for operation '" handle _ => (Logger.warn ("return parameter for operation '"
^name^"' has no declared type, \ ^name^"' has no declared type, \
\defaulting to OclVoid"); \defaulting to OclVoid");
Rep_OclType.OclVoid) Rep_OclType.OclVoid)
in in
(warn ("operation '"^name^ (Logger.warn ("operation '"^name^
"' has multiple return parameters. Using only '"^ "' has multiple return parameters. Using only '"^
(Rep_OclType.string_of_OclType ret_type)^"'."); (Rep_OclType.string_of_OclType ret_type)^"'.");
ret_type) ret_type)
@ -277,7 +277,7 @@ fun transform_operation t {xmiid,name,isQuery,parameter,visibility,
fun transform_attribute t ({xmiid,name,type_id,changeability,visibility,ordering, fun transform_attribute t ({xmiid,name,type_id,changeability,visibility,ordering,
multiplicity,taggedValue,ownerScope,targetScope,stereotype,initialValue}) = multiplicity,taggedValue,ownerScope,targetScope,stereotype,initialValue}) =
let val cls_type = find_classifier_type t type_id let val cls_type = find_classifier_type t type_id
handle _ => (warn ("no type found for attribute '"^name^ handle _ => (Logger.warn ("no type found for attribute '"^name^
"', defaulting to OclVoid"); "', defaulting to OclVoid");
Rep_OclType.OclVoid) Rep_OclType.OclVoid)
in in
@ -354,7 +354,7 @@ fun transform_state t (XMI.CompositeState {xmiid,outgoing,incoming,subvertex,
outgoing = outgoing, outgoing = outgoing,
incoming = incoming, incoming = incoming,
kind = kind } kind = kind }
| transform_state t _ = error ("in transform_state: unsupported StateVertex type \ | transform_state t _ = Logger.error ("in transform_state: unsupported StateVertex type \
\(Subactivity states, object flow states and \ \(Subactivity states, object flow states and \
\sync states are not supported).") \sync states are not supported).")
(* a primitive hack: we take the body of the guard g as the name of an *) (* a primitive hack: we take the body of the guard g as the name of an *)
@ -408,24 +408,24 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
classifierInState,activity_graphs, classifierInState,activity_graphs,
state_machines}) = state_machines}) =
let let
val _ = trace function_calls ("RepParser.transform_classifier: Class\n") val _ = Logger.debug2 ("RepParser.transform_classifier: Class\n")
val _ = trace function_arguments ("class name: "^ name ^"\n") val _ = Logger.debug2 ("class name: "^ name ^"\n")
val assocs = find_classifier_associations t xmiid val assocs = find_classifier_associations t xmiid
val _ = trace high ("number of associations added: "^(Int.toString (List.length assocs))^"\n") val _ = Logger.debug1 ("number of associations added: "^(Int.toString (List.length assocs))^"\n")
val parents = map ((find_classifier_type t) o (find_parent t)) val parents = map ((find_classifier_type t) o (find_parent t))
generalizations generalizations
val filtered_parents = filter (fn x => x <> Rep_OclType.OclAny) parents val filtered_parents = filter (fn x => x <> Rep_OclType.OclAny) parents
val filtered_parent = case filtered_parents val filtered_parent = case filtered_parents
of [] => NONE of [] => NONE
| [x] => SOME x | [x] => SOME x
| x::y::_ => (warn ("Class '"^name^"' has multiple parents."^ | x::y::_ => (Logger.warn ("Class '"^name^"' has multiple parents."^
" Using only '"^ " Using only '"^
(Rep_OclType.string_of_OclType x)^"'."); (Rep_OclType.string_of_OclType x)^"'.");
SOME x) SOME x)
val checked_invariants = filter_exists t invariant 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 val class_type = find_classifier_type t xmiid
val _ = print ("transform_classifier: adding "^name^"\n") val _ = Logger.info ("transform_classifier: adding "^name^"\n")
val res = val res =
Rep.Class {name = (* type_of_classifier *) class_type, Rep.Class {name = (* type_of_classifier *) class_type,
parent = case filtered_parents parent = case filtered_parents
@ -443,7 +443,7 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
activity_graphs = List.concat [map (transform_activitygraph t) activity_graphs, activity_graphs = List.concat [map (transform_activitygraph t) activity_graphs,
map (transform_statemachine t) state_machines], map (transform_statemachine t) state_machines],
thyname = NONE} thyname = NONE}
val _ = trace function_ends ("RepParser.transform_classifier\n") val _ = Logger.debug2 ("RepParser.transform_classifier\n")
in in
res res
end end
@ -453,21 +453,21 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
clientDependency,connection, clientDependency,connection,
supplierDependency,taggedValue}) = supplierDependency,taggedValue}) =
let let
val _ = trace function_calls ("RepParser.transform_classifier: AssociationClass\n") val _ = Logger.debug2 ("RepParser.transform_classifier: AssociationClass\n")
val _ = trace function_arguments ("associationclass name: "^ name ^"\n") val _ = Logger.debug2 ("associationclass name: "^ name ^"\n")
val (_,assocs,assoc,_,_) = find_classifier_entries t xmiid val (_,assocs,assoc,_,_) = find_classifier_entries t xmiid
val _ = trace high ("number of associations added: "^(Int.toString (List.length assocs))^"\n") val _ = Logger.debug1 ("number of associations added: "^(Int.toString (List.length assocs))^"\n")
val _ = trace high ("ac association found: "^(Bool.toString (assoc <> []))^"\n") val _ = Logger.debug1 ("ac association found: "^(Bool.toString (assoc <> []))^"\n")
val _ = print "associations retrieved\n" val _ = Logger.info "associations retrieved\n"
val parents = map ((find_classifier_type t) o (find_parent t)) val parents = map ((find_classifier_type t) o (find_parent t))
generalizations generalizations
val _ = trace high "parents retrieved\n" val _ = Logger.debug1 "parents retrieved\n"
(* FIXME: filter for classes vs. interfaces *) (* FIXME: filter for classes vs. interfaces *)
val filtered_parents = filter (fn x => x <> Rep_OclType.OclAny) parents val filtered_parents = filter (fn x => x <> Rep_OclType.OclAny) parents
val checked_invariants = filter_exists t invariant val checked_invariants = filter_exists t invariant
(*val navigable_aends = filter #isNavigable connection *) (*val navigable_aends = filter #isNavigable connection *)
val class_type = find_classifier_type t xmiid val class_type = find_classifier_type t xmiid
val _ = print ("transform_classifier: adding "^name^"\n") val _ = Logger.debug1 ("transform_classifier: adding "^name^"\n")
val res = val res =
Rep.AssociationClass {name = (* type_of_classifier *)class_type, Rep.AssociationClass {name = (* type_of_classifier *)class_type,
parent = case filtered_parents parent = case filtered_parents
@ -484,16 +484,16 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
associations = assocs, associations = assocs,
visibility = visibility, visibility = visibility,
association = assoc} association = assoc}
val _ = trace function_ends ("RepParser.transform_classifier\n") val _ = Logger.debug2 ("RepParser.transform_classifier\n")
in in
res res
end end
| transform_classifier t (XMI.Primitive {xmiid,name,generalizations,operations,invariant,taggedValue}) = | transform_classifier t (XMI.Primitive {xmiid,name,generalizations,operations,invariant,taggedValue}) =
let let
val _ = trace function_calls ("RepParser.transform_classifier: Primitive\n") val _ = Logger.debug2 ("RepParser.transform_classifier: Primitive\n")
val _ = trace function_arguments ("primitive name: "^ name ^"\n") val _ = Logger.debug2 ("primitive name: "^ name ^"\n")
val (_,assocs,_,_,_) = find_classifier_entries t xmiid val (_,assocs,_,_,_) = find_classifier_entries t xmiid
val _ = trace high ("number of associations added: "^(Int.toString (List.length assocs))^"\n") val _ = Logger.debug1 ("number of associations added: "^(Int.toString (List.length assocs))^"\n")
val checked_invariants = filter_exists t invariant val checked_invariants = filter_exists t invariant
val res = val res =
Rep.Primitive {name = (* case *) find_classifier_type t xmiid (*of Rep_OclType.Classifier x => x Rep.Primitive {name = (* case *) find_classifier_type t xmiid (*of Rep_OclType.Classifier x => x
@ -508,14 +508,14 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
stereotypes = nil (*FIX *), stereotypes = nil (*FIX *),
interfaces = nil (* FIX *), interfaces = nil (* FIX *),
thyname = NONE} thyname = NONE}
val _ = trace function_ends ("RepParser.transform_classifier\n") val _ = Logger.debug2 ("RepParser.transform_classifier\n")
in in
res res
end end
| transform_classifier t (XMI.Enumeration {xmiid,name,generalizations, | transform_classifier t (XMI.Enumeration {xmiid,name,generalizations,
operations,literals,invariant}) = operations,literals,invariant}) =
let let
val _ = trace function_calls ("RepParser.transform_classifier: Enumeration\n") val _ = Logger.debug2 ("RepParser.transform_classifier: Enumeration\n")
val checked_invariants = filter_exists t invariant val checked_invariants = filter_exists t invariant
val res = val res =
Rep.Enumeration {name = (* case *) find_classifier_type t xmiid (* of Rep_OclType.Classifier x => x Rep.Enumeration {name = (* case *) find_classifier_type t xmiid (* of Rep_OclType.Classifier x => x
@ -528,14 +528,14 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
stereotypes = nil, (* FIX *) stereotypes = nil, (* FIX *)
interfaces = nil, (* FIX *) interfaces = nil, (* FIX *)
thyname = NONE} thyname = NONE}
val _ = trace function_ends ("RepParser.transform_classifier\n") val _ = Logger.debug2 ("RepParser.transform_classifier\n")
in in
res res
end end
| transform_classifier t (XMI.Interface { xmiid, name, generalizations, operations, invariant, | transform_classifier t (XMI.Interface { xmiid, name, generalizations, operations, invariant,
...}) = ...}) =
let let
val _ = trace function_calls ("RepParser.transform_classifier: Interface\n") val _ = Logger.debug2 ("RepParser.transform_classifier: Interface\n")
val checked_invariants = filter_exists t invariant val checked_invariants = filter_exists t invariant
val res = val res =
Rep.Interface { name = find_classifier_type t xmiid, Rep.Interface { name = find_classifier_type t xmiid,
@ -547,25 +547,25 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
(find_constraint t)) checked_invariants, (find_constraint t)) checked_invariants,
thyname = NONE thyname = NONE
} }
val _ = trace function_ends ("RepParser.transform_classifier\n") val _ = Logger.debug2 ("RepParser.transform_classifier\n")
in in
res res
end end
| transform_classifier t (_) = error "Not supported Classifier type found." | transform_classifier t (_) = Logger.error "Not supported Classifier type found."
(** transform an XMI.Association into a Rep.association *) (** transform an XMI.Association into a Rep.association *)
fun transform_association t ({xmiid,name,connection}:XMI.Association): fun transform_association t ({xmiid,name,connection}:XMI.Association):
Rep.association = Rep.association =
let let
val _ = trace function_calls ("RepParser.transform_association\n") val _ = Logger.debug2 ("RepParser.transform_association\n")
val _ = trace function_arguments ("transform_association xmiid: " val _ = Logger.debug2 ("transform_association xmiid: "
^xmiid^"\n") ^xmiid^"\n")
val associationPath = find_association_path t xmiid val associationPath = find_association_path t xmiid
val _ = print ("transform_association path: "^(string_of_path val _ = Logger.info ("transform_association path: "^(string_of_path
associationPath)^ associationPath)^
"\n") "\n")
val _ = print ("transform_association path length: "^ val _ = Logger.info ("transform_association path length: "^
(Int.toString (List.length associationPath)) ^"\n") (Int.toString (List.length associationPath)) ^"\n")
val (associationEnds,qualifierPairs) = val (associationEnds,qualifierPairs) =
ListPair.unzip (map (transform_aend t associationPath) connection) ListPair.unzip (map (transform_aend t associationPath) connection)
@ -574,7 +574,7 @@ fun transform_association t ({xmiid,name,connection}:XMI.Association):
aends = associationEnds, aends = associationEnds,
qualifiers = qualifierPairs, qualifiers = qualifierPairs,
aclass = NONE (* regular association *)} aclass = NONE (* regular association *)}
val _ = trace function_ends ("RepParser.transform_association\n") val _ = Logger.debug2 ("RepParser.transform_association\n")
in in
res res
end end
@ -583,17 +583,17 @@ fun transformAssociationFromAssociationClass t (XMI.AssociationClass
{xmiid,connection,...}): {xmiid,connection,...}):
Rep.association = Rep.association =
let let
val _ = trace function_calls ("RepParser.transformAssociationFromAassociation Class\n") val _ = Logger.debug2 ("RepParser.transformAssociationFromAassociation Class\n")
val id = xmiid^"_association" val id = xmiid^"_association"
val associationPath = find_association_path t id val associationPath = find_association_path t id
val _ = trace low ("transform_association path: "^ val _ = Logger.debug4 ("transform_association path: "^
(string_of_path associationPath)^"\n") (string_of_path associationPath)^"\n")
val _ = trace low ("transform_association path length: "^ val _ = Logger.debug4 ("transform_association path length: "^
(Int.toString (List.length associationPath)) ^"\n") (Int.toString (List.length associationPath)) ^"\n")
val (associationEnds,qualifierPairs) = val (associationEnds,qualifierPairs) =
ListPair.unzip (map (transform_aend t associationPath) connection) ListPair.unzip (map (transform_aend t associationPath) connection)
val aClass = SOME (path_of_OclType (find_classifier_type t xmiid)) val aClass = SOME (path_of_OclType (find_classifier_type t xmiid))
val _ = trace function_ends ("RepParser.transformAssociationFromAssociationClass\n") val _ = Logger.debug2 ("RepParser.transformAssociationFromAssociationClass\n")
in in
{name = associationPath (* path_of_association *), {name = associationPath (* path_of_association *),
aends = associationEnds, aends = associationEnds,
@ -605,7 +605,7 @@ fun transformAssociationFromAssociationClass t (XMI.AssociationClass
fun transform_package t (XMI.Package p) :transform_model = fun transform_package t (XMI.Package p) :transform_model =
let let
(* we do not transform the ocl library *) (* we do not transform the ocl library *)
val _ = trace function_calls ("RepParser.transform_package\n") val _ = Logger.debug2 ("RepParser.transform_package\n")
val filteredPackages = val filteredPackages =
filter (fn (XMI.Package x) => filter (fn (XMI.Package x) =>
((#name x <> "oclLib") andalso (#name x <> "UML_OCL"))) ((#name x <> "oclLib") andalso (#name x <> "UML_OCL")))
@ -621,7 +621,7 @@ fun transform_package t (XMI.Package p) :transform_model =
val associations = local_associations @ (List.concat res_associations) val associations = local_associations @ (List.concat res_associations)
val classifiers =local_classifiers @ (List.concat res_classifiers) val classifiers =local_classifiers @ (List.concat res_classifiers)
val res = (classifiers, associations ) val res = (classifiers, associations )
val _ = trace function_ends ("RepParser.transform_package\n") val _ = Logger.debug2 ("RepParser.transform_package\n")
in in
res res
end end
@ -670,40 +670,37 @@ fun transformXMI_ext ({classifiers,constraints,packages,stereotypes,
fun test2 (classifiers,associations) = fun test2 (classifiers,associations) =
let let
val _ = print "test2\n" val _ = Logger.info "test2\n"
val _ = print "classifiers\n" val _ = Logger.info "classifiers\n"
val _ = map (print o (fn x => x^"\n") o string_of_path o name_of) val _ = map (Logger.info o (fn x => x^"\n") o string_of_path o name_of)
classifiers classifiers
val _ = print "associations\n" val _ = Logger.info "associations\n"
val _ = map (print o (fn x => x^"\n") o string_of_path o val _ = map (Logger.info o (fn x => x^"\n") o string_of_path o
(fn {name,aends,qualifiers,aclass} => name)) (fn {name,aends,qualifiers,aclass} => name))
associations associations
val _ = print "operations\n" val _ = Logger.info "operations\n"
fun printClassifier cls = fun printClassifier cls =
let let
val _ = print ("output of transformXMI_ext:\n") val _ = Logger.info ("output of transformXMI_ext:\n")
val _ = print ("classifier: "^ (string_of_path (name_of cls)) val _ = Logger.info ("classifier: "^ (string_of_path (name_of cls))
^"\n") ^"\n")
val _ = print ("associations: \n") val _ = Logger.info ("associations: \n")
val _ = map (print o(fn x => x ^ "\n") o string_of_path ) val _ = map (Logger.info o(fn x => x ^ "\n") o string_of_path )
(associations_of cls) (associations_of cls)
val _ = print ("operations: \n") val _ = Logger.info ("operations: \n")
val _ = map (print o (fn {name,...} => name)) val _ = map (Logger.info o (fn {name,...} => name))
(operations_of cls) (operations_of cls)
in in
print "\n" print "\n"
end end
val _ = map printClassifier classifiers val _ = map printClassifier classifiers
in in
trace 27 "\n### transformXMI_ext done\n\n"; Logger.debug2 "\n### transformXMI_ext done\n\n";
(classifiers,associations) (classifiers,associations)
end end
in in
trace 27 "### transformXMI: populate hash table\n";
insert_model xmiid_table model (* fill xmi.id table *); insert_model xmiid_table model (* fill xmi.id table *);
trace 27 "### transformXMI: fix associations\n";
fix_associations xmiid_table model (* handle associations *); fix_associations xmiid_table model (* handle associations *);
trace 27 "### transformXMI: transform XMI into Rep\n";
test2 (transform_package xmiid_table model) (* transform classifiers *) test2 (transform_package xmiid_table model) (* transform classifiers *)
end end
@ -718,7 +715,7 @@ fun transformXMI x:Classifier list = fst (transformXMI_ext x)
fun normalize_ext ((clsses,accs):transform_model):Rep.Model = fun normalize_ext ((clsses,accs):transform_model):Rep.Model =
(map (Rep.normalize accs) clsses,accs) (map (Rep.normalize accs) clsses,accs)
fun readFile f = (info ("opening "^f); fun readFile f = (Logger.info ("opening "^f);
(normalize_ext o transformXMI_ext o XmiParser.readFile) f) (normalize_ext o transformXMI_ext o XmiParser.readFile) f)
(* handle ex as (IllFormed msg) => raise ex *) (* handle ex as (IllFormed msg) => raise ex *)
@ -744,16 +741,6 @@ fun importArgoUML file =
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
@ -761,8 +748,8 @@ fun printStackTrace e =
***************************************************** *****************************************************
* Test function. * Test function.
*) *)
fun test (_,filename::_) = (Rep2String.printList (fst (readFile filename)); OS.Process.success) (* fun test (_,filename::_) = (Rep2String.printList (fst (readFile filename)); OS.Process.success) *)
handle ex => (printStackTrace ex; OS.Process.failure) (* handle ex => (printStackTrace ex; OS.Process.failure) *)

1
su4sml/src/rep_su2holocl.sml
View File

@ -44,7 +44,6 @@ structure SecureUML2HolOcl:sig
end = struct end = struct
open Rep_Helper open Rep_Helper
open Rep_Logger
open Rep_Core open Rep_Core
open XMI_DataTypes open XMI_DataTypes
open Rep_OclTerm open Rep_OclTerm

32
su4sml/src/rep_transform.sml
View File

@ -110,7 +110,6 @@ datatype transformFlag = BinaryAssociationsOnly
type modelTransformation = Rep_Core.transform_model * transformFlag list type modelTransformation = Rep_Core.transform_model * transformFlag list
-> Rep_Core.transform_model * transformFlag list -> Rep_Core.transform_model * transformFlag list
open Rep_Helper open Rep_Helper
open Rep_Logger
open Transform_Library open Transform_Library
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType
@ -137,8 +136,8 @@ fun get_association (all_assocs: Rep_Core.association list) (assoc_path:Path):
in in
(case assoc of (case assoc of
[x] => x [x] => x
| [] => error ("in get_association: no match found ("^(string_of_path (assoc_path))^")") | [] => Logger.error ("in get_association: no match found ("^(string_of_path (assoc_path))^")")
| _ => error "in get_association: more than 1 match found") | _ => Logger.error "in get_association: more than 1 match found")
end end
fun get_other_associationends (all_assocs:association list) (assoc_path:Path) fun get_other_associationends (all_assocs:association list) (assoc_path:Path)
@ -194,7 +193,7 @@ fun transformAggregation (allClassifiers,allAssociations) =
fun transformQualifiers ((allClassifiers,allAssociations):transform_model): fun transformQualifiers ((allClassifiers,allAssociations):transform_model):
transform_model = transform_model =
let let
val _ = trace function_calls "transformQualifiers\n" val _ = Logger.debug2 "transformQualifiers\n"
(* connects the dummy class to the new qualifier classes *) (* connects the dummy class to the new qualifier classes *)
fun handleQualifier assocPath (role,attributes) = fun handleQualifier assocPath (role,attributes) =
let let
@ -478,7 +477,7 @@ fun transformQualifiers ((allClassifiers,allAssociations):transform_model):
fun transformNAryAssociationsToAssociationClasses (allClassifiers, fun transformNAryAssociationsToAssociationClasses (allClassifiers,
allAssociations) = allAssociations) =
let let
val _ = trace function_calls "transformNAryAssociationsTo\ val _ = Logger.debug2 "transformNAryAssociationsTo\
\AssociationClasses\n" \AssociationClasses\n"
fun toAssocClass (assoc as {name,aends,qualifiers,aclass=NONE}) = fun toAssocClass (assoc as {name,aends,qualifiers,aclass=NONE}) =
let let
@ -528,7 +527,7 @@ fun transformAssociationClassIntoClass (AssociationClass
fun transformAssociationClassesToNAryAssociations (allClassifiers, fun transformAssociationClassesToNAryAssociations (allClassifiers,
allAssociations) = allAssociations) =
let let
val _ = trace function_calls "transformAssociationClassesTo\ val _ = Logger.debug2 "transformAssociationClassesTo\
\NAryAssociations\n" \NAryAssociations\n"
fun morph {name,aends,qualifiers,aclass} class = fun morph {name,aends,qualifiers,aclass} class =
let let
@ -583,7 +582,7 @@ fun generalTransfromNAryAssociation dummy (association as {name,aends,
aclass=NONE}, aclass=NONE},
(classifiers,processedAssocs)) = (classifiers,processedAssocs)) =
let let
val _ = trace function_calls "generalTransformNAryAssociation\n" val _ = Logger.debug2 "generalTransformNAryAssociation\n"
fun modifyClassifier ((assocs,classifier),classifiers) = fun modifyClassifier ((assocs,classifier),classifiers) =
let let
val ([cls],rem) = List.partition (fn x => name_of x = val ([cls],rem) = List.partition (fn x => name_of x =
@ -655,7 +654,7 @@ fun generalTransfromNAryAssociation dummy (association as {name,aends,
*) *)
fun transformAssociationClasses (allClassifiers,allAssociations) = fun transformAssociationClasses (allClassifiers,allAssociations) =
let let
val _ = trace function_calls "transformAssociationClasses\n" val _ = Logger.debug2 "transformAssociationClasses\n"
fun transformAssociationClass ({name,aends,qualifiers=[], fun transformAssociationClass ({name,aends,qualifiers=[],
aclass=SOME aClass}, aclass=SOME aClass},
(classifiers,procAssocs)) = (classifiers,procAssocs)) =
@ -699,7 +698,7 @@ fun transformAssociationClasses (allClassifiers,allAssociations) =
*) *)
fun transformNAryAssociations (allClassifiers,allAssociations) = fun transformNAryAssociations (allClassifiers,allAssociations) =
let let
val _ = trace function_calls "transformNAryAssociations\n" val _ = Logger.debug2 "transformNAryAssociations\n"
fun transformNAryAssociation (association,(classifiers,procAssocs)) = fun transformNAryAssociation (association,(classifiers,procAssocs)) =
generalTransfromNAryAssociation generalTransfromNAryAssociation
(newDummyClass (package_of_association association)) (newDummyClass (package_of_association association))
@ -723,7 +722,7 @@ fun transformNAryAssociations (allClassifiers,allAssociations) =
fun transformMultiplicities (allClassifiers,allAssociations) = fun transformMultiplicities (allClassifiers,allAssociations) =
let let
val _ = trace function_calls "transformMultiplicities\n" val _ = Logger.debug2 "transformMultiplicities\n"
fun withinBound selfVar targetType role (low,high)= fun withinBound selfVar targetType role (low,high)=
let let
val returnType = Set targetType val returnType = Set targetType
@ -749,7 +748,7 @@ fun transformMultiplicities (allClassifiers,allAssociations) =
aclass=NONE}, aclass=NONE},
localClassifiers) = localClassifiers) =
let let
val _ = trace function_calls "addMultiplicityConstraints\n" val _ = Logger.debug2 "addMultiplicityConstraints\n"
val aType = type_of_aend a val aType = type_of_aend a
val bType = type_of_aend b val bType = type_of_aend b
val aPath = path_of_aend a val aPath = path_of_aend a
@ -826,20 +825,11 @@ fun transformClassifiers (model:transform_model):Rep.Classifier list =
* read and transform an .xmi file. * read and transform an .xmi file.
* @return a list of rep classifiers, or nil in case of problems * @return a list of rep classifiers, or nil in case of problems
*) *)
fun transformFile f:transform_model = (info ("opening "^f); fun transformFile f:transform_model = (Logger.info ("opening "^f);
(normalize_ext o transformClassifiersExt o (normalize_ext o transformClassifiersExt o
RepParser.transformXMI_ext o XmiParser.readFile) f) RepParser.transformXMI_ext o XmiParser.readFile) f)
(* handle ex as (IllFormed msg) => raise ex *) (* handle ex as (IllFormed msg) => raise ex *)
exception FileNotFound of string 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 end

17
su4sml/src/secure_uml.sml
View File

@ -68,7 +68,6 @@ end
functor SecureUML(structure Design: DESIGN_LANGUAGE):SECUREUML = functor SecureUML(structure Design: DESIGN_LANGUAGE):SECUREUML =
struct struct
open Rep_Helper open Rep_Helper
open Rep_Logger
structure Design : DESIGN_LANGUAGE = Design structure Design : DESIGN_LANGUAGE = Design
@ -170,11 +169,11 @@ 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) fun mkRole (C as Rep.Class c) = Rep.string_of_path (Rep.name_of C)
| mkRole _ = error ("in mkRole: argument is not a class") | mkRole _ = Logger.error ("in mkRole: argument is not a class")
(* FIXME: handle groups also *) (* FIXME: handle groups also *)
fun mkSubject (C as Rep.Class c) = User (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") | mkSubject _ = Logger.error ("in mkSubject: argument is not a class")
fun mkPermission (cs,ascs) (c as Rep.Class _) = fun mkPermission (cs,ascs) (c as Rep.Class _) =
let val classifiers = (Rep.connected_classifiers_of ascs c cs) let val classifiers = (Rep.connected_classifiers_of ascs c cs)
val role_classes = List.filter (classifier_has_stereotype "secuml.role") val role_classes = List.filter (classifier_has_stereotype "secuml.role")
@ -184,24 +183,24 @@ fun mkPermission (cs,ascs) (c as Rep.Class _) =
Design.root_stereotypes) Design.root_stereotypes)
classifiers classifiers
val root_resource = hd root_classes val root_resource = hd root_classes
handle Empty => error ("in mkPermission: no root resource found "^ handle Empty => Logger.error ("in mkPermission: no root resource found "^
"for permission "^Rep.string_of_path (Rep.name_of c)) "for permission "^Rep.string_of_path (Rep.name_of c))
val action_attributes = val action_attributes =
List.filter (fn x => ListEq.overlaps (#stereotypes x) (Design.action_stereotypes)) List.filter (fn x => ListEq.overlaps (#stereotypes x) (Design.action_stereotypes))
(Rep.attributes_of c) (Rep.attributes_of c)
handle ex => (error_msg "could not parse permission attributes"; raise ex) handle ex => (Logger.error "could not parse permission attributes"; raise ex)
in in
{ name = (Rep.string_of_path (Rep.name_of c)), { name = (Rep.string_of_path (Rep.name_of c)),
roles = (map (Rep.string_of_path o Rep.name_of) role_classes), roles = (map (Rep.string_of_path o Rep.name_of) role_classes),
(* FIXME: find attached constraints *) (* FIXME: find attached constraints *)
constraints = nil, constraints = nil,
actions = if action_attributes = [] actions = if action_attributes = []
then error ("in mkPermission: Permission "^ then Logger.error ("in mkPermission: Permission "^
(Rep.string_of_path (Rep.name_of c))^ (Rep.string_of_path (Rep.name_of c))^
"has no action attributes") "has no action attributes")
else map (Design.parse_action root_resource) action_attributes } else map (Design.parse_action root_resource) action_attributes }
end end
| mkPermission _ _ = error "in mkPermission: argument is not a class" | mkPermission _ _ = Logger.error "in mkPermission: argument is not a class"
fun mkSubjectAssignment (cs,ascs) (c as (Rep.Class _)) = fun mkSubjectAssignment (cs,ascs) (c as (Rep.Class _)) =
@ -314,7 +313,7 @@ fun removeSecureUmlAends (Rep.Class {name=class_name,...},(assocs,removed_assocs
* removes the classes with SecureUML stereotypes. * removes the classes with SecureUML stereotypes.
*) *)
fun parse (model as (cs,assocs):Rep.Model) = fun parse (model as (cs,assocs):Rep.Model) =
let val _ = info "parsing security configuration" let val _ = Logger.info "parsing security configuration"
val non_secureumlstereotypes = List.filter (classifier_has_no_stereotype ["secuml.permission", val non_secureumlstereotypes = List.filter (classifier_has_no_stereotype ["secuml.permission",
"secuml.role", "secuml.role",
"secuml.subject", "secuml.subject",
@ -400,7 +399,7 @@ fun parse (model as (cs,assocs):Rep.Model) =
(List.filter classifier_has_parent (filter_role cs)), (List.filter classifier_has_parent (filter_role cs)),
sa = map (mkSubjectAssignment model) (filter_subject cs)}) sa = map (mkSubjectAssignment model) (filter_subject cs)})
end end
handle ex => (error_msg "in SecureUML.parse: security configuration \ handle ex => (Logger.warn "in SecureUML.parse: security configuration \
\could not be parsed"; \could not be parsed";
raise ex) raise ex)

15
su4sml/src/su4sml.sml
View File

@ -93,29 +93,29 @@ fun check uml ocl = let
val ocl = ModelImport.parseOCL ocl val ocl = ModelImport.parseOCL ocl
handle _ => [] handle _ => []
val OclParse = if ocl = [] then false else true val OclParse = if ocl = [] then false else true
val _ = print "### Preprocess Context List ###\n" val _ = Logger.info "### Preprocess Context List ###\n"
val fixed_ocl = Preprocessor.preprocess_context_list val fixed_ocl = Preprocessor.preprocess_context_list
ocl ((OclLibrary.oclLib)@(#1 xmi)) ocl ((OclLibrary.oclLib)@(#1 xmi))
handle _ => [] handle _ => []
val OclPreprocess = if fixed_ocl = [] then false else true val OclPreprocess = if fixed_ocl = [] then false else true
val OclPreprocess = OclPreprocess andalso OclParse val OclPreprocess = OclPreprocess andalso OclParse
val _ = print "### Finished Preprocess Context List ###\n\n" val _ = Logger.info "### Finished Preprocess Context List ###\n\n"
val _ = print "### Type Checking ###\n" val _ = Logger.info "### Type Checking ###\n"
val typed_cl = TypeChecker.check_context_list val typed_cl = TypeChecker.check_context_list
fixed_ocl (((OclLibrary.oclLib)@(#1 xmi)),#2 xmi) fixed_ocl (((OclLibrary.oclLib)@(#1 xmi)),#2 xmi)
handle _ => [] handle _ => []
val OclTC = if typed_cl = [] then false else true val OclTC = if typed_cl = [] then false else true
val OclTC = OclTC andalso OclPreprocess val OclTC = OclTC andalso OclPreprocess
val _ = print "### Finished Type Checking ###\n\n" val _ = Logger.info "### Finished Type Checking ###\n\n"
val _ = print"### Updating Classifier List ###\n" val _ = Logger.info "### Updating Classifier List ###\n"
val model = Update_Model.gen_updated_classifier_list val model = Update_Model.gen_updated_classifier_list
typed_cl ((OclLibrary.oclLib)@(#1 xmi)) typed_cl ((OclLibrary.oclLib)@(#1 xmi))
handle _ => [] handle _ => []
val modelUpdate = if model = [] then false else true val modelUpdate = if model = [] then false else true
val modelUpdate = modelUpdate andalso OclTC val modelUpdate = modelUpdate andalso OclTC
val _ = print "### Finished Updating Classifier List ###\n" val _ = Logger.info "### Finished Updating Classifier List ###\n"
fun printBool b = if b then "passed" else "FAILED" fun printBool b = if b then "passed" else "FAILED"
@ -136,8 +136,7 @@ end
fun main (name:string,args:(string list)) = fun main (name:string,args:(string list)) =
let let
val prgName = (hd o rev) (String.fields (fn s => s = #"/" orelse s = #"\\") name); val prgName = (hd o rev) (String.fields (fn s => s = #"/" orelse s = #"\\") name);
val _ = print ("Name: "^prgName^"\n"); val _ = Logger.set_log_level Logger.WARN
val _ = (Rep_Logger.log_level := 2)
in in
case (prgName,args) of case (prgName,args) of
(n, []) => print_usage n (n, []) => print_usage n

1
su4sml/src/su4sml_core.cm
View File

@ -59,6 +59,7 @@ Group is
contrib/HashTable.sml contrib/HashTable.sml
#endif #endif
../lib/fxp/src/fxlib.cm ../lib/fxp/src/fxlib.cm
config.sml
rep_helper.sml rep_helper.sml
rep_logger.sml rep_logger.sml
listeq.sml listeq.sml

19
su4sml/src/transform_library.sml
View File

@ -241,7 +241,6 @@ structure Transform_Library:TRANSFORM_LIBRARY =
struct struct
open Rep_Helper open Rep_Helper
open Rep_Logger
open StringHandling open StringHandling
open Rep_OclTerm open Rep_OclTerm
open Rep_OclHelper open Rep_OclHelper
@ -522,7 +521,7 @@ fun mapCalls f [] = []
fun updateAssociationReferences classifiers [] = classifiers fun updateAssociationReferences classifiers [] = classifiers
| updateAssociationReferences classifiers updates = | updateAssociationReferences classifiers updates =
let let
val _ = trace function_calls "updateAssociationReferences\n" val _ = Logger.debug2 "updateAssociationReferences\n"
fun findNewPath oldAssoc newAssocs source path = fun findNewPath oldAssoc newAssocs source path =
let let
@ -613,7 +612,7 @@ fun updateAssociationReferences classifiers [] = classifiers
fun handleConstraint oldAssoc newAssocs (name,term) = fun handleConstraint oldAssoc newAssocs (name,term) =
let let
val _ = trace function_calls "handleConstraint\n" val _ = Logger.debug2 "handleConstraint\n"
in in
(name,traverseOcl oldAssoc newAssocs term) (name,traverseOcl oldAssoc newAssocs term)
end end
@ -661,7 +660,7 @@ fun updateAssociationReferences classifiers [] = classifiers
fun updateReferences ((oldAssoc,newAssocs),tmpClassifiers) = fun updateReferences ((oldAssoc,newAssocs),tmpClassifiers) =
let let
val _ = trace function_calls "updateReferences\n" val _ = Logger.debug2 "updateReferences\n"
in in
map (modifyClassifier oldAssoc newAssocs) tmpClassifiers map (modifyClassifier oldAssoc newAssocs) tmpClassifiers
end end
@ -742,7 +741,7 @@ fun modifyAssociationsOfClassifier (newAssociations:association list)
fun uniquenessOclConstraint (source:Classifier) fun uniquenessOclConstraint (source:Classifier)
(associations:association list) = (associations:association list) =
let let
val _ = trace function_calls "uniquenessOclConstraint\n" val _ = Logger.debug2 "uniquenessOclConstraint\n"
fun assocAendCalls (self:OclTerm) (iter:OclTerm) {name,aends=[a,b], fun assocAendCalls (self:OclTerm) (iter:OclTerm) {name,aends=[a,b],
qualifiers, qualifiers,
aclass} = aclass} =
@ -801,7 +800,7 @@ fun binaryAssociations (source:Classifier) (sourceRole:string option)
(targetRolePairs:(Classifier*string option) list): (targetRolePairs:(Classifier*string option) list):
(association list * associationend list)= (association list * associationend list)=
let let
val _ = trace function_calls "binaryAssociations\n" val _ = Logger.debug2 "binaryAssociations\n"
fun generateAssociation srcRole (target,roleOpt): fun generateAssociation srcRole (target,roleOpt):
(association * associationend)= (association * associationend)=
let let
@ -839,7 +838,7 @@ fun binaryAssociations (source:Classifier) (sourceRole:string option)
fun orderedBinaryAssociations (source:Classifier) (targets:Classifier list) fun orderedBinaryAssociations (source:Classifier) (targets:Classifier list)
aends: (association list * associationend list)= aends: (association list * associationend list)=
let let
val _ = trace function_calls "orderedBinaryAssociations\n" val _ = Logger.debug2 "orderedBinaryAssociations\n"
fun order [] [] = [] fun order [] [] = []
| order [] (x::xs) = | order [] (x::xs) =
@ -898,7 +897,7 @@ fun fixAends source (aends:associationend list) =
fun multiplicityOclConstraints source multis oppAends = fun multiplicityOclConstraints source multis oppAends =
let let
val _ = trace function_calls "multiplicityOclConstraint\n" val _ = Logger.debug2 "multiplicityOclConstraint\n"
fun bound set (low,high) = fun bound set (low,high) =
if low = high then if low = high then
ocl_eq (ocl_size set) (Literal(Int.toString high,Integer)) ocl_eq (ocl_size set) (Literal(Int.toString high,Integer))
@ -932,7 +931,7 @@ fun multiplicityOclConstraints source multis oppAends =
*) *)
fun consistencyOclConstraint source reference selfAend roles refRoles = fun consistencyOclConstraint source reference selfAend roles refRoles =
let let
val _ = trace function_calls "consistencyOclConstraint\n" val _ = Logger.debug2 "consistencyOclConstraint\n"
fun implies selfVar refVar {name=selfPath,aend_type=selfType, fun implies selfVar refVar {name=selfPath,aend_type=selfType,
multiplicity,init,visibility,ordered} multiplicity,init,visibility,ordered}
((role as {name=newPath,aend_type=newType,ordered=ord2, ((role as {name=newPath,aend_type=newType,ordered=ord2,
@ -986,7 +985,7 @@ fun splitNAryAssociation (association as {name,qualifiers,aends=[a,b],
| splitNAryAssociation (association as {name,qualifiers, | splitNAryAssociation (association as {name,qualifiers,
aends,aclass}) classifiers = aends,aclass}) classifiers =
let let
val _ = trace function_calls "splitNAryAssociation\n" val _ = Logger.debug2 "splitNAryAssociation\n"
fun updateClassifier ((clsType,newAssocs),classifiers) = fun updateClassifier ((clsType,newAssocs),classifiers) =
let let
val ([cls],rem) = List.partition (fn x => type_of x = clsType ) val ([cls],rem) = List.partition (fn x => type_of x = clsType )

1
su4sml/src/wfcpog/SecureUML_constraint.sml
View File

@ -70,7 +70,6 @@ struct
(* su4sml *) (* su4sml *)
open Rep_Core open Rep_Core
open Rep_Logger
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType
open Rep2String open Rep2String

1
su4sml/src/wfcpog/command_query_consistency.sml
View File

@ -60,7 +60,6 @@ structure WFCPOG_Command_Query_Constraint:WFCPOG_COMMAND_QUERY_CONSTRAINT =
struct struct
(* su4sml *) (* su4sml *)
open Rep_Logger
open Rep_Core open Rep_Core
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType

1
su4sml/src/wfcpog/constructor_consistency.sml
View File

@ -55,7 +55,6 @@ structure WFCPOG_Constructor_Constraint : WFCPOG_CONSTRUCTOR_CONSTRAINT =
struct struct
(* SU4SML *) (* SU4SML *)
open Rep_Logger
open Rep_Core open Rep_Core
open Rep open Rep
open Rep_OclTerm open Rep_OclTerm

1
su4sml/src/wfcpog/data_model_consistency.sml
View File

@ -51,7 +51,6 @@ structure WFCPOG_Data_Model_Consistency_Constraint : WFCPOG_DATA_MODEL_CONSISTEN
struct struct
(* su4sml *) (* su4sml *)
open Rep_Logger
open Rep_Core open Rep_Core
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType

1
su4sml/src/wfcpog/interface_consistency.sml
View File

@ -57,7 +57,6 @@ structure WFCPOG_Interface_Constraint:WFCPOG_INTERFACE_CONSTRAINT =
struct struct
(* su4sml *) (* su4sml *)
open Rep_Logger
open Rep_Core open Rep_Core
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType

1
su4sml/src/wfcpog/library.sml
View File

@ -99,7 +99,6 @@ struct
(* SU4SML *) (* SU4SML *)
open Rep_Helper open Rep_Helper
open Rep_Logger
open Rep_Core open Rep_Core
open Rep open Rep
open Rep_OclType open Rep_OclType

1
su4sml/src/wfcpog/liskov_constraint.sml
View File

@ -69,7 +69,6 @@ struct
exception WFCPOG_LiskovError of string exception WFCPOG_LiskovError of string
(* su4sml *) (* su4sml *)
open Rep_Logger
open Rep_Core open Rep_Core
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType

1
su4sml/src/wfcpog/load_model.sml
View File

@ -1,7 +1,6 @@
(* open structures *) (* open structures *)
(* SU4SML *) (* SU4SML *)
open Rep_Logger
open OclLibrary open OclLibrary
open ModelImport open ModelImport
open Rep_Core open Rep_Core

1
su4sml/src/wfcpog/operational_consistency.sml
View File

@ -49,7 +49,6 @@ struct
(* SU4SML *) (* SU4SML *)
open Rep_Logger
open Rep_Core open Rep_Core
open Rep open Rep
open Rep_OclTerm open Rep_OclTerm

1
su4sml/src/wfcpog/refine_constraint.sml
View File

@ -61,7 +61,6 @@ struct
(* su4sml *) (* su4sml *)
open Rep_Helper open Rep_Helper
open Rep_Logger
open Rep_Core open Rep_Core
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType

1
su4sml/src/wfcpog/rep_holocl.sml
View File

@ -249,7 +249,6 @@ end
structure Rep_HolOcl_Helper:REP_HOLOCL_HELPER = structure Rep_HolOcl_Helper:REP_HOLOCL_HELPER =
struct struct
open Rep_Core open Rep_Core
open Rep_Logger
open Rep_OclType open Rep_OclType
open Rep_OclTerm open Rep_OclTerm
open WFCPOG_Library open WFCPOG_Library

1
su4sml/src/wfcpog/taxonomy_consistency.sml
View File

@ -63,7 +63,6 @@ structure WFCPOG_Taxonomy_Constraint:WFCPOG_TAXONOMY_CONSTRAINT =
struct struct
(* su4sml *) (* su4sml *)
open Rep_Logger
open Rep_Core open Rep_Core
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType

1
su4sml/src/wfcpog/test-data.sml
View File

@ -1,7 +1,6 @@
open OclLibrary open OclLibrary
open Rep_Logger
open WFCPOG open WFCPOG
open WFCPOG_Registry open WFCPOG_Registry
open WFCPOG_TestSuite open WFCPOG_TestSuite

1
su4sml/src/wfcpog/test-suite.sml
View File

@ -17,7 +17,6 @@ end
structure WFCPOG_TestSuite : WFCPOG_TESTSUITE = structure WFCPOG_TestSuite : WFCPOG_TESTSUITE =
struct struct
open Rep_Logger
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType
open WFCPOG open WFCPOG

1
su4sml/src/wfcpog/visibility_consistency.sml
View File

@ -73,7 +73,6 @@ struct
(* su4sml *) (* su4sml *)
open Rep_Core open Rep_Core
open Rep_Logger
open Rep_OclTerm open Rep_OclTerm
open Rep_OclType open Rep_OclType
open Rep2String open Rep2String

1
su4sml/src/wfcpog/wfcpog_registry.sml
View File

@ -112,7 +112,6 @@ struct
exception WFCPOG_RegistryError of string exception WFCPOG_RegistryError of string
exception WFCPOG_MethodologyError of string exception WFCPOG_MethodologyError of string
open Rep_Logger
open WFCPOG open WFCPOG
open Datatab open Datatab

2
su4sml/src/xmi_core.sml
View File

@ -400,7 +400,7 @@ fun classifier_elementtype_of (Collection{elementtype,...}) = elementtype
| classifier_elementtype_of (Set{elementtype,...}) = elementtype | classifier_elementtype_of (Set{elementtype,...}) = elementtype
| classifier_elementtype_of (Bag{elementtype,...}) = elementtype | classifier_elementtype_of (Bag{elementtype,...}) = elementtype
| classifier_elementtype_of (OrderedSet{elementtype,...}) = elementtype | classifier_elementtype_of (OrderedSet{elementtype,...}) = elementtype
| classifier_elementtype_of _ = Rep_Logger.error "in classifier_elementtype_of: \ | classifier_elementtype_of _ = Logger.error "in classifier_elementtype_of: \
\argument is not a collection value" \argument is not a collection value"
end end

118
su4sml/src/xmi_idtable.sml
View File

@ -5,7 +5,8 @@
* xmi_idtable.sml --- * xmi_idtable.sml ---
* This file is part of su4sml. * This file is part of su4sml.
* *
* Copyright (c) 2005-2007, ETH Zurich, Switzerland * Copyright (c) 2005-2007 ETH Zurich, Switzerland
* 2008-2009 Achim D. Brucker, Germany
* *
* All rights reserved. * All rights reserved.
* *
@ -42,7 +43,6 @@
structure Xmi_IDTable = structure Xmi_IDTable =
struct struct
open Rep_Helper open Rep_Helper
open Rep_Logger
(** (**
* special keys: * special keys:
@ -91,85 +91,85 @@ fun next_unique_name t:string=
Int.toString number Int.toString number
) )
end end
handle Option => error ("expected UniqueName to be defined in table") handle Option => Logger.error ("expected UniqueName to be defined in table")
fun find_tagdefinition t xmiid = fun find_tagdefinition t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of TagDefinition x => x of TagDefinition x => x
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected TagDefinition "^xmiid^" in table") handle Option => Logger.error ("expected TagDefinition "^xmiid^" in table")
fun find_state t xmiid = fun find_state t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of State x => x of State x => x
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected State "^xmiid^" in table") handle Option => Logger.error ("expected State "^xmiid^" in table")
fun find_event t xmiid = fun find_event t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Event x => x of Event x => x
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Event "^xmiid^" in table") handle Option => Logger.error ("expected Event "^xmiid^" in table")
fun find_transition t xmiid = fun find_transition t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Transition x => x of Transition x => x
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Transition "^xmiid^" in table") handle Option => Logger.error ("expected Transition "^xmiid^" in table")
fun find_dependency t xmiid = fun find_dependency t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Dependency x => x of Dependency x => x
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Dependency "^xmiid^" in table") handle Option => Logger.error ("expected Dependency "^xmiid^" in table")
fun find_generalization t xmiid = fun find_generalization t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Generalization x => x of Generalization x => x
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Generalization "^xmiid^" in table") handle Option => Logger.error ("expected Generalization "^xmiid^" in table")
fun find_stereotype t xmiid = fun find_stereotype t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Stereotype x => x of Stereotype x => x
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Stereotype "^xmiid^" in table") handle Option => Logger.error ("expected Stereotype "^xmiid^" in table")
fun find_attribute t xmiid = fun find_attribute t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Attribute x => x of Attribute x => x
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Attribute "^xmiid^" in table") handle Option => Logger.error ("expected Attribute "^xmiid^" in table")
fun find_operation t xmiid = fun find_operation t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Operation x => x of Operation x => x
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Operation "^xmiid^" in table") handle Option => Logger.error ("expected Operation "^xmiid^" in table")
fun find_type t xmiid = fun find_type t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Type x => x of Type x => x
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Type "^xmiid^" in table (find_type)") handle Option => Logger.error ("expected Type "^xmiid^" in table (find_type)")
fun find_assoc t xmiid = fun find_assoc t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of (Association(path,assoc)) => assoc of (Association(path,assoc)) => assoc
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Type "^xmiid^" in table (find_assocs)") handle Option => Logger.error ("expected Type "^xmiid^" in table (find_assocs)")
fun find_aend t xmiid = fun find_aend t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of (AssociationEnd(path,aend)) => aend of (AssociationEnd(path,aend)) => aend
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected AssociationEnd "^xmiid^" in table (find_aend)") handle Option => Logger.error ("expected AssociationEnd "^xmiid^" in table (find_aend)")
fun find_variable_dec t xmiid = fun find_variable_dec t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Variable x => x of Variable x => x
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected VariableDeclaration "^xmiid^" in table") handle Option => Logger.error ("expected VariableDeclaration "^xmiid^" in table")
fun find_parent t xmiid = #2 (find_generalization t xmiid) fun find_parent t xmiid = #2 (find_generalization t xmiid)
@ -177,42 +177,42 @@ fun find_package t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Package path => path of Package path => path
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Path "^xmiid^" in table") handle Option => Logger.error ("expected Path "^xmiid^" in table")
fun path_of_classifier (Rep_OclType.Classifier x) = x fun path_of_classifier (Rep_OclType.Classifier x) = x
| path_of_classifier _ = error ("path_of_classifier called on non-Classifier argument") | path_of_classifier _ = Logger.error ("path_of_classifier called on non-Classifier argument")
fun find_constraint t xmiid = fun find_constraint t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Constraint c => c of Constraint c => c
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Constraint "^xmiid^" in table") handle Option => Logger.error ("expected Constraint "^xmiid^" in table")
fun find_associationend t xmiid = fun find_associationend t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of AssociationEnd (path,ae) => ae of AssociationEnd (path,ae) => ae
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected AssociationEnd "^xmiid^" in table") handle Option => Logger.error ("expected AssociationEnd "^xmiid^" in table")
fun path_of_association t xmiid = fun path_of_association t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Association (path,ae) => path of Association (path,ae) => path
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Association "^xmiid^" in table") handle Option => Logger.error ("expected Association "^xmiid^" in table")
fun path_of_associationend t xmiid = fun path_of_associationend t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of AssociationEnd (path,ae) => path of AssociationEnd (path,ae) => path
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected AssociationEnd "^xmiid^" in table") handle Option => Logger.error ("expected AssociationEnd "^xmiid^" in table")
fun find_association t xmiid = fun find_association t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Association (p,a) => a of Association (p,a) => a
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Association "^xmiid^" in table") handle Option => Logger.error ("expected Association "^xmiid^" in table")
fun find_association_of_associationend t xmiid = fun find_association_of_associationend t xmiid =
@ -227,7 +227,7 @@ fun find_classifier_associations t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Type(_,assocs,_,_,_) => assocs of Type(_,assocs,_,_,_) => assocs
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Association "^xmiid^" in table") handle Option => Logger.error ("expected Association "^xmiid^" in table")
fun filter_exists t cs = fun filter_exists t cs =
filter (fn x => Option.isSome (HashTable.find t x)) cs filter (fn x => Option.isSome (HashTable.find t x)) cs
@ -261,12 +261,12 @@ fun filter_bodyconstraint t cs
fun find_classifier_entries t xmiid = fun find_classifier_entries t xmiid =
let let
val _ = trace function_calls "Xmi_IDTable.find_classifier_entries \n" val _ = Logger.debug2 "Xmi_IDTable.find_classifier_entries \n"
val res = (case valOf (HashTable.find t xmiid) of val res = (case valOf (HashTable.find t xmiid) of
Type c => c Type c => c
| _ => raise Option | _ => raise Option
) handle Option => error ("expected Classifier "^xmiid^" in table (in find_classifer_entries)") ) handle Option => Logger.error ("expected Classifier "^xmiid^" in table (in find_classifer_entries)")
val _ = trace function_ends "end Xmi_IDTable.find_classifiers_entries \n" val _ = Logger.debug2 "end Xmi_IDTable.find_classifiers_entries \n"
in in
res res
end end
@ -275,7 +275,7 @@ fun find_classifier_entries t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Type (_,_,_,c,_) => c of Type (_,_,_,c,_) => c
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Classifier "^xmiid^" in table (in find_classifer)") handle Option => Logger.error ("expected Classifier "^xmiid^" in table (in find_classifer)")
fun exists_classifier t xmiid = fun exists_classifier t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
@ -287,19 +287,19 @@ fun find_classifierInState_classifier t cis_id =
of ClassifierInState c => find_classifier t c of ClassifierInState c => find_classifier t c
| Type (_,_,_,c,_) => c | Type (_,_,_,c,_) => c
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected ClassifierInState " handle Option => Logger.error ("expected ClassifierInState "
^cis_id^" in table") ^cis_id^" in table")
fun find_association_of_associationclass t xmiid = fun find_association_of_associationclass t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Type (_,_,ac,_,_) => ac of Type (_,_,ac,_,_) => ac
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected associationclass "^xmiid^" in table (in find_association_of_associationclass)") handle Option => Logger.error ("expected associationclass "^xmiid^" in table (in find_association_of_associationclass)")
fun find_activity_graph_of t xmiid = fun find_activity_graph_of t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Type (_,_,_,_,ag) => ag of Type (_,_,_,_,ag) => ag
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Classifier "^xmiid^" in table (in find_activity_graph_of)") handle Option => Logger.error ("expected Classifier "^xmiid^" in table (in find_activity_graph_of)")
fun find_classifier_type t xmiid fun find_classifier_type t xmiid
@ -319,20 +319,20 @@ fun find_classifier_type t xmiid
| Rep_OclType.Set (Rep_OclType.Classifier [x]) => Rep_OclType.Set (find_classifier_type t x) | Rep_OclType.Set (Rep_OclType.Classifier [x]) => Rep_OclType.Set (find_classifier_type t x)
| Rep_OclType.Bag (Rep_OclType.Classifier [x]) => Rep_OclType.Bag (find_classifier_type t x) | Rep_OclType.Bag (Rep_OclType.Classifier [x]) => Rep_OclType.Bag (find_classifier_type t x)
| Rep_OclType.OrderedSet (Rep_OclType.Classifier [x]) => Rep_OclType.OrderedSet (find_classifier_type t x) | Rep_OclType.OrderedSet (Rep_OclType.Classifier [x]) => Rep_OclType.OrderedSet (find_classifier_type t x)
| _ => error ("unexpected Classifier-Type "^xmiid^" in table") | _ => Logger.error ("unexpected Classifier-Type "^xmiid^" in table")
end end
handle Option => error ("expected Classifier "^xmiid^" in table (in find_classifier_type)") handle Option => Logger.error ("expected Classifier "^xmiid^" in table (in find_classifier_type)")
fun find_association_path t xmiid = fun find_association_path t xmiid =
case valOf (HashTable.find t xmiid) of (Association (x,xs)) => x case valOf (HashTable.find t xmiid) of (Association (x,xs)) => x
| _ => raise Option | _ => raise Option
handle Option => error ("expected Association "^xmiid^" in table (in find_association_path)") handle Option => Logger.error ("expected Association "^xmiid^" in table (in find_association_path)")
fun find_association_name t xmiid = fun find_association_name t xmiid =
case valOf (HashTable.find t xmiid) of (Association (_,{xmiid,name,connection})) => name case valOf (HashTable.find t xmiid) of (Association (_,{xmiid,name,connection})) => name
| _ => raise Option | _ => raise Option
handle Option => error ("expected Association "^xmiid^" in table (in find_association_name)") handle Option => Logger.error ("expected Association "^xmiid^" in table (in find_association_name)")
fun insert_constraint table (c:XMI.Constraint) = fun insert_constraint table (c:XMI.Constraint) =
HashTable.insert table (#xmiid c, Constraint c) HashTable.insert table (#xmiid c, Constraint c)
@ -379,7 +379,7 @@ fun insert_activity_graph table (XMI.mk_ActivityGraph ag) =
table (context, Type (c,xs,assocs,ac, table (context, Type (c,xs,assocs,ac,
XMI.mk_ActivityGraph ag::ags)) XMI.mk_ActivityGraph ag::ags))
| _ => raise Option) | _ => raise Option)
handle Option => error ("expected Type "^context^" in table (insert_activity_graph)"); handle Option => Logger.error ("expected Type "^context^" in table (insert_activity_graph)");
List.app (insert_transition table) (#transitions ag); List.app (insert_transition table) (#transitions ag);
insert_state table (#top ag) insert_state table (#top ag)
end end
@ -396,13 +396,13 @@ fun insert_classifierInState table cls_id cis_id =
(** insert an association into the hashtable *) (** insert an association into the hashtable *)
fun insert_association table package_prefix (association:XMI.Association) = fun insert_association table package_prefix (association:XMI.Association) =
let let
val _ = trace function_calls ("Xmi_IDTable.insert_association\n") val _ = Logger.debug2 ("Xmi_IDTable.insert_association\n")
val id = #xmiid association val id = #xmiid association
val name = #name association val name = #name association
val path = if (isSome name) then package_prefix@[valOf name] val path = if (isSome name) then package_prefix@[valOf name]
else package_prefix@["association_"^(next_unique_name table)] else package_prefix@["association_"^(next_unique_name table)]
val res = HashTable.insert table (id,Association(path,association)) val res = HashTable.insert table (id,Association(path,association))
val _ = trace function_ends ("Xmi_IDTable.insert_association\n") val _ = Logger.debug2 ("Xmi_IDTable.insert_association\n")
in in
res res
@ -410,7 +410,7 @@ fun insert_association table package_prefix (association:XMI.Association) =
fun insert_classifier table package_prefix class = fun insert_classifier table package_prefix class =
let val _ = trace function_calls ("Xmi_IDTable.insert_classifier\n") let val _ = Logger.debug2 ("Xmi_IDTable.insert_classifier\n")
val id = XMI.classifier_xmiid_of class val id = XMI.classifier_xmiid_of class
val name = XMI.classifier_name_of class val name = XMI.classifier_name_of class
val path = package_prefix @ [name] val path = package_prefix @ [name]
@ -440,7 +440,7 @@ fun insert_classifier table package_prefix class =
else if String.isPrefix "OrderedSet(" name else if String.isPrefix "OrderedSet(" name
then Rep_OclType.OrderedSet (Rep_OclType.Classifier [ then Rep_OclType.OrderedSet (Rep_OclType.Classifier [
XMI.classifier_elementtype_of class]) XMI.classifier_elementtype_of class])
else error ("didn't recognize ocltype "^name) else Logger.error ("didn't recognize ocltype "^name)
else Rep_OclType.Classifier path else Rep_OclType.Classifier path
(* This function is called before the associations are handled, *) (* This function is called before the associations are handled, *)
(* so we do not have to take care of them now... *) (* so we do not have to take care of them now... *)
@ -464,7 +464,7 @@ fun insert_classifier table package_prefix class =
val _ = HashTable.insert table (id,Type (ocltype,assocs,acPath,class,ag)) val _ = HashTable.insert table (id,Type (ocltype,assocs,acPath,class,ag))
in in
(case class (case class
of XMI.Class c => (trace function_calls "insert_classifier: Class\n"; of XMI.Class c => (Logger.debug2 "insert_classifier: Class\n";
List.app (insert_attribute table path) (#attributes c); List.app (insert_attribute table path) (#attributes c);
List.app (insert_operation table path) (#operations c); List.app (insert_operation table path) (#operations c);
List.app (insert_classifierInState table id) (#classifierInState c); List.app (insert_classifierInState table id) (#classifierInState c);
@ -477,7 +477,7 @@ fun insert_classifier table package_prefix class =
| XMI.Set c => (List.app (insert_operation table path) (#operations c); ()) | XMI.Set c => (List.app (insert_operation table path) (#operations c); ())
| XMI.Bag 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.OrderedSet c => (List.app (insert_operation table path) (#operations c); ())
| XMI.AssociationClass c => (trace function_calls "insert_classifier: AssociationClass\n"; | XMI.AssociationClass c => (Logger.debug2 "insert_classifier: AssociationClass\n";
List.app (insert_attribute table path) (#attributes c); List.app (insert_attribute table path) (#attributes c);
List.app (insert_operation table path) (#operations c); List.app (insert_operation table path) (#operations c);
List.app (insert_classifierInState table id) []; List.app (insert_classifierInState table id) [];
@ -487,7 +487,7 @@ fun insert_classifier table package_prefix class =
| _ => () | _ => ()
) )
end end
val _ = trace function_ends ("end Xmi_IDTable.insert_classifier \n") val _ = Logger.debug2 ("end Xmi_IDTable.insert_classifier \n")
in in
res res
end end
@ -496,34 +496,34 @@ fun insert_classifier table package_prefix class =
(* recursively insert mapping of xmi.id's to model elements into Hashtable *) (* recursively insert mapping of xmi.id's to model elements into Hashtable *)
fun insert_package table package_prefix (XMI.Package p) = fun insert_package table package_prefix (XMI.Package p) =
let let
val _ = trace function_calls ("Xmi_IDTable.insert_package\n") val _ = Logger.debug2 ("Xmi_IDTable.insert_package\n")
val full_name = package_prefix @ [#name p] val full_name = package_prefix @ [#name p]
val res = val res =
let let
val _ = List.app (insert_generalization table) (#generalizations p) val _ = List.app (insert_generalization table) (#generalizations p)
val _ = trace 24 "insert_package: constraints\n" val _ = Logger.debug3 "insert_package: constraints\n"
val _ = List.app (insert_constraint table) (#constraints p) val _ = List.app (insert_constraint table) (#constraints p)
val _ = trace 24 "insert_package: stereotypes\n" val _ = Logger.debug3 "insert_package: stereotypes\n"
val _ = List.app (insert_stereotype table) (#stereotypes p) val _ = List.app (insert_stereotype table) (#stereotypes p)
val _ = trace 24 "insert_package: classifiers\n" val _ = Logger.debug3 "insert_package: classifiers\n"
val _ = List.app (insert_classifier table full_name) (#classifiers p) val _ = List.app (insert_classifier table full_name) (#classifiers p)
val _ = trace 24 "insert_package: associations\n" val _ = Logger.debug3 "insert_package: associations\n"
val _ = List.app (insert_association table full_name) (#associations p) val _ = List.app (insert_association table full_name) (#associations p)
val _ = trace 24 "insert_package: packages\n" val _ = Logger.debug3 "insert_package: packages\n"
val _ = List.app (insert_package table full_name) (#packages p) val _ = List.app (insert_package table full_name) (#packages p)
val _ = trace 24 "insert_package: activity_graphs\n" val _ = Logger.debug3 "insert_package: activity_graphs\n"
val _ = List.app (insert_activity_graph table) (#activity_graphs p) val _ = List.app (insert_activity_graph table) (#activity_graphs p)
val _ = trace 24 "insert_package: dependencies\n" val _ = Logger.debug3 "insert_package: dependencies\n"
val _ = List.app (insert_dependency table) (#dependencies p) val _ = List.app (insert_dependency table) (#dependencies p)
val _ = trace 24 "insert_package: tag defenitions\n" val _ = Logger.debug3 "insert_package: tag defenitions\n"
val _ = List.app (insert_tagdefinition table) (#tag_definitions p) val _ = List.app (insert_tagdefinition table) (#tag_definitions p)
val _ = trace 24 "insert_package: events\n" val _ = Logger.debug3 "insert_package: events\n"
val _ = List.app (insert_event table) (#events p) val _ = List.app (insert_event table) (#events p)
val _ = trace 24 "insert_package: insert package\n" val _ = Logger.debug3 "insert_package: insert package\n"
in in
HashTable.insert table (#xmiid p,Package full_name) HashTable.insert table (#xmiid p,Package full_name)
end end
val _ = trace function_ends ("Xmi_IDTable.insert_package \n") val _ = Logger.debug2 ("Xmi_IDTable.insert_package \n")
in in
res res
end end
@ -532,7 +532,7 @@ fun insert_package table package_prefix (XMI.Package p) =
(* therefore we handle the top-level model seperately *) (* therefore we handle the top-level model seperately *)
fun insert_model table (XMI.Package p) = fun insert_model table (XMI.Package p) =
let let
val _ = trace function_calls ("insert_model\n") val _ = Logger.debug2 ("insert_model\n")
val full_name = nil val full_name = nil
val res = val res =
let let
@ -549,7 +549,7 @@ fun insert_model table (XMI.Package p) =
in in
HashTable.insert table (#xmiid p,Package full_name) HashTable.insert table (#xmiid p,Package full_name)
end end
val _ = trace function_ends ("Xmi_IDTable.insert_model\n") val _ = Logger.debug2 ("Xmi_IDTable.insert_model\n")
in in
res res
end end
@ -576,7 +576,7 @@ fun class_taggedvalues_of table (XMI.Class c) =
| class_taggedvalues_of table (XMI.Primitive c) = | class_taggedvalues_of table (XMI.Primitive c) =
map (fn x => (find_tagdefinition table (#tag_type x),#dataValue x)) map (fn x => (find_tagdefinition table (#tag_type x),#dataValue x))
(#taggedValue c) (#taggedValue c)
| class_taggedvalues_of table _ = error "in class_taggedvalues_of: \ | class_taggedvalues_of table _ = Logger.error "in class_taggedvalues_of: \
\argument doesn't support tagged values" \argument doesn't support tagged values"
@ -590,7 +590,7 @@ fun class_taggedvalue_of table tag (XMI.Class c) =
| class_taggedvalue_of table tag (XMI.Primitive c) = | class_taggedvalue_of table tag (XMI.Primitive c) =
Option.map #2 ((List.find (fn (x,y) => x=tag)) Option.map #2 ((List.find (fn (x,y) => x=tag))
(class_taggedvalues_of table (XMI.Primitive c))) (class_taggedvalues_of table (XMI.Primitive c)))
| class_taggedvalue_of table tag _ = error "in class_taggedvalues_of: \ | class_taggedvalue_of table tag _ = Logger.error "in class_taggedvalues_of: \
\argument doesn't support tagged values" \argument doesn't support tagged values"

2
su4sml/src/xmi_ocl.sml
View File

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

98
su4sml/src/xmi_parser.sml
View File

@ -5,7 +5,8 @@
* xmi_parser.sml --- an xmi-parser for the import interface for su4sml * xmi_parser.sml --- an xmi-parser for the import interface for su4sml
* This file is part of su4sml. * This file is part of su4sml.
* *
* Copyright (c) 2005-2007, ETH Zurich, Switzerland * Copyright (c) 2005-2007 ETH Zurich, Switzerland
* 2008-2009 Achim D. Brucker, Germany
* *
* All rights reserved. * All rights reserved.
* *
@ -44,7 +45,6 @@ structure XmiParser : sig
end = end =
struct struct
open Rep_Helper open Rep_Helper
open Rep_Logger
open XmlTree open XmlTree
open XmlTreeHelper open XmlTreeHelper
@ -58,7 +58,7 @@ fun bool_value_of string atts =
let val att = value_of string atts let val att = value_of string atts
in in
(valOf o Bool.fromString) att (valOf o Bool.fromString) att
handle Option => error ("boolean attribute \""^string^ handle Option => Logger.error ("boolean attribute \""^string^
"\" has non-boolean value \""^att^ "\" has non-boolean value \""^att^
"\" (xmi.id = "^(value_of "xmi.id" atts)^")") "\" (xmi.id = "^(value_of "xmi.id" atts)^")")
end end
@ -68,7 +68,7 @@ fun int_value_of string atts =
let val att = value_of string atts let val att = value_of string atts
in in
(valOf o Int.fromString) att (valOf o Int.fromString) att
handle Option => error ("integer attribute \""^string^ handle Option => Logger.error ("integer attribute \""^string^
"\" has non-integer value \""^att^ "\" has non-integer value \""^att^
"\" (xmi.id = "^(value_of "xmi.id" atts)^")") "\" (xmi.id = "^(value_of "xmi.id" atts)^")")
end end
@ -82,7 +82,7 @@ fun xmiidref t = t |> attributes |> value_of "xmi.idref"
fun optional_name_or_empty atts = atts |> optional_value_of "name" fun optional_name_or_empty atts = atts |> optional_value_of "name"
|> get_optional_or_default "" |> get_optional_or_default ""
fun unknown_attribute_value atts att s = error ("attribute \""^att^ fun unknown_attribute_value atts att s = Logger.error ("attribute \""^att^
"\" has unknown value \""^s^ "\" has unknown value \""^s^
"\" (xmi.id = "^(atts |> xmiid)^")") "\" (xmi.id = "^(atts |> xmiid)^")")
@ -281,7 +281,7 @@ fun mkOCLExpression (tree as Node(("UML15OCL.Expressions.BooleanLiteralExp",
} }
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.AssociationClassCall\ | mkOCLExpression (tree as Node(("UML15OCL.Expressions.AssociationClassCall\
\Exp",atts),_)) \Exp",atts),_))
= error ("AssociationClassCallExp is not yet implemented"^some_id tree) = Logger.error ("AssociationClassCallExp is not yet implemented"^some_id tree)
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.VariableExp",atts),_)) | mkOCLExpression (tree as Node(("UML15OCL.Expressions.VariableExp",atts),_))
= XMI.VariableExp = XMI.VariableExp
{ referredVariable = tree |> xmiidref_to { referredVariable = tree |> xmiidref_to
@ -347,7 +347,7 @@ fun mkOCLExpression (tree as Node(("UML15OCL.Expressions.BooleanLiteralExp",
expression_type = tree |> expression_type expression_type = tree |> expression_type
} }
| mkOCLExpression tree = | mkOCLExpression tree =
error ("unknown OCLExpression type \""^(tagname tree)^"\""^some_id tree^ Logger.error ("unknown OCLExpression type \""^(tagname tree)^"\""^some_id tree^
".") ".")
and mkVariableDec vtree = and mkVariableDec vtree =
let val atts = vtree |> assert "UML15OCL.Expressions.VariableDeclaration" let val atts = vtree |> assert "UML15OCL.Expressions.VariableDeclaration"
@ -363,7 +363,7 @@ and mkVariableDec vtree =
|> xmiidref |> xmiidref
} }
end end
(* handle IllFormed msg => error ("in mkVariableDec: "^msg)*) (* handle IllFormed msg => Logger.error ("in mkVariableDec: "^msg)*)
fun mkTaggedValue tree = fun mkTaggedValue tree =
let val atts = tree |> assert "UML:TaggedValue" |> attributes let val atts = tree |> assert "UML:TaggedValue" |> attributes
@ -378,7 +378,7 @@ fun mkTaggedValue tree =
|> xmiidref |> xmiidref
} }
end end
(*handle IllFormed msg => error ("in mkTaggedValue: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkTaggedValue: "^msg)*)
fun mkAttribute tree = fun mkAttribute tree =
let val atts = tree |> assert "UML:Attribute" |> attributes let val atts = tree |> assert "UML:Attribute" |> attributes
@ -408,7 +408,7 @@ fun mkAttribute tree =
|> map mkTaggedValue |> map mkTaggedValue
} }
end end
(*handle IllFormed msg => error ("in mkAttribute: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkAttribute: "^msg)*)
fun mkQualifier tree = fun mkQualifier tree =
get_maybe "UML:Attribute" tree get_maybe "UML:Attribute" tree
@ -437,7 +437,7 @@ fun mkAssociationEnd association tree:XMI_Core.AssociationEnd =
|> xmiidref |> xmiidref
} }
end end
(*handle IllFormed msg => error ("in mkAssociationEnd: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkAssociationEnd: "^msg)*)
(* This is a hack to handle the implicit association end to *) (* This is a hack to handle the implicit association end to *)
(* the AssociationClass itself. *) (* the AssociationClass itself. *)
@ -478,12 +478,12 @@ fun mkAssociationFromAssociationClass tree =
|> map (mkAssociationEnd id) |> map (mkAssociationEnd id)
} }
end end
(*handle IllFormed msg => error ("in mkAssociation: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkAssociation: "^msg)*)
fun mkAssociation tree = fun mkAssociation tree =
let let
val _ = trace function_calls ("XmiParser.mkAssociation\n") val _ = Logger.debug2 ("XmiParser.mkAssociation\n")
val atts = tree |> assert "UML:Association" |> attributes val atts = tree |> assert "UML:Association" |> attributes
val id = atts |> xmiid val id = atts |> xmiid
(* FIXME: empty string is returned as (SOME "") instead of NONE *) (* FIXME: empty string is returned as (SOME "") instead of NONE *)
@ -496,11 +496,11 @@ fun mkAssociation tree =
connection = tree |> get_many "UML:Association.connection" connection = tree |> get_many "UML:Association.connection"
|> map (mkAssociationEnd id) |> map (mkAssociationEnd id)
} }
val _ = trace function_ends ("end XmiParser.mkAssociation") val _ = Logger.debug2 ("end XmiParser.mkAssociation")
in in
res res
end end
(* handle IllFormed msg => error ("in mkAssociation: "^msg)*) (* handle IllFormed msg => Logger.error ("in mkAssociation: "^msg)*)
val filterAssociations = filter "UML:Association" val filterAssociations = filter "UML:Association"
val filterAssociationClasses = filter "UML:AssociationClass" val filterAssociationClasses = filter "UML:AssociationClass"
@ -551,7 +551,7 @@ fun mkDependency tree =
|> xmiidref |> xmiidref
} }
end end
(*handle IllFormed msg => error ("in mkDependency: "^msg) *) (*handle IllFormed msg => Logger.error ("in mkDependency: "^msg) *)
fun mkConstraint tree = fun mkConstraint tree =
let val atts = tree |> assert "UML:Constraint" |> attributes let val atts = tree |> assert "UML:Constraint" |> attributes
@ -566,7 +566,7 @@ fun mkConstraint tree =
|> mkOCLExpression |> mkOCLExpression
} }
end end
(*handle IllFormed msg => error ("in mkConstraint: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkConstraint: "^msg)*)
fun mkParameter tree = fun mkParameter tree =
@ -580,7 +580,7 @@ fun mkParameter tree =
|> get_optional_or_default "" |> get_optional_or_default ""
} }
end end
(*handle IllFormed msg => error ("in mkParameter: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkParameter: "^msg)*)
fun mkOperation tree = fun mkOperation tree =
let val atts = tree |> assert "UML:Operation" |> attributes let val atts = tree |> assert "UML:Operation" |> attributes
@ -596,7 +596,7 @@ fun mkOperation tree =
|> map xmiidref |> map xmiidref
} }
end end
(*handle IllFormed msg => error ("in mkOperation: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkOperation: "^msg)*)
fun mkTagDefinition tree = fun mkTagDefinition tree =
let val atts = tree |> assert "UML:TagDefinition" |> attributes let val atts = tree |> assert "UML:TagDefinition" |> attributes
@ -607,14 +607,14 @@ fun mkTagDefinition tree =
|> mkMultiplicity |> mkMultiplicity
} }
end end
(*handle IllFormed msg => error ("in mkTagDefinition: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkTagDefinition: "^msg)*)
fun mkStereotypeR tree = fun mkStereotypeR tree =
let val atts = tree |> assert "UML:Stereotype" |> attributes let val atts = tree |> assert "UML:Stereotype" |> attributes
in in
tree |> xmiidref tree |> xmiidref
end end
(*handle IllFormed msg => error ("in mkStereotype: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkStereotype: "^msg)*)
fun mkAction tree = fun mkAction tree =
let val atts = tree |> attributes let val atts = tree |> attributes
@ -630,7 +630,7 @@ fun mkAction tree =
body = expr_atts |> body , body = expr_atts |> body ,
expression = "" (* FIXME: is this even useful? *)} expression = "" (* FIXME: is this even useful? *)}
end end
(*handle IllFormed msg => error ("in mkAction: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkAction: "^msg)*)
(* This works for ArgoUML, i.e. 1.4 metamodels... *) (* This works for ArgoUML, i.e. 1.4 metamodels... *)
fun mkProcedure tree = fun mkProcedure tree =
@ -644,7 +644,7 @@ fun mkProcedure tree =
elem = "UML:TerminateAction" orelse elem = "UML:TerminateAction" orelse
elem = "UML:UninterpretedAction" elem = "UML:UninterpretedAction"
then mkAction tree then mkAction tree
else error ("unknown Action type \""^elem^"\""^(some_id tree)^".") else Logger.error ("unknown Action type \""^elem^"\""^(some_id tree)^".")
end end
fun mkGuard tree = fun mkGuard tree =
@ -662,7 +662,7 @@ fun mkGuard tree =
expr is "UML:BooleanExpression" expr is "UML:BooleanExpression"
then expr_atts |> language then expr_atts |> language
else else
error ("unknown expression type \""^(tagname expr)^ Logger.error ("unknown expression type \""^(tagname expr)^
"\""^some_id expr^"."), "\""^some_id expr^"."),
body = if expr is "UML:BooleanExpression" then body = if expr is "UML:BooleanExpression" then
SOME (expr_atts |> body) SOME (expr_atts |> body)
@ -671,7 +671,7 @@ fun mkGuard tree =
then SOME (mkOCLExpression expr) then SOME (mkOCLExpression expr)
else NONE} else NONE}
end end
(*handle IllFormed msg => error ("in mkGuard: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkGuard: "^msg)*)
fun mkTransition tree = fun mkTransition tree =
@ -694,7 +694,7 @@ fun mkTransition tree =
|> map mkTaggedValue |> map mkTaggedValue
} }
end end
(*handle IllFormed msg => error ("in mkTransition: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkTransition: "^msg)*)
@ -804,7 +804,7 @@ fun mkState tree =
outgoing = outgoing,incoming = incoming, outgoing = outgoing,incoming = incoming,
taggedValue = tagval} taggedValue = tagval}
| s => error ("unknown StateVertex type \""^s^"\""^some_id tree^".") | s => Logger.error ("unknown StateVertex type \""^s^"\""^some_id tree^".")
end end
and mkStateMachine tree = and mkStateMachine tree =
let val atts = tree |> assert "UML:StateMachine" |> attributes let val atts = tree |> assert "UML:StateMachine" |> attributes
@ -820,7 +820,7 @@ and mkStateMachine tree =
|> map mkTransition |> map mkTransition
} }
end end
(*handle IllFormed msg => error ("in mkStateMachine: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkStateMachine: "^msg)*)
fun mkActivityGraph tree = fun mkActivityGraph tree =
@ -837,11 +837,11 @@ fun mkActivityGraph tree =
|> map mkTransition, |> map mkTransition,
partition = nil} partition = nil}
end end
(*handle IllFormed msg => error ("in mkActivityGraph: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkActivityGraph: "^msg)*)
fun mkClass atts tree = fun mkClass atts tree =
let let
val _ = trace function_calls ("XmiParser.mkClass \n") val _ = Logger.debug2 ("XmiParser.mkClass \n")
val res = XMI.Class val res = XMI.Class
{ xmiid = atts |> xmiid, { xmiid = atts |> xmiid,
name = atts |> name, name = atts |> name,
@ -876,17 +876,17 @@ fun mkClass atts tree =
|> filter "UML:ActivityGraph" |> filter "UML:ActivityGraph"
|> map mkActivityGraph |> map mkActivityGraph
} }
val _ = trace function_ends ("end XmiParser.mkClass \n") val _ = Logger.debug2 ("end XmiParser.mkClass \n")
in in
res res
end end
(*handle IllFormed msg => error ("Error in mkClass "^(name atts)^ (*handle IllFormed msg => Logger.error ("Error in mkClass "^(name atts)^
": "^msg)*) ": "^msg)*)
(* extended to match Rep.AssociationClass *) (* extended to match Rep.AssociationClass *)
fun mkAssociationClass atts tree = fun mkAssociationClass atts tree =
let let
val _ = trace function_calls ("XmiParser.mkAssociationClass\n") val _ = Logger.debug2 ("XmiParser.mkAssociationClass\n")
val id = atts |> xmiid val id = atts |> xmiid
val res = XMI.AssociationClass val res = XMI.AssociationClass
{ xmiid = id, { xmiid = id,
@ -926,12 +926,12 @@ fun mkAssociationClass atts tree =
*)connection = tree |> get_many "UML:Association.connection" *)connection = tree |> get_many "UML:Association.connection"
|> map (mkAssociationEnd id) |> map (mkAssociationEnd id)
} }
val _ = trace function_ends ("end XmiParser.mkAssociation Class\n") val _ = Logger.debug2 ("end XmiParser.mkAssociation Class\n")
in in
res res
end end
(*handle IllFormed msg => error ("in mkAssociationClass: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkAssociationClass: "^msg)*)
fun mkPrimitive atts tree fun mkPrimitive atts tree
@ -948,7 +948,7 @@ fun mkPrimitive atts tree
taggedValue = tree |> get "UML:ModelElement.taggedValue" taggedValue = tree |> get "UML:ModelElement.taggedValue"
|> map mkTaggedValue |> map mkTaggedValue
} }
(* handle IllFormed msg => error ("in mkPrimitive: "^msg)*) (* handle IllFormed msg => Logger.error ("in mkPrimitive: "^msg)*)
fun mkInterface atts tree fun mkInterface atts tree
= XMI.Interface = XMI.Interface
@ -966,12 +966,12 @@ fun mkInterface atts tree
supplierDependency = tree |> get "UML:ModelElement.supplierDependency" supplierDependency = tree |> get "UML:ModelElement.supplierDependency"
|> map xmiidref |> map xmiidref
} }
(*handle IllFormed msg => error ("in mkInterface: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkInterface: "^msg)*)
fun mkEnumerationLiteral tree = fun mkEnumerationLiteral tree =
tree |> assert "UML:EnumerationLiteral" tree |> assert "UML:EnumerationLiteral"
|> attributes |> name |> attributes |> name
(*handle IllFormed msg => error ("in mkOperation: "^msg)*) (*handle IllFormed msg => Logger.error ("in mkOperation: "^msg)*)
fun mkEnumeration atts tree fun mkEnumeration atts tree
@ -988,12 +988,12 @@ fun mkEnumeration atts tree
literals = tree |> get "UML:Enumeration.literal" literals = tree |> get "UML:Enumeration.literal"
|> map mkEnumerationLiteral |> map mkEnumerationLiteral
} }
(* handle IllFormed msg => error ("in mkEnumeration: "^msg)*) (* handle IllFormed msg => Logger.error ("in mkEnumeration: "^msg)*)
fun mkVoid atts tree = XMI.Void { xmiid = atts |> xmiid, fun mkVoid atts tree = XMI.Void { xmiid = atts |> xmiid,
name = atts |> name name = atts |> name
} }
(* handle IllFormed msg => error ("in mkVoid: "^msg)*) (* handle IllFormed msg => Logger.error ("in mkVoid: "^msg)*)
fun mkGenericCollection atts tree = fun mkGenericCollection atts tree =
@ -1007,7 +1007,7 @@ fun mkGenericCollection atts tree =
elementtype = tree |> get_one "OCL.Types.CollectionType.elementType" elementtype = tree |> get_one "OCL.Types.CollectionType.elementType"
|> xmiidref |> xmiidref
} }
(* handle IllFormed msg => error ("in mkGenericCollection: "^msg) *) (* handle IllFormed msg => Logger.error ("in mkGenericCollection: "^msg) *)
fun mkCollection atts tree = XMI.Collection (mkGenericCollection atts tree) fun mkCollection atts tree = XMI.Collection (mkGenericCollection atts tree)
@ -1027,7 +1027,7 @@ fun mkStereotype tree =
stereotypeConstraint = NONE (* FIXME, not supported by ArgoUML 0.22 *) stereotypeConstraint = NONE (* FIXME, not supported by ArgoUML 0.22 *)
} }
end end
(* handle IllFormed msg => error ("in mkStereotype: "^msg)*) (* handle IllFormed msg => Logger.error ("in mkStereotype: "^msg)*)
fun mkClassifier tree = fun mkClassifier tree =
@ -1047,7 +1047,7 @@ fun mkClassifier tree =
| "UML15OCL.Types.SetType" => mkSet atts tree | "UML15OCL.Types.SetType" => mkSet atts tree
| "UML15OCL.Types.BagType" => mkBag atts tree | "UML15OCL.Types.BagType" => mkBag atts tree
| "UML15OCL.Types.OrderedSetType" => mkOrderedSet atts tree | "UML15OCL.Types.OrderedSetType" => mkOrderedSet atts tree
| _ => error ("unknown Classifier type \""^elem^ | _ => Logger.error ("unknown Classifier type \""^elem^
"\""^some_id tree^".") "\""^some_id tree^".")
end end
@ -1088,7 +1088,7 @@ fun mkEvent tree =
in in
case elem of "UML:CallEvent" => mkCallEvent atts tree case elem of "UML:CallEvent" => mkCallEvent atts tree
| "UML:SignalEvent" => mkSignalEvent atts tree | "UML:SignalEvent" => mkSignalEvent atts tree
| _ => error ("unknown Event type \""^elem^"\""^some_id tree^".") | _ => Logger.error ("unknown Event type \""^elem^"\""^some_id tree^".")
end end
@ -1099,8 +1099,8 @@ fun mkPackage tree =
then let val trees = tree |> get "UML:Namespace.ownedElement" then let val trees = tree |> get "UML:Namespace.ownedElement"
val atts = attributes tree val atts = attributes tree
val package_name = atts |> name val package_name = atts |> name
val _ = if tree is "UML:Model" then info ("parsing model "^package_name) val _ = if tree is "UML:Model" then Logger.info ("parsing model "^package_name)
else info ("parsing package "^package_name) else Logger.info ("parsing package "^package_name)
in in
XMI.Package XMI.Package
{ xmiid = atts |> xmiid, { xmiid = atts |> xmiid,
@ -1128,7 +1128,7 @@ fun mkPackage tree =
events = trees |> filterEvents |> map mkEvent events = trees |> filterEvents |> map mkEvent
} }
end end
else error "no UML:Model or UML:Package found" else Logger.error "no UML:Model or UML:Package found"
fun mkXmiContent tree = fun mkXmiContent tree =
@ -1154,10 +1154,10 @@ val emptyXmiContent = { packages = nil,
state_machines = nil} state_machines = nil}
fun findXmiContent tree = valOf (dfs "XMI.content" tree) fun findXmiContent tree = valOf (dfs "XMI.content" tree)
handle Option => error "no XMI.content found" handle Option => Logger.error "no XMI.content found"
fun readFile f = (mkXmiContent o findXmiContent o XmlTreeParser.readFile) f fun readFile f = (mkXmiContent o findXmiContent o XmlTreeParser.readFile) f
handle ex => (error_msg ("Error during parsing of "^f^": \n\t"^General.exnMessage ex); handle ex => (Logger.warn ("Error during parsing of "^f^": \n\t"^General.exnMessage ex);
raise ex) raise ex)
end end

8
su4sml/src/xmi_state_machines.sml
View File

@ -201,7 +201,7 @@ and StateMachine = mk_StateMachine of
transitions : Transition list} transitions : Transition list}
fun state_type_of (ObjectFlowState{type_,...}) = type_ fun state_type_of (ObjectFlowState{type_,...}) = type_
| state_type_of _ = Rep_Logger.error "in state_type_of: argument is not an ObjectFlow state" | state_type_of _ = Logger.error "in state_type_of: argument is not an ObjectFlow state"
fun state_entry_of (CompositeState{entry,...}) = entry fun state_entry_of (CompositeState{entry,...}) = entry
| state_entry_of (SubactivityState{entry,...}) = entry | state_entry_of (SubactivityState{entry,...}) = entry
@ -209,7 +209,7 @@ fun state_entry_of (CompositeState{entry,...}) = entry
| state_entry_of (ActionState{entry,...}) = entry | state_entry_of (ActionState{entry,...}) = entry
| state_entry_of (ObjectFlowState{entry,...}) = entry | state_entry_of (ObjectFlowState{entry,...}) = entry
| state_entry_of (FinalState{entry,...}) = entry | state_entry_of (FinalState{entry,...}) = entry
| state_entry_of _ = Rep_Logger.error "in state_entry_of: argument does not have entry actions" | state_entry_of _ = Logger.error "in state_entry_of: argument does not have entry actions"
fun state_xmiid_of (CompositeState{xmiid,...}) = xmiid fun state_xmiid_of (CompositeState{xmiid,...}) = xmiid
| state_xmiid_of (SubactivityState{xmiid,...}) = xmiid | state_xmiid_of (SubactivityState{xmiid,...}) = xmiid
@ -231,7 +231,7 @@ fun state_name_of (CompositeState{name,...}) = name
fun state_subvertices_of (CompositeState{subvertex,...}) = subvertex fun state_subvertices_of (CompositeState{subvertex,...}) = subvertex
| state_subvertices_of (SubactivityState{subvertex,...}) = subvertex | state_subvertices_of (SubactivityState{subvertex,...}) = subvertex
| state_subvertices_of _ = Rep_Logger.error "in state_subvertices_of: argument is \ | state_subvertices_of _ = Logger.error "in state_subvertices_of: argument is \
\not a composite state" \not a composite state"
fun state_outgoing_trans_of (CompositeState{outgoing,...}) = outgoing fun state_outgoing_trans_of (CompositeState{outgoing,...}) = outgoing
@ -241,7 +241,7 @@ fun state_outgoing_trans_of (CompositeState{outgoing,...}) = outgoing
| state_outgoing_trans_of (ObjectFlowState{outgoing,...}) = outgoing | state_outgoing_trans_of (ObjectFlowState{outgoing,...}) = outgoing
| state_outgoing_trans_of (PseudoState{outgoing,...}) = outgoing | state_outgoing_trans_of (PseudoState{outgoing,...}) = outgoing
| state_outgoing_trans_of (SyncState{outgoing,...}) = outgoing | state_outgoing_trans_of (SyncState{outgoing,...}) = outgoing
| state_outgoing_trans_of (FinalState _) = Rep_Logger.error "in state_outgoing_trans_of: \ | state_outgoing_trans_of (FinalState _) = Logger.error "in state_outgoing_trans_of: \
\argument is a final state" \argument is a final state"
fun state_incoming_trans_of (CompositeState{incoming,...}) = incoming fun state_incoming_trans_of (CompositeState{incoming,...}) = incoming

13
su4sml/src/xmltree.sml
View File

@ -57,7 +57,6 @@ structure XmlTree : sig
val value_of : string -> Attribute list -> string val value_of : string -> Attribute list -> string
val has_attribute : string -> Tree -> bool val has_attribute : string -> Tree -> bool
end = struct end = struct
open Rep_Logger
infix 1 |> infix 1 |>
(** A name-value pair. *) (** A name-value pair. *)
@ -80,19 +79,19 @@ fun tagname (Node ((elem,atts),trees)) = elem
| tagname (Text _) = "" | tagname (Text _) = ""
fun text (Text s) = s fun text (Text s) = s
| text x = error ("in XmlTree.text: argument is a Node element (<"^tagname x^">).") | text x = Logger.error ("in XmlTree.text: argument is a Node element (<"^tagname x^">).")
fun attributes (Node ((elem,atts),trees)) = atts fun attributes (Node ((elem,atts),trees)) = atts
| attributes _ = error "in attributes_of: argument is a Text-Node" | attributes _ = Logger.error "in attributes_of: argument is a Text-Node"
fun children (Node ((elem,atts),trees)) = trees fun children (Node ((elem,atts),trees)) = trees
| children _ = error "in XmlTree.children: argument is a Text-Node" | children _ = Logger.error "in XmlTree.children: argument is a Text-Node"
fun node_children (Node ((elem,atts),trees)) = filter_nodes trees fun node_children (Node ((elem,atts),trees)) = filter_nodes trees
| node_children _ = error "in XmlTree.node_children: argument is a Text-Node" | node_children _ = Logger.error "in XmlTree.node_children: argument is a Text-Node"
fun text_children (Node ((elem,atts),trees)) = filter_text trees fun text_children (Node ((elem,atts),trees)) = filter_text trees
| text_children _ = error "in XmlTree.text_children: argument is a Text-Node" | text_children _ = Logger.error "in XmlTree.text_children: argument is a Text-Node"
fun optional_value_of string atts = Option.map #2 (List.find (fn (x,_) => x = string) atts) fun optional_value_of string atts = Option.map #2 (List.find (fn (x,_) => x = string) atts)
@ -102,6 +101,6 @@ fun has_attribute string tree = Option.isSome (optional_value_of string (attribu
fun value_of string atts = valOf (optional_value_of string atts) fun value_of string atts = valOf (optional_value_of string atts)
handle Option => error ("in XmlTree.value_of: argument has no attribute "^string) handle Option => Logger.error ("in XmlTree.value_of: argument has no attribute "^string)
end end

9
su4sml/src/xmltree_helper.sml
View File

@ -68,7 +68,6 @@ structure XmlTreeHelper : sig
end = end =
struct struct
open Rep_Helper open Rep_Helper
open Rep_Logger
open XmlTree open XmlTree
infix 1 |> infix 1 |>
@ -80,7 +79,7 @@ fun filter_children string tree = filter string (node_children tree)
fun find_some string trees = (List.find (fn x => string = tagname x) trees) fun find_some string trees = (List.find (fn x => string = tagname x) trees)
fun find string trees = valOf (List.find (fn x => string = tagname x) trees) fun find string trees = valOf (List.find (fn x => string = tagname x) trees)
handle Option => error ("in XmlTree.find: no element "^string) handle Option => Logger.error ("in XmlTree.find: no element "^string)
fun some_id' atts = let val xmiid = atts |> optional_value_of "xmi.id" fun some_id' atts = let val xmiid = atts |> optional_value_of "xmi.id"
@ -100,10 +99,10 @@ fun some_id' atts = let val xmiid = atts |> optional_value_of "xmi.id"
fun some_id tree = some_id' (attributes tree) fun some_id tree = some_id' (attributes tree)
fun value_of string atts = XmlTree.value_of string atts fun value_of string atts = XmlTree.value_of string atts
handle ex => error ((General.exnMessage ex)^(some_id' atts)) handle ex => Logger.error ((General.exnMessage ex)^(some_id' atts))
fun find_child string tree = find string (node_children tree) fun find_child string tree = find string (node_children tree)
handle ex => error ((General.exnMessage ex)^" inside node "^(tagname tree)^(some_id tree)^"\n") handle ex => Logger.error ((General.exnMessage ex)^" inside node "^(tagname tree)^(some_id tree)^"\n")
fun dfs string tree = if tagname tree = string fun dfs string tree = if tagname tree = string
then SOME tree then SOME tree
@ -126,7 +125,7 @@ fun skipM string tree = if has_child string tree
fun is (tree,string) = string = tagname tree fun is (tree,string) = string = tagname tree
infix 2 is infix 2 is
fun assert string tree = if tree is string then tree fun assert string tree = if tree is string then tree
else error ("expected "^string^" but found "^ else Logger.error ("expected "^string^" but found "^
(tagname tree)^(some_id tree)^"\n") (tagname tree)^(some_id tree)^"\n")
(* navigate to association ends with multiplicity 1..* *) (* navigate to association ends with multiplicity 1..* *)

6
su4sml/src/xmltree_hooks.sml
View File

@ -41,7 +41,7 @@
structure XmlTreeHooks : Hooks = structure XmlTreeHooks : Hooks =
struct struct
open IgnoreHooks XmlTree UniChar HookData Rep_Logger open IgnoreHooks XmlTree UniChar HookData
type AppData = Dtd.Dtd * Tree list * (Tag * Tree list) list type AppData = Dtd.Dtd * Tree list * (Tag * Tree list) list
type AppFinal = Tree type AppFinal = Tree
@ -71,7 +71,7 @@ fun hookStartTag ((dtd,content, stack), (_,elem,atts,_,empty)) =
else (dtd,nil,((elemName,attNames),content)::stack) else (dtd,nil,((elemName,attNames),content)::stack)
end end
fun hookEndTag ((dtd,_,nil),_) = error "in hookEndTag: illformed XML" fun hookEndTag ((dtd,_,nil),_) = Logger.error "in hookEndTag: illformed XML"
| hookEndTag ((dtd,content,(tag,content')::stack),_) = | hookEndTag ((dtd,content,(tag,content')::stack),_) =
(dtd,Node (tag,rev content)::content',stack) (dtd,Node (tag,rev content)::content',stack)
@ -85,7 +85,7 @@ fun hookCharRef ((dtd,content,stack),(_,c,_)) = (* FIX *)
(dtd,content,stack) (dtd,content,stack)
fun hookFinish (dtd,[elem],nil) = elem fun hookFinish (dtd,[elem],nil) = elem
| hookFinish _ = error "in hookFinish: illformed XML" | hookFinish _ = Logger.error "in hookFinish: illformed XML"
fun print_message (pos,msg) = fun print_message (pos,msg) =

7
su4sml/src/xmltree_parser.sml
View File

@ -43,7 +43,6 @@ structure XmlTreeParser : sig
val readFile : string -> XmlTree.Tree val readFile : string -> XmlTree.Tree
end = end =
struct struct
open Rep_Logger
open XmlTree open XmlTree
exception FileNotFound of string exception FileNotFound of string
@ -57,13 +56,13 @@ fun readFile filename =
(* how to do the following in a clean/portable way? *) (* how to do the following in a clean/portable way? *)
fun read_dtd dtd = fun read_dtd dtd =
(OS.FileSys.chDir (su4sml_home()); (OS.FileSys.chDir (Config.su4sml_home());
(* check to see if the DTD file exists. *) (* check to see if the DTD file exists. *)
if OS.FileSys.access ("UML15OCL.xmi",[]) then if OS.FileSys.access ("UML15OCL.xmi",[]) then
(Parser.parseDocument (Parser.parseDocument
(SOME (Uri.String2Uri ("file:UML15OCL.xmi"))) (SOME (Uri.String2Uri ("file:UML15OCL.xmi")))
(SOME dtd) (dtd,nil,nil)) (SOME dtd) (dtd,nil,nil))
else error ("Error while reading file UML15OCL.xmi: "^ else Logger.error ("Error while reading file UML15OCL.xmi: "^
"no such file or directory"); "no such file or directory");
OS.FileSys.chDir currentDir) OS.FileSys.chDir currentDir)
@ -79,7 +78,7 @@ fun readFile filename =
(SOME (Uri.String2Uri filename)) (SOME (Uri.String2Uri filename))
(SOME dtd) (dtd,nil,nil) (SOME dtd) (dtd,nil,nil)
end end
handle ex => (error_msg ("Error while reading file " ^filename^": "^ handle ex => (Logger.warn ("Error while reading file " ^filename^": "^
General.exnMessage ex); General.exnMessage ex);
raise ex) raise ex)