Commit 193b887b authored by Pietro Abate's avatar Pietro Abate

[r2003-06-25 23:11:01 by cvscast] Starting Namespaces -- Alain

Original author: cvscast
Date: 2003-06-25 23:11:03+00:00
parent 3b8d004b
......@@ -64,7 +64,8 @@ OBJECTS = \
misc/pretty.cmo \
\
types/sortedList.cmo types/boolean.cmo types/ident.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo \
types/normal.cmo \
types/types.cmo types/patterns.cmo types/sequence.cmo \
types/sample.cmo types/builtin_defs.cmo \
\
......
......@@ -18,6 +18,8 @@ types/intervals.cmo: misc/q_symbol.cmo types/intervals.cmi
types/intervals.cmx: misc/q_symbol.cmo types/intervals.cmi
types/chars.cmo: misc/q_symbol.cmo types/chars.cmi
types/chars.cmx: misc/q_symbol.cmo types/chars.cmi
types/ns.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi types/ns.cmi
types/ns.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx types/ns.cmi
types/atoms.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi types/sortedList.cmi \
types/atoms.cmi
types/atoms.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx types/sortedList.cmx \
......@@ -92,14 +94,16 @@ typing/typed.cmo: misc/q_symbol.cmo types/ident.cmo parser/location.cmi types/pa
types/types.cmi runtime/value.cmi
typing/typed.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx types/patterns.cmx \
types/types.cmx runtime/value.cmx
typing/typer.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/ident.cmo \
parser/location.cmi types/patterns.cmi schema/schema_builtin.cmi \
schema/schema_types.cmi schema/schema_validator.cmi types/sequence.cmi \
misc/state.cmi typing/typed.cmo types/types.cmi typing/typer.cmi
typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/ident.cmx \
parser/location.cmx types/patterns.cmx schema/schema_builtin.cmx \
schema/schema_types.cmx schema/schema_validator.cmx types/sequence.cmx \
misc/state.cmx typing/typed.cmx types/types.cmx typing/typer.cmi
typing/typer.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/chars.cmi \
types/ident.cmo parser/location.cmi types/patterns.cmi \
schema/schema_builtin.cmi schema/schema_types.cmi \
schema/schema_validator.cmi types/sequence.cmi misc/state.cmi \
typing/typed.cmo types/types.cmi typing/typer.cmi
typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/chars.cmx \
types/ident.cmx parser/location.cmx types/patterns.cmx \
schema/schema_builtin.cmx schema/schema_types.cmx \
schema/schema_validator.cmx types/sequence.cmx misc/state.cmx \
typing/typed.cmx types/types.cmx typing/typer.cmi
runtime/load_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi runtime/value.cmi runtime/load_xml.cmi
runtime/load_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
......@@ -149,6 +153,7 @@ driver/webiface.cmo: misc/q_symbol.cmo driver/cduce.cmi driver/examples.cmo pars
driver/webiface.cmx: misc/q_symbol.cmo driver/cduce.cmx driver/examples.cmx parser/location.cmx \
misc/state.cmx
types/boolean.cmi: misc/q_symbol.cmo types/sortedList.cmi
types/ns.cmi: misc/q_symbol.cmo misc/encodings.cmi
types/atoms.cmi: misc/q_symbol.cmo misc/encodings.cmi
types/types.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/ident.cmo \
types/intervals.cmi types/sortedList.cmi
......
......@@ -39,8 +39,10 @@ let dump_env ppf =
Format.fprintf ppf "@[val %a : @[%a = %a@]@]@."
U.print (Id.value x) print_norm t print_value v
)
!eval_env
!eval_env;
Format.fprintf ppf "Namespaces:@.";
Atoms.Ns.dump_prefix_table ppf
let rec print_exn ppf = function
| Location (loc, w, exn) ->
......@@ -54,9 +56,9 @@ let rec print_exn ppf = function
Format.fprintf ppf "Multiple declaration for global value %a@."
U.print (Id.value v)
| Typer.WrongLabel (t,l) ->
Format.fprintf ppf "Wrong record selection: the label %a@."
Format.fprintf ppf "Wrong record selection; field %a "
U.print (LabelPool.value l);
Format.fprintf ppf "applied to an expression of type:@.%a@."
Format.fprintf ppf "not present in an expression of type:@.%a@."
print_norm t
| Typer.ShouldHave (t,msg) ->
Format.fprintf ppf "This expression should have type:@.%a@.%s@."
......@@ -168,6 +170,9 @@ let rec phrases ppf phs = match phs with
| { descr = Ast.SchemaDecl (name, schema) } :: rest ->
Typer.register_schema name schema;
phrases ppf rest
| { descr = Ast.Namespace (pr,ns) } :: rest ->
Typer.register_ns_prefix pr ns;
phrases ppf rest
| { descr = Ast.EvalStatement e } :: rest ->
let (fv,e) = Typer.expr e in
let t = Typer.type_check !typing_env e Types.any true in
......
......@@ -7,6 +7,7 @@ struct
let hash = Hashtbl.hash
let equal (x : t) y = x = y
let compare (x : t) y = compare x y
(* TODO: handle UTF-8 viewport *)
let to_string s =
......
......@@ -7,6 +7,7 @@ sig
val hash: t -> int
val equal: t -> t -> bool
val compare: t -> t -> int
val check: string -> bool
......
......@@ -9,10 +9,11 @@ type pprog = pmodule_item list
and pmodule_item = pmodule_item' located
and pmodule_item' =
| TypeDecl of string * ppat
| TypeDecl of U.t * ppat
| SchemaDecl of string * Schema_types.schema (* name, schema *)
| LetDecl of ppat * pexpr
| FunDecl of pexpr
| Namespace of U.t * Atoms.Ns.t
| EvalStatement of pexpr
| Debug of debug_directive
| Directive of toplevel_directive
......@@ -29,6 +30,10 @@ and toplevel_directive =
]
and pconst =
| Const_internal of Types.const
| Const_atom of U.t * U.t
and pexpr =
| LocatedExpr of loc * pexpr
......@@ -41,7 +46,7 @@ and pexpr =
| Abstraction of abstr
(* Data constructors *)
| Cst of Types.const
| Cst of pconst
| Pair of pexpr * pexpr
| Xml of pexpr * pexpr
| RecordLitt of pexpr label_map
......@@ -71,10 +76,11 @@ and branches = (ppat * pexpr) list
and ppat = ppat' located
and ppat' =
| PatVar of string
| PatVar of U.t
| SchemaVar of (* type/pattern schema variable *)
schema_item_kind * string * string
| Recurs of ppat * (string * ppat) list
| AtomT of U.t * (U.t option)
| Recurs of ppat * (U.t * ppat) list
| Internal of Types.descr
| Or of ppat * ppat
| And of ppat * ppat
......@@ -85,7 +91,7 @@ and ppat' =
| Optional of ppat
| Record of bool * ppat label_map
| Capture of id
| Constant of id * Types.const
| Constant of id * pconst
| Regexp of regexp * ppat
(* regular expression, continuation: [ re ; cont ], e.g: [ re ; nil ] *)
......@@ -99,14 +105,3 @@ and regexp =
| SeqCapture of id * regexp
open Printf
(*
let rec string_of_regexp = function
| Epsilon -> "e"
| Elem _ -> "ELEM"
| Seq (re1, re2) -> sprintf "(%s),(%s)" (string_of_regexp re1) (string_of_regexp re2)
| Alt (re1, re2) -> sprintf "(%s)|(%s)" (string_of_regexp re1) (string_of_regexp re2)
| Star re -> sprintf "(%s)*" (string_of_regexp re)
| WeakStar _ -> assert false
| SeqCapture _ -> assert false
*)
......@@ -7,6 +7,8 @@ open Printf
let () = Grammar.error_verbose := true
*)
exception Error of string
let error (i,j) s = Location.raise_loc i j (Error s)
let gram = Grammar.gcreate (Wlexer.lexer Wlexer.token Wlexer.latin1_engine)
......@@ -15,10 +17,19 @@ let false_atom = Atoms.mk_ascii "false"
let true_type = Types.atom (Atoms.atom true_atom)
let false_type = Types.atom (Atoms.atom false_atom)
let parse_ident = Encodings.Utf8.mk_latin1
let parse_ident = U.mk_latin1
let id_dummy = ident (U.mk "$$$")
let atom s = Atoms.mk (parse_ident s)
let split_qname s =
try
let i = String.index s ':' in
let ns = String.sub s 0 i in
let s = String.sub s (i + 1) (String.length s - i - 1) in
(parse_ident ns, parse_ident s)
with Not_found ->
(U.mk "", parse_ident s)
let label s = LabelPool.mk (parse_ident s)
let ident s = ident (parse_ident s)
......@@ -48,7 +59,7 @@ let tuple_queue =
let char = mknoloc (Internal (Types.char Chars.any))
let string_regexp = Star (Elem char)
let cst_nil = Cst (Types.Atom Sequence.nil_atom)
let cst_nil = Cst (Const_internal (Types.Atom Sequence.nil_atom))
let seq_of_string s =
let s = Encodings.Utf8.mk s in
......@@ -58,9 +69,6 @@ let seq_of_string s =
in
aux (Encodings.Utf8.start_index s) (Encodings.Utf8.end_index s)
exception Error of string
let error (i,j) s = Location.raise_loc i j (Error s)
let make_record loc r =
LabelMap.from_list (fun _ _ -> error loc "Duplicated record field") r
......@@ -97,19 +105,29 @@ EXTEND
[ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ]
];
uident: [ [ x = UIDENT -> parse_ident x ] ];
phrase: [
[ (f,p,e) = let_binding ->
if f then [ mk loc (FunDecl e) ] else
[ mk loc (LetDecl (p,e)) ]
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
[ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ]
| "type"; x = UIDENT; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
| "type"; x = uident; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
| "type"; x = LIDENT -> error loc "Type identifiers must be capitalized"
| "schema"; name = UIDENT; "="; uri = STRING2 ->
protect_op "schema";
let schema_doc = Schema_xml.pxp_tree_of uri in
let schema = Schema_parser.parse_schema schema_doc in
[ mk loc (SchemaDecl (name, schema))]
| "namespace";
name = [ name = [ UIDENT | LIDENT | keyword ]; "=" ->
parse_ident name
| -> U.mk "" ];
uri = STRING2 ->
let ns = Atoms.Ns.mk (parse_ident uri) in
Atoms.Ns.register_prefix name ns;
[ mk loc (Namespace (name, ns)) ]
| "debug"; d = debug_directive -> [ mk loc (Debug d) ]
| DIRECTIVE "#quit" -> [ mk loc (Directive `Quit) ]
| DIRECTIVE "#env" -> [ mk loc (Directive `Env) ]
......@@ -158,7 +176,7 @@ EXTEND
| "if" | "then" | "else"
| "transform" | "fun" | "in"
| "let" | "type" | "debug" | "include"
| "and" | "validate" | "schema"
| "and" | "validate" | "schema" | "namespace"
]
-> a
]
......@@ -260,10 +278,11 @@ EXTEND
in
exp loc l
| "<"; t = [ "("; e = expr; ")" -> e
| a = [ LIDENT | UIDENT | keyword ] ->
exp loc (Cst (Types.Atom (atom a))) ];
| a = tag -> exp loc (Cst a)
];
a = expr_attrib_spec; ">"; c = expr ->
exp loc (Xml (t, Pair (a,c)))
(* let t = Pair (cst_nil, t) in *)
exp loc (Xml (t, Pair (a,c)))
| "{"; r = [ expr_record_spec | -> exp loc (RecordLitt LabelMap.empty) ]; "}" -> r
| s = STRING2 ->
let s = U.mk s in
......@@ -273,6 +292,19 @@ EXTEND
];
tag: [ [ a = [ LIDENT | UIDENT | keyword ] ->
let (ns,l) = split_qname a in Const_atom (ns,l) ] ];
tag_type: [
[ LIDENT "_" -> mk loc (Internal (Types.atom Atoms.any))
| a = [ LIDENT | UIDENT | keyword ] ->
let (ns,l) = split_qname a in
mk loc (AtomT (ns, Some l))
| t = ANY_IN_NS ->
mk loc (AtomT (parse_ident t, None))
]
];
seq_elem: [
[ x = STRING1 ->
let s = U.mk x in
......@@ -373,7 +405,7 @@ EXTEND
pat: [
[ x = pat; LIDENT "where";
b = LIST1 [ a = UIDENT; "="; y = pat -> (a,y)
b = LIST1 [ a = uident; "="; y = pat -> (a,y)
| LIDENT -> error loc "Type/pattern identifiers must be capitalized"
] SEP "and"
-> mk loc (Recurs (x,b)) ]
......@@ -399,7 +431,7 @@ EXTEND
| _ -> assert false
in
mk loc (SchemaVar (kind, schema, typ))
| a = UIDENT -> mk loc (PatVar a)
| a = uident -> mk loc (PatVar a)
| i = INT ; "--"; j = INT ->
let i = Intervals.mk i
and j = Intervals.mk j in
......@@ -417,18 +449,23 @@ EXTEND
mk loc (Internal (Types.char (Chars.char_class i i)))
| i = char ; "--"; j = char ->
mk loc (Internal (Types.char (Chars.char_class i j)))
| c = const -> mk loc (Internal (Types.constant c))
| "`"; c = tag_type -> c
| c = const ->
(match c with
| Const_atom (ns,l) -> mk loc (AtomT (ns,Some l))
| Const_internal c ->
mk loc (Internal (Types.constant c))
)
| "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
| "["; r = [ r = regexp -> r | -> Epsilon ];
q = [ ";"; q = pat -> q
| -> mknoloc (Internal (Sequence.nil_type)) ];
"]" -> mk loc (Regexp (r,q))
| "<"; t =
[ x = [ LIDENT | UIDENT | keyword ] ->
let a = if x = "_" then Atoms.any else Atoms.atom (atom x) in
mk loc (Internal (Types.atom a))
| "("; t = pat; ")" -> t ];
[ x = tag_type -> x
| "("; t = pat; ")" -> t ];
a = attrib_spec; ">"; c = pat ->
(* let t = mk loc (Prod (mk loc (Internal Sequence.nil_type), t)) in *)
mk loc (XmlT (t, multi_prod loc [a;c]))
| s = STRING2 ->
let s =
......@@ -463,9 +500,9 @@ EXTEND
const:
[
[ i = INT -> Types.Integer (Intervals.mk i)
| "`"; a = [LIDENT | UIDENT | keyword ] -> Types.Atom (atom a)
| c = char -> Types.Char c ]
[ i = INT -> Const_internal (Types.Integer (Intervals.mk i))
| "`"; a = tag -> a
| c = char -> Const_internal (Types.Char c) ]
];
......
This diff is collapsed.
......@@ -83,6 +83,13 @@ rule token = parse
then "UIDENT",s
else if Hashtbl.mem keywords s then "",s else "LIDENT",s
}
| ncname ":*"
{
let s = Lexing.lexeme lexbuf in
let s = String.sub s 0 (String.length s - 2) in
"ANY_IN_NS", s
}
| ".:*" { "ANY_IN_NS", "" }
| '-'? ascii_digit+
{ "INT",Lexing.lexeme lexbuf }
| [ "<>=.,:;+-*/@&{}[]()|?`!" ]
......
......@@ -52,7 +52,7 @@ let attrib att =
LabelMap.from_list (fun _ _ -> assert false) att
let elem tag att child =
Xml (Atom (Atoms.mk (U.mk tag)), Record (attrib att), child)
Xml (Atom (Atoms.mk Atoms.Ns.empty (U.mk tag)), Record (attrib att), child)
(*
class warner = object method warn w = print_endline ("PXP WARNING: " ^ w) end
......
......@@ -180,7 +180,7 @@ and print_xml ppf tag attr content =
print_attr attr
print content
and print_tag ppf = function
| Atom tag -> Utf8.print ppf (Atoms.value tag)
| Atom tag -> Atoms.vprint ppf tag
| tag -> Format.fprintf ppf "(%a)" print tag
and print_attr ppf = function
| Record attr -> print_record ppf (LabelMap.get attr)
......
......@@ -21,3 +21,6 @@ let fun f (x : [ T ]) : [ S ] =
let x = f [ <a>[ <b>[] <b>[] ] ];;
This diff is collapsed.
open Encodings
module Ns : sig
type t
val mk: Utf8.t -> t
val value: t -> Utf8.t
val empty : t
val register_prefix : Utf8.t -> t -> unit
val prefix : t -> Utf8.t
val dump_prefix_table : Format.formatter -> unit
end
type v
val value: v -> Utf8.t
val mk: Utf8.t -> v
val mk: Ns.t -> Utf8.t -> v
val mk_ascii: string -> v
val print_v: Format.formatter -> v -> unit
val vcompare: v -> v -> int
val vhash: v -> int
val vprint: Format.formatter -> v -> unit
type t
......@@ -22,12 +35,12 @@ val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val atom : v -> t
val any_in_ns : Ns.t -> t
val contains : v -> t -> bool
val disjoint : t -> t -> bool
val is_empty : t -> bool
val is_atom : t -> v option
val sample : t -> v
val print_tag : t -> (Format.formatter -> unit) option
type 'a map
......
......@@ -21,7 +21,9 @@ let types =
let () =
List.iter
(fun (n,t) ->
Typer.register_global_types [n, Location.mknoloc (Ast.Internal t)])
Typer.register_global_types
[ Ident.U.mk n,
Location.mknoloc (Ast.Internal t)])
types
(* Operators *)
......@@ -193,7 +195,7 @@ unary_op_cst "atom_of"
string atom
(fun v ->
let (s,_) = Value.get_string_utf8 v in (* TODO: check that s is a correct Name wrt XML *)
Value.Atom (Atoms.mk s));;
Value.Atom (Atoms.mk Atoms.Ns.empty s));;
binary_op_warning2 "dump_to_file"
string string string_latin1 nil
......
......@@ -61,11 +61,14 @@ sig
external get: ('a,'b) map -> ('a elem * 'b) list = "%identity"
val empty: ('a,'b) map
val iter: ('b -> unit) -> ('a,'b) map -> unit
val filter: ('a elem -> 'b -> bool) -> ('a,'b) map -> ('a,'b) map
val is_empty: ('a,'b) map -> bool
val singleton: 'a elem -> 'b -> ('a,'b) map
val assoc_remove: 'a elem -> ('a,'b) map -> 'b * ('a,'b) map
val remove: 'a elem -> ('a,'b) map -> ('a,'b) map
val merge: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val cap: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val sub: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val merge_elem: 'b -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val union_disj: ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val diff: ('a,'b) map -> 'a t -> ('a,'b) map
......@@ -246,6 +249,10 @@ module Map = struct
| (_,y)::l -> f y; iter f l
| [] -> ()
let rec filter f = function
| ((x,y) as c)::l -> if f x y then c::(filter f l) else filter f l
| [] -> []
let rec assoc_remove_aux v r = function
| ((x,y) as a)::l ->
let c = X.compare x v in
......@@ -279,6 +286,24 @@ module Map = struct
| ([],l2) -> l2
| (l1,[]) -> l1
let rec cap f l1 l2 =
match (l1,l2) with
| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
let c = X.compare x1 x2 in
if c = 0 then (x1,(f y1 y2))::(cap f q1 q2)
else if c < 0 then cap f q1 l2
else cap f l1 q2
| _ -> []
let rec sub f l1 l2 =
match (l1,l2) with
| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
let c = X.compare x1 x2 in
if c = 0 then (x1,(f y1 y2))::(sub f q1 q2)
else if c < 0 then t1::(sub f q1 l2)
else sub f l1 q2
| (l1,_) -> l1
let merge_elem x l1 l2 = merge (fun _ _ -> x) l1 l2
(* TODO: optimize this ? *)
......
......@@ -54,11 +54,15 @@ sig
external get: ('a,'b) map -> ('a elem * 'b) list = "%identity"
val empty: ('a,'b) map
val iter: ('b -> unit) -> ('a,'b) map -> unit
val filter: ('a elem -> 'b -> bool) -> ('a,'b) map -> ('a,'b) map
val is_empty: ('a,'b) map -> bool
val singleton: 'a elem -> 'b -> ('a,'b) map
val assoc_remove: 'a elem -> ('a,'b) map -> 'b * ('a,'b) map
val remove: 'a elem -> ('a,'b) map -> ('a,'b) map
val merge: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val cap: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val sub: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val merge_elem: 'b -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val union_disj: ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val diff: ('a,'b) map -> 'a t -> ('a,'b) map
......
This diff is collapsed.
......@@ -217,7 +217,7 @@ val subtype : descr -> descr -> bool
module Print :
sig
val register_global : string -> descr -> unit
val register_global : U.t -> descr -> unit
val print_const : Format.formatter -> const -> unit
val print: Format.formatter -> descr -> unit
end
......
This diff is collapsed.
......@@ -10,16 +10,18 @@ exception Error of string
val warning: Location.loc -> string -> unit
val error: Location.loc -> string -> 'a
type env = Types.descr Env.t
val register_global_types : (string * Ast.ppat) list -> unit
val register_global_types : (U.t * Ast.ppat) list -> unit
val dump_global_types: Format.formatter -> unit
val register_ns_prefix : U.t -> Atoms.Ns.t -> unit
val typ : Ast.ppat -> Typed.ttyp
val pat : Ast.ppat -> Typed.tpat
val expr: Ast.pexpr -> fv * Typed.texpr
val let_decl : Ast.ppat -> Ast.pexpr -> Typed.let_decl
type env = Types.descr Env.t
val type_check:
env -> Typed.texpr -> Types.descr -> bool -> Types.descr
(* [type_check env e t precise] checks that expression [e]
......
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