Good old compiler-workout

regression/test001.expr

@@ -76,4 +76,41 @@ fun f2 (p1, p2, p3) local p4, p5 {
     return p4
 }
 
+fun f3 (p1, p2, p3) local p4, p5 {
+    p4 := {};
+    while (1) do
+        case p2[p3[0]] of
+             A (a, b) ->
+                p5 := foo(p3, p2, a);
+                p4 := p5 : p4;
+                foo(p3, b, p5)
+            |B (a, b) ->
+                case P(foo(p3, p2, a), foo(p3, p2, b)) of
+                     P (L (a), L (b)) -> p5 := L (a + b)
+                    |P (a, b)         -> p5 := foo(p3, a, b)
+                esac;
+                p4 := p5 : p4;
+                foo(p3, b, p5)
+            |C (a, b) ->
+                case P(foo(p3, p2, a), foo(p3, p2, b)) of
+                     P (L (a), L (b)) -> p5 := L (a - b)
+                    |P (a, b)         -> p5 := foo(p3, a, b)
+                esac;
+                p4 := p5 : p4;
+                foo(p3, b, p5)
+            |D (a) ->
+                p5 := foo(p3, p2, a);
+                p4 := p5 : p4;
+                case p3[1][7] of
+                    L (m) -> p3[1][7] := L (m + 1);
+                             p3[2][m + 1] := p5
+                esac
+            |E ->
+                return p4
+            |a -> skip
+        esac
+    od;
+    return p4
+}
+
 write(7)

src/Driver.ml

@@ -30,7 +30,7 @@ let parse infile =
        ] s
      end
     )
-    (ostap (!(Language.parse (Language.Expr.defaultInfix ()))  -EOF))
+    (ostap (!(Language.parse Language.Infix.default)  -EOF))
 
 let main =
   try

src/Language.ml

@@ -260,13 +260,13 @@ module Expr =
     (* intrinsic (for evaluation) *) | Intrinsic of (config -> config)
     (* control (for control flow) *) | Control   of (config -> t * config)
 
-    (* Reff : parsed expression should return value Reff (look for ":=");
+    (* Available binary operators:
-       Val : -//- returns simple value;
+        !!                   --- disjunction
-       Void : parsed expression should not return any value;  *)
+        &&                   --- conjunction
-    type atr = Reff | Void | Val
+        ==, !=, <=, <, >=, > --- comparisons
-    let notRef  x = match x with Reff -> false | _ -> true
+        +, -                 --- addition, subtraction
-    let isVoid  x = match x with Void -> true  | _ -> false
+        *, /, %              --- multiplication, division, reminder
-    let isValue x = match x with Void -> false | _ -> true       (* functions for handling atribute *)
+    *)
 
     (* Update state *)
     let update st x v =
@@ -400,21 +400,6 @@ module Expr =
          in
          eval env conf Skip (schedule_list [e; Intrinsic (fun conf -> branch conf bs)])
 
-    (* places ignore if expression should be void *)
-    let ignore atr expr = if isVoid atr then Ignore expr else expr
-
-    (* semantics for default set of infixes *)
-    (* Available binary operators:
-        !!                   --- disjunction
-        &&                   --- conjunction
-        ==, !=, <=, <, >=, > --- comparisons
-        +, -                 --- addition, subtraction
-        *, /, %              --- multiplication, division, reminder
-    *)
-
-    (* semantics for infixes creaed in runtime *)
-    let sem s = (fun x atr y -> ignore atr (Call (Var s, [x; y]))), (fun _ -> Val, Val)
-
     (* Expression parser. You can use the following terminals:
 
          LIDENT  --- a non-empty identifier a-z[a-zA-Z0-9_]* as a string
@@ -422,190 +407,227 @@ module Expr =
          DECIMAL --- a decimal constant [0-9]+ as a string
     *)
 
-    let default =
+    (* Propagates *)
+    let rec propagate_ref = function
+    | Var   x          -> Ref x
+    | Elem (e, i)      -> ElemRef (e, i)
+    | Seq  (s1, s2)    -> Seq (s1, propagate_ref s2)
+    | If   (e, t1, t2) -> If (e, propagate_ref t1, propagate_ref t2)
+    | Case (e, bs)     -> Case (e, List.map (fun (p, e) -> p, propagate_ref e) bs)
+    | _                -> raise (Semantic_error "not a destination")
+
+    (* Balance values *)
+    let rec balance_value = function
+    | Array     es        -> Array     (List.map balance_value es)
+    | Sexp      (s, es)   -> Sexp      (s, List.map balance_value es)
+    | Binop     (o, l, r) -> Binop     (o, balance_value l, balance_value r)
+    | Elem      (b, i)    -> Elem      (balance_value b, balance_value i)
+    | ElemRef   (b, i)    -> ElemRef   (balance_value b, balance_value i)
+    | Length    x         -> Length    (balance_value x)
+    | StringVal x         -> StringVal (balance_value x)
+    | Call      (f, es)   -> Call      (balance_value f, List.map balance_value es)
+    | Assign    (d, s)    -> Assign    (balance_value d, balance_value s)
+    | Seq       (l, r)    -> Seq       (balance_void l, balance_value r)
+    | If        (c, t, e) -> If        (balance_value c, balance_value t, balance_value e)
+    | Case      (e, ps)   -> Case      (balance_value e, List.map (fun (p, e) -> p, balance_value e) ps)
+
+    | Return    _
+    | While     _
+    | Repeat    _
+    | Skip        -> raise (Semantic_error "missing value")
+
+    | e                   -> e
+    and balance_void = function
+    | If     (c, t, e) -> If     (balance_value c, balance_void t, balance_void e)
+    | Seq    (l, r)    -> Seq    (balance_void l, balance_void r)
+    | Case   (e, ps)   -> Case   (balance_value e, List.map (fun (p, e) -> p, balance_void e) ps)
+    | While  (e, s)    -> While  (balance_value e, balance_void s)
+    | Repeat (s, e)    -> Repeat (balance_void s, balance_value e)
+    | Return (Some e)  -> Return (Some (balance_value e))
+    | Return None      -> Return None
+    | Skip             -> Skip
+    | e                -> Ignore (balance_value e)
+
+    (* ======= *)
+
+    let left  f c x y = f (c x) y
+    let right f c x y = c (f x y)
+
+    let expr f ops opnd =
+      let ops =
+        Array.map
+          (fun (assoc, list) ->
+            let g = match assoc with `Lefta | `Nona -> left | `Righta -> right in
+            assoc = `Nona, altl (List.map (fun (oper, sema) -> ostap (!(oper) {g sema})) list)
+          )
+          ops
+      in
+      let n      = Array.length ops in
+      let op   i = snd ops.(i)      in
+      let nona i = fst ops.(i)      in
+      let id   x = x                in
+      let ostap (
+              inner[l][c]: f[ostap (
+              {n = l                } => x:opnd {c x}
+            | {n > l && not (nona l)} => x:inner[l+1][id] b:(-o:op[l] inner[l][o c x])? {
+                                                                                                 match b with None -> c x | Some x -> x
+                                                                                               }
+                               | {n > l && nona l} => x:inner[l+1][id] b:(op[l] inner[l+1][id])? {
+                                                            c (match b with None -> x | Some (o, y) -> o id x y)
+                })]
+            )
+      in
+      ostap (inner[0][id])
+
+    (* ======= *)
+
+    ostap (
+      parse[infix]: h:basic[infix] t:(-";" parse[infix])? {match t with None -> h | Some t -> Seq (h, t)};
+      basic[infix]:
+	  !(expr
+             (fun x -> x)
+             (Array.map (fun (a, l) -> a, List.map (fun (s, f) -> ostap (- $(s)), f) l) infix)
+	     (primary infix));
+      primary[infix]:
+        b:base[infix] is:(-"[" i:parse[infix] -"]" {`Elem i} | -"." (%"length" {`Len} | %"string" {`Str} | f:LIDENT {`Post f})) * {
+        List.fold_left
+          (fun b ->
+            function
+            | `Elem i -> Elem (b, i)
+            | `Len    -> Length b
+            | `Str    -> StringVal b
+            | `Post f -> Call (Var f, [b])
+          )
+          b
+          is
+      };
+      base[infix]:
+        n:DECIMAL                                            {Const n}
+      | s:STRING                                             {String (unquote s)}
+      | c:CHAR                                               {Const  (Char.code c)}
+      | "[" es:!(Util.list0)[parse infix] "]"                {Array es}
+      | "{" es:!(Util.list0)[parse infix] "}"                {match es with
+                                                              | [] -> Const 0
+                                                              | _  -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0)
+                                                             }
+      | t:UIDENT args:(-"(" !(Util.list)[parse infix] -")")? {Sexp (t, match args with None -> [] | Some args -> args)}
+      | x:LIDENT s:("(" args:!(Util.list0)[parse infix] ")"  {Call (Var x, args)} | empty {Var x}) {s}
+
+      | %"skip"                                              {Skip}
+
+      | %"if" e:!(parse infix)
+	%"then" the:parse[infix]
+          elif:(%"elif" parse[infix] %"then" parse[infix])*
+	  els:(%"else" parse[infix])?
+        %"fi" {
+          If (e, the,
+	         List.fold_right
+		   (fun (e, t) elif -> If (e, t, elif))
+		   elif
+		   (match els with None -> Skip | Some s -> s)
+          )
+        }
+
+      | %"while" e:parse[infix] %"do" s:parse[infix] %"od" {While (e, s)}
+
+      | %"for" i:parse[infix] "," c:parse[infix] "," s:parse[infix] %"do" b:parse[infix] %"od" {
+	  Seq (i, While (c, Seq (b, s)))
+                                                                                            }
+
+      | %"repeat" s:parse[infix] %"until" e:basic[infix]  {Repeat (s, e)}
+      | %"return" e:basic[infix]?                         {Return e}
+
+      | %"case" e:parse[infix] %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[infix])] %"esac" {Case (e, bs)}
+
+      | -"(" parse[infix] -")"
+    )
+
+  end
+
+(* Infix helpers *)
+module Infix =
+  struct
+
+    type t = ([`Lefta | `Righta | `Nona] * (string * (Expr.t -> Expr.t -> Expr.t)) list) array
+
+    let name infix =
+      let b = Buffer.create 64 in
+      Buffer.add_string b "__Infix_";
+      Seq.iter (fun c -> Buffer.add_string b (string_of_int @@ Char.code c)) @@ String.to_seq infix;
+      Buffer.contents b
+
+    let default : t =
       Array.map (fun (a, s) ->
         a,
         List.map (fun s -> s,
-                           (fun x atr y -> ignore atr (
+                           (fun x y ->
                               match s with
-                              | ":"  -> Sexp   ("cons", [x; y])
+                              | ":"  -> Expr.Sexp   ("cons", [x; y])
-                              | "++" -> Call   (Var "strcat", [x; y])
+                              | "++" -> Expr.Call   (Var "strcat", [x; y])
-                              | ":=" -> Assign (x, y)
+                              | ":=" -> Expr.Assign (Expr.propagate_ref x, y)
-                              | _    -> Binop  (s, x, y))
+                              | _    -> Expr.Binop  (s, x, y)
                            )
           ) s
       )
       [|
         `Righta, [":="];
         `Righta, [":"];
-        `Lefta , ["!!"];
+	`Lefta , ["!!"];
-        `Lefta , ["&&"];
+	`Lefta , ["&&"];
-        `Nona  , ["=="; "!="; "<="; "<"; ">="; ">"];
+	`Nona  , ["=="; "!="; "<="; "<"; ">="; ">"];
-        `Lefta , ["++"; "+" ; "-"];
+	`Lefta , ["++"; "+" ; "-"];
-        `Lefta , ["*" ; "/"; "%"];
+	`Lefta , ["*" ; "/"; "%"];
       |]
 
-    let sem_init s = (fun x atr y ->
+    exception Break of [`Ok of t | `Fail of string]
-      ignore atr (
-         match s with
-         | ":"  -> Sexp   ("cons", [x; y])
-         | "++" -> Call   (Var "strcat", [x; y])
-         | ":=" -> Assign (x, y)
-         | _ -> Binop  (s, x, y)
-      )), (fun _ -> (if s = ":=" then Reff else Val), Val)
 
-    let defaultInfix : unit -> (t, atr, 'm, 'stream, 'b, 'c) Util.Infix.t = fun () ->
+    let find_op infix op cb ce =
-        let infix = fst (Array.fold_left
+      try
-          (fun (infix, prev) (a, s) ->
+        Array.iteri (fun i (_, l) -> if List.exists (fun (s, _) -> s = op) l then raise (Break (cb i))) infix;
-            let fstOp = List.hd s in
+        ce ()
-            let newInfix = match Util.Infix.after (0, 0) prev fstOp a (sem_init fstOp) infix with `Ok t -> t in
+      with Break x -> x
-            (List.fold_right (fun s infix -> match Util.Infix.at (0, 0) fstOp s (sem_init s) infix with `Ok t -> t) s newInfix, fstOp)
-          )
-          ((Util.Infix.singleton `Righta ":=" (sem_init ":=")), ":=")
-          [|
-            `Righta, [":"];
-            `Lefta , ["!!"];
-            `Lefta , ["&&"];
-            `Lefta , ["=="; "!="; "<="; "<"; ">="; ">"];
-            `Lefta , ["++"; "+" ; "-"];
-            `Lefta , ["*" ; "/"; "%"];
-          |]
-        ) in Util.Infix.setArr infix default
 
-    let left  f c x a y = f (c x) a y
+    let no_op op coord = `Fail (Printf.sprintf "infix ``%s'' not found in the scope at %s" op (Msg.Coord.toString coord))
-    let right f c x a y = c (f x a y)
 
-    let expr f infix opnd atr =
+    let sem name x y = Expr.Call (Var name, [x; y])
 
-      let default =
+    let at coord op newp name infix =
-        Array.map (fun (a, s) ->
+      find_op infix op
-          let g = match a with `Lefta | `Nona -> left | `Righta -> right in
+        (fun i ->
-          let l = List.map (fun s -> s,
+          `Ok (Array.init (Array.length infix)
-                             ((fun x atr y -> ignore atr (
+                 (fun j ->
-                                match s with
+                   if j = i
-                                | ":"  -> Sexp   ("cons", [x; y])
+                   then let (a, l) = infix.(i) in (a, (newp, sem name) :: l)
-                                | "++" -> Call   (Var "strcat", [x; y])
+                   else infix.(j)
-                                | ":=" -> Assign (x, y)
+            ))
-                                | _    -> Binop  (s, x, y))
-                             ), (fun _ -> (if s = ":=" then Reff else Val), Val))
-            ) s in
-          a,
-          (snd (snd (List.hd l)),
-          (altl (List.map (fun (oper, (sema, _)) -> ostap (- $(oper) {g sema})) l),
-          l))
         )
-        [|
+        (fun _ -> no_op op coord)
-          `Righta, [":="];
-          `Righta, [":"];
-          `Lefta , ["!!"];
-          `Lefta , ["&&"];
-          `Nona  , ["=="; "!="; "<="; "<"; ">="; ">"];
-          `Lefta , ["++"; "+" ; "-"];
-          `Lefta , ["*" ; "/"; "%"];
-        |]
-      in
-      let ops = Util.Infix.createArray infix in
-      if Array.length ops != Array.length default then failwith (Printf.sprintf "I said so: %d %s" (Array.length ops) (Array.fold_left (fun s (_, (_, (_, l))) -> s ^ (fst (List.hd l))) "" ops));
-      let atrr i atr = snd (fst (snd ops.(i)) atr) in
-      let atrl i atr = fst (fst (snd ops.(i)) atr) in
-      let n      = Array.length ops  in
-      let op   i = fst (snd (snd ops.(i))) in
-      let nona i = fst ops.(i) = `Nona in
-      let id   x = x                 in
-      let ostap (
-        inner[l][c][atr]: f[ostap (
-          {n = l                } => x:opnd[atr] {c x}
-        | {n > l && not (nona l)} => (-x:inner[l+1][id][atrl l atr] -o:op[l] y:inner[l][o c x atr][atrr l atr] |
-                                       x:inner[l+1][id][atr] {c x})
-        | {n > l && nona l} => (x:inner[l+1][id][atrl l atr] o:op[l] y:inner[l+1][id][atrr l atr] {c (o id x atr y)} |
-                                x:inner[l+1][id][atr] {c x})
-          )]
-      )
-      in
-      ostap (inner[0][id][atr])
 
+    let before coord op newp ass name infix =
+      find_op infix op
+        (fun i ->
+          `Ok (Array.init (1 + Array.length infix)
+                 (fun j ->
+                   if j < i
+                   then infix.(j)
+                   else if j = i then (ass, [newp, sem name])
+                   else infix.(j-1)
+                 ))
+        )
+        (fun _ -> no_op op coord)
 
-    ostap (
+    let after coord op newp ass name infix =
-      parse[infix][atr]: h:basic[infix][Void] -";" t:parse[infix][atr] {Seq (h, t)}
+      find_op infix op
-                         | basic[infix][atr];
+        (fun i ->
-
+          `Ok (Array.init (1 + Array.length infix)
-      basic[infix][atr]: !(expr (fun x -> x) (infix) (primary infix) atr);
+                 (fun j ->
-
+                   if j <= i
-      primary[infix][atr]:
+                   then infix.(j)
-        b:base[infix][Val] is:(-"[" i:parse[infix][Val] -"]" {`Elem i} | -"." (%"length" {`Len} | %"string" {`Str} | f:LIDENT {`Post f}))+
+                   else if j = i+1 then (ass, [newp, sem name])
-        => {match (List.hd (List.rev is)), atr with
+                   else infix.(j-1)
-            | `Elem i, Reff -> true
+                 ))
-            |  _,      Reff -> false
+        )
-            |  _,      _    -> true} =>
+        (fun _ -> no_op op coord)
-        {
-          let lastElem = List.hd (List.rev is) in
-          let is = List.rev (List.tl (List.rev is)) in
-          let b =
-            List.fold_left
-              (fun b ->
-                function
-                | `Elem i -> Elem (b, i)
-                | `Len    -> Length b
-                | `Str    -> StringVal b
-                | `Post f -> Call (Var f, [b])
-              )
-              b
-              is
-          in
-          let res = match lastElem, atr with
-                    | `Elem i, Reff -> ElemRef (b, i)
-                    | `Elem i,  _   -> Elem (b, i)
-                    | `Len,     _   -> Length b
-                    | `Str,     _   -> StringVal b
-                    | `Post f,  _   -> Call (Var f, [b])
-          in
-          ignore atr res
-        }
-        | base[infix][atr];
-      base[infix][atr]:
-        n:DECIMAL                                 => {notRef atr} => {ignore atr (Const n)}
-      | s:STRING                                  => {notRef atr} => {ignore atr (String (unquote s))}
-      | c:CHAR                                    => {notRef atr} => {ignore atr (Const  (Char.code c))}
-      | "[" es:!(Util.list0)[parse infix Val] "]" => {notRef atr} => {ignore atr (Array es)}
-      | "{" es:!(Util.list0)[parse infix Val] "}" => {notRef atr} => {ignore atr (match es with
-                                                                                  | [] -> Const 0
-                                                                                  | _  -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0))
-                                                                     }
-      | t:UIDENT args:(-"(" !(Util.list)[parse infix Val] -")")? => {notRef atr} => {ignore atr (Sexp (t, match args with
-                                                                                                          | None -> []
-                                                                                                          | Some args -> args))
-                                                                                    }
-      | x:LIDENT s:(  "(" args:!(Util.list0)[parse infix Val] ")" => {notRef atr} => {Call (Var x, args)}
-                    | empty {if notRef atr then Var x else Ref x})   {ignore atr s}
-
-      | {isVoid atr} => %"skip"                                      {Skip}
-
-      | %"if" e:!(parse infix Val) %"then" the:parse[infix][atr]
-                             elif:(%"elif" parse[infix][Val] %"then" parse[infix][atr])*
-	                                 %"else" els:parse[infix][atr] %"fi"
-                                                                     {If (e, the, List.fold_right (fun (e, t) elif -> If (e, t, elif)) elif els)}
-      | %"if" e:!(parse infix Val) %"then" the:parse[infix][Void]
-                             elif:(%"elif" parse[infix][Val] %"then" parse[infix][atr])*
-                             => {isVoid atr} => %"fi"
-                                                                     {If (e, the, List.fold_right (fun (e, t) elif -> If (e, t, elif)) elif Skip)}
-
-      | %"while" e:parse[infix][Val] %"do" s:parse[infix][Void]
-                                            => {isVoid atr} => %"od" {While (e, s)}
-
-      | %"for" i:parse[infix][Void] "," c:parse[infix][Val] "," s:parse[infix][Void] %"do" b:parse[infix][Void] => {isVoid atr} => %"od"
-                                                                     {Seq (i, While (c, Seq (b, s)))}
-
-      | %"repeat" s:parse[infix][Void] %"until" e:basic[infix][Val]
-                                                  => {isVoid atr} => {Repeat (s, e)}
-      | %"return" e:basic[infix][Val]?            => {isVoid atr} => {Return e}
-
-      | %"case" e:parse[infix][Val] %"of" bs:!(Util.listBy1)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[infix][atr])] %"esac"
-                                                                     {Case (e, bs)}
-      | %"case" e:parse[infix][Val] %"of" bs:(!(Pattern.parse) -"->" parse[infix][Void]) => {isVoid atr} => %"esac"
-                                                                     {Case (e, [bs])}
-
-      | -"(" parse[infix][atr] -")"
-    )
 
   end
 
@@ -619,23 +641,23 @@ module Definition =
     ostap (
       arg : LIDENT;
       position[ass][coord][newp]:
-        %"at" s:STRING {Util.Infix.at coord (unquote s) newp}
+        %"at" s:STRING {Infix.at coord (unquote s) newp}
-        | f:(%"before" {Util.Infix.before} | %"after" {Util.Infix.after}) s:STRING {f coord (unquote s) newp ass};
+        | f:(%"before" {Infix.before} | %"after" {Infix.after}) s:STRING {f coord (unquote s) newp ass};
       head[infix]:
         %"fun" name:LIDENT {name, infix}
       | ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta})
         l:$ op:(s:STRING {unquote s})
         md:position[ass][l#coord][op] {
-          let name = Util.Infix.name op in
+          let name = Infix.name op in
-          match md (Expr.sem name) infix with
+          match md name infix with
           | `Ok infix' -> name, infix'
           | `Fail msg  -> raise (Semantic_error msg)
       };
       parse[infix]:
         <(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")"
            locs:(%"local" !(Util.list arg))?
-        "{" body:!(Expr.parse infix' Void) "}" {
+        "{" body:!(Expr.parse infix') "}" {
-        (name, (args, (match locs with None -> [] | Some l -> l), body)), infix'
+        (name, (args, (match locs with None -> [] | Some l -> l), Expr.balance_void body)), infix'
       }
     )
 
@@ -674,7 +696,7 @@ let eval (defs, body) i =
 
 (* Top-level parser *)
 ostap (
-  parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse (infix') Void) {defs, body};
+  parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix') {defs, Expr.balance_void body};
   definitions[infix]:
     <(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''}
   | empty {[], infix}