Add intersection of records. Add _base_ hack to objects

src/compiler/flx_bind/flx_bind_expression.ml

@@ -166,7 +166,6 @@ let rec bind_expression'
   | `EXPR_arrow _
   | `EXPR_effector _
   | `EXPR_longarrow _
-  | `EXPR_intersect _
   | `EXPR_union _
   | `EXPR_isin _
     ->
@@ -1490,6 +1489,10 @@ print_endline ("Bind_expression general apply " ^ string_of_expr e);
     end else if n = 1 then List.hd bets
     else syserr sr "Empty array?"
 
+  | `EXPR_intersect (sr, es) ->
+    let es = List.map be es in
+    bexpr_intersect es
+
   (* the code for this is pretty messy and inefficient but it should work *)
   (* actually no, it only works at binding time! we need tuple_cons, which
      should work at instantiation time!

src/compiler/flx_core/flx_bexpr.ml

@@ -596,6 +596,7 @@ let bexpr_getall_field (e',t' as e) s =
 
 
 (************************ POLYRECORD **************************)
+
 let bexpr_polyrecord (es: (string * t) list) ((e',t') as e) =
 (*
 print_endline ("[bexpr_polyrecord] Constructing polyrecord: extension fields = " ^ String.concat "," (List.map (fun (s,(_,t)) -> s^":"^ st t) es));
@@ -700,6 +701,35 @@ print_endline ("Core = " ^ st (snd reduced_e));
    let es = es @ [fld] in
    bexpr_record es
 
+let rec bexpr_intersect es =
+  let rec aux out es =
+    match es with
+    | [] -> out
+    | ((_,ht) as h) :: tail ->
+      let mkprj fld seq fldt : t = bexpr_rnprj fld seq ht fldt in
+      match ht with
+      | BTYP_record flds -> 
+        let dcnt = ref 0 in
+        let idx = ref 0 in
+        let ctrl_key = ref "" in
+        let nuflds = ref [] in
+        let first = ref true in
+        List.iter 
+          (fun (name,t) -> 
+            if !first then begin first := false; ctrl_key := name; dcnt := 0 end else
+            if name = !ctrl_key then incr dcnt else begin ctrl_key := name; dcnt := 0 end;
+            let x = bexpr_apply t (mkprj name (!dcnt) t, h) in
+            nuflds := ( name, x) :: !nuflds;
+            incr idx
+          ) 
+          flds
+        ;
+        aux (out @ (List.rev !nuflds)) tail 
+
+      | _ ->
+        print_endline ("bexpr_intersect requires arguments to be records at the moment");
+        assert false
+  in bexpr_record (aux [] es)
 
 (************************ END POLYRECORD **************************)
 let bexpr_aprj ix d c = 

src/compiler/flx_core/flx_bexpr.mli

@@ -145,6 +145,7 @@ val cal_removal :
 val bexpr_remove_fields : t -> string list -> t
 val bexpr_getall_field : t -> string -> t
 val bexpr_polyrecord : (string * t) list -> t -> t
+val bexpr_intersect : t list -> t
 val bexpr_variant : Flx_btype.t -> string * t -> t
 val bexpr_aprj : t -> Flx_btype.t -> Flx_btype.t -> t
 val bexpr_inj : int -> Flx_btype.t -> Flx_btype.t -> t

src/compiler/flx_desugar/flx_curry.ml

@@ -263,7 +263,7 @@ let mkcurry seq sr name vs args return_type effects kind body props =
         print_endline "Found an object, scanning for methods and bogus returns";
         *)
         let methods = ref [] in
-
+        let bases = ref [] in
         List.iter 
           (fun st ->
             (*
@@ -275,6 +275,12 @@ let mkcurry seq sr name vs args return_type effects kind body props =
             | STMT_curry (_,name, vs, pss, (res,traint) , effects, kind, adjectives, ss)
                 when kind = `Method || kind = `GeneratorMethod -> 
                 methods := name :: !methods
+            | STMT_var_decl (_, name, ([],_),_,e) when String.length name > 6 && String.sub name 0 6 = "_base_" ->
+(*
+print_endline ("Flx_curry: Base " ^ name);
+*)
+              bases := name :: !bases
+
             | _ -> ()
           )
           body
@@ -286,6 +292,11 @@ let mkcurry seq sr name vs args return_type effects kind body props =
         let record = `EXPR_record (sr, List.map mkfield (!methods)) in
 (*
         print_endline ("Object method record: " ^ string_of_expr record);
+*)
+        let bases = List.map (fun s -> `EXPR_name (sr,s,[])) !bases in
+        let record = `EXPR_intersect (sr, record :: bases) in
+(*
+        print_endline ("Object " ^name^ " return value " ^ string_of_expr record); 
 *)
         let retstatement = STMT_fun_return (sr, record) in
         let revbody = retstatement :: revbody in

src/compiler/flx_desugar/flx_desugar_expr.ml

@@ -146,12 +146,16 @@ let rec rex rst_with_ret mkreqs map_reqs (state:desugar_state_t) name (e:expr_t)
   | `EXPR_case_arg _
   | `EXPR_arrow _
   | `EXPR_effector _
-  | `EXPR_intersect _
   | `EXPR_union _
   | `EXPR_isin _
     ->
     clierrx "[flx_desugar/flx_desugar_expr.ml:127: E326] " sr ("[rex] Unexpected " ^ string_of_expr e)
 
+  | `EXPR_intersect (sr, es) ->
+    let lxs = List.map rex es in
+    let ls,xs = List.split lxs in
+    let ls = List.concat ls in
+    ls, `EXPR_intersect (sr, xs)
 
   | `EXPR_longarrow (sr,x) -> [], `EXPR_longarrow (sr,x)
 

src/compiler/flx_desugar/flx_sex2flx.ml

@@ -452,7 +452,7 @@ print_endline ("sex2flx:expr] " ^ Sex_print.string_of_sex x);
  | Lst [Id "ast_patany"; sr] -> `EXPR_patany (xsr sr)
 
 
- | Lst [Id "ast_intersect"; Lst es] -> `EXPR_intersect (sr, map ex es)
+ | Lst [Id "ast_intersect"; sr; Lst es] -> `EXPR_intersect (xsr sr, map ex es)
  | Lst [Id "ast_isin"; Lst [a; b]] -> `EXPR_isin (sr, (ex a, ex b))
  | Lst [Id "ast_not"; sr; e] -> `EXPR_not (xsr sr, ex e)
 (*

src/packages/gmp.fdoc

@@ -190,14 +190,6 @@ open Str[Gmp::mpf];
 include "gnu/gmp";
 open Gmp;
 
-syntax gmp_syntax {
-  x[ssetunion_pri] := x[ssetunion_pri] "/\" x[>ssetunion_pri] =># 
-    "`(ast_apply ,_sr (lcm (ast_tuple ,_sr (,_1 ,_3))))" note "lcm";
-  x[ssetintersection_pri] := x[ssetintersection_pri] "\/" x[>ssetintersection_pri] =># 
-    "`(ast_apply ,_sr (gcd (ast_tuple ,_sr (,_1 ,_3))))" note "gcd";
-}
-open syntax gmp_syntax;
-
 {
   val x:mpz = mpz_of_int 99;
   val y:mpz = mpz_of_int 7;
@@ -218,8 +210,8 @@ open syntax gmp_syntax;
 
   print$ lcm (x,y); endl;
   print$ gcd (x,y); endl;
-  print$ x /\ y; endl;
-  print$ x \/ y; endl;
+  print$ lcm(x,y); endl;
+  print$ gcd(x,y); endl;
 };
 {
   val x:mpq = mpq_of_int 99;

src/packages/grammar.fdoc

@@ -482,6 +482,7 @@ syntax expressions {
 
   //$ multiplication: right associative
   x[sproduct_pri] := x[>sproduct_pri] "\otimes" x[sproduct_pri] =># "(Infix)";
+  x[sproduct_pri] := x[sproduct_pri]  ("/\" x[>sproduct_pri])+ =># "(chain 'ast_intersect _1 _2)";
 
   // repeated sum type, eg 4 *+ int == int + int + int + int
   // right associative:  2 *+ 3 *+ int is approx 6 *+ int