Standard infix capturing

regression/x86only/orig/test006.log

@@ -0,0 +1,3 @@
+3
+{1}
+{1}

regression/x86only/test006.expr

@@ -0,0 +1,3 @@
+printf ("%d\n", infix + (1, 2));
+printf ("%s\n", (1 : 2).string);
+printf ("%s\n", (infix : (1, 2)).string)

runtime/Std.i

@@ -21,5 +21,19 @@ F,read;
 F,write;
 F,compare;
 F,i__Infix_4343;
+F,s__Infix_58;
+F,s__Infix_3333;
+F,s__Infix_3838;
+F,s__Infix_6161;
+F,s__Infix_3361;
+F,s__Infix_6061;
+F,s__Infix_60;
+F,s__Infix_6261;
+F,s__Infix_62;
+F,s__Infix_43;
+F,s__Infix_45;
+F,s__Infix_42;
+F,s__Infix_47;
+F,s__Infix_37;
 L,"++",T,"+";
  

runtime/runtime.c

@@ -93,6 +93,124 @@ typedef struct {
 } sexp; 
 
 extern void* alloc (size_t);
+extern void* Bsexp (int n, ...);
+
+// Functional synonym for built-in operator ":";
+void* Ls__Infix_58 (void *p, void *q) {
+  void *res;
+  
+  __pre_gc ();
+
+  res = Bsexp (3, p, q, 848787);
+
+  __post_gc ();
+
+  return res;
+}
+
+// Functional synonym for built-in operator "!!";
+int Ls__Infix_3333 (void *p, void *q) {
+  ASSERT_UNBOXED("captured !!:1", p);
+  ASSERT_UNBOXED("captured !!:2", q);
+
+  return BOX(UNBOX(p) || UNBOX(q));
+}
+
+// Functional synonym for built-in operator "&&";
+int Ls__Infix_3838 (void *p, void *q) {
+  ASSERT_UNBOXED("captured &&:1", p);
+  ASSERT_UNBOXED("captured &&:2", q);
+
+  return BOX(UNBOX(p) && UNBOX(q));
+}
+
+// Functional synonym for built-in operator "==";
+int Ls__Infix_6161 (void *p, void *q) {
+  ASSERT_UNBOXED("captured ==:1", p);
+  ASSERT_UNBOXED("captured ==:2", q);
+
+  return BOX(UNBOX(p) == UNBOX(q));
+}
+
+// Functional synonym for built-in operator "!=";
+int Ls__Infix_3361 (void *p, void *q) {
+  ASSERT_UNBOXED("captured !=:1", p);
+  ASSERT_UNBOXED("captured !=:2", q);
+
+  return BOX(UNBOX(p) != UNBOX(q));
+}
+
+// Functional synonym for built-in operator "<=";
+int Ls__Infix_6061 (void *p, void *q) {
+  ASSERT_UNBOXED("captured <=:1", p);
+  ASSERT_UNBOXED("captured <=:2", q);
+
+  return BOX(UNBOX(p) <= UNBOX(q));
+}
+
+// Functional synonym for built-in operator "<";
+int Ls__Infix_60 (void *p, void *q) {
+  ASSERT_UNBOXED("captured <:1", p);
+  ASSERT_UNBOXED("captured <:2", q);
+
+  return BOX(UNBOX(p) < UNBOX(q));
+}
+
+// Functional synonym for built-in operator ">=";
+int Ls__Infix_6261 (void *p, void *q) {
+  ASSERT_UNBOXED("captured >=:1", p);
+  ASSERT_UNBOXED("captured >=:2", q);
+
+  return BOX(UNBOX(p) >= UNBOX(q));
+}
+
+// Functional synonym for built-in operator ">";
+int Ls__Infix_62 (void *p, void *q) {
+  ASSERT_UNBOXED("captured >:1", p);
+  ASSERT_UNBOXED("captured >:2", q);
+
+  return BOX(UNBOX(p) > UNBOX(q));
+}
+
+// Functional synonym for built-in operator "+";
+int Ls__Infix_43 (void *p, void *q) {
+  ASSERT_UNBOXED("captured +:1", p);
+  ASSERT_UNBOXED("captured +:2", q);
+
+  return BOX(UNBOX(p) + UNBOX(q));
+}
+
+// Functional synonym for built-in operator "-";
+int Ls__Infix_45 (void *p, void *q) {
+  ASSERT_UNBOXED("captured -:1", p);
+  ASSERT_UNBOXED("captured -:2", q);
+
+  return BOX(UNBOX(p) - UNBOX(q));
+}
+
+// Functional synonym for built-in operator "*";
+int Ls__Infix_42 (void *p, void *q) {
+  ASSERT_UNBOXED("captured *:1", p);
+  ASSERT_UNBOXED("captured *:2", q);
+
+  return BOX(UNBOX(p) * UNBOX(q));
+}
+
+// Functional synonym for built-in operator "/";
+int Ls__Infix_47 (void *p, void *q) {
+  ASSERT_UNBOXED("captured /:1", p);
+  ASSERT_UNBOXED("captured /:2", q);
+
+  return BOX(UNBOX(p) / UNBOX(q));
+}
+
+// Functional synonym for built-in operator "%";
+int Ls__Infix_37 (void *p, void *q) {
+  ASSERT_UNBOXED("captured %:1", p);
+  ASSERT_UNBOXED("captured %:2", q);
+
+  return BOX(UNBOX(p) % UNBOX(q));
+}
 
 extern int Blength (void *p) {
   data *a = (data*) BOX (NULL);

src/Driver.ml

@@ -110,7 +110,7 @@ class options args =
   end
   
 let main =
-  try
+  (*  try *)
     let cmd = new options Sys.argv in
     match (try parse cmd with Language.Semantic_error msg -> `Fail msg) with
     | `Ok prog ->
@@ -137,5 +137,5 @@ let main =
 	   List.iter (fun i -> Printf.printf "%d\n" i) output 
        )
     | `Fail er -> Printf.eprintf "Error: %s\n" er
-  with Language.Semantic_error msg -> Printf.printf "Error: %s\n" msg
+(*with Language.Semantic_error msg -> Printf.printf "Error: %s\n" msg *)
 

src/Language.ml

@@ -180,12 +180,7 @@ module State =
                     
     (* Undefined state *)
     let undefined x =
-(*      let ops =
+      report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" x)
-        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)
@@ -617,6 +612,9 @@ module Expr =
       
     let atr' = atr
     let not_a_reference s = new Reason.t (Msg.make "not a reference" [||] (Msg.Locator.Point s#coord))
+                          
+    (* UGLY! *)
+    let predefined_op : (Obj.t -> Obj.t -> Obj.t) ref = Pervasives.ref (fun _ _ -> invalid_arg "must not happen")
                             
     (* ======= *)
     ostap (
@@ -681,7 +679,18 @@ module Expr =
       
       | l:$ c:(%"true" {Const 1} | %"false" {Const 0}) => {notRef atr} :: (not_a_reference l) => {ignore atr c} 
        
-      | 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:$ %"infix" s:INFIX => {notRef atr} :: (not_a_reference l) => {
+          if ((* UGLY! *) Obj.magic !predefined_op) infix s
+          then (
+            if s = ":="
+            then report_error ~loc:(Some l#coord) (Printf.sprintf "can not capture predefined operator \":=\"")
+            else
+              let name = sys_infix_name s in Loc.attach name l#coord; ignore atr (Var name)
+          )            
+          else (
+            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)}
@@ -722,10 +731,10 @@ module Expr =
 module Infix =
   struct
     
-    @type kind   = Predefined | Public | Local with show
+    @type kind     = Predefined | Public | Local with show
-    @type ass    = [`Lefta | `Righta | `Nona] with show
+    @type ass      = [`Lefta | `Righta | `Nona] with show
-    @type loc    = [`Before of string | `After of string | `At of string] with show
+    @type loc      = [`Before of string | `After of string | `At of string] with show
-    @type export = (ass * string * loc) list 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
@@ -765,6 +774,19 @@ module Infix =
     let is_predefined op =      
       List.exists (fun x -> op = x) [":"; "!!"; "&&"; "=="; "!="; "<="; "<"; ">="; ">"; "+"; "-"; "*" ; "/"; "%"; ":="]
       
+    (*
+    List.iter (fun op ->
+        Printf.eprintf "F,%s\n" (sys_infix_name op);
+        (*
+        Printf.eprintf "// Functional synonym for built-in operator \"%s\";\n" op;
+        Printf.eprintf "int L%s (void *p, void *q) {\n" (sys_infix_name op);
+        Printf.eprintf "  ASSERT_UNBOXED(\"captured %s:1\", p);\n" op;
+        Printf.eprintf "  ASSERT_UNBOXED(\"captured %s:2\", q);\n\n" op;
+        Printf.eprintf "  return BOX(UNBOX(p) %s UNBOX(q));\n" op;
+        Printf.eprintf "}\n\n"        *)
+      ) [":"; "!!"; "&&"; "=="; "!="; "<="; "<"; ">="; ">"; "+"; "-"; "*" ; "/"; "%"]
+     *)
+      
     let default : t =
       Array.map (fun (a, s) ->
         a,
@@ -782,13 +804,23 @@ module Infix =
       |]
 
     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 predefined_op infix op =      
+      Array.exists
+        (fun (_, (_, l)) ->
+           List.exists (fun (s, p, _) -> s = op && p = Predefined) l
+        )
+        infix;;
+
+    (* UGLY!!! *)
+    Expr.predefined_op := (Obj.magic) predefined_op;;
+                          
     let no_op op coord = `Fail (Printf.sprintf "infix \"%s\" not found in the scope" op) 
 
     let kind_of = function true -> Public | _ -> Local

src/SM.ml

@@ -271,8 +271,6 @@ let check_name_and_add names name mut =
 | Top  of fundef list
 | Item of fundef * fundef list * context
 with show
-
-(* @type funinfo = {parent : string; closure : Value.designation list} with show *)
                                                                        
 let init_scope st = {
     st          = st;