Better infixes

regression/test053.expr

@@ -1,6 +1,6 @@
 local n;
 
-infix "===" at "==" (v1, v2) {
+infix === at == (v1, v2) {
   local s1, s2, i;
   
   s1 := v1.string;
@@ -17,14 +17,14 @@ infix "===" at "==" (v1, v2) {
   fi
 }
 
-infix "?" before "+" (v, l) {
+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) {
+infix +++ at + (l1, l2) {
   case l1 of
     {}     -> return l2
   | h : tl -> return (h : tl +++ l2)

regression/test060.expr

@@ -1,5 +1,5 @@
 fun f (l) {
-  infix "===" at "==" (a, b) {
+  infix === at == (a, b) {
     return a == b
   }
 

regression/test064.expr

@@ -1,5 +1,5 @@
-infix "++" at "+" (a, b) {return a+b}
+infix ++ at + (a, b) {return a+b}
 
 local x = read ();
 
-write (infix "++" (2, 3))
+write (infix ++ (2, 3))

regression/test067.expr

@@ -1,4 +1,4 @@
-infixr "**" before "*" (f, g) {
+infixr ** before * (f, g) {
   return fun (x) {return f (g (x))}
 }
 

regression/test087.expr

@@ -1,6 +1,6 @@
 local n;
 
-infix "===" at "==" (v1, v2) {
+infix === at == (v1, v2) {
   local s1, s2, i;
   
   s1 := v1.string;
@@ -17,14 +17,14 @@ infix "===" at "==" (v1, v2) {
   fi
 }
 
-infix "?" before "+" (v, l) {
+infix ? before + (v, l) {
   case l of
    {}      ->  0
   | h : tl -> if h === v then 1 else (v ? tl) fi
   esac
 }
 
-infix "+++" at "+" (l1, l2) {
+infix +++ at + (l1, l2) {
   case l1 of
     {}     -> l2
   | h : tl -> (h : tl +++ l2)

regression/test092.expr

@@ -1,5 +1,5 @@
 fun f (l) {
-  infix "===" at "==" (a, b) {
+  infix === at == (a, b) {
      a == b
   }
 

regression/test095.expr

@@ -1,5 +1,5 @@
-infix "++" at "+" (a, b) { a+b}
+infix ++ at + (a, b) { a+b}
 
 local x = read ();
 
-write (infix "++" (2, 3))
+write (infix ++ (2, 3))

regression/test098.expr

@@ -1,4 +1,4 @@
-infixr "**" before "*" (f, g) {
+infixr ** before * (f, g) {
    fun (x) { f (g (x))}
 }
 

src/Driver.ml

@@ -22,6 +22,7 @@ let parse cmd =
        inherit Util.Lexers.decimal s
        inherit Util.Lexers.string s
        inherit Util.Lexers.char   s
+       inherit Util.Lexers.infix  s
        inherit Util.Lexers.lident kws s
        inherit Util.Lexers.uident kws s
        inherit Util.Lexers.skip [

src/Language.ml

@@ -9,6 +9,18 @@ open GT
 open Ostap
 open Combinators
    
+let infix_name infix =
+  let b = Buffer.create 64 in
+  Buffer.add_string b "i__Infix_";
+  Seq.iter (fun c -> Buffer.add_string b (string_of_int @@ Char.code c)) @@ String.to_seq infix;
+  Buffer.contents b
+  
+let sys_infix_name infix =
+  let b = Buffer.create 64 in
+  Buffer.add_string b "s__Infix_";
+  Seq.iter (fun c -> Buffer.add_string b (string_of_int @@ Char.code c)) @@ String.to_seq infix;
+  Buffer.contents b
+
 exception Semantic_error of string
 
 module Loc =
@@ -167,7 +179,13 @@ module State =
       fst @@ inner n st
                     
     (* Undefined state *)
-    let undefined x = report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" x)
+    let undefined x =
+(*      let ops =
+        List.map (fun op -> infix_name op, op)
+
+      in
+      try Value.Var (Value.Fun (List.assoc x ops)) with
+      Not_found -> *) report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" x)
 
     (* Create a state from bindings list *)
     let from_list l = fun x -> try List.assoc x l with Not_found -> report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" x)
@@ -404,12 +422,6 @@ module Expr =
 
     let seq x = function Skip -> x | y -> Seq (x, y)
 
-    let infix_name infix =
-      let b = Buffer.create 64 in
-      Buffer.add_string b "i__Infix_";
-      Seq.iter (fun c -> Buffer.add_string b (string_of_int @@ Char.code c)) @@ String.to_seq infix;
-      Buffer.contents b
-
     let schedule_list h::tl =
       List.fold_left seq h tl
 
@@ -669,7 +681,7 @@ module Expr =
       
       | l:$ c:(%"true" {Const 1} | %"false" {Const 0}) => {notRef atr} :: (not_a_reference l) => {ignore atr c} 
        
-      | l:$ %"infix" s:STRING                         => {notRef atr}  :: (not_a_reference l) => {ignore atr (Var (infix_name s))}
+      | l:$ %"infix" s:INFIX                       => {notRef atr}  :: (not_a_reference l) => {let name = infix_name s in Loc.attach name l#coord; ignore atr (Var name)}
       | l:$ %"fun" "(" args:!(Util.list0)[ostap (l:$ x:LIDENT {Loc.attach x l#coord; x})] ")"
                "{" body:scope[def][infix][Weak][parse def] "}"=> {notRef atr} :: (not_a_reference l) => {ignore atr (Lambda (args, body))}
       | l:$ "[" es:!(Util.list0)[parse def infix Val] "]" => {notRef atr} :: (not_a_reference l) => {ignore atr (Array es)}
@@ -714,9 +726,13 @@ module Infix =
     @type ass    = [`Lefta | `Righta | `Nona] with show
     @type loc    = [`Before of string | `After of string | `At of string] with show
     @type export = (ass * string * loc) list with show
+    @type showable = (ass * string * kind) list array with show
                                                                                                      
     type t = ([`Lefta | `Righta | `Nona] * ((Expr.atr -> (Expr.atr * Expr.atr)) * ((string * kind * (Expr.t -> Expr.atr -> Expr.t -> Expr.t)) list))) array
 
+    let show_infix (infix : t) =
+      show(showable) @@ Array.map (fun (ass, (_, l)) -> List.map (fun (str, kind, _) -> ass, str, kind) l) infix
+
     let extract_exports infix =
       let ass_string = function `Lefta -> "L" | `Righta -> "R" | _ -> "I" in
       let exported = 
@@ -746,6 +762,9 @@ module Infix =
           exported
       in List.rev exports
 
+    let is_predefined op =      
+      List.exists (fun x -> op = x) [":"; "!!"; "&&"; "=="; "!="; "<="; "<"; ">="; ">"; "+"; "-"; "*" ; "/"; "%"; ":="]
+      
     let default : t =
       Array.map (fun (a, s) ->
         a,
@@ -780,7 +799,7 @@ module Infix =
           `Ok (Array.init (Array.length infix)
                  (fun j ->
                    if j = i
-                   then let (a, (atr, l)) = infix.(i) in (a, (atr, ((newp, kind_of public, sem) :: l)))
+                   then let (a, (atr, l)) = infix.(i) in (a, ( (*atr*) (fun _ -> Expr.Val, Expr.Val), ((newp, kind_of public, sem) :: (List.filter (fun (op', _, _) -> op' <> newp) l))))
                    else infix.(j)
             ))
         )
@@ -826,17 +845,19 @@ module Definition =
     ostap (
       arg : l:$ x:LIDENT {Loc.attach x l#coord; x};      
       position[pub][ass][coord][newp]:
-        %"at" s:STRING {match ass with
+        %"at" s:INFIX {match ass with
                        | `Nona -> Infix.at coord s newp pub
                        | _     -> report_error ~loc:(Some coord) (Printf.sprintf "associativity for infix \"%s\" can not be specified (it is inherited from that for \"%s\")" newp s)
            }
-        | f:(%"before" {Infix.before} | %"after" {Infix.after}) s:STRING {f coord s newp ass pub};
+        | f:(%"before" {Infix.before} | %"after" {Infix.after}) s:INFIX {f coord s newp ass pub};
       head[infix]:
         m:(%"external" {`Extern} | %"public" e:(%"external")? {match e with None -> `Public | _ -> `PublicExtern})? %"fun" l:$ name:LIDENT {Loc.attach name l#coord; unopt_mod m, name, name, infix}
     |   m:(%"public" {`Public})? ass:(%"infix" {`Nona} | %"infixl" {`Lefta} | %"infixr" {`Righta})
-        l:$ op:(s:STRING {s})
+        l:$ op:(s:INFIX {s})
         md:position[match m with Some _ -> true | _ -> false][ass][l#coord][op] {
-          let name = Expr.infix_name op in
+          if m <> None && Infix.is_predefined op then report_error ~loc:(Some l#coord) (Printf.sprintf "redefinition of standard infix operator \"%s\" can not be exported" op);
+          let name = infix_name op in
+          Loc.attach name l#coord;
           match md (Expr.sem name) infix with
           | `Ok infix' -> unopt_mod m, op, name, infix'
           | `Fail msg  -> report_error ~loc:(Some l#coord) msg
@@ -962,7 +983,7 @@ ostap (
           List.fold_left
             (fun infix item ->
                let insert name infix md = 
-                 let name = Expr.infix_name name in
+                 let name = infix_name name in
                  match md (Expr.sem name) infix with
                  | `Ok infix' -> infix'
                  | `Fail msg  -> report_error msg