Commit bbcdbaaa authored by Pietro Abate's avatar Pietro Abate

[r2005-03-03 23:47:00 by afrisch] Identifiers are now qualified names. Uniform...

[r2005-03-03 23:47:00 by afrisch] Identifiers are now qualified names. Uniform dot syntax for external
CDuce and OCaml unit

Original author: afrisch
Date: 2005-03-03 23:47:02+00:00
parent a7f76a2c
......@@ -13,7 +13,9 @@ let global_size env = env.global_size
let dump ppf env =
Env.iter
(fun id loc ->
Format.fprintf ppf "Var %a : %a@\n" U.print (Id.value id) Lambda.print_var_loc loc)
Format.fprintf ppf "Var %a : %a@\n"
Ident.print id
Lambda.print_var_loc loc)
env.vars
......@@ -257,8 +259,8 @@ let rec collect_funs accu = function
| rest -> (accu,rest)
let rec collect_types accu = function
| { descr = Ast.TypeDecl (x,t) } :: rest ->
collect_types ((x,t) :: accu) rest
| { descr = Ast.TypeDecl ((loc,x),t) } :: rest ->
collect_types ((loc,x,t) :: accu) rest
| rest -> (accu,rest)
let rec phrases ~run ~show ~loading ~directive =
......
......@@ -51,7 +51,7 @@ let print_value ppf v =
let dump_value ppf x t v =
Format.fprintf ppf "@[val %a : @[%a = %a@]@]@."
U.print (Id.value x) print_norm t print_value v
Ident.print x print_norm t print_value v
let dump_env ppf tenv cenv =
Format.fprintf ppf "Types:%a@." Typer.dump_types tenv;
......@@ -116,12 +116,12 @@ let rec print_exn ppf = function
print_norm t;
Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t)
| Typer.UnboundId (x,tn) ->
Format.fprintf ppf "Unbound identifier %a%s@." U.print (Id.value x)
Format.fprintf ppf "Unbound identifier %a%s@." Ident.print x
(if tn then " (it is a type name)" else "")
| Typer.UnboundExtId (cu,x) ->
Format.fprintf ppf "Unbound external identifier %a:%a@."
U.print (Types.CompUnit.value cu)
U.print (Id.value x)
Ident.print x
| Ulexer.Error (i,j,s) ->
let loc = Location.loc_of_pos (i,j), `Full in
Format.fprintf ppf "Error %a:@." Location.print_loc loc;
......@@ -188,7 +188,8 @@ let debug ppf tenv cenv = function
Patterns.Print.print (Patterns.descr p);
let f = Patterns.filter (Types.descr t) p in
IdMap.iteri (fun x t ->
Format.fprintf ppf " %a:%a@." U.print (Id.value x)
Format.fprintf ppf " %a:%a@."
Ident.print x
print_norm (Types.descr t)) f
| `Accept p ->
Format.fprintf ppf "[DEBUG:accept]@.";
......@@ -272,7 +273,7 @@ let directive ppf tenv cenv = function
let print_id_opt ppf = function
| None -> Format.fprintf ppf "-"
| Some id -> Format.fprintf ppf "val %a" U.print (Id.value id)
| Some id -> Format.fprintf ppf "val %a" Ident.print id
let print_value_opt ppf = function
| None -> ()
......
......@@ -17,5 +17,5 @@ val run: string -> unit
val print_exn: Format.formatter -> exn -> unit
val eval: string -> (Encodings.Utf8.t option * Value.t) list
val eval: string -> (Ns.qname option * Value.t) list
(* Can be used from CDuce units *)
......@@ -141,7 +141,7 @@ let show ppf id t v =
match id with
| Some id ->
Format.fprintf ppf "@[val %a : @[%a@]@."
U.print (Id.value id)
Ident.print id
Types.Print.print t
| None -> ()
......@@ -164,7 +164,6 @@ let rec compile verbose name id src =
raise_loc i.Lexing.pos_cnum j.Lexing.pos_cnum e
in
if src <> "" then close_in ic;
let argv = ident (U.mk "argv") in
during_compile := true;
C.enter id;
let show =
......
......@@ -439,7 +439,7 @@ let exts = ref []
let check_value ty_env c_env (s,caml_t,t) =
(* Find the type for the value in the CDuce module *)
let id = Id.mk (U.mk s) in
let id = Id.mk (Ns.empty, U.mk s) in
let vt =
try Typer.find_value id ty_env
with Not_found ->
......
......@@ -7,7 +7,7 @@ type pprog = pmodule_item list
and pmodule_item = pmodule_item' located
and pmodule_item' =
| TypeDecl of id * ppat
| TypeDecl of (Location.loc * U.t) * ppat
| SchemaDecl of U.t * string * U.t option (* name, uri, ns prefix *)
| LetDecl of ppat * pexpr
| FunDecl of pexpr
......@@ -74,7 +74,6 @@ and pexpr =
| NamespaceIn of U.t * Ns.t * pexpr
| Forget of pexpr * ppat
| Check of pexpr * ppat
(* | Op of string * pexpr list *)
| Ref of pexpr * ppat
| External of string * ppat list
......@@ -83,7 +82,7 @@ and pexpr =
and label = U.t
and abstr = {
fun_name : id option;
fun_name : (Location.loc * U.t) option;
fun_iface : (ppat * ppat) list;
fun_body : branches
}
......@@ -94,12 +93,12 @@ and branches = (ppat * pexpr) list
and ppat = ppat' located
and ppat' =
| PatVar of U.t
| PatVar of (U.t option) * U.t (* optional compilation unit *)
| SchemaVar of (* type/pattern schema variable *)
Schema_types.component_kind * U.t * U.t (* kind, schema, name *)
| Cst of pexpr
| NsT of U.t
| Recurs of ppat * (id * ppat) list
| Recurs of ppat * (Location.loc * U.t * ppat) list
| Internal of Types.descr
| Or of ppat * ppat
| And of ppat * ppat
......@@ -109,7 +108,7 @@ and ppat' =
| Arrow of ppat * ppat
| Optional of ppat
| Record of bool * (label * (ppat * ppat option)) list
| Constant of id * pexpr
| Constant of U.t * pexpr
| Regexp of regexp
and regexp =
......@@ -120,7 +119,7 @@ and regexp =
| Alt of regexp * regexp
| Star of regexp
| WeakStar of regexp
| SeqCapture of id * regexp
| SeqCapture of Location.loc * U.t * regexp
let pat_true = mknoloc (Internal Builtin_defs.true_type)
......
......@@ -23,10 +23,21 @@ let gram = Grammar.gcreate Ulexer.lex
let parse_ident = U.mk
let id_dummy = ident (U.mk "$$$")
let id_dummy = U.mk "$$$"
let ident s =
let b = Buffer.create (String.length s) in
let rec aux i =
if (i = String.length s) then Buffer.contents b
else match s.[i] with
| '\\' -> assert (s.[i+1] = '.'); Buffer.add_char b '.'; aux (i+2)
| c -> Buffer.add_char b c; aux (i+1)
in
aux 0
let label = parse_ident
let ident s = ident (parse_ident s)
let label s = U.mk (ident s)
(*let ident s = ident (parse_ident s)*)
let ident s = U.mk (ident s)
let prog = Grammar.Entry.create gram "prog"
let top_phrases = Grammar.Entry.create gram "toplevel phrases"
......@@ -35,7 +46,8 @@ let pat = Grammar.Entry.create gram "type/pattern expression"
let regexp = Grammar.Entry.create gram "type/pattern regexp"
let keyword = Grammar.Entry.create gram "keyword"
let exp pos e = LocatedExpr (loc_of_pos (tloc pos),e)
let lop pos = loc_of_pos (tloc pos)
let exp pos e = LocatedExpr (lop pos,e)
let rec multi_prod loc = function
| [ x ] -> x
......@@ -90,6 +102,15 @@ let is_fun_decl =
| _ -> raise Stream.Failure
)
let is_capture =
Grammar.Entry.of_parser gram "[is_capture]"
(fun strm ->
match Stream.npeek 2 strm with
| [ ("IDENT", _) ; ("", "::") ; _ ] -> ()
| _ -> raise Stream.Failure
)
let if_then_else cond e1 e2 = Match (cond, [pat_true,e1; pat_false,e2])
let logical_and e1 e2 = if_then_else e1 e2 cst_false
......@@ -117,7 +138,7 @@ EXTEND
[ 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 = IDENT; "="; t = pat -> [ mk loc (TypeDecl (ident x,t)) ]
| "type"; x = located_ident; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
| "using"; name = IDENT; "="; cu = [ IDENT | STRING2 ] ->
[ mk loc (Using (U.mk name, U.mk cu)) ]
| "schema"; name = IDENT;
......@@ -131,20 +152,20 @@ EXTEND
let e = exp loc (NamespaceIn (name, ns, e2)) in
[ mk loc (EvalStatement (exp loc e)) ]
| "debug"; d = debug_directive -> [ mk loc (Directive (`Debug d)) ]
| DIRECTIVE "#verbose" -> [ mk loc (Directive `Verbose) ]
| DIRECTIVE "#silent" -> [ mk loc (Directive `Silent) ]
| DIRECTIVE "#utf8" -> Ulexer.enc := Ulexing.Utf8; [ ]
| DIRECTIVE "#latin1" -> Ulexer.enc := Ulexing.Latin1; [ ]
| DIRECTIVE "#ascii" -> Ulexer.enc := Ulexing.Ascii; [ ]
| DIRECTIVE "#quit" -> [ mk loc (Directive `Quit) ]
| DIRECTIVE "#env" -> [ mk loc (Directive `Env) ]
| DIRECTIVE "#print_schema"; name = IDENT ->
| "#"; IDENT "verbose" -> [ mk loc (Directive `Verbose) ]
| "#"; IDENT "silent" -> [ mk loc (Directive `Silent) ]
| "#"; IDENT "utf8" -> Ulexer.enc := Ulexing.Utf8; [ ]
| "#"; IDENT "latin1" -> Ulexer.enc := Ulexing.Latin1; [ ]
| "#"; IDENT "ascii" -> Ulexer.enc := Ulexing.Ascii; [ ]
| "#"; IDENT "quit" -> [ mk loc (Directive `Quit) ]
| "#"; IDENT "env" -> [ mk loc (Directive `Env) ]
| "#"; IDENT "print_schema"; name = IDENT ->
[ mk loc (Directive (`Print_schema (U.mk name))) ]
| DIRECTIVE "#print_type"; t = pat ->
| "#"; IDENT "print_type"; t = pat ->
[ mk loc (Directive (`Print_type t)) ]
| DIRECTIVE "#dump_value"; e = expr -> [ mk loc (Directive (`Dump e)) ]
| DIRECTIVE "#reinit_ns" -> [ mk loc (Directive `Reinit_ns) ]
| DIRECTIVE "#help" -> [ mk loc (Directive `Help) ]
| "#"; IDENT "dump_value"; e = expr -> [ mk loc (Directive (`Dump e)) ]
| "#"; IDENT "reinit_ns" -> [ mk loc (Directive `Reinit_ns) ]
| "#"; IDENT "help" -> [ mk loc (Directive `Help) ]
| "include"; s = STRING2 ->
let s =
if Filename.is_relative s
......@@ -265,10 +286,10 @@ EXTEND
let tag = mk loc (Internal (Types.atom (Atoms.any))) in
let att = mk loc (Internal Types.Record.any) in
let any = mk loc (Internal (Types.any)) in
let re = Star(Alt(SeqCapture(id_dummy,Elem p), Elem any)) in
let re = Star(Alt(SeqCapture(noloc,id_dummy,Elem p), Elem any)) in
let ct = mk loc (Regexp re) in
let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
let b = (p, Var (Id.value id_dummy)) in
let b = (p, Var id_dummy) in
exp loc (Transform (e,[b]))
]
|
......@@ -350,7 +371,7 @@ EXTEND
let_binding: [
[ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
let f = match f with Some x -> x | None -> assert false in
let p = mk loc (PatVar (Id.value f)) in
let p = mk loc (PatVar (None, snd f)) in
let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
let e = exp loc (Abstraction abst) in
(true,p,e)
......@@ -406,8 +427,7 @@ EXTEND
fun_decl: [
[ f = OPT IDENT; "("; (a,b) = fun_decl_after_lparen ->
let f = match f with Some x -> Some (ident x) | None -> None in
[ f = OPT located_ident; "("; (a,b) = fun_decl_after_lparen ->
(f,a,b)
]
];
......@@ -437,7 +457,7 @@ EXTEND
| Elem x, Elem y -> Elem (mk loc (And (x,y)))
| _ -> error loc "Conjunction not allowed in regular expression"
]
| [ a = IDENT; "::"; x = regexp -> SeqCapture (ident a,x) ]
| [ a = IDENT; "::"; x = regexp -> SeqCapture (lop loc,ident a,x) ]
| [ x = regexp; "*" -> Star x
| x = regexp; "*?" -> WeakStar x
| x = regexp; "+" -> Seq (x, Star x)
......@@ -508,9 +528,12 @@ EXTEND
]
];
located_ident: [ [ a = IDENT -> (lop loc,ident a) ] ];
pat: [
[ x = pat; "where";
b = LIST1 [ a = IDENT; "="; y = pat -> (ident a,y) ] SEP "and"
b = LIST1 [ (la,a) = located_ident; "="; y = pat ->
(la,a,y) ] SEP "and"
-> mk loc (Recurs (x,b)) ]
| RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]
| "no_arrow" [ x = pat; "|"; y = pat -> mk loc (Or (x,y)) ]
......@@ -533,8 +556,10 @@ EXTEND
mk loc (SchemaVar (kind, U.mk schema, U.mk typ))
| "!"; a = IDENT ->
mk loc (Internal (Types.abstract (Types.Abstract.atom a)))
| a = IDENT ->
mk loc (PatVar (U.mk a))
(* | a = IDENT ->
mk loc (PatVar (None, U.mk a)) *)
| cu = OPT [ cu = IDENT; "." -> U.mk cu ]; a = IDENT ->
mk loc (PatVar (cu, U.mk a))
| i = INT ; "--"; j = INT ->
let i = Intervals.V.mk i
and j = Intervals.V.mk j in
......@@ -595,7 +620,7 @@ EXTEND
[ [ r = LIST0 [ l = [IDENT | keyword ]; f = opt_field_pat ->
let (o,x,y) =
match f with
| None -> (false, mknoloc (PatVar (U.mk l)), None)
| None -> (false, mknoloc (PatVar (None,U.mk l)), None)
| Some z -> z
in
let x = if o then mk loc (Optional x) else x in
......@@ -614,7 +639,7 @@ EXTEND
[ [ r = LIST0 [ l = [IDENT | keyword ]; f = opt_field_pat; OPT ";" ->
let (o,x,y) =
match f with
| None -> (false, mknoloc (PatVar (U.mk l)), None)
| None -> (false, mknoloc (PatVar (None,U.mk l)), None)
| Some z -> z
in
let x = if o then mk loc (Optional x) else x in
......
......@@ -44,7 +44,7 @@ let parse_char lexbuf base i =
let regexp ncname_char =
xml_letter | xml_digit | [ '.' '-' '_' ] | xml_combining_char | xml_extender
xml_letter | xml_digit | [ '-' '_' ] | xml_combining_char | xml_extender | "\\."
let regexp ncname = (xml_letter | '_' ) ncname_char*
let regexp qname = (ncname ':')? ncname
......@@ -77,8 +77,6 @@ let rec token = lexer
| "{|" | "|}" | "<=" | ">=" | "<<" | ">>" | "||" | "&&" | "**"
| ["?+*"] "?" | "#" ->
return lexbuf ("", L.utf8_lexeme lexbuf)
| "#" ncname ->
return lexbuf ("DIRECTIVE", L.utf8_lexeme lexbuf)
| '"' | "'" ->
let start = L.lexeme_start lexbuf in
let double_quote = L.latin1_lexeme_char lexbuf 0 = '"' in
......
......@@ -50,7 +50,7 @@ let rec string_of_ppat p =
match rg with
|Elem(e) -> string_of_ppat e
|Guard(e) -> "/" ^ (string_of_ppat e)
|SeqCapture(id,rg) -> U.get_str (Id.value id) ^"::"^ string_of_regexp rg
|SeqCapture(_,id,rg) -> U.get_str id ^"::"^ string_of_regexp rg
|Seq(r1,r2) -> string_of_regexp r1 ^ " "^string_of_regexp r2
|Alt(r1,r2) -> " ("^string_of_regexp r1 ^"|"^ string_of_regexp r2^")"
|Star r1 -> string_of_regexp r1^"* "
......@@ -59,7 +59,7 @@ let rec string_of_ppat p =
in match p with
{loc = loc ; descr = descr }
-> ( match descr with
|PatVar(id) -> U.get_str ( id)
|PatVar(_,id) -> U.get_str ( id)
|Cst(Atom a) -> U.get_str a
|Internal(descr) ->
if descr=Builtin_defs.true_type then "`true"
......@@ -82,7 +82,7 @@ mais pas prioritaire [] -> ""
|(s,ppat)::r -> " "^(U.get_str
((LabelPool.value s)))^"="^string_of_ppat(ppat)^listing r
)in listing (lm) *)
|Constant(i,t) -> U.get_str (Id.value i)
|Constant(i,t) -> U.get_str i
|Regexp(rg) -> "["^string_of_regexp rg ^ "]"
| _ ->"?"
)
......@@ -92,7 +92,7 @@ let rec var_of_ppat x =
match rg with
|Elem(e) -> []
|Guard(e) -> []
|SeqCapture(id,rg) -> [id] @ var_of_rg rg
|SeqCapture(_,id,rg) -> [ident (Ns.empty,id)] @ var_of_rg rg
|Seq(r1,r2) -> var_of_rg r1 @ var_of_rg r2
|Alt(r1,r2) -> var_of_rg r1 @ var_of_rg r2
|Star r1 -> var_of_rg r1
......@@ -102,7 +102,8 @@ let rec var_of_ppat x =
in match x with
{loc = loc ; descr = descr }
-> ( match descr with
|PatVar(id) -> [ident id]
|PatVar(None,id) -> [ident (Ns.empty,id)]
|PatVar(Some _,_) -> []
|Internal(descr) -> []
|Or(p1,p2) -> var_of_ppat p1 @ var_of_ppat p2
|And(p1,p2) -> var_of_ppat p1 @ var_of_ppat p2
......@@ -119,7 +120,7 @@ let rec var_of_ppat x =
| Some ppat -> var_of_ppat ppat @ accu
in
List.fold_left aux [] lm
|Constant(i,t) -> [i]
|Constant(i,t) -> [ident (Ns.empty,i)]
|Regexp(rg) -> var_of_rg rg
|_ ->[]
)
......@@ -160,7 +161,7 @@ let rec string_of_pexpr x =
let rec var_of_pexpr x =
match x with
LocatedExpr(_,x) -> var_of_pexpr x
|Var(s) -> [ident s]
|Var(s) -> [ident (Ns.empty,s)]
|Pair(e1,e2) -> var_of_pexpr e1 @ var_of_pexpr e2
|Apply(e1,e2) -> var_of_pexpr e1 @ var_of_pexpr e2
|Transform(e,_) -> var_of_pexpr e
......@@ -172,7 +173,7 @@ match x with
let rec aff_var l =
match l with
[] -> ""
| s::r -> U.get_str ( Id.value s) ^" "^ aff_var r
| s::r -> Ident.to_string s ^" "^ aff_var r
(*************************************************
**************************************************
......
......@@ -16,7 +16,7 @@ let exp pos e = LocatedExpr (loc_of_pos (tloc pos),e)
let cst_nil = Const Sequence.nil_cst
let parse_ident = U.mk
let id_dummy = ident (U.mk "$$$")
let id_dummy = U.mk "$$$"
let label = parse_ident
......@@ -56,21 +56,21 @@ EXTEND
let tag = mk loc (Internal(Types.atom Atoms.any)) in
let any = mk loc (Internal(Types.any)) in
let att = mk loc (Record(true,[(label a,
(mk loc (PatVar(U.mk "$$$")),None))]))in
(mk loc (PatVar(None,U.mk "$$$")),None))]))in
(*let ct= mk loc (Regexp(Elem any , any)) in *)
let p = mk loc(XmlT (tag,multi_prod loc[att;any])) in
let t =(p, Pair(Var (Id.value id_dummy),cst_nil))
let t =(p, Pair(Var id_dummy,cst_nil))
in exp loc (Transform (e,[t]))
| e = expr; "//" ; p = pat -> (* projections sur tous les descendants *)
let assign=
exp loc ( Apply (Dot (Var(U.mk"$stack"), U.mk"set"),
(op2 "@" (Apply(Dot(Var(U.mk"$stack"),U.mk"get"),cst_nil)) (Pair(Var(U.mk"$$$"),cst_nil)))))
in let branche=Pair(Var (Id.value id_dummy),cst_nil)
in let branche=Pair(Var id_dummy,cst_nil)
in let branches= exp loc (Match(assign,[pat_nil,branche]))
in let xt=exp loc (Xtrans (e,[(mk loc(And(mk loc(PatVar(U.mk "$$$")),p))),branches]))
in let xt=exp loc (Xtrans (e,[(mk loc(And(mk loc(PatVar(None,U.mk "$$$")),p))),branches]))
in let rf=exp loc(Ref(cst_nil,mk loc (Regexp
(Star(Elem p)))))
in exp loc(Match(rf,[mk loc(PatVar(U.mk"$stack")),
in exp loc(Match(rf,[mk loc(PatVar(None,U.mk"$stack")),
exp loc(Match(xt,
[mk loc(Internal Types.any),
exp loc (Apply(Dot(Var(U.mk"$stack"),U.mk"get"),cst_nil))]))
......
- substitution groups
- don't name schema, use namespaces
- detect ill-formed recursion (e.g. between attribute groups)
\ No newline at end of file
- detect ill-formed recursion (e.g. between attribute groups)
- redefine
\ No newline at end of file
......@@ -25,8 +25,8 @@ let types =
let env =
List.fold_left
(fun accu (n,t) ->
let n = Ident.U.mk n in
Types.Print.register_global n t;
let n = (Ns.empty, Ident.U.mk n) in
Types.Print.register_global Types.CompUnit.pervasives n t;
Typer.enter_type (Ident.ident n) t accu
)
Typer.empty_env
......
module U = Encodings.Utf8
module Id = Pool.Weak(U)
module Id = Pool.Weak(Ns.QName)
type id = Id.t
let ident = Id.mk
let to_string id = U.to_string (Id.value id)
let print ppf id = Format.fprintf ppf "%s" (to_string id)
let value = Id.value
let to_string id = Ns.QName.to_string (Id.value id)
let print ppf id = Ns.QName.print ppf (Id.value id)
module IdSet = SortedList.Make(Id)
module IdMap = IdSet.Map
......
......@@ -59,9 +59,9 @@ let rec print ppf (a,_,d) =
Format.fprintf ppf "{ %a = P%i }" Label.print (LabelPool.value l) n.id;
to_print := n :: !to_print
| Capture x ->
Format.fprintf ppf "%a" U.print (Id.value x)
Format.fprintf ppf "%a" Ident.print x
| Constant (x,c) ->
Format.fprintf ppf "(%a := %a)" U.print (Id.value x)
Format.fprintf ppf "(%a := %a)" Ident.print x
Types.Print.print_const c
| Dummy ->
Format.fprintf ppf "*DUMMY*"
......@@ -113,7 +113,7 @@ let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) =
in
raise
(Error
("The capture variable " ^ (U.to_string (Id.value x)) ^
("The capture variable " ^ (Ident.to_string x) ^
" should appear on both side of this | pattern"))
);
(Types.cup acc1 acc2, IdSet.cup fv1 fv2, Cup (x1,x2))
......@@ -123,7 +123,7 @@ let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) =
| Some x ->
raise
(Error
("The capture variable " ^ (U.to_string (Id.value x)) ^
("The capture variable " ^ (Ident.to_string x) ^
" cannot appear on both side of this & pattern"))
| None -> assert false
);
......@@ -1679,10 +1679,9 @@ module Compile2 = struct
let print ppf r =
Format.fprintf ppf "{ ";
List.iter (fun (x,s) ->
Format.fprintf ppf "%a:=%a "
U.print (Id.value x)
print_src s) (IdMap.get r);
List.iter
(fun (x,s) -> Format.fprintf ppf "%a:=%a " Ident.print x print_src s)
(IdMap.get r);
Format.fprintf ppf "}";
end
......
......@@ -40,6 +40,7 @@ module Make(X : Custom.T) = struct
let singleton x = [ x ]
let pick = function x::_ -> Some x | _ -> None
let choose = function x::_ -> x | _ -> raise Not_found
let length = List.length
let empty = []
......
......@@ -11,6 +11,7 @@ sig
val exists: (X.t -> bool) -> t -> bool
val fold: ('a -> X.t -> 'a) -> 'a -> t -> 'a
val pick: t -> X.t option
val choose: t -> X.t
val length: t -> int
val empty: t
......
......@@ -19,9 +19,16 @@ let compare = 1
module CompUnit = struct
include Pool.Make(Utf8)
module Tbl = Inttbl
let pervasives = mk (U.mk "Pervasives")
let current = ref dummy_min
let get_current () =
assert (!current != dummy_min);
!current
let print_qual ppf t =
if (t != !current) && (t != pervasives) then
Format.fprintf ppf "%a." U.print (value t)
let close_serialize_ref = ref (fun () -> assert false)
......@@ -1339,11 +1346,16 @@ struct
let is_regexp t = subtype t seqs_descr
type gname = CompUnit.t * Ns.qname
type nd = { id : int;
mutable def : d list;
mutable state : [ `Expand | `None | `Marked | `Named of U.t ] }
mutable state :
[ `Expand | `None | `Marked
| `GlobalName of gname
| `Named of U.t ] }
and d =
| Name of U.t
| Name of gname
| Regexp of nd Pretty.regexp
| Atomic of (Format.formatter -> unit)
| Pair of nd * nd
......@@ -1367,17 +1379,17 @@ struct
let named = State.ref "Types.Print.named" DescrMap.empty
let named_xml = State.ref "Types.Print.named_xml" DescrPairMap.empty
let register_global (name : U.t) d =
let register_global cu (name : Ns.qname) d =
if equal { d with hash = 0; xml = BoolPair.empty } empty then
(let l = (*Product.merge_same_2*) (Product.get ~kind:`XML d) in
match l with
| [(t1,t2)] ->
if DescrPairMap.mem (t1,t2) !named_xml then ()
else
named_xml := DescrPairMap.add (t1,t2) name !named_xml
named_xml := DescrPairMap.add (t1,t2) (cu,name) !named_xml
| _ -> ());
if DescrMap.mem d !named then ()
else named := DescrMap.add d name !named
else named := DescrMap.add d (cu,name) !named
let unregister_global d =
if equal { d with hash = 0; xml = BoolPair.empty } empty then
......@@ -1429,7 +1441,7 @@ struct
try
let n = DescrMap.find d !named in
let s = alloc [] in
s.state <- `Named n;
s.state <- `GlobalName n;
DescrHash.add memo d s;
s