src/ast.ml

@@ -47,6 +47,7 @@ type t_expression =
   | ETriOp of full_ty * triop * t_expression * t_expression * t_expression
   | EComp  of full_ty * compop * t_expression * t_expression
   | EWhen  of full_ty * t_expression * t_expression
+  | EFby   of full_ty * t_expression * t_expression
   | EConst of full_ty * const
   | ETuple of full_ty * (t_expression list)
   | EApp   of full_ty * t_node * t_expression

src/parser.mly

@@ -60,53 +60,6 @@
     | RVar _, (FTList tl, l) -> (FTList (FTBase TReal :: tl), v :: l)
     | _ -> raise (MyParsingError ("This exception should not have been raised.",
                   current_location()))
-
-  let monop_condition expr typ_constraint error_msg res =
-    if type_exp expr = typ_constraint
-      then res
-      else raise (MyParsingError (error_msg, current_location()))
-
-  let monop_neg_condition expr typ_constraint error_msg res =
-    if type_exp expr <> typ_constraint
-      then res
-      else raise (MyParsingError (error_msg, current_location()))
-
-  let make_binop_nonbool e1 e2 op error_msg =
-    let t1 = type_exp e1 in let t2 = type_exp e2 in
-    match t1 with
-    | FTBase _ -> (** e1 and e2 should be nunmbers here.*)
-      if t1 = t2 && t1 <> FTBase TBool
-        then EBinOp (t1, op, e1, e2)
-        else raise (MyParsingError (error_msg, current_location()))
-    | _ -> raise (MyParsingError (error_msg, current_location()))
-
-  let make_binop_bool e1 e2 op error_msg =
-    let t1 = type_exp e1 in let t2 = type_exp e2 in
-    if t1 = t2 && t1 = FTBase TBool
-      then EBinOp (t1, op, e1, e2)
-      else raise (MyParsingError (error_msg, current_location()))
-
-  let make_comp e1 e2 op error_msg =
-    let t1 = type_exp e1 in let t2 = type_exp e2 in
-    if t1 = t2
-      then EComp (FTBase TBool, op, e1, e2)
-      else raise (MyParsingError (error_msg, current_location()))
-
-  let make_comp_nonbool e1 e2 op error_msg =
-    let t1 = type_exp e1 in let t2 = type_exp e2 in
-    match t1 with
-    | FTBase _ -> (** e1 and e2 should be numbers here. *)
-      if t1 = t2 && t1 <> FTBase TBool
-        then EComp (FTBase TBool, op, e1, e2)
-        else raise (MyParsingError (error_msg, current_location()))
-    | _ -> raise (MyParsingError (error_msg, current_location()))
-
-  let make_tertiary e1 e2 e3 op error_msg =
-    let t1 = type_exp e1 in let t2 = type_exp e2 in let t3 = type_exp e3 in
-    if t2 = t3 && t1 = FTBase TBool
-      then ETriOp (t2, op, e1, e2, e3)
-      else raise (MyParsingError (error_msg, current_location()))
-
 %}
 
 %token EOF
@@ -261,39 +214,84 @@ expr:
   | IDENT                              { let v  = fetch_var $1 in EVar (type_var v, v) }
   /* Unary operators */
   | MO_not expr
-      { monop_condition $2 (FTBase TBool)
+      { let t = type_exp $2 in
-          "You cannot negate a non-boolean expression."
+        if t = FTBase TBool
-          (EMonOp (type_exp $2, MOp_not, $2)) }
+          then EMonOp (t, MOp_not, $2)
+          else raise (MyParsingError ("You cannot negate a non-boolean \
+            expression.",
+            current_location())) }
   | MO_pre expr                        { EMonOp (type_exp $2, MOp_pre, $2) }
   | MINUS expr
-      { monop_neg_condition $2 (FTBase TBool)
+      { let t = type_exp $2 in
-          "You cannot take the opposite of a boolean expression."
+        if t = FTBase TBool
-          (EMonOp (type_exp $2, MOp_minus, $2)) }
+          then raise (MyParsingError ("You cannot take the opposite of a \
+            boolean expression.",
+            current_location()))
+          else EMonOp (t, MOp_minus, $2) }
   | PLUS expr
-      { monop_neg_condition $2 (FTBase TBool)
+      { let t = type_exp $2 in
-          "You cannot take the plus of a boolean expression." $2 }
+        if t = FTBase TBool
+          then raise (MyParsingError ("You cannot take the plus of a boolean \
+            expression.",
+            current_location()))
+          else $2 }
   /* Binary operators */
   | expr PLUS expr
-      { make_binop_nonbool $1 $3 BOp_add
+      { let e1 = $1 in let t1 = type_exp e1 in
-          "You should know better; addition hates booleans" }
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2 && t1 <> FTBase TBool
+          then  EBinOp (t1, BOp_add, $1, $3)
+          else raise (MyParsingError ("You should know better; addition hates \
+            booleans",
+            current_location())) }
   | expr MINUS expr
-      { make_binop_nonbool $1 $3 BOp_sub
+      { let e1 = $1 in let t1 = type_exp e1 in
-          "You should know better; subtraction hates booleans" }
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2 && t1 <> FTBase TBool
+          then  EBinOp (t1, BOp_sub, $1, $3)
+          else raise (MyParsingError ("You should know better; subtraction \
+            hates booleans",
+            current_location())) }
   | expr BO_mul expr
-      { make_binop_nonbool $1 $3 BOp_mul
+      { let e1 = $1 in let t1 = type_exp e1 in
-          "You should know better; multiplication hates booleans" }
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2 && t1 <> FTBase TBool
+          then  EBinOp (t1, BOp_mul, $1, $3)
+          else raise (MyParsingError ("You should know better; multiplication \
+            hates booleans",
+            current_location())) }
   | expr BO_div expr
-      { make_binop_nonbool $1 $3 BOp_div
+      { let e1 = $1 in let t1 = type_exp e1 in
-          "You should know better; division hates booleans" }
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2 && t1 <> FTBase TBool
+          then  EBinOp (t1, BOp_div, $1, $3)
+          else raise (MyParsingError ("You should know better; division hates \
+            booleans",
+            current_location())) }
   | expr BO_mod expr
-      { make_binop_nonbool $1 $3 BOp_mod
+      { let e1 = $1 in let t1 = type_exp e1 in
-          "You should know better; modulo hates booleans" }
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2 && t1 <> FTBase TBool
+          then  EBinOp (t1, BOp_mod, $1, $3)
+          else raise (MyParsingError ("You should know better; modulo hates \
+            booleans",
+            current_location())) }
   | expr BO_and expr
-      { make_binop_bool $1 $3 BOp_and
+      { let e1 = $1 in let t1 = type_exp e1 in
-          "You should know better; conjunction hates numbers" }
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2 && t1 = FTBase TBool
+          then  EBinOp (t1, BOp_and, $1, $3)
+          else raise (MyParsingError ("You should know better; conjunction \
+            hates numbers",
+            current_location())) }
   | expr BO_or expr
-      { make_binop_bool $1 $3 BOp_or
+      { let e1 = $1 in let t1 = type_exp e1 in
-          "You should know better; disjunction hates numbers" }
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2 && t1 = FTBase TBool
+          then  EBinOp (t1, BOp_or, $1, $3)
+          else raise (MyParsingError ("You should know better; disjunction \
+            hates numbers",
+            current_location())) }
   | expr BO_arrow expr
       { let e1 = $1 in let t1 = type_exp e1 in
         let e2 = $3 in let t2 = type_exp e2 in
@@ -304,30 +302,72 @@ expr:
   /* Binary operators, syntactic sugar */
   | expr BO_fby expr
       { (* e fby e' ==> e -> (pre e') *)
-        let e1 = $1 in let t1 = type_exp e1 in
+        let e = $1 in let e' = $3 in
-        let e2 = $3 in let t2 = type_exp e2 in
+        let te = type_exp e in
-        if t1 = t2
+        if te = type_exp e'
-          then EBinOp (t1, BOp_arrow, e1, (EMonOp (t1, MOp_pre, e2)))
+          then EBinOp (te, BOp_arrow, e, (EMonOp (te, MOp_pre, e')))
           else raise (MyParsingError ("The fby does not type-check!",
                       current_location())) }
   /* Comparison operators */
   | expr EQUAL expr
-      { make_comp $1 $3 COp_eq "The equality does not type-check!" }
+      { let e1 = $1 in let t1 = type_exp e1 in
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2
+          then EComp (FTBase TBool, COp_eq, $1, $3)
+          else raise (MyParsingError ("The equality does not type-check!",
+                      current_location())) }
   | expr CMP_neq expr
-      { make_comp $1 $3 COp_neq "The inquality does not type-check!" }
+      { let e1 = $1 in let t1 = type_exp e1 in
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2
+          then EComp (FTBase TBool, COp_neq, $1, $3)
+          else raise (MyParsingError ("The inequality does not type-check!",
+                      current_location())) }
   | expr CMP_le expr
-      { make_comp_nonbool $1 $3 COp_le "The comparison <= does not type-check!" }
+      { let e1 = $1 in let t1 = type_exp e1 in
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2 && t1 <> FTBase TBool
+          then EComp (FTBase TBool, COp_le, $1, $3)
+          else raise (MyParsingError ("The comparison does not type-check!",
+                      current_location())) }
   | expr CMP_lt expr
-      { make_comp_nonbool $1 $3 COp_lt "The comparison < does not type-check!" }
+      { let e1 = $1 in let t1 = type_exp e1 in
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2 && t1 <> FTBase TBool
+          then EComp (FTBase TBool, COp_lt, $1, $3)
+          else raise (MyParsingError ("The comparison does not type-check!",
+                      current_location())) }
   | expr CMP_ge expr
-      { make_comp_nonbool $1 $3 COp_ge "The comparison >= does not type-check!" }
+      { let e1 = $1 in let t1 = type_exp e1 in
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2 && t1 <> FTBase TBool
+          then EComp (FTBase TBool, COp_ge, $1, $3)
+          else raise (MyParsingError ("The comparison does not type-check!",
+                      current_location())) }
   | expr CMP_gt expr
-      { make_comp_nonbool $1 $3 COp_gt "The comparison > does not type-check!" }
+      { let e1 = $1 in let t1 = type_exp e1 in
+        let e2 = $3 in let t2 = type_exp e2 in
+        if t1 = t2 && t1 <> FTBase TBool
+          then EComp (FTBase TBool, COp_gt, $1, $3)
+          else raise (MyParsingError ("The comparison does not type-check!",
+                      current_location())) }
   /* Tertiary operators */
   | IF expr THEN expr ELSE expr
-      { make_tertiary $2 $4 $6 TOp_if "The if-then-else does not type-check!" }
+      { let e1 = $2 in let t1 = type_exp e1 in
+        let e2 = $4 in let t2 = type_exp e2 in
+        let e3 = $6 in let t3 = type_exp e3 in
+        if t2 = t3 && t1 = FTBase TBool
+          then ETriOp (t2, TOp_if, e1, e2, e3)
+          else raise (MyParsingError ("The if-then-else does not type-check!",
+                      current_location())) }
   | TO_merge expr expr expr
-      { make_tertiary $2 $3 $4 TOp_merge "The merge does not type-check!" }
+      { let e1 = $2 in let t1 = type_exp e1 in
+        let e2 = $3 in let t2 = type_exp e2 in
+        let e3 = $4 in let t3 = type_exp e3 in
+        if t2 = t3 && t1 = FTBase TBool
+          then ETriOp (t2, TOp_merge, e1, e2, e3)
+          else raise (MyParsingError ("The if-then-else does not type-check!",
+                      current_location())) }
   /* When is neither a binop (a * 'a -> 'a) or a comp ('a * 'a -> bool) */
   | expr WHEN expr
       { let e1 = $1 in let t1 = type_exp e1 in

src/pp.ml

@@ -33,6 +33,13 @@ let pp_expression =
       | _ -> raise (MyTypeError "This exception should not have been raised.")
     in
     match expression with
+    | EFby (_, e1, e2) ->
+        begin
+          Format.fprintf fmt "\t\t\t%sFBY\n%a\t\t\tFBY\n%a"
+            prefix
+            (pp_expression_aux (upd_prefix prefix)) e1
+            (pp_expression_aux (upd_prefix prefix)) e2
+        end
     | EWhen (_, e1, e2) ->
         begin
           Format.fprintf fmt "\t\t\t%sWHEN\n%a\t\t\tWHEN\n%a"