Commit 5e46205c authored by Pietro Abate's avatar Pietro Abate

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

Original author: cvscast
Date: 2003-07-24 15:12:14+00:00
parent aa51dd43
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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 ->
......
let x : ref String = ref Int 0;;
let fun loop ([] : []) : [] =
print "Hello world !\n";
x := !x + 1;
if !x << 10 then loop [] else [];;
loop [];;
......@@ -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)
......@@ -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
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,
......
val nil_type: Types.descr
val nil_node: Types.node
val nil_atom: Atoms.v
val any: Types.descr
val seqseq: Types.descr
......
......@@ -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;
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment