Commits

camlspotter  committed 8742acf

mutable field via ref and build fix

  • Participants
  • Parent commits 81dac83

Comments (0)

Files changed (6)

-.*\.(cm*|a|o|omc|out)$
+.*\.(cm.*|a|o|omc|out|annot|exe)$
 .*~$
 .*\.out\.ml$
 .*\.auto\.mli$
 
 MyOCamlLibrary(pa_polyrecord, $(FILES))
 
-%.out.ml: %.ml pa_polyrecord.cma 
+%.out.ml: %.ml pa_polyrecord.cma
     camlp4o pa_polyrecord.cma -printer Camlp4OCamlPrinter $< > $@
 
-test.exe: test.out.ml
-    ocamlc -o test.exe polyrecord.cma test.out.ml
+test.exe: test.out.ml polyrecord.cma
+    ocamlc -o test.exe -i polyrecord.cma test.out.ml
 
 .DEFAULT: test.exe
 

File pa_polyrecord.ml

 let xlabel_expr_list = Gram.Entry.mk "xlabel_expr_list"
 let xlabel_expr = Gram.Entry.mk "xlabel_expr"
 
+let create_var = 
+  let cntr = ref 0 in
+  fun prefix ->
+    incr cntr;
+    prefix ^ string_of_int !cntr
+
 EXTEND Gram
 
   GLOBAL: expr xlabel_expr_list xlabel_expr ;
              <:expr< $int: string_of_int (hash_variant l)$, 
                      Obj.repr $lid:l$ >>) lel) 
           in
+          let var = create_var "a" in
           <:expr< let $concat_let_bindings bindings$ in
-                  let _o = ($o$ : 'a) in
-                  (Polyrecord.create $list$ : 'a Polyrecord.t) >>
+                  let _o = ($o$ : '$var$) in
+                  (Polyrecord.create $list$ : '$var$ Polyrecord.t) >>
 
       | "{<"; e = TRY [e = expr LEVEL "."; "with" -> e]; lel = xlabel_expr_list; ">}" ->
       
              <:expr< $int: string_of_int (hash_variant l)$, 
                      Obj.repr $lid:l$ >>) lel) 
           in
-          <:expr< let e : 'a Polyrecord.t = $e$ in
+          let var = create_var "a" in
+          <:expr< let e : '$var$ Polyrecord.t = $e$ in
                   let $concat_let_bindings bindings$ in
-                  let _o : 'a -> _ = fun o -> $o$ in
-                  (Polyrecord.update e $list$ : 'a Polyrecord.t) >>
+                  let _o : '$var$ -> _ = fun o -> $o$ in
+                  (Polyrecord.update e $list$ : '$var$ Polyrecord.t) >>
 
       ] ];
 
-  expr: LEVEL "." (* LEFTA *)
+  expr: BEFORE "." (* LEFTA *)
      [ [ e = SELF; ".."; l = label; "<-"; e2 = expr LEVEL "top" ->
           
+          let var = create_var "a" in
+          let res = create_var "res" in 
            <:expr< 
-             let e : 'a Polyrecord.t = $e$ in
-             let e2 : 'res = $e2$ in
-             let _o : 'a -> 'res = fun o -> o#$l$ in
+             let e : '$var$ Polyrecord.t = $e$ in
+             let e2 : '$res$ = $e2$ in
+             let _o : '$var$ -> '$res$ ref = fun o -> o#$l$ in
              Polyrecord.set $e$ $int:string_of_int (hash_variant l)$ (Obj.repr $e2$)
            >> 
 
        | e = SELF; ".."; l = label -> 
 
+          let var = create_var "a" in
+          let res = create_var "res" in 
            <:expr< 
-             let e : 'a Polyrecord.t = $e$ in
-             let _o : 'a -> 'res = fun o -> o#$l$ in
-             (Obj.magic (Polyrecord.get $e$ $int:string_of_int (hash_variant l)$) : 'res)
+             let e : '$var$ Polyrecord.t = $e$ in
+             let _o : '$var$ -> '$res$ = fun o -> o#$l$ in
+             (Obj.magic (Polyrecord.get $e$ $int:string_of_int (hash_variant l)$) : '$res$)
            >> 
 
      ]];

File polyrecord.ml

 
 let get t k = Hashtbl.find t k
 
-let set t k o = Hashtbl.replace t k o
+let set t k o = (Obj.magic (Hashtbl.find t k) : Obj.t ref) := o

File polyrecord.mli

-type 'a t  (** since it is mutable record, it must be invariant *)
+type +'a t  (** Covariant since it is immutable by itself 
+                Mutability is achieved by having ref members
+            *)
 
 val create : (int * Obj.t) list -> 'a t
 val update : 'a t -> (int * Obj.t) list -> 'a t
 val get : 'a t -> int -> Obj.t
-val set : 'a t -> int -> Obj.t -> unit
+val set : 'a t -> int -> Obj.t -> unit (* the field must be a reference *)
+
-let r = {< x = 1; y = None >}
+(* Record creation 
 
-let 3 = r..x + 2
+   {< .. >} is a record but all the fields are immutable.
+   If you want to have mutability, use ref explicitly.
+*)
 
-(* those records are just hashtbls, so streamable *)
+let r = {< x = 1; y = ref None >}
+
+(* Record access
+
+   r..field
+
+*)
+
+let () = match r..x + 2 with 3 -> prerr_endline "ok" | _ -> assert false
+
+(* Non existent field access is statically rejected.
+
+let z = r..z
+
+*)
+
+(* You can define polymorphic accessor, however. *)
+
+let get_z r = r..z
+
+let get_z_w r = r..z..w
+
+(* Marshalling. Those records are just hashtbls, so streamable *)
+
 let () = output_value stdout r; print_newline ()
 
-let r2 = {< r with x = 3 >} (* make a copy *)
+(* Making a copy with 
 
-(* impos       let r2 = {< r with z = 3 >} *)
+   {< r with bindings >}
 
-let () = r2..y <- Some 3;;  (* all the fields are mutable *)
-
-(* impos: since it is a ref
-  let () = r2..y <- Some 3.0;;  (* all the fields are mutable *) 
 *)
 
-let () = Printf.printf "%d\n" (match r2..y with None -> -1 | Some v -> v)
- 
+let r2 = {< r with x = 3 >}
 
+(* You cannot add fields at copy. :-(
+
+   let r2 = {< r with z = 3 >} 
+
+*)
+
+(* Mutability via ref member by 
+
+   r..field <- e
+
+*)
+
+let () = r2..y <- Some 3;; 
+
+(* Mutable field cannot have poly type
+
+   let () = r2..y <- Some 3.0 (* error *)
+*)
+
+(* Accessing the content of the mutable field is via (!).
+   A bit glitchy... 
+*)
+
+let () = Printf.printf "%d\n" (match !(r2..y) with None -> -1 | Some v -> v)
+
+(* !r..y = (!r)..y  not  !(r..y)
+
+   just like !r.y = (!r).y  not  !(r.y)
+
+*)
+
+let g r = !r..y
+
+