[r2003-07-24 15:11:47 by cvscast] Experiment with encoded references

Original author: cvscast
Date: 2003-07-24 15:12:14+00:00

CHANGES

+since 0.1.0
+  * Various bug fixes
+  * Sequencing operator   e1;e2  (equivalent to: let [] = e1 in e2)
+  * Encoded references
+  
+
 0.1.0
   * Support for XML Namespaces
   * Better support for expat; clean Makefile

parser/ast.ml

@@ -38,9 +38,6 @@ and pconst =
 and pexpr = 
   | LocatedExpr of loc * pexpr
 
-  | Forget of pexpr * ppat    
-  | Op of string * pexpr list
-
   (* CDuce is a Lambda-calculus ... *)
   | Var of id
   | Apply of pexpr * pexpr
@@ -67,6 +64,11 @@ and pexpr =
 
   (* Other *)
   | NamespaceIn of U.t * Ns.t * pexpr
+  | Forget of pexpr * ppat    
+  | Op of string * pexpr list
+  | Ref of pexpr * ppat
+
+
 
 and label = U.t
 

parser/parser.ml

@@ -21,7 +21,6 @@ let parse_ident = U.mk_latin1
 
 let id_dummy = ident (U.mk "$$$")
 
-(* TODO: NS *)
 let label = parse_ident
 let ident s = ident (parse_ident s)
 
@@ -52,6 +51,7 @@ let char = mknoloc (Internal (Types.char Chars.any))
 let string_regexp = Star (Elem char)
 	       
 let cst_nil =  Cst (Const_internal (Types.Atom Sequence.nil_atom))
+let pat_nil = mknoloc (Internal (Sequence.nil_type))
 		 
 let seq_of_string s =
   let s = Encodings.Utf8.mk s in
@@ -164,7 +164,7 @@ EXTEND
 	| "if" | "then"	| "else"
 	| "transform" | "fun" | "in"
 	| "let" | "type" | "debug" | "include"
-        | "and" | "validate" | "schema" | "namespace"
+        | "and" | "validate" | "schema" | "namespace" | "ref"
 	]
 	-> a
     ]
@@ -197,9 +197,15 @@ EXTEND
 	exp loc (NamespaceIn (name, ns, e2))
     | e = expr; ":"; p = pat ->
 	exp loc (Forget (e,p))
+    | e1 = expr; ";"; e2 = expr ->
+	exp loc (Match (e1, [pat_nil,e2]))
+    | "ref"; p = pat; e = expr ->
+	exp loc (Ref (e,p))
+    ]
+    |
+    [ e1 = expr; ":="; e2 = expr ->
+	exp loc (Apply (Dot (e1, U.mk "set"), e2))
     ]
-
-    
     | 
     [ e1 = expr; op = ["=" | "<=" | "<<" | ">>" | ">=" ]; e2 = expr -> 
 	let op = match op with
@@ -279,6 +285,8 @@ EXTEND
 	let s = U.mk s in
 	exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
     | a = LIDENT -> exp loc (Var (ident a))
+    | "!"; e = expr ->
+	exp loc (Apply (Dot (e, U.mk "get"), cst_nil))
     ]
 
   ];
@@ -416,6 +424,11 @@ EXTEND
     | 
       [ "{"; r = record_spec; "}" -> mk loc (Record (true,r))
       | "{|"; r = record_spec; "|}" -> mk loc (Record (false,r))
+      | "ref"; p = pat ->
+	  let get_fun = mk loc (Arrow (pat_nil, p)) 
+	  and set_fun = mk loc (Arrow (p, pat_nil)) in
+	  let fields = [ label "get", get_fun; label "set", set_fun ] in
+	  mk loc (Record (false, fields))
       | LIDENT "_" -> mk loc (Internal Types.any)
       | a = LIDENT -> mk loc (Capture (ident a))
       | "("; a = LIDENT; ":="; c = const; ")" -> 
@@ -458,7 +471,7 @@ EXTEND
       | "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
       | "["; r = [ r = regexp -> r | -> Epsilon ];
              q = [ ";"; q = pat -> q 
-                 | -> mknoloc (Internal (Sequence.nil_type)) ]; 
+                 | -> pat_nil ]; 
              "]" -> mk loc (Regexp (r,q))
       | "<"; t =
             [ x = tag_type -> x

runtime/eval.ml

@@ -42,6 +42,15 @@ let rec eval env e0 = match e0.Typed.exp_descr with
 *)
       Schema_validator.validate ~validator
         (Schema_xml.pxp_stream_of_value (eval env e))
+  | Typed.Ref (e,t) ->
+      let r = ref (eval env e) in
+      let get = 
+	Abstraction ([Sequence.nil_type, Types.descr t], fun _ -> !r)
+      and set = 
+	Abstraction 
+	  ([Types.descr t, Sequence.nil_type], fun x -> r := x; nil) in
+      Record (Builtin_defs.mk_ref ~get ~set)
+
 
 and eval_try env arg brs =
   try eval env arg

runtime/value.ml

@@ -28,7 +28,7 @@ let vbool x = if x then vtrue else vfalse
 (* TODO: namespaces for the two following functions *)
 let vrecord l =
   let l = List.map (fun (l,v) -> LabelPool.mk (Ns.empty, U.mk l), v) l in
-  Record (LabelMap.from_list (fun _ _ -> assert false) l)
+  Record (LabelMap.from_list_disj l)
 
 let get_fields = function
   | Record map ->

tests/ref.cd

+let x : ref String = ref Int 0;;
+
+let fun loop ([] : []) :  [] =
+  print "Hello world !\n";
+  x := !x + 1;
+  if !x << 10 then loop [] else [];;
+
+loop [];;

types/builtin_defs.ml

@@ -31,3 +31,16 @@ let atom = Types.atom Atoms.any
 
 let char_latin1 = Types.char (Chars.mk_classes [ (0,255) ])
 let string_latin1 = Sequence.star char_latin1
+
+
+open Ident
+let get_label = LabelPool.mk (Ns.empty, U.mk "get") 
+let set_label = LabelPool.mk (Ns.empty, U.mk "set")
+
+let mk_ref ~get ~set =
+  LabelMap.from_list_disj [ get_label, get; set_label, set ]
+
+let ref_type t =
+  let get = Types.cons (Types.arrow Sequence.nil_node t)
+  and set = Types.cons (Types.arrow t Sequence.nil_node) in
+  Types.record' (false , mk_ref ~get ~set)

types/builtin_defs.mli

@@ -29,3 +29,7 @@ val int : Types.descr
 val string : Types.descr
 val char_latin1 : Types.descr
 val string_latin1 : Types.descr
+
+
+val mk_ref: get:'a -> set:'a -> 'a Ident.label_map
+val ref_type: Types.node -> Types.descr

types/sequence.ml

 let nil_atom = Atoms.mk_ascii "nil"
 let nil_type = Types.atom (Atoms.atom nil_atom)
+let nil_node = Types.cons nil_type
 
 let decompose t =
   (Types.Atom.has_atom t nil_atom,

types/sequence.mli

 val nil_type: Types.descr
+val nil_node: Types.node
 val nil_atom: Atoms.v
 val any: Types.descr
 val seqseq: Types.descr

typing/typed.ml

@@ -48,6 +48,7 @@ and  texpr' =
 
   | UnaryOp of unary_op * texpr
   | BinaryOp of binary_op * texpr * texpr
+  | Ref of texpr * ttyp
 
 and unary_op = {
   un_op_typer : loc -> typ_fun -> typ_fun;

typing/typer.ml

@@ -740,7 +740,9 @@ let rec expr glb loc = function
   | NamespaceIn (pr,ns,e) ->
       let glb = register_ns glb pr ns in
       expr glb loc e
-
+  | Ref (e,t) ->
+      let (fv,e) = expr glb loc e and t = typ glb t in
+      exp loc fv (Typed.Ref (e,t))
 	      
   and branches glb b = 
     let fv = ref Fv.empty in
@@ -955,6 +957,10 @@ and type_check' loc env e constr precise = match e with
       let t = fst (Hashtbl.find !schema_elements (schema_name, elt_name)) in
       check loc t constr
 
+  | Ref (e,t) ->
+      ignore (type_check env e (Types.descr t) false);
+      check loc (Builtin_defs.ref_type t) constr
+
 and type_check_pair ?(kind=`Normal) loc env e1 e2 constr precise =
   let rects = Types.Product.normal ~kind constr in
   if Types.Product.is_empty rects then