(***************************************************************************** * su4sml --- a SML repository for managing (Secure)UML/OCL models * http://projects.brucker.ch/su4sml/ * * library.sml --- * This file is part of su4sml. * * Copyright (c) 2005-2007, ETH Zurich, Switzerland * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) (* $Id$ *) signature EXT_LIBRARY = sig (* operations with parents *) val class_of_parent : Rep_Core.Classifier -> Rep_Core.Classifier list -> Rep_Core.Classifier val type_of_parent : Rep_Core.Classifier -> Rep_OclType.OclType (* classifiers and packages *) val class_of_type : Rep_OclType.OclType -> Rep_Core.Classifier list -> Rep_Core.Classifier val get_classifier : Rep_OclTerm.OclTerm -> Rep_Core.Classifier list -> Rep_Core.Classifier val package_of_template_parameter : Rep_OclType.OclType -> string list (* operations for types *) val type_equals : Rep_OclType.OclType -> Rep_OclType.OclType -> bool val prefix_type : string list -> Rep_OclType.OclType -> Rep_OclType.OclType val flatten_type : Rep_OclType.OclType -> Rep_OclType.OclType val template_parameter : Rep_OclType.OclType -> Rep_OclType.OclType val isColl_Type : Rep_OclType.OclType -> bool val replace_templ_para : Rep_OclType.OclType -> Rep_OclType.OclType -> Rep_OclType.OclType val string_to_type : string list -> Rep_OclType.OclType val correct_type_for_CollLiteral : Rep_OclType.OclType -> Rep_OclTerm.CollectionPart -> bool val type_of_CollPart : Rep_OclTerm.CollectionPart -> Rep_OclType.OclType val dispatch_collection : (string * Rep_OclType.OclType) -> Rep_OclType.OclType (* operations for terms *) val prefix_expression : string list -> Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm val type_of_term : Rep_OclTerm.OclTerm -> Rep_OclType.OclType val find_operation : string -> Rep_Core.operation list -> Rep_Core.operation val find_attribute : string -> Rep_Core.attribute list -> Rep_Core.attribute (* operations for inheritance *) val conforms_to : Rep_OclType.OclType -> Rep_OclType.OclType -> Rep_Core.Classifier list -> bool val upcast : (Rep_OclTerm.OclTerm * Rep_OclType.OclType) -> Rep_OclTerm.OclTerm val args_interfereable : (string * Rep_OclType.OclType) list -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_Core.Classifier list -> bool val interfere_args : (string * Rep_OclType.OclType) list -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_Core.Classifier list -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list val interfere_methods : (Rep_Core.Classifier * Rep_Core.operation) list -> Rep_OclTerm.OclTerm -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_Core.Classifier list -> Rep_OclTerm.OclTerm val interfere_attrs_or_assocends: (Rep_Core.Classifier * Rep_Core.attribute option * Rep_Core.associationend option) list -> Rep_OclTerm.OclTerm -> Rep_Core.Classifier list -> Rep_OclTerm.OclTerm val get_overloaded_methods : Rep_Core.Classifier -> string -> Rep_Core.Classifier list -> (Rep_Core.Classifier * Rep_Core.operation) list val get_overloaded_attrs_or_assocends : Rep_Core.Classifier -> string -> Rep_Core.Classifier list -> (Rep_Core.Classifier * Rep_Core.attribute option * Rep_Core.associationend option) list val get_meth : Rep_OclTerm.OclTerm -> string -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_Core.Classifier list -> Rep_OclTerm.OclTerm val get_attr_or_assoc : Rep_OclTerm.OclTerm -> string -> Rep_Core.Classifier list -> Rep_OclTerm.OclTerm (* operations/values for debugging/logging *) val trace : int -> string -> unit val log_level : int ref val zero : int val high : int val medium : int val low : int val development : int (* exceptions *) exception InterferenceError of string exception TemplateInstantiationError of string exception NoModelReferenced of string exception GetClassifierError of string exception TemplateError of string exception NoCollectionTypeError of Rep_OclType.OclType exception NoSuchAttributeError of string exception NoSuchAssociationEndError of string exception NoSuchOperationError of string end structure Ext_Library:EXT_LIBRARY = struct open Rep_Core open Rep_OclType open Rep_OclTerm open OclLibrary exception InterferenceError of string exception TemplateInstantiationError of string exception NoModelReferenced of string exception GetClassifierError of string exception TemplateError of string exception NoCollectionTypeError of OclType exception NoSuchAttributeError of string exception NoSuchAssociationEndError of string exception NoSuchOperationError of string (* Error logging *) (* default value *) val log_level = ref 5 (* debugging-levels *) val zero = 0 val high = 5 val medium = 20 val low = 100 val development = 200 (* RETURN: unit *) fun trace lev s = if (lev <= !log_level ) then print(s) else () (* RETURN: OclType *) fun dispatch_collection (selector,typ) = case selector of "Set" => Set (typ) | "Sequence" => Sequence (typ) | "Collection" => Collection (typ) | "OrderedSet" => OrderedSet (typ) | "Bag" => Bag (typ) | _ => DummyT (* RETURN: Boolean *) fun correct_type_for_CollLiteral coll_typ (CollectionItem (term,typ)) = if (typ = coll_typ) then true else false | correct_type_for_CollLiteral coll_typ (CollectionRange (term1,term2,typ)) = if (typ = coll_typ) then true else false (* RETURN: operation *) fun find_operation op_name [] = raise NoSuchOperationError ("no such operation") | find_operation op_name ((oper:operation)::tail) = if (op_name = #name oper) then let val _ = trace low ("Operation found ... " ^ "\n"); in oper end else let val _ = trace low ("no match: next op ..." ^ (#name oper) ^ "\n") in find_operation op_name tail end (* RETURN: attribute *) fun find_attribute attr_name [] = let val _ = trace low ("Error ... " ^ "\n") in raise (NoSuchAttributeError ("Error: no attribute '"^attr_name^" found")) end | find_attribute attr_name ((a:attribute)::attribute_list) = if (attr_name = #name a) then let val _ = trace low ("Attribute found ... " ^ "\n") in (a) end else let val _ = trace low ("Attribute not found ... " ^ "\n") in (find_attribute attr_name attribute_list) end (* RETURN: OclType *) fun flatten_type (Set(Set(t))) = Set(t) | flatten_type (Set(Collection(t))) = Set(t) | flatten_type (Set(Bag(t))) = Set(t) | flatten_type (Set(OrderedSet(t))) = Set(t) | flatten_type (Set(Sequence(t))) = Set(t) | flatten_type (Collection(Set(t))) = Collection(t) | flatten_type (Collection(Bag(t))) = Collection(t) | flatten_type (Collection(OrderedSet(t))) = Collection(t) | flatten_type (Collection(Sequence(t))) = Collection(t) | flatten_type (Collection(Collection(t))) = Collection(t) | flatten_type (OrderedSet(Collection(t))) = OrderedSet(t) | flatten_type (OrderedSet(Bag(t))) = OrderedSet(t) | flatten_type (OrderedSet(OrderedSet(t))) = OrderedSet(t) | flatten_type (OrderedSet(Sequence(t))) = OrderedSet(t) | flatten_type (OrderedSet(Set(t))) = OrderedSet(t) | flatten_type (Bag(Collection(t))) = Bag(t) | flatten_type (Bag(Bag(t))) = Bag(t) | flatten_type (Bag(OrderedSet(t))) = Bag(t) | flatten_type (Bag(Sequence(t))) = Bag(t) | flatten_type (Bag(Set(t))) = Bag(t) | flatten_type (Sequence(Collection(t))) = Sequence(t) | flatten_type (Sequence(Bag(t))) = Sequence(t) | flatten_type (Sequence(OrderedSet(t))) = Sequence(t) | flatten_type (Sequence(Sequence(t))) = Sequence(t) | flatten_type (Sequence(Set(t))) = Sequence(t) | flatten_type typ = typ (* RETURN: bool *) fun member x [] = false | member x (h::tail) = if (x = h) then true else member x tail (* RETURN: Path *) fun real_path ([]) = [] | real_path ([x]) = [] | real_path (x::tail) = x::real_path tail (* RETURN: Boolean *) fun isColl_Type (Set(x)) = true | isColl_Type (Sequence(x)) = true | isColl_Type (OrderedSet(x)) = true | isColl_Type (Bag(x)) = true | isColl_Type (Collection(x)) = true | isColl_Type _ = false (* RETURN: OclTerm *) fun type_of_term (Literal (s,typ)) = typ | type_of_term (AttributeCall (t,typ,p,res_typ)) = res_typ | type_of_term (AssociationEndCall (t,typ,p,res_typ)) = res_typ | type_of_term (OperationCall (t,typ,p,l,res_typ)) = res_typ | type_of_term (Variable (s,typ)) = typ | type_of_term (CollectionLiteral (set,typ)) = typ | type_of_term (Iterator (_,_,_,_,_,_,res_typ)) = res_typ | type_of_term (If(_,_,_,_,_,_,res_typ)) = res_typ | type_of_term (OperationWithType (_,_,_,_,res_typ)) = res_typ | type_of_term (Let (_,_,_,_,_,res_typ)) = res_typ | type_of_term (Iterate (_,_,_,_,_,_,_,_,res_typ)) = res_typ fun type_of_CollPart (CollectionItem (term,typ)) = typ | type_of_CollPart (CollectionRange (term1,term2,typ)) = typ (* RETURN: OclType *) fun type_of_parent (Class {parent,...}) = let val _ = trace development ("type_of_parent : Class{parent,...} \n") in ( case parent of NONE => OclAny | SOME (t) => t ) end | type_of_parent (Primitive {parent, ...}) = ( case parent of NONE => OclAny | SOME (t) => t ) | type_of_parent (Interface {parents, ...}) = List.hd parents | type_of_parent (Template{classifier,...}) = let val _ = trace development ("type_of_parent: Template {classifier,...} \n") in type_of_parent classifier end (* RETURN: string list *) fun adjust_path [] [] = [] | adjust_path [] list = list | adjust_path (h1::tail1) (h2::tail2) = if (h1 = h2) then (h1::(adjust_path tail1 tail2)) else (h1::tail1)@(h2::tail2) (* RETURN: OclType *) fun prefix_type [] typ = typ | prefix_type h (Classifier (path)) = Classifier (h@[List.last path]) | prefix_type h (Set (t)) = Set (prefix_type h t) | prefix_type h (Collection (t)) = Collection (prefix_type h t) | prefix_type h (OrderedSet (t)) = OrderedSet (prefix_type h t) | prefix_type h (Sequence (t)) = Sequence (prefix_type h t) | prefix_type h (Bag (t)) = Bag (prefix_type h t) | prefix_type h basic_type = basic_type (* RETURN: (string * OclType) list *) fun prefix_signature ext_path [] = [] | prefix_signature ext_path ((s,typ)::tail) = (s,prefix_type ext_path typ)::(prefix_signature ext_path tail) (* RETURN: CollectionPart *) fun prefix_collectionpart ext_path (CollectionItem (term,typ)) = (CollectionItem (prefix_expression ext_path term,typ)) | prefix_collectionpart ext_path (CollectionRange (first_term,last_term,typ)) = (CollectionRange (prefix_expression ext_path first_term,prefix_expression ext_path last_term,typ)) (* RETURN: OclTerm *) and prefix_expression ext_path (Variable (s,t)) = (Variable (s,t)) | prefix_expression ext_path (Literal(s,t)) = Literal (s,t) | prefix_expression ext_path (AttributeCall (sterm,stype,path,res_typ)) = (AttributeCall (prefix_expression ext_path sterm,stype,path,res_typ)) | prefix_expression ext_path (OperationCall (sterm,stype,path,args,res_typ)) = (OperationCall (prefix_expression ext_path sterm,stype,path,args,res_typ)) | prefix_expression ext_path (Iterator (name,iter_vars,sterm,styp,expr,expr_typ,res_typ)) = let val prefixed_vars = List.map (fn a => (#1 a,prefix_type ext_path (#2 a))) iter_vars in Iterator (name,prefixed_vars,prefix_expression ext_path sterm,styp,prefix_expression ext_path expr,expr_typ,res_typ) end | prefix_expression ext_path (Let (var_name,var_type,rhs_term,rhs_type,expr,expr_type)) = (Let (var_name,prefix_type ext_path var_type,rhs_term,rhs_type,prefix_expression ext_path expr,expr_type)) | prefix_expression ext_path (If (cond,cond_type,then_e,then_type,else_e,else_type,res_type)) = (If (prefix_expression ext_path cond,cond_type,prefix_expression ext_path then_e,then_type,prefix_expression ext_path else_e,else_type,res_type)) | prefix_expression ext_path (OperationWithType (sterm,stype,para_name,para_type,res_type)) = (OperationWithType (prefix_expression ext_path sterm,stype,para_name,para_type,res_type)) | prefix_expression ext_path (CollectionLiteral (coll_part_list,typ)) = (CollectionLiteral (List.map (prefix_collectionpart ext_path) coll_part_list,typ)) (* RETURN: OclType *) fun template_parameter typ = case typ of Set(t) => t | Sequence(t) => t | Bag(t) => t | Collection(t) => t | OrderedSet(t) => t | t => raise NoCollectionTypeError t (* RETURN: OclType *) fun replace_templ_para (Collection(tt)) t = Collection (t) | replace_templ_para (Set (tt)) t = Set (t) | replace_templ_para (OrderedSet (tt)) t = OrderedSet (t) | replace_templ_para (Sequence (tt)) t = Sequence (t) | replace_templ_para (Bag (tt)) t = Bag (t) | replace_templ_para t1 t2 = raise TemplateError ("Not possible to replace template parameter of a basic type. Type is: " ^ string_of_OclType t1 ^ " \n") (* RETURN: String list *) fun package_of_template_parameter typ = case (typ) of Set (t) => (package_of_template_parameter (template_parameter t) handle NoCollectionTypeError t => package_of_template_parameter t) | OrderedSet (t) => (package_of_template_parameter (template_parameter t) handle NoCollectionTypeError t => package_of_template_parameter t) | Collection (t) => (package_of_template_parameter (template_parameter t) handle NoCollectionTypeError t => package_of_template_parameter t) | Sequence (t) => (package_of_template_parameter (template_parameter t) handle NoCollectionTypeError t => package_of_template_parameter t) | Bag (t) => (package_of_template_parameter (template_parameter t) handle NoCollectionTypeError t => package_of_template_parameter t) | Integer => [OclLibPackage] | String => [OclLibPackage] | Boolean => [OclLibPackage] | Real => [OclLibPackage] | DummyT => [] | OclVoid => [] | OclAny => [] | Classifier (p) => if (length p > 1) then List.take (p,(length p) -1) else [] (* RETURN: IDENDITAET *) fun swap1 f a b c = f c b a (* RETURN: (a' list * a' list ) *) fun parse_string c ([]) = ([],[]) fun parse_string c (h::tail) = if (c = h) then ([],h::tail) else (h::(#1 (parse_string c tail)),(#2 (parse_string c tail))) (* RETURN: OclType *) fun string_to_cons "Set" typ = Set(typ) | string_to_cons "Bag" typ = Bag(typ) | string_to_cons "Collection" typ = Collection (typ) | string_to_cons "OrderedSet" typ = OrderedSet (typ) | string_to_cons "Sequence" typ = Sequence (typ) (* RETURN: OclType *) fun string_to_type ["Integer"] = Integer | string_to_type ["Boolean"] = Boolean | string_to_type ["Real"] = Real | string_to_type ["OclAny"] = OclAny | string_to_type ["DummyT"] = DummyT | string_to_type ["String"] = String | string_to_type ["OclVoid"] = OclVoid | string_to_type [set] = if (List.exists (fn a => if (a = (#"(")) then true else false) (String.explode set)) then (* set *) let val tokens = parse_string (#"(") (String.explode set) val cons = (#1 tokens) (* delete first "(" and last ")" element *) val tail = List.tl (real_path (#2 tokens)) val _ = TextIO.output(TextIO.stdOut,"tail "^ (String.implode tail) ^ "\n") in string_to_cons (String.implode cons) (string_to_type ([String.implode tail])) end else Classifier ([set]) | string_to_type list = Classifier (list) (* RETURN: OclType *) fun type_of_template (T as Template{classifier,parameter}) = case (name_of classifier) of ["Collection(T)"] => Collection (parameter) | ["Set(T)"] => Set (parameter) | ["OrderedSet(T)"] => OrderedSet (parameter) | ["Bag(T)"] => Bag (parameter) | ["Sequence(T)"] => Sequence (parameter) (*** TYPE INFERENCE ***) (* RETURN: Boolean *) fun type_equals Integer (Classifier ([OclLibPackage,"Real"])) = true | type_equals (Classifier ([OclLibPackage,"Integer"])) Real = true | type_equals _ OclAny = true | type_equals _ (Classifier ([OclLibPackage,"OclAny"])) = true | type_equals x y = if (x = y) then true else false (* INHERITANCE *) (* RETURN: OclTyp *) fun substitute_typ typ templ_type = let val _ = trace low ("substitute type : " ^ (string_of_OclType typ) ^ " instead of " ^ (string_of_OclType templ_type) ^ " \n") in case templ_type of (* innerst type *) Sequence(TemplateParameter "T") => Sequence (typ) | Set(TemplateParameter "T") => Set(typ) | OrderedSet(TemplateParameter "T") => OrderedSet (typ) | Collection(TemplateParameter "T") => Collection(typ) | Bag(TemplateParameter "T") => Bag(typ) (* nested types *) | Sequence (t) => Sequence (substitute_typ typ t) | Set (t) => Set (substitute_typ typ t) | OrderedSet (t) => OrderedSet (substitute_typ typ t) | Collection (t) => Collection (substitute_typ typ t) | Bag (t) => Bag (substitute_typ typ t) (* only parameter *) | TemplateParameter "T" => typ (* basic types *) | OclAny => OclAny | OclVoid => OclVoid | Integer => Integer | Real => Real | String => String | Boolean => Boolean | DummyT => DummyT | Classifier (path) => Classifier (path) (* else error *) | _ => raise TemplateInstantiationError ("Template type not of type: Sequence, Set, OrderedSet, Collection or Bag") end (* RETURN: (string * OclType ) list *) fun substitute_args typ [] = [] | substitute_args typ ((s,t)::tail) = let val _ = trace low ("substitute argument : " ^ (string_of_OclType typ) ^ " template parameter of " ^ (string_of_OclType t) ^ " \n") in (s,substitute_typ typ t)::(substitute_args typ tail) end (* RETURN: operation list*) fun substitute_operations typ [] = [] | substitute_operations typ ((oper:operation)::tail) = let val _ = trace low ("\n\nsubstitute operation : " ^ (#name oper) ^ " ... \n") val args = substitute_args typ (#arguments oper) val res = substitute_typ typ (#result oper) in ({ name = #name oper, postcondition = #postcondition oper, precondition = #precondition oper, body = #body oper, arguments = args, result = res, visibility = #visibility oper, isQuery = #isQuery oper, scope = #scope oper }:operation)::(substitute_operations typ tail) end (* RETURN: OclType option *) fun substitute_parent (Set (t)) = SOME (Collection t) | substitute_parent (OrderedSet (t)) = SOME (Set (t)) | substitute_parent (Sequence (t)) = SOME (Collection (t)) | substitute_parent (Bag (t)) = SOME (Collection t) | substitute_parent (Collection (t)) = SOME (Collection (t)) | substitute_parent t = SOME (Collection t) (* RETURN: Classifier *) fun substitute_classifier typ classifier = let val _ = trace low ("substitute classifier: parameter type: " ^ string_of_OclType typ ^ " template type: " ^ string_of_OclType (type_of classifier) ^ "\n") val styp = substitute_typ typ (type_of classifier) val ops = substitute_operations typ (operations_of classifier) val sparent = substitute_parent typ in (Class { name = styp, (* take the parent of the template parameter *) parent = sparent, (* a template has no attributes *) attributes = [], operations = ops, (* a template has no associationends *) associationends = [], (* a template has no invariants *) invariant = [], (* a template has no stereotypes *) stereotypes = [], (* a template has no interfaces *) interfaces = [], (* a template's thyname is NONE *) thyname = NONE, (* a template has no activity_graphs *) activity_graphs = [] }) end (* RETURN: classifier *) (* RETURN: Classifer *) and get_classifier source model = let val typ = type_of_term (source) fun class_of_t typ cl = hd (List.filter (fn a => if ((type_of a) = typ) then true else false) cl) in case typ of (* Primitive types of lib *) Boolean => class_of_t Boolean model | Integer => class_of_t Integer model | Real => class_of_t Real model | String => class_of_t String model (* Template types of lib *) | Sequence (T) => templ_of (Sequence(TemplateParameter "T")) T model | Set (T) => templ_of (Set(TemplateParameter "T")) T model | OrderedSet (T) => templ_of (OrderedSet(TemplateParameter "T")) T model | Bag (T) => templ_of (Bag(TemplateParameter "T")) T model | Collection (T) => templ_of (Collection(TemplateParameter "T")) T model (* Class types of lib *) | OclVoid => class_of_t OclVoid model | OclAny => class_of_t OclAny model (* Model types *) | Classifier (path) => class_of_t (Classifier (path)) model | DummyT => let val _ = trace development ("GetClassifierError: DummyT \n") in raise GetClassifierError ("No classifier of type: 'DummyT' \n") end | TemplateParameter (string) => let val _ = trace development ("GetClassifierError: TemplateParameter ("^ string ^") \n") in raise GetClassifierError ("No classifier of type: 'TemplateParameter (string)' \n") end end (* RETURN: Classifier /* one-time classifier */ *) (* Return the "one-time" classifier. The classifier is instanciated form the corresponding template form the library. Its only instanciate for one use and not stored later in the library. *) and templ_of temp_typ para_typ [] = raise TemplateInstantiationError ("Error during instantiating a template" ^ "\n") | templ_of temp_typ para_typ (Template{parameter,classifier}::tail) = let val _ = trace low ("Instantiate Template for classifier: " ^ (string_of_OclType (type_of classifier)) ^ "\n") in if ((type_of classifier) = temp_typ) then substitute_classifier para_typ classifier else templ_of temp_typ para_typ tail end (* element in lib not a template *) | templ_of temp_typ para_typ (h::tail) = let val _ = trace development ("shit") in templ_of temp_typ para_typ tail end and class_of_type typ model = get_classifier (Variable ("x",typ)) model (* RETURN: Boolean *) fun conforms_to_up _ OclAny _ = true | conforms_to_up (Set(T1)) (Collection(T2)) model = let val _ = trace low ("conforms_to_up: set -> collection \n") in if (conforms_to T1 T2 model) then true else false end | conforms_to_up (Bag(T1)) (Collection(T2)) model = let val _ = trace low ("conforms_to_up: bag -> collection \n") in if (conforms_to T1 T2 model) then true else false end | conforms_to_up (Sequence(T1)) (Collection(T2)) model = let val _ = trace low ("conforms_to_up: sequence -> collection \n") in if (conforms_to T1 T2 model) then true else false end | conforms_to_up (OrderedSet(T1)) (Collection(T2)) model = let val _ = trace low ("conforms_to_up: orderedset -> collection \n") in if (conforms_to T1 T2 model) then true else false end | conforms_to_up typ1 typ2 model = let val class = class_of_type typ1 model val parents_types = type_of_parents (class) model val _ = trace low ("conforms_to_up: ... \n") in member (typ2) (parents_types) end and (* RETRUN: Boolean *) conforms_to x y model = let val _ = trace low ("conforms_to: " ^ string_of_OclType x ^ " -> " ^ string_of_OclType y ^ " ? \n") in if (x = y) then true else if (type_equals x y) then true else conforms_to_up x y model end (* RETURN: OclTerm *) and upcast (term,typ) = if (type_equals (type_of_term term) typ) then term else OperationWithType (term,type_of_term term,"oclIsTypeOf",typ,typ) (* RETURN: OclType list *) and type_of_parents (Primitive {parent,...}) model = ( case parent of NONE => [OclAny] | SOME (OclAny) => [OclAny] | SOME (t) => (t)::(type_of_parents (class_of_type t model) model) ) | type_of_parents (Class {parent,...}) model = ( case parent of NONE => [OclAny] | SOME (OclAny) => [OclAny] | SOME (t) => (t)::(type_of_parents (class_of_type t model) model) ) | type_of_parents (Interface {parents,...}) model = parents | type_of_parents (Template {classifier,...}) model = raise TemplateInstantiationError ("During Instantiation of template parent needn't to be accessed") (* RETURN: Classifier *) fun class_of_parent (Class {parent,...}) clist = (case parent of NONE => get_classifier (Variable ("x",OclAny)) clist | SOME (others) => get_classifier (Variable ("x",others)) clist ) | class_of_parent (Primitive {parent,...}) clist = (case parent of NONE => class_of_type OclAny clist | SOME (others) => class_of_type others clist ) | class_of_parent (Interface {parents,...}) clist = (* TODO: change API *) (* (case (List.last (parents)) of NONE => class_of_type OclAny clist | SOME (others) => class_of_type others clist ) *) class_of_type (List.hd parents) clist | class_of_parent c (h::tail) = class_of_parent c tail (* RETURN: Boolean *) fun args_interfereable [] [] model = true | args_interfereable ((str,typ)::tail) ((term,ttyp)::args) model = let val _ = trace low ("term type: " ^ (Ocl2String.ocl2string true term) ^ "\n") val _ = trace low ("must conform to: " ^ (string_of_OclType typ) ^ "\n") in if (conforms_to (type_of_term term) typ model) then true else false end (* not same nuber of arguments *) | args_interfereable [x] list model = false | args_interfereable list [x] model = false (* RETURN: (OclTerm * OclType) list *) fun interfere_args [] [] model = [] | interfere_args ((str,typ)::tail) ((term,_)::args) model = let val _ = trace low ("interfere args" ^ "\n") in if (type_equals typ (type_of_term term)) then (term,type_of_term term)::(interfere_args tail args model) else if (conforms_to (type_of_term term) typ model) then (term,typ)::(interfere_args tail args model) else raise InterferenceError ("Arguments are not interferebable \n") end (* RETURN: OclType *) fun interfere_res_type t1 t2 model = if (conforms_to t1 t2 model) then t2 else raise InterferenceError ("Result type does not conform \n") (* RETURN: OclTerm *) fun interfere_methods [] source args model = let val _ = trace development ("InterferenceError ... \n") in raise InterferenceError ("interefere_methods: No operation signature matches given types (source: "^(Ocl2String.ocl2string false source)^").") end | interfere_methods ((class,meth)::class_meth_list) source args model = let val _ = trace low ("\nInterfere method : name : '" ^ name_of_op meth ^ "'\n") val check_source = conforms_to (type_of_term source) (type_of class) model val check_args = args_interfereable (#arguments meth) args model val _ = trace low ("Interfereable ? : 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") in if (check_source andalso check_args) then (* signature matches given types *) (OperationCall(source,type_of class,(name_of class)@[name_of_op meth],interfere_args (#arguments meth) args model,result_of_op meth)) else (interfere_methods class_meth_list source args model) end (* RETURN: (OclTerm) *) fun interfere_attrs (class,attr:attribute) source model = let val check_source = conforms_to (type_of_term source) (type_of class) model val _ = trace low ("interfere attribute: check_source "^ Bool.toString check_source ^ "\n\n") in if check_source then (* signature matches given types *) SOME ((AttributeCall (source,type_of class,(name_of class)@[(#name attr)],(#attr_type attr)))) else NONE end (* RETURN: OclTerm option*) fun interfere_assocends (class,assocend:associationend) source model = let val check_source = conforms_to (type_of_term source) (type_of class) model val _ = trace low ("Interfere assocend: check_source " ^ Bool.toString check_source ^ "\n") val _ = trace low ("type of assoc " ^ string_of_OclType (assoc_to_attr_type assocend) ^ "\n") in if check_source then SOME ((AssociationEndCall (source,type_of class,(name_of class)@[(#name assocend)],assoc_to_attr_type assocend))) else NONE end (* RETURN: OclTerm *) fun interfere_attrs_or_assocends [] source model = raise InterferenceError ("interference_attr_or_assoc: No operation signature matches given types (source: " ^ (Ocl2String.ocl2string false source) ^ ").") | interfere_attrs_or_assocends ((class,SOME(attr:attribute),NONE)::class_attr_or_assoc_list) source model = ( case (interfere_attrs (class,attr) source model) of NONE => (interfere_attrs_or_assocends class_attr_or_assoc_list source model) | SOME (term) => term ) | interfere_attrs_or_assocends ((class,NONE,SOME(assocend:associationend))::class_attr_or_assoc_list) source model = ( case (interfere_assocends (class,assocend) source model) of NONE => (interfere_attrs_or_assocends class_attr_or_assoc_list source model) | SOME (term) => term ) (* RETURN: Boolean *) fun collection_type classifier = case (type_of classifier) of Collection(T) => true | Set (T) => true | OrderedSet (T) => true | Sequence (T) => true | Bag (T) => true | x => false (* RETURN: Boolean *) fun end_of_recursion classifier = case (type_of classifier) of Collection (T) => true | others => false (* RETURN: (Classifier * operation ) list *) fun get_overloaded_methods class op_name [] = raise NoModelReferenced ("in 'get_overloaded_methods' ...\n") | get_overloaded_methods class op_name model = let val _ = trace low("\n") val ops = operations_of class val _ = trace low("Look for methods for classifier: " ^ string_of_OclType (type_of class) ^ "\n") val ops2 = List.filter (fn a => (if ((#name a) = op_name) then true else false)) ops val _ = trace low("operation name : " ^ op_name ^ " Found " ^ Int.toString (List.length ops2) ^ " method(s) \n") val parent = class_of_parent class model val _ = trace low("Parent class : " ^ string_of_OclType (type_of parent) ^ "\n\n") val cl_op = List.map (fn a => (class,a)) ops2 in if (class = class_of_type OclAny model) then (* end of hierarchie *) if (List.length ops2 = 0) then[] else[(class,List.hd(ops2))] else ( if (end_of_recursion class) then (* end of collection hierarchie *) if (List.length ops2 = 0) then [] else [(class,List.hd(ops2))] else (* go up the hierarchie tree *) ( if (List.length ops2 = 0) then (get_overloaded_methods parent op_name model) else (cl_op)@(get_overloaded_methods parent op_name model) ) ) end (* RETURN: (Classifier * attribute option * association option) list *) fun get_overloaded_attrs_or_assocends class attr_name [] = raise NoModelReferenced ("in 'get_overloaded_attrs' ... \n") | get_overloaded_attrs_or_assocends class attr_name model = let val _ = trace low ("\n") val attrs = attributes_of class val assocends = associationends_of class val _ = trace low ("Look for attributes/assocends : Class: " ^ string_of_OclType (type_of class) ^ " \n") val attrs2 = List.filter (fn a => (if ((#name a) = attr_name) then true else false)) attrs val assocends2 = List.filter (fn a => (if ((#name a) = attr_name) then true else false)) assocends val _ = trace low ("Name of attr/assocend : " ^ attr_name ^ " Found " ^ Int.toString (List.length attrs2) ^ " attribute(s), " ^ Int.toString (List.length assocends2) ^ " assocend(s) \n") val parent = class_of_parent class model val _ = trace low ("Parent class : " ^ string_of_OclType(type_of parent) ^ "\n\n") val cl_at = List.map (fn a => (class,SOME(a),NONE)) attrs2 val cl_as = List.map (fn a => (class,NONE,SOME(a))) assocends2 in if (class = class_of_type OclAny model) then (* end of hierarchie *) if (List.length attrs2 = 0) then if (List.length assocends2 = 0) then [] else [(class,NONE,SOME(List.hd(assocends2)))] else [(class,SOME(List.hd(attrs2)),NONE)] else ( if (end_of_recursion class) then (* end of collection hierarchie *) if (List.length attrs2 = 0) then if (List.length assocends2 = 0) then [] else [(class,NONE,SOME(List.hd(assocends2)))] else [(class,SOME(List.hd(attrs2)),NONE)] else (* go up the hierarchie tree *) ( if (List.length attrs2 = 0) then if (List.length assocends2 = 0) then (get_overloaded_attrs_or_assocends parent attr_name model) else (cl_as)@(get_overloaded_attrs_or_assocends parent attr_name model) else (cl_at)@(get_overloaded_attrs_or_assocends parent attr_name model) ) ) end (* RETURN: OclTerm *) fun get_meth source op_name args model= (* object type *) let val _ = trace low ("Type of Classifier : " ^ string_of_OclType (type_of_term source ) ^ "\n") val class = get_classifier source model val meth_list = get_overloaded_methods class op_name model val _ = trace low ("overloaded methods found: " ^ Int.toString (List.length meth_list) ^ "\n") in interfere_methods meth_list source args model end (* RETURN: OclTerm *) fun get_attr_or_assoc source attr_name model = let val _ = trace low ("GET ATTRIBUTES OR ASSOCENDS: source term = " ^ Ocl2String.ocl2string false source ^ "\n") val class = get_classifier source model val attr_or_assocend_list = get_overloaded_attrs_or_assocends class attr_name model val _ = trace low ("overloaded attributes/associationends found: " ^ Int.toString (List.length attr_or_assocend_list) ^ "\n") in let val x = interfere_attrs_or_assocends attr_or_assocend_list source model val _ = trace low ("\nReturn type of attribute: " ^ string_of_OclType (type_of_term x) ^ "\n\n") in x end end end