integrated iterate support from Manuel

git-svn-id: https://projects.brucker.ch/su4sml/svn/infsec-import/trunk/src/su4sml@6727 3260e6d1-4efc-4170-b0a7-36055960796d

su4sml/src/ocl2string.sml

@@ -203,7 +203,15 @@ fun ocl2string show_types oclterm =
       (* Iterate                            *)
       (**************************************)
       (* Error                              *)
-      | Iterate (_,s,_,_,src,_,c,_,_) =>  error ("error: unknown Iterate '"^(s)^"' in in ocl2string") 
+      | Iterate ([],acc_name,acc_type,acc_term,sterm,stype,bterm,btype,res_type) =>
+	(ocl2string false sterm) ^ "->" ^ "iterate(" ^ acc_name ^ ":" ^ (Rep_OclType.string_of_OclType acc_type) ^ (ocl2string false acc_term) ^ (ocl2string false bterm)
+      | Iterate (iter_vars,acc_name,acc_type,acc_term,sterm,stype,bterm,btype,res_type) =>  
+	let
+	    fun  string_of_vars [] = "" 
+	       | string_of_vars ((string,typ)::tail) = (string ^ ":" ^ (Rep_OclType.string_of_OclType typ))^(string_of_vars tail)
+	in
+	    (ocl2string false sterm) ^ "->" ^ "iterate(" ^ (string_of_vars iter_vars)  ^ acc_name ^ ":" ^ (Rep_OclType.string_of_OclType acc_type) ^ (ocl2string false acc_term) ^ (ocl2string false bterm)
+	end
       (**************************************)
       (* Iterator                           *)
       (**************************************)
@@ -217,17 +225,17 @@ fun ocl2string show_types oclterm =
 						       else (ocl2string show_types src)^"->"^iname^"("
 							    ^(cs_list (map #1 vars))
 							    ^"|"^(ocl2string show_types c)^")"
+(*
       (* OCL Collection                     *) 
-   (* 
       | Iterate (src,styp,["oclLib",classifier,"iterate"],args,Collection _) => OclIterate u C be e  
       | Iterate (src,styp,["oclLib",classifier,"isUnique"],args,Collection _) => OclIsUnique  u C be  
       | Iterate (src,styp,["oclLib",classifier,"one"],args,Collection _) => OclOne  u C be       
       | Iterate (src,styp,["oclLib",classifier,"any"],args,Collection _) => OclAny  u C be       
       (* OCL OrderedSet                     *) 
-      | Iterate (src,styp,["oclLib",classifier,"count"],[(arg,_)],OrderedSet _) => OclOSetCount u S e       *)
+      | Iterate (src,styp,["oclLib",classifier,"count"],[(arg,_)],OrderedSet _) => OclOSetCount u S e   *)
       (* Error                              *)
-  (*    | Iterator (s,_,_,_,_,_,_) => error ("error: unknown Iterator '"^(s)^"' in in ocl2string") 
+      (*    | Iterator (s,_,_,_,_,_,_) => error ("error: unknown Iterator '"^(s)^"' in in ocl2string") *)   
-   *)   (**************************************)
+      (**************************************)
       (* Catch out                          *)
       (**************************************)
       (* Error                              *)

su4sml/src/ocl_parser/context_declarations.sml

@@ -229,6 +229,18 @@ fun add_source (source,(AttributeCall (_, _, path, res_typ ))) =
   | add_source (source, If (paras)) = 
     (* If has no source *)
     If (paras)
+  | add_source (source, Iterate([],acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) =
+    let
+	val _ = trace low ("source added for Iterate ..." ^ "\n");
+    in
+	(Iterate ([],acc_var_name,acc_var_type,acc_var_term,source,DummyT,bterm,btype,res_type))
+    end
+  | add_source (source, Iterate(iter_vars,acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) =
+    let
+	val _ = trace high ("source added for Iterate ..." ^ "\n");
+    in
+	(Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,source,DummyT,bterm,btype,res_type))
+    end
 
 (* RETURN: OclTerm list *)
 fun add_source_to_list source (h::tail) = (add_source (source,h))::tail

su4sml/src/ocl_parser/library.sml

@@ -341,6 +341,14 @@ and prefix_expression ext_path (Variable (s,t)) = (Variable (s,t))
     (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))
+  | prefix_expression ext_path (Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,restype)) = 
+    let
+	val prefixed_vars = List.map (fn a => (#1 a,prefix_type ext_path (#2 a))) iter_vars
+	val prefix_acc_type = prefix_type ext_path acc_var_type 
+    in
+	(Iterate (prefixed_vars,acc_var_name,prefix_acc_type,acc_var_term,sterm,stype,bterm,btype,restype))
+    end
+
 
 (* RETURN: OclType *)
 fun template_parameter typ =

su4sml/src/ocl_parser/ocl.grm

@@ -262,7 +262,7 @@ exception NotYetSupported of string
         | msg_operator_cs of OclTerm
         | property_call_parameters_cs of (OclTerm * OclType) list
         | qualifiers of CollectionPart list
-        | iterate_vars_cs
+        | iterate_vars_cs of (string * OclType) list
         | initialized_variable_cs of (string * OclType * OclTerm) 
         | actual_parameter_list_cs of (OclTerm * OclType) list
         | actual_parameter_list_tail_cs of (OclTerm * OclType) list
@@ -625,14 +625,14 @@ arrow_property_call_exp_cs:             iterator_name_cs PAREN_OPEN expression P
 					| 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 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 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 iterate_vars_cs initialize_variable_cs VERTICAL_BAR expression PAREN_CLOSE ()
 *)
+                                        | ITERATE PAREN_OPEN iterate_vars_cs initialized_variable_cs VERTICAL_BAR expression PAREN_CLOSE (Iterate (iterate_vars_cs,(#1 (initialized_variable_cs)),(#2 (initialized_variable_cs)),(#3 (initialized_variable_cs)),Variable ("dummy_source",DummyT),DummyT,expression,DummyT,DummyT))
+
 
-(*
 (* RETURN: (string * OclType) list *)
-iterate_vars_cs :                         actual_parameter_list_cs SEMI_COLON                ()
+iterate_vars_cs :                         formal_parameter_list_cs SEMI_COLON                (formal_parameter_list_cs)
-*)
+
 (* RETURN: (string * OclType) list *)
 iterator_vars_cs :			  formal_parameter_list_cs VERTICAL_BAR              (formal_parameter_list_cs)
 
@@ -707,7 +707,7 @@ initialized_variable_list_tail_cs_p :	  initialized_variable_list_tail_cs
 (* RETURN: (string * OclType * OclTerm) *)
 initialized_variable_list_tail_cs :       COMMA initialized_variable_cs                (initialized_variable_cs)
 
-(* RETURN: (string * OclType * OclTerm*)
+(* RETURN: string * OclType * OclTerm  *)
 initialized_variable_cs :                 formal_parameter_cs variable_initializer      ((#1 formal_parameter_cs),(#2 formal_parameter_cs),variable_initializer)
 
 (* RETURN: (string * OclType) *)

su4sml/src/ocl_parser/ocl.grm.sig

@@ -1,44 +1,3 @@
-(*****************************************************************************
- * su4sml --- a SML repository for managing (Secure)UML/OCL models
- *             http://projects.brucker.ch/su4sml/
- *                                                                            
- * ocl.grm.sig --- 
- * 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 OclParser_TOKENS =
 sig
 type ('a,'b) token

su4sml/src/ocl_parser/preprocessor.sml

@@ -187,7 +187,8 @@ and embed_atPre_expressions (Variable (str,typ)) = (Variable (str,typ))
     (Let (var_name,var_type,embed_atPre_expressions rhs,rhs_type,embed_atPre_expressions in_e,in_type))
   | embed_atPre_expressions (Iterator (name,iter_vars,sterm,stype,body_e,body_type,res_type)) = 
     (Iterator (name,iter_vars,embed_atPre_expressions sterm,stype,embed_atPre_expressions body_e,body_type,res_type))
-
+  | embed_atPre_expressions (Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) = 
+    (Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,embed_atPre_expressions sterm,stype,embed_atPre_expressions bterm,btype,res_type))
 (* RETURN: OclTerm *)
 fun embed_bound_variable (str,typ) (Variable(s,t)) = 
     let
@@ -220,6 +221,12 @@ fun embed_bound_variable (str,typ) (Variable(s,t)) =
   in
       (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))
   end
+| embed_bound_variable (s,typ) (Iterate (iter_vars,acc_name,acc_type,acc_term,sterm,stype,bterm,btype,res_type)) =
+  let
+      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")
+  in
+     (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))
+  end
 | embed_bound_variable (s,typ) (Let (var_name,var_type,rhs,rhs_type,in_e,in_type)) =
   let
       val _ = trace zero ("Bound variable '" ^ s ^ "' in 'Let': " ^ Ocl2String.ocl2string false (Let (var_name,var_type,rhs,rhs_type,in_e,in_type)) ^ "\n")
@@ -353,10 +360,16 @@ check_for_self arg_list typ (AttributeCall (Variable("dummy_source",_),_,path,_)
   end
 | check_for_self arg_list typ (Iterator (name,iter_var,sterm,styp,expr,expr_typ,res_typ)) model = 
   let
-      val _ = trace zero ("check_for_self: complex OperationCall "^ "\n")
+      val _ = trace zero ("check_for_self: Iterator "^ "\n")
   in
       (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))
   end
+| check_for_self arg_list typ (Iterate (iter_vars,acc_name,acc_type,acc_term,sterm,stype,bterm,btype,res_type)) model = 
+  let
+      val _ = trace zero ("check_for_self: Iterate "^ "\n")
+  in
+      (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))
+  end
 | check_for_self arg_list typ (Let (str,ttyp,rhs_term,rhs_typ,in_term,in_typ)) model =
   let
       val self_rhs_term = check_for_self arg_list typ rhs_term model

su4sml/src/ocl_parser/type_checker.sml

@@ -51,6 +51,8 @@ sig
     exception NotYetSupportedError of string
     exception WrongContextChecked of Context.context
     exception IterateError of string
+    exception IterateAccumulatorTypeError of string
+    exception IterateTypeMissMatch of string
 
     val check_context_list            : Context.context list -> Rep_Core.Classifier list -> Context.context option list
     val check_context                 : Context.context -> Rep_Core.Classifier list -> Context.context option
@@ -75,8 +77,6 @@ open Ext_Library
 type operation = Rep_Core.operation
 type attribute = Rep_Core.attribute
 
-
-
 exception wrongCollectionLiteral of Rep_OclTerm.OclTerm * string
 exception CollectionRangeError of Rep_OclTerm.CollectionPart * string
 exception IteratorTypeMissMatch of Rep_OclTerm.OclTerm * string 
@@ -87,6 +87,8 @@ exception WrongContextChecked of context
 exception AsSetError of (OclTerm * string list * int * (OclTerm * OclType) list *  Classifier list)
 exception DesugaratorCall of (OclTerm * string list * int * (OclTerm * OclType) list * Classifier list)
 exception IterateError of string			     
+exception IterateAccumulatorTypeError of string
+exception IterateTypeMissMatch of string			  
 
 (* RETURN: bool *)
 fun check_argument_type [] [] = true
@@ -440,48 +442,6 @@ let
 			   | NoCollectionTypeError typ => AsSet_desugarator rterm meth_path 0 rargs model 
 		     )
       end
-  end
-(* generic iterate: Iterate *)
-| resolve_OclTerm (Iterate (iter_vars,res_var_name,res_var_typ,res_var_term,sterm,_,body_expr,_,res_typ)) model = 
-let
-    val _ = trace low ("RESOLVE Iterte: iterate = " ^ res_var_name  ^ "\n")
-	    
-	    
-    (* resolve source *)
-    val rsterm = resolve_OclTerm sterm model
-    val rtyp = type_of_term rsterm
-    val typ_of_iter = template_parameter rtyp
-
-    (* check type of iterate variables *)
-    val class_list = List.map (fn (a,b) => class_of_type b model) iter_vars
-    val typ_list = List.map type_of class_list
-		   
-    val list_conf = List.map (fn a => conforms_to a typ_of_iter model) typ_list
-in
-    if (List.all (fn (a) => if (a) then true else false) list_conf)
-    then
-	let
-	    (* resolve res term *)
-	    val res_var_rterm = resolve_OclTerm res_var_term model
-	    val res_var_rtyp = type_of_term res_var_rterm
-	    (* embed 'iterate'-variable in body_expr term *)
-	    val embed_body = embed_bound_variables iter_vars body_expr 
-	    (* resolve body_expr *)
-	    val rbody = resolve_OclTerm embed_body model
-	    val rbody_typ = type_of_term rbody
-	in
-	    if (conforms_to res_var_rtyp res_var_typ model)
-	    then
-		if (conforms_to rbody_typ res_var_typ model)
-		then
-		    Iterate (iter_vars,res_var_name,res_var_typ,res_var_rterm,rsterm,rtyp,rbody,rbody_typ,res_var_typ)
-		else
-		    raise IterateError ("Bodytermtyp (" ^ string_of_OclType rbody_typ ^") does not conform to result typ of expression (" ^ string_of_OclType res_var_typ ^ "\n")
-	    else
-		raise IterateError ("Static type of result variable (" ^ string_of_OclType res_var_typ ^ ") does not conform to dynamic type result variable (" ^ string_of_OclType res_var_rtyp ^ ") \n") 
-	end
-    else
-	raise IterateError ("Type of iteratores [] doesn't conform to type of source (" ^ (string_of_OclType rtyp) ^ "\n")
 end
 (* Iterator *)
 | resolve_OclTerm (Iterator (name,iter_vars,source_term,_,expr,expr_typ,res_typ)) model =
@@ -541,6 +501,53 @@ end
       else      
 	  raise IteratorTypeMissMatch (Iterator (name,iter_vars,source_term,DummyT,expr,expr_typ,res_typ),("Iterator variable doesn't conform to choosen set \n"))
   end     
+| resolve_OclTerm (Iterate (iter_vars,acc_var_name,acc_var_type,acc_var_term,sterm,stype,bterm,btype,res_type)) model = 
+let
+      (* resolve source term, type *)
+      val _ = trace medium ("RESOLVE Iterate: accumulator " ^ acc_var_name ^ "\n")
+      val rterm = resolve_OclTerm sterm model
+      val rtyp = type_of_term rterm
+      val _ = trace medium ("res Iterate: source type " ^ string_of_OclType (type_of_term  rterm) ^ "\n\n")
+      (* get source classifier *)
+      val source_class = get_classifier rterm model
+      val _ = trace medium ("res Iterate: type of classifier: " ^ string_of_OclType (type_of source_class) ^ "\n")
+      (* prefix types *)
+      val prfx = (package_of_template_parameter (type_of source_class))
+      val _ = trace medium ("res Iterate: Type prefixed ... \n")
+      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 _ = trace medium ("res Iterate: first iter types: " ^ string_of_OclType (List.hd piter_types) ^ "\n") 
+      (* check if iterator types correspond to source type *)
+      val static_iter_type = template_parameter (type_of (source_class))
+      val _ = trace medium ("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 _ = trace medium ("\nstatic iter type : " ^ string_of_OclType static_iter_type ^ "  \n")
+      val _ = trace medium ("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 check = List.all (fn a => a=true) h2
+      (* check if initial value of accumulator has correct type *)
+      val racc_var_term = resolve_OclTerm acc_var_term model
+      val racc_var_type = type_of_term racc_var_term
+  in
+      if (check) then
+	  if (racc_var_type = acc_var_type) then
+	      let
+		  val _ = trace medium  ("res Iterate: types conforms \n")
+		  val bound_expr = embed_bound_variables piter_vars bterm
+		  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 rexpr = resolve_OclTerm bound_expr2 model
+		  val _ = trace medium (" manuel " ^ string_of_OclType (type_of_term rexpr) ^ "\n")
+		  val _ = trace medium (" ma     " ^ string_of_OclType (Set(static_iter_type)) ^ "\n")
+		  val _ = trace medium  ("res Iterate: \n\n\n")
+	      in
+		  Iterate(piter_vars,acc_var_name,racc_var_type,racc_var_term,rterm,rtyp,rexpr,type_of_term rexpr,racc_var_type)
+	      end
+	  else
+	      raise IterateAccumulatorTypeError ("Type of accumulator does not conform to type of expression of accumulator")
+      else
+	  raise IterateTypeMissMatch ("Iterate variables doesn't conform to choosen set \n")
+  end     
 | resolve_OclTerm (CollectionLiteral ([],typ)) model = 
   let
       val _ = trace medium ("RESOLVE CollectionLiteral\n")