Infixes

regression/orig/test053.log

@@ -0,0 +1,6 @@
+> 1
+0
+1
+0
+1
+1

regression/test053.expr

@@ -0,0 +1,39 @@
+infix "===" at "==" (v1, v2) local s1, s2, i {
+  s1 := v1.string;
+  s2 := v2.string;
+
+  if s1.length == s2.length
+  then
+    for i := 0, i < s1.length, i := i + 1
+    do
+      if s1[i] != s2[i] then return 0 fi  
+    od;
+    return 1
+  else return 0
+  fi
+}
+
+infix "?" before "+" (v, l) {
+  case l of
+   {}      -> return 0
+  | h : tl -> if h === v then return 1 else return v ? tl fi
+  esac
+}
+
+infix "+++" at "+" (l1, l2) {
+  case l1 of
+    {}     -> return l2
+  | h : tl -> return h : tl +++ l2
+  esac
+}
+
+n := read ();
+
+write ({1, 2, 3} === {1, 2, 3});
+write ({1, 2, 3} === {1, 2, 4});
+write (1+2 ? {1, 2, 3});
+write (1*3+2 ? {1, 2, 3});
+write (1*3+2 ? {1, 2, 5});
+write (8*4 ? {1, 2, 3} +++ {5, 7, 32, 6})
+
+

regression/test053.input

@@ -0,0 +1 @@
+0

src/Driver.ml

@@ -12,7 +12,8 @@ let parse infile =
     "length";
     "string";
     "case"; "of"; "esac"; "when";
-    "boxed"; "unboxed"; "string"; "sexp"; "array"]
+    "boxed"; "unboxed"; "string"; "sexp"; "array";
+    "infix"; "infixl"; "infixr"; "at"; "before"; "after"]
   in
   Util.parse
     (object
@@ -29,7 +30,7 @@ let parse infile =
        ] s
      end
     )
-    (ostap (!(Language.parse) -EOF))
+    (ostap (!(Language.parse Language.Infix.default) -EOF))
 
 let main =
   try
@@ -37,7 +38,7 @@ let main =
     let stack      = Sys.argv.(1) = "-s"  in
     let to_compile = not (interpret || stack) in
     let infile     = Sys.argv.(if not to_compile then 2 else 1) in    
-    match parse infile with
+    match (try parse infile with Language.Semantic_error msg -> `Fail msg) with
     | `Ok prog ->
        if to_compile
        then            
@@ -58,6 +59,6 @@ let main =
 	   else SM.run (SM.compile prog) input
 	 in
 	 List.iter (fun i -> Printf.printf "%d\n" i) output
-    | `Fail er -> Printf.eprintf "Syntax error: %s\n" er
+    | `Fail er -> Printf.eprintf "Error: %s\n" er
   with Invalid_argument _ ->
     Printf.printf "Usage: rc [-i | -s] <input file.expr>\n"

src/Language.ml

@@ -7,6 +7,10 @@ open GT
 open Ostap
 open Combinators
 
+exception Semantic_error of string
+                          
+let unquote s = String.sub s 1 (String.length s - 2)
+              
 (* Values *)
 module Value =
   struct
@@ -259,30 +263,12 @@ module Expr =
          DECIMAL --- a decimal constant [0-9]+ as a string                                                                                                                  
     *)
     ostap (                                      
-      parse: 
+      parse[infix]: 
 	  !(Ostap.Util.expr 
              (fun x -> x)
-	     (Array.map (fun (a, s) -> a, 
+             (Array.map (fun (a, l) -> a, List.map (fun (s, f) -> ostap (- $(s)), f) l) infix)
-                                       List.map (fun s -> ostap(- $(s)),
+	     (primary infix)); 
-                                                          (fun x y ->
+      primary[infix]: b:base[infix] is:(-"[" i:parse[infix] -"]" {`Elem i} | -"." (%"length" {`Len} | %"string" {`Str} | f:LIDENT {`Post f})) * {
-                                                             match s with
-                                                             | ":"  -> Sexp ("cons", [x; y])
-                                                             | "++" -> Call ("strcat", [x; y])
-                                                             | _    -> Binop (s, x, y)
-                                                          )
-                                         ) s
-                        ) 
-              [|
-                `Righta, [":"];  
-		`Lefta , ["!!"];
-		`Lefta , ["&&"];
-		`Nona  , ["=="; "!="; "<="; "<"; ">="; ">"];
-		`Lefta , ["++"; "+" ; "-"];
-		`Lefta , ["*" ; "/"; "%"];
-              |] 
-	     )
-	     primary); 
-      primary: b:base is:(-"[" i:parse -"]" {`Elem i} | -"." (%"length" {`Len} | %"string" {`Str} | f:LIDENT {`Post f})) * {
         List.fold_left
           (fun b ->
             function
@@ -294,22 +280,107 @@ module Expr =
           b
           is
       }; 
-      base:
+      base[infix]:
         n:DECIMAL                                            {Const n}  
-      | s:STRING                                       {String (String.sub s 1 (String.length s - 2))}
+      | s:STRING                                             {String (unquote s)}
       | c:CHAR                                               {Const  (Char.code c)}
-      | "[" es:!(Util.list0)[parse] "]"                {Array es}
+      | "[" es:!(Util.list0)[parse infix] "]"                {Array es}
-      | "{" es:!(Util.list0)[parse] "}"                {match es with
+      | "{" 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] -")")? {Sexp (t, match args with None -> [] | Some args -> args)}
+      | t:UIDENT args:(-"(" !(Util.list)[parse infix] -")")? {Sexp (t, match args with None -> [] | Some args -> args)}
-      | x:LIDENT s:("(" args:!(Util.list0)[parse] ")"  {Call (x, args)} | empty {Var x}) {s}
+      | x:LIDENT s:("(" args:!(Util.list0)[parse infix] ")"  {Call (x, args)} | empty {Var x}) {s}
-      | -"(" parse -")" 
+      | -"(" 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 y ->
+                              match s with
+                              | ":"  -> Expr.Sexp ("cons", [x; y])
+                              | "++" -> Expr.Call ("strcat", [x; y])
+                              | _    -> Expr.Binop (s, x, y)
+                           )
+          ) s
+      ) 
+      [|
+        `Righta, [":"];  
+	`Lefta , ["!!"];
+	`Lefta , ["&&"];
+	`Nona  , ["=="; "!="; "<="; "<"; ">="; ">"];
+	`Lefta , ["++"; "+" ; "-"];
+	`Lefta , ["*" ; "/"; "%"];
+      |]     
+
+    exception Break of [`Ok of t | `Fail of string]
+            
+    let find_op infix op cb ce =
+      try
+        Array.iteri (fun i (_, l) -> if List.exists (fun (s, _) -> s = op) l then raise (Break (cb i))) infix;
+        ce ()
+      with Break x -> x
+
+    let no_op op coord = `Fail (Printf.sprintf "infix ``%s'' not found in the scope at %s" op (Msg.Coord.toString coord))
+
+    let sem name x y = Expr.Call (name, [x; y])
+                     
+    let at coord op newp name infix =
+      find_op infix op
+        (fun i ->
+          `Ok (Array.init (Array.length infix)
+                 (fun j ->
+                   if j = i
+                   then let (a, l) = infix.(i) in (a, (newp, sem name) :: l)
+                   else infix.(j)
+            ))
+        )
+        (fun _ -> no_op op coord)
+
+    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)
+      
+    let after 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+1 then (ass, [newp, sem name])
+                   else infix.(j-1)
+                 ))
+        )
+        (fun _ -> no_op op coord)
+                                
+  end
+
 (* Simple statements: syntax and sematics *)
 module Stmt =
   struct
@@ -354,7 +425,7 @@ module Stmt =
                                                          }
           | x:LIDENT y:(-"@" parse)?                     {match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)}
           | c:DECIMAL                                    {Const c}
-          | s:STRING                                     {String (String.sub s 1 (String.length s - 2))}
+          | s:STRING                                     {String (unquote s)}
           | c:CHAR                                       {Const  (Char.code c)}
           | "#" %"boxed"                                 {Boxed}
           | "#" %"unboxed"                               {UnBoxed}
@@ -419,9 +490,6 @@ module Stmt =
       | Repeat (s, e)      -> eval env conf (seq (While (Expr.Binop ("==", e, Expr.Const 0), s)) k) s
       | Return  e          -> (match e with None -> (st, i, o, None) | Some e -> Expr.eval env conf e)
       | Expr    e          -> eval env (Expr.eval env conf e) k Skip
-(*                            
-      | Call   (f, args)   -> eval env (Expr.eval env conf (Expr.Call (f, args))) k Skip
- *)                            
       | Case   (e, bs)     ->
           let (_, _, _, Some v) as conf' = Expr.eval env conf e in
           let rec branch ((st, i, o, _) as conf) = function
@@ -461,15 +529,15 @@ module Stmt =
            
     (* Statement parser *)
     ostap (
-      parse:
+      parse[infix]:
-        s:stmt ";" ss:parse {Seq (s, ss)}
+        s:stmt[infix] ";" ss:parse[infix] {Seq (s, ss)}
-      | stmt;
+      | stmt[infix];
-      stmt:
+      stmt[infix]:
         %"skip" {Skip}
-      | %"if" e:!(Expr.parse)
+      | %"if" e:!(Expr.parse infix)
-	  %"then" the:parse 
+	  %"then" the:parse[infix] 
-          elif:(%"elif" !(Expr.parse) %"then" parse)*
+          elif:(%"elif" !(Expr.parse infix) %"then" parse[infix])*
-	  els:(%"else" parse)? 
+	  els:(%"else" parse[infix])? 
         %"fi" {
           If (e, the, 
 	         List.fold_right 
@@ -478,21 +546,17 @@ module Stmt =
 		   (match els with None -> Skip | Some s -> s)
           )
         }
-      | %"while" e:!(Expr.parse) %"do" s:parse %"od"{While (e, s)}
+      | %"while" e:!(Expr.parse infix) %"do" s:parse[infix] %"od"{While (e, s)}
-      | %"for" i:parse "," c:!(Expr.parse) "," s:parse %"do" b:parse %"od" {
+      | %"for" i:parse[infix] "," c:!(Expr.parse infix) "," s:parse[infix] %"do" b:parse[infix] %"od" {
 	  Seq (i, While (c, Seq (b, s)))
         }
-      | %"repeat" s:parse %"until" e:!(Expr.parse)  {Repeat (s, e)}
+      | %"repeat" s:parse[infix] %"until" e:!(Expr.parse infix)  {Repeat (s, e)}
-      | %"return" e:!(Expr.parse)?                  {Return e}
+      | %"return" e:!(Expr.parse infix)?                  {Return e}
-      | %"case" e:!(Expr.parse) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse)] %"esac" {Case (e, bs)}
+      | %"case" e:!(Expr.parse infix) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse[infix])] %"esac" {Case (e, bs)}
       | x:LIDENT 
-            s:(is:(-"[" !(Expr.parse) -"]")* ":=" e :!(Expr.parse) {Assign (x, is, e)}
+            s:(is:(-"[" !(Expr.parse infix) -"]")* ":=" e :!(Expr.parse infix) {Assign (x, is, e)}
-(*
-               | 
-              "("  args:!(Util.list0)[Expr.parse] ")"             {Call   (x, args)}                
- *)
              ) {s}
-      | e:!(Expr.parse) {Expr e}
+      | e:!(Expr.parse infix) {Expr e}
     )
       
   end
@@ -506,10 +570,24 @@ module Definition =
 
     ostap (
       arg : LIDENT;
-      parse: %"fun" name:LIDENT "(" args:!(Util.list0 arg) ")"
+      position[ass][coord][newp]:
+        %"at" s:STRING {Infix.at coord (unquote s) newp}
+      | 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 = Infix.name op in
+          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:!(Stmt.parse) "}" {
+        "{" body:!(Stmt.parse infix') "}" {
-        (name, (args, (match locs with None -> [] | Some l -> l), body))
+        (name, (args, (match locs with None -> [] | Some l -> l), body)), infix'
       }
     )
 
@@ -547,4 +625,9 @@ let eval (defs, body) i =
   o
 
 (* Top-level parser *)
-let parse = ostap (!(Definition.parse)* !(Stmt.parse))
+ostap (
+  parse[infix]: <(defs, infix')> : definitions[infix] body:!(Stmt.parse infix') {defs, body};
+  definitions[infix]:
+    <(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''}
+  | empty {[], infix}
+)