You signed in with another tab or window. Reload to refresh your session.You signed out in another tab or window. Reload to refresh your session.You switched accounts on another tab or window. Reload to refresh your session.Dismiss alert
Original bug ID: 3856 Reporter: administrator Status: closed (set by @garrigue on 2005-12-08T02:12:17Z) Resolution: fixed Priority: normal Severity: minor Category: ~DO NOT USE (was: OCaml general) Monitored by: alexbaretta "Boris Yakokobowski"
Bug description
Full_Name: Alessandro Baretta
Version: 3.09.0
OS: Linux alex.barettadeit.com 2.6.14.ipw2200 #0 PREEMPT Tue Nov 1 13:29:36 CET 2005 i686 GNU/Linux
Submission from: h213-255-109-130.albacom.net (213.255.109.130)
It would have been easier to submit the bug report via caml-bugs@caml.inria.fr,
but this address seems to have been deactivated. I'll submit it with the web
interface. Hopefully, it will not be too hard to manually decipher the MIME
encoded attachments.
I'm working in a findlib-managed installation with patched versions of Ocamlnet
1.1 and PXP 1.1.95. I'm submitting a full test case containing the actual
script, a script packaging in a single file the various modules referenced by
the test case script, and the patches which I have applied to ocamlnet and
pxp-1.1.95. The following is quoted from the shell session I use to run the test
case.
alex@alex:~/meldolo_totale_2005$ ocaml -rectypes test_case_309_try_1.ml
Fatal error: exception Assert_failure("typing/typeclass.ml", 1348, 18)
(Program not linked with -g, cannot print stack backtrace)
The assertion-failure is caused by obvious syntax error at line 41 which
apparently the parser does not report. The error appears both in the native
ocamlyacc syntax and with the camlp4o preprocessor enabled.
Copyright by Gerd Stolpmann. See LICENSE for details.
*)
+(* Portions of this code are contributions made to Ocamlnet by Alex Baretta.
Copyright is held by Baretta SRL DE&IT. Such code is released under the
terms of the LICENSE convering the whole of Ocamlnet.
*)
open Pxp_types
open Pxp_lexers
open Pxp_lexer_types
@@ -23,6 +28,13 @@
method find : string -> 'ext node
end
+(* reverse_index is a contribution to Ocamlnet made by Baretta SRL DE&IT *)
+class type [ 'ext ] reverse_index =
+object
inherit [ 'ext ] index
method ref_add : string -> 'ext node -> unit
method ref_find : string -> 'ext node list
+end
class [ 'ext ] hash_index =
object
@@ -40,6 +52,25 @@
method index = ht
end
+(* reverse_hash_index is a contribution to Ocamlnet made by Baretta SRL DE&IT
*)
+class [ 'ext ] reverse_hash_index =
+object (self : 'ext #reverse_index )
inherit [ 'ext ] hash_index
val ref_ht = (Hashtbl.create 100 : (string, 'ext node) Hashtbl.t)
method ref_add id referring_node = Hashtbl.add ref_ht id referring_node
method ref_find id = Hashtbl.find_all ref_ht id
method ref_index = ref_ht
+end
+(* fake_reverse_hash_index is a contribution to Ocamlnet made by Baretta SRL
DE&IT *)
+class [ 'ext ] fake_reverse_index (index : 'ext #index) =
+object (self : 'ext #reverse_index )
(* DELEGATION WANTED, DEAD OR ALIVE! *)
method add = index # add
method find = index # find
method ref_add id referring_node = ()
method ref_find id = []
+end
class default_ext =
object(self : 'self)
@@ -93,7 +124,7 @@
val transform_dtd = transform_dtd
(* A function transforming the DTD *)
val id_index = (id_index : 'ext index option)
val id_index = (id_index : 'ext reverse_index option)
(* The ID index or None *)
val doc = init_doc
@@ -513,14 +544,14 @@
(fun att ->
match t # attribute att with
Value s ->
begin try ignore(id_index # find s) with
begin try ignore(id_index # find s); id_index # ref_add s t with
Not_found ->
error t att s
end
| Valuelist l ->
List.iter
(fun s ->
try ignore(id_index # find s) with
try ignore(id_index # find s); id_index # ref_add s t with
Not_found ->
error t att s
)
in
let mgr = new entity_manager en dtd in
let gen_att_events = cfg.escape_attributes <> None in
@@ -637,6 +668,7 @@
dtd # validate; (* ensure that the DTD is valid *)
if cfg.accept_only_deterministic_models then dtd #
only_deterministic_models;
let doc = new document ?swarner:cfg.swarner cfg.warner cfg.encoding in
let idx = match id_index with None -> None | Some idx' -> Some(new
fake_reverse_index idx') in
let pobj =
call_tree_parser
~configuration:cfg
@@ -645,7 +677,32 @@
~document:doc
~specification:spec
~transform_dtd:(fun x -> x) (* Do not transform the DTD *)
~id_index:(id_index :> 'ext index option)
~id_index:(idx :> 'ext reverse_index option)
~use_document_entity:false
~entry:(`Entry_content []) (* Entry point of the grammar *)
~init_lexer:Content (* The initially used lexer *)
dtd # validate; (* ensure that the DTD is valid *)
if cfg.accept_only_deterministic_models then dtd #
only_deterministic_models;
let doc = new document ?swarner:cfg.swarner cfg.warner cfg.encoding in
let idx = Some id_index in
let pobj =
call_tree_parser
~configuration:cfg
~source:src
~dtd:dtd
~document:doc
~specification:spec
~transform_dtd:(fun x -> x) (* Do not transform the DTD *)
~id_index:(idx :> 'ext reverse_index option)
~use_document_entity:false
~entry:(`Entry_content []) (* Entry point of the grammar *)
~init_lexer:Content (* The initially used lexer *)
~id_index:(id_index :> 'ext reverse_index option)
~use_document_entity:true
~entry:(`Entry_document entry_flags) (* Entry point of the grammar *)
~init_lexer:Document (* The initially used lexer *)
@@ -734,10 +791,19 @@
let parse_document_entity ?(transform_dtd = (fun x -> x))
?id_index
cfg src spec =
let idx = match id_index with None -> None | Some idx' -> Some(new
fake_reverse_index idx') in
Copyright by Gerd Stolpmann. See LICENSE for details.
*)
+(* Portions of this code are contributions made to Ocamlnet by Alex Baretta.
Copyright is held by Baretta SRL DE&IT. Such code is released under the
terms of the LICENSE convering the whole of Ocamlnet.
*)
open Pxp_types
open Pxp_dtd
open Pxp_document
@@ -18,6 +23,10 @@
*)
constraint 'ext = 'ext node #extension
method add : string -> 'ext node -> unit
(* index # add id referenced_node
* This method allows idref_pass to incrementally build the function
* mapping ID to the ID-defining nodes.
*)
(* Add the passed node to the index. If there is already an ID with
* the passed string value, the exception ID_not_unique should be
* raised. (But the index is free also to accept several identical IDs.)
@@ -26,7 +35,22 @@
(* Finds the node with the passed ID value, or raises Not_found *)
end
+(* reverse_index is a contribution to Ocamlnet made by Baretta SRL DE&IT *)
+class type [ 'ext ] reverse_index =
+object
inherit [ 'ext ] index
method ref_add : string -> 'ext node -> unit
(* index # ref_add idref referring_node
* This method allows the idref_pass to incrementally build the inverse
* relation of the function mapping IDs to the ID-defining nodes. This
* function is useful to find all nodes referring to a given ID.
*)
method ref_find : string -> 'ext node list
(* index # ref_find id
* Returns the list of all nodes containing an IDREF
* refering to the given id.
*)
+end
class [ 'ext ] hash_index :
object
@@ -40,6 +64,17 @@
(* Returns the hash table. *)
end
+(* reverse_hash_index is a contribution to Ocamlnet made by Baretta SRL DE&IT
*)
+class [ 'ext ] reverse_hash_index :
+object
+class [ 'ext ] fake_reverse_index : 'ext #index -> [ 'ext ] reverse_index
+
val default_extension : ('a node extension) as 'a
(* A "null" extension; an extension that does not extend the functionality
*)
@@ -71,6 +106,18 @@
* violations of the uniqueness of IDs.
*)
+(* parse_document_entity_with_reverse_index is a contribution
val default_extension : ('a node extension) as 'a
(* now defined in Pxp_tree_parser )
diff -Naur --exclude '~' --exclude '.cm' pxp-1.1.95/src/pxp-pp/pxp_pp.ml
pxp-1.1.95-deit/src/pxp-pp/pxp_pp.ml
--- pxp-1.1.95/src/pxp-pp/pxp_pp.ml 2004-09-04 19:48:32.000000000 +0200
+++ pxp-1.1.95-deit/src/pxp-pp/pxp_pp.ml 2005-10-28 11:28:31.000000000 +0200
@@ -665,23 +665,23 @@
raise_at p1 p2 (Failure("pxp-pp: Typing error: " ^ msg))
;;
-let generate_list loc el =
List.fold_right (fun x l -> <:expr< [$x$ :: $l$] >>) el <:expr< [] >>
-;;
-let generate_ann_list loc el =
List.fold_right (fun (ann,x) l ->
match ann with
`Single -> <:expr< [$x$ :: $l$] >>
| `List -> <:expr< $x$ @ $l$ >>)
+let generate_list _loc el =
let loc = _loc in
List.fold_right (fun x l -> <:expr< [$x$ :: $l$] >>) el <:expr< [] >>
+let generate_ann_list _loc el =
let loc = _loc in
List.fold_right (fun (ann,x) l ->
match ann with
`Single -> <:expr< [$x$ :: $l$] >>
| `List -> <:expr< $x$ @ $l$ >>)
el
<:expr< [] >>
;;
-let generate_ident loc name =
+let generate_ident _loc name =
let loc = _loc in
(* TODO: "." separation )
( TODO: Convert back to latin 1 *)
<:expr< $lid:name$ >>
@@ -694,7 +694,8 @@
check_file();
let valcheck_expr =
let loc = mkloc (0,0,0) (0,0,0) in
let _loc = mkloc (0,0,0) (0,0,0) in
let loc = _loc in
if valcheck then <:expr< True >> else <:expr< False >> in
let to_rep s =
@@ -714,7 +715,8 @@
(* nsmode: Whether there is a variable [scope] in the environment *)
function
(`Element(name,attrs,subnodes),p1,p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
let name_expr = generate_for_string_expr name in
let attrs_expr_l = List.map generate_for_attr_expr attrs in
let attrs_expr = generate_ann_list loc attrs_expr_l in
@@ -740,28 +742,33 @@
node } >>
| (`Data text,p1,p2) ->
let text_expr = generate_for_string_expr text in
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
<:expr< Pxp_document.create_data_node spec dtd $text_expr$ >>
| (`Comment text,p1,p2) ->
let text_expr = generate_for_string_expr text in
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
<:expr< Pxp_document.create_comment_node spec dtd $text_expr$ >>
| (`PI(target,value),p1,p2) ->
let target_expr = generate_for_string_expr target in
let value_expr = generate_for_string_expr value in
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
<:expr< Pxp_document.create_pinstr_node spec dtd
(new Pxp_dtd.proc_instruction
$target_expr$ $value_expr$ dtd#encoding)
>>
| (`Super subnodes,p1,p2) ->
let subnodes_expr = generate_for_nodelist_expr nsmode subnodes in
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
<:expr< let node = Pxp_document.create_super_root_node spec dtd in
do { node # set_nodes $subnodes_expr$;
node } >>
| (`Meta(name,attrs,subnode),p1,p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
( match name with
"scope" -> generate_scope loc attrs subnode
| "autoscope" -> generate_autoscope loc subnode
let loc = _loc in
generate_ident loc (to_src name)
| (`Anti text,p1,p2) ->
Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string (to_src text))
@@ -780,16 +788,19 @@
and generate_for_nodelist_expr nsmode : ast_node_list -> MLast.expr = (
function
(`Nodes l, p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
let l' = List.map (generate_for_node_expr nsmode) l in
generate_list loc l'
| (`Concat l, p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
let l' = List.map (generate_for_nodelist_expr nsmode) l in
let l'' = generate_list loc l' in
<:expr< List.concat $l''$ >>
| (`Ident name, p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
generate_ident loc (to_src name)
| (`Anti text, p1, p2) ->
Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string (to_src text))
@@ -798,7 +809,8 @@
and generate_for_attr_expr : ast_attr -> [Single|List] * MLast.expr = (
function
(`Attr(n,v), p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
let n_expr = generate_for_string_expr n in
let v_expr = generate_for_string_expr v in
`Single, <:expr< ($n_expr$, $v_expr$) >>
@@ -808,6 +820,7 @@
)
and generate_scope loc attrs subnode : MLast.expr = (
let _loc = loc in
let subexpr = generate_for_node_expr true subnode in
if attrs = [] then
subexpr
@@ -822,6 +835,7 @@
)
and generate_autoscope loc subnode : MLast.expr = (
let _loc = loc in
let subexpr = generate_for_node_expr true subnode in
<:expr< let scope =
( let mng = dtd # namespace_manager in
@@ -830,6 +844,7 @@
)
and generate_emptyscope loc subnode : MLast.expr = (
let _loc = loc in
let subexpr = generate_for_node_expr true subnode in
<:expr< let scope =
( let mng = dtd # namespace_manager in
@@ -840,16 +855,19 @@
and generate_for_string_expr : ast_string -> MLast.expr = (
function
(`Literal s, p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
let s' = to_rep s in
<:expr< $str:s'$ >>
| (`Concat l, p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
let l' = List.map generate_for_string_expr l in
let l'' = generate_list loc l' in
<:expr< String.concat "" $l''$ >>
| (`Ident name, p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
generate_ident loc (to_src name)
| (`Anti text, p1, p2) ->
Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string (to_src text))
@@ -863,7 +881,8 @@
let ast = call_parser parse_any_expr stream in
let ast' = check_any_expr ast in
let ocaml_expr = generate_for_any_expr ast' in
let loc = mkloc (1,0,0) (last_pos stream) in
let _loc = mkloc (1,0,0) (last_pos stream) in
let loc = _loc in
<:expr< $anti:ocaml_expr$ >>
)
;;
@@ -912,6 +931,7 @@
~in_enc:`Enc_utf8 ~out_enc:(!current_decl.source_enc) s in
let rec generate_for_any_expr loc : ast_any_node -> MLast.expr =
let _loc = loc in
function Node n -> let e = generate_tree (generate_for_node_expr false n) in @@ -924,7 +944,8 @@ (* nsmode: Whether there is a variable [scope] in the environment *) function (Element(name,attrs,subnodes),p1,p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
let name_expr = generate_for_string_expr name in
let attrs_expr_l = List.map generate_for_attr_expr attrs in
let attrs_expr = generate_ann_list loc attrs_expr_l in
@@ -943,25 +964,30 @@
[Single, start_tag] @ subnodes_expr @ [Single, end_tag]
| (`Data text,p1,p2) ->
let text_expr = generate_for_string_expr text in
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
[ `Single, <:expr< Pxp_types.E_char_data($text_expr$) >> ]
| (`Comment text,p1,p2) ->
let text_expr = generate_for_string_expr text in
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
[ `Single, <:expr< Pxp_types.E_comment($text_expr$) >> ]
| (`PI(target,value),p1,p2) ->
let target_expr = generate_for_string_expr target in
let value_expr = generate_for_string_expr value in
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
[ `Single, <:expr< Pxp_types.E_pinstr($target_expr$,$value_expr$,_eid) >> ]
| (`Super subnodes,p1,p2) ->
let subnodes_expr = generate_for_nodelist_expr nsmode subnodes in
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
( [ `Single, <:expr< Pxp_types.E_start_super >> ] @
subnodes_expr @
[ `Single, <:expr< Pxp_types.E_end_super >> ] )
| (`Meta(name,attrs,subnode),p1,p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
( match name with
"scope" -> generate_scope loc attrs subnode
| "autoscope" -> generate_autoscope loc subnode
let loc = _loc in
[ `Tree, (generate_ident loc (to_src name)) ]
| (`Anti text,p1,p2) ->
let expr =
@@ -984,15 +1011,18 @@
ast_node_list -> (ann * MLast.expr) list = (
function
(`Nodes l, p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
let l' = List.map (generate_for_node_expr nsmode) l in
List.flatten l'
| (`Concat l, p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
let l' = List.map (generate_for_nodelist_expr nsmode) l in
List.flatten l'
| (`Ident name, p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
[ `Forest, (generate_ident loc (to_src name)) ]
| (`Anti text, p1, p2) ->
let expr =
@@ -1004,7 +1034,8 @@
and generate_for_attr_expr : ast_attr -> [Single|List] * MLast.expr = (
function
(`Attr(n,v), p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
let n_expr = generate_for_string_expr n in
let v_expr = generate_for_string_expr v in
`Single, <:expr< ($n_expr$, $v_expr$) >>
@@ -1014,6 +1045,7 @@
)
and generate_scope loc attrs subnode : (ann * MLast.expr) list = (
let _loc = loc in
let subexpr = generate_for_node_expr true subnode in
if attrs = [] then
subexpr
@@ -1031,6 +1063,7 @@
)
and generate_autoscope loc subnode : (ann * MLast.expr) list = (
let _loc = loc in
let subexpr = generate_for_node_expr true subnode in
let compiled_subexpr = generate_tree subexpr in
let scope_expr =
@@ -1041,6 +1074,7 @@
)
and generate_emptyscope loc subnode : (ann * MLast.expr) list = (
let _loc = loc in
let subexpr = generate_for_node_expr true subnode in
let compiled_subexpr = generate_tree subexpr in
let scope_expr =
@@ -1053,16 +1087,19 @@
and generate_for_string_expr : ast_string -> MLast.expr = (
function
(`Literal s, p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
let s' = to_rep s in
<:expr< $str:s'$ >>
| (`Concat l, p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
let l' = List.map generate_for_string_expr l in
let l'' = generate_list loc l' in
<:expr< String.concat "" $l''$ >>
| (`Ident name, p1, p2) ->
let loc = mkloc p1 p2 in
let _loc = mkloc p1 p2 in
let loc = _loc in
generate_ident loc (to_src name)
| (`Anti text, p1, p2) ->
Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string (to_src text))
@@ -1075,7 +1112,8 @@
let stream = scan_string s in
let ast = call_parser parse_any_expr stream in
let ast' = check_any_expr ast in
let loc = mkloc (1,0,0) (last_pos stream) in
let _loc = mkloc (1,0,0) (last_pos stream) in
let loc = _loc in
let expr = generate_for_any_expr loc ast' in
<:expr< $anti:expr$ >>
)
@@ -1083,7 +1121,8 @@
let expand_evlist_expr s =
let loc = mkloc (0,0,0) (0,0,0) in (* ??? *)
let _loc = mkloc (0,0,0) (0,0,0) in (* ??? *)
let loc = _loc in
let rec generate_tree annlist =
match annlist with
(`Single, e) :: annlist' ->
@@ -1102,7 +1141,8 @@
let expand_evpull_expr s =
let loc = mkloc (0,0,0) (0,0,0) in (* ??? *)
let _loc = mkloc (0,0,0) (0,0,0) in (* ??? *)
let loc = _loc in
let generate_tree annlist =
let rec generate_match k annlist =
match annlist with
@@ -1156,7 +1196,8 @@
let stream = scan_string s in
let decl = call_parser parse_charset_decl stream in
current_decl := decl;
module Duality = struct
external identity : 'a -> 'a = "%identity"
let (++) x f = f x
let (+>) f g = fun x -> x ++ f ++ g
let (+/>) f g = fun x y -> g (f x) (f y)
let (~%) f = fun y x -> f x y
end
module String_conversions = struct
exception Unable_to_escape of string
type char_escape_function = Buffer.t -> char -> bool
let xml_quote_attribute_escape_char buffer char = match char with
| '&' -> Buffer.add_string buffer "&"; true
| ''' -> Buffer.add_string buffer "'"; true
| _ -> false
let xml_dquote_attribute_escape_char buffer char = match char with
| '&' -> Buffer.add_string buffer "&"; true
| '"' -> Buffer.add_string buffer """; true
| _ -> false
let js_escape_char buffer char =
let js_style_escape char = Printf.bprintf buffer "\x%02x" (Char.code char)
in
match char with
| x when x < '\x20' -> js_style_escape x; true
| '"'
| '\'
| '>'
| '<'
| '&'
| '%'
| '''-> js_style_escape char; true
| '\xA0' -> js_style_escape '\x20'; true (* Non breaking space gets
converted to a normal space *)
| _ -> false
let no_escape_char buffer c = Buffer.add_char buffer c; true
let generic_escape_string escape_functions s =
if String.length s = 0 then "" else
let buffer = Buffer.create (String.length s + 16) in
let folder char res funz = res || (funz buffer char) in
let composite_escape char = if (List.fold_left (folder char) false
escape_functions) = false then raise (Unable_to_escape s) in
let () = String.iter composite_escape s in
Buffer.contents buffer
let to_xml_complete = generic_escape_string [xml_quote_attribute_escape_char;
xml_dquote_attribute_escape_char; xml_escape_char; no_escape_char ]
let to_xml_data = generic_escape_string [xml_escape_char; no_escape_char ]
let to_xml_quote_attribute = generic_escape_string
[xml_quote_attribute_escape_char; no_escape_char ]
let to_xml_dquote_attribute = generic_escape_string
[xml_dquote_attribute_escape_char; no_escape_char ]
let to_js = generic_escape_string [js_escape_char; no_escape_char]
end
module Xdbs_base = struct
open Duality
open Pxp_types
open Pxp_document
open Pxp_dtd
open Pxp_tree_parser
open String_conversions
exception Validation_error_at_position of string * int * int
let lazy_error = lazy(assert false)
let list_of_opt = function
| None -> []
| Some x -> [x]
class warner =
object (self)
val wq : string Queue.t = Queue.create ()
method warn s = Queue.add s wq
method fetch_all f = Queue.iter f wq
method output_all ?(intro="XML Warning") ch =
self # fetch_all (fun s -> Printf.fprintf ch "%s: %s\n" intro s)
method prerr_all ?intro () = self # output_all ?intro stderr; flush stderr
end
let rec handle_pxp_exn = function
| Pxp_core_types.At(s,exn) -> prerr_endline s; handle_pxp_exn exn
| exn -> prerr_endline (Printexc.to_string exn)
type out = { f : 'a. int -> ('a,unit,string,unit) format4 -> 'a;
nl : 'a. int -> ('a,unit,string,unit) format4 -> 'a;
raw : string -> unit;
filename: string option;
}
let rec copy_node (out : out) level node : unit = match node # node_type, node
sub_nodes with
| T_data, _ -> out.f level "%s" node # data
| T_element s, [] -> empty_tag out level s node # attributes
| T_element s, sub_nodes -> open_tag out level s node # attributes ; node #
iter_nodes (copy_node out 0); close_tag out 0 s
| _ -> ()
and open_tag (out : out) level name attributes : unit =
out.f level "<%s " name;
copy_attributes out attributes;
out.f level ">"
and close_tag (out : out) level name : unit =
out.f level "</%s>" name
and empty_tag (out : out) level name attributes : unit =
out.f level "<%s " name;
copy_attributes out attributes;
out.f level "/>"
and copy_attributes (out : out) attributes = match attributes with
| (name, Value v) :: [] -> out.f 0 "%s='%s'" name (to_xml_quote_attribute
v)
| (name, Value v) :: tl -> out.f 0 "%s='%s' " name (to_xml_quote_attribute
v); copy_attributes out tl
| (name, Valuelist vl) :: [] -> out.f 0 "%s='%s'" name
(to_xml_quote_attribute (String.concat " " vl))
| (name, Valuelist vl) :: tl -> out.f 0 "%s='%s' " name
(to_xml_quote_attribute (String.concat " " vl)); copy_attributes out tl
| (_, Implied_value) :: tl -> copy_attributes out tl
| [] -> ()
let rec clone_with_new_dtd (dtd : dtd) (node : 'a node) =
let position = node # position in
let valcheck = false in
let att_values = node # attributes in
let node_type = node # node_type in
let node' = node # create_element ~position ~valcheck ~att_values dtd
node_type [] in
let sub_nodes = List.map (clone_with_new_dtd dtd) node # sub_nodes in
node' # set_nodes sub_nodes;
node'
class counter = object
val mutable state = 0
method get = let n = state in state <- succ n; n
end
class base_ext (index : 'a reverse_hash_index) =
object (self : 'a node #extension as 'a )
(* constraint 'node = 'a node *)
val mutable node = lazy_error
val mutable elt_type = lazy_error
val mutable required_string_attribute = fun n -> assert false
val mutable optional_string_attribute = fun n -> assert false
val mutable required_list_attribute = fun n -> assert false
val mutable optional_list_attribute = fun n -> assert false
method init =
elt_type <- lazy(
match self # node # node_type with
| T_element s -> s
| _ -> "{not XML element node}"
);
required_string_attribute <- self # node # required_string_attribute;
optional_string_attribute <- self # node # optional_string_attribute;
required_list_attribute <- self # node # required_list_attribute;
optional_list_attribute <- self # node # optional_list_attribute
method clone = {< >}
method node = Lazy.force node
method set_node n = node <- lazy(n); self # init
method iter_ext f = self # node # iter_nodes (fun n -> f n # extension)
method validate_recursively () =
let () = try self # node # validate () with Validation_error _ ->
let filename, line, pos = self # node # position in
raise (Validation_error_at_position(filename, line, pos) ) in
self # node # iter_nodes (fun n -> n # extension # validate_recursively
())
method was_opt = optional_string_attribute "was"
method as_opt = optional_string_attribute "as"
method id = required_string_attribute "id"
method was = required_string_attribute "was"
method _type = required_string_attribute "type"
method name = required_string_attribute "name"
method nullable = required_string_attribute "nullable"
method optional = required_string_attribute "optional"
method visible = required_string_attribute "visible"
method default_opt = optional_string_attribute "default"
method label_opt = optional_string_attribute "label"
method size_opt = optional_string_attribute "size"
method maxlength_opt = optional_string_attribute "maxlength"
method ref = required_string_attribute "ref"
method elt_type = Lazy.force elt_type
method idmem idref = Hashtbl.mem index # index idref
method idref = index # find self # id
method find = index # find
method idref_find = index # ref_find self # id
method ref_find = index # ref_find
method equals (node : 'a node) =
let these_attributes = List.stable_sort Pervasives.compare self # node #
attributes in
let other_attributes = List.stable_sort Pervasives.compare node #
attributes in
if these_attributes <> other_attributes then false else
List.fold_left2 (fun flag n1 n2 -> flag && n1 # extension # equals n2)
true self # node # sub_nodes node # sub_nodes
#use "test_case_309_prerequisites.ml"
;;
(* The real thing begins here. *)
open Pxp_types
open Pxp_document
open Pxp_tree_parser
class type_index =
object (self)
val table : (string*string, string) Hashtbl.t = Hashtbl.create 32
method add language er_type implementation =
Hashtbl.add table (language,er_type) implementation
method find language er_type = Hashtbl.find table (language,er_type)
end
;;
(* class xdbs_ext : ('a Pxp_document.node #Pxp_document.extension as 'a) = *)
fun (index : 'a reverse_hash_index) (type_index : type_index) ->
object (self : 'a Pxp_document.node #Pxp_document.extension as 'a )
inherit Xdbs_base.base_ext (index : 'a reverse_hash_index )
method scan_types = ()
method fragment = required_string_attribute "fragment"
method applications = optional_list_attribute "applications"
method from = required_string_attribute "from"
method table = required_string_attribute "table"
method alias = required_string_attribute "alias"
method sql_type db_driver =
let _type = self # _type in
try type_index # find db_driver self # _type with
| Not_found -> _type
method fragmentation_nodes =
let idrefs = self # idref_find in
let predicate n = match n # node_type with T_element "slice" -> true | _ ->
false in
List.filter predicate idrefs
end
;;
class data_implementation_ext (index : 'a reverse_hash_index) (type_index :
type_index) =
object (self : 'a node #extension as 'a)
inherit xdbs_ext index type_index
method private language = required_string_attribute "language"
method private is = required_string_attribute "is"
method scan_types = type_index # add (self # language) (self # _type) (self #
is)
end
#use "test_case_309_prerequisites.ml"
;;
(* The real thing begins here. *)
open Pxp_types
open Pxp_document
open Pxp_tree_parser
class type_index =
object (self)
val table : (string*string, string) Hashtbl.t = Hashtbl.create 32
method add language er_type implementation =
Hashtbl.add table (language,er_type) implementation
method find language er_type = Hashtbl.find table (language,er_type)
end
;;
(* class xdbs_ext : ('a Pxp_document.node #Pxp_document.extension as 'a) = *)
fun (index : 'a reverse_hash_index) (type_index : type_index) ->
object (self : 'a Pxp_document.node #Pxp_document.extension as 'a )
inherit Xdbs_base.base_ext (index : 'a reverse_hash_index )
method scan_types = ()
method fragment = required_string_attribute "fragment"
method applications = optional_list_attribute "applications"
method from = required_string_attribute "from"
method table = required_string_attribute "table"
method alias = required_string_attribute "alias"
method sql_type db_driver =
let _type = self # _type in
try type_index # find db_driver self # _type with
| Not_found -> _type
method fragmentation_nodes =
let idrefs = self # idref_find in
let predicate n = match n # node_type with T_element "slice" -> true | _ ->
false in
List.filter predicate idrefs
end
;;
class data_implementation_ext (index : 'a reverse_hash_index) (type_index :
type_index) =
object (self : 'a node #extension as 'a)
inherit xdbs_ext index type_index
method private language = required_string_attribute "language"
method private is = required_string_attribute "is"
method scan_types = type_index # add (self # language) (self # _type) (self #
is)
end
--------------000900010702060808050907--
The text was updated successfully, but these errors were encountered:
alex@alex:~/meldolo_totale_2005$ ocaml -rectypes test_case_309_try_1.ml
Fatal error: exception Assert_failure("typing/typeclass.ml", 1348, 18)
(Program not linked with -g, cannot print stack backtrace)
The assertion-failure is caused by obvious syntax error at line 41 which
apparently the parser does not report. The error appears both in the native
ocamlyacc syntax and with the camlp4o preprocessor enabled.
Thanks for your error report.
No, the problem is not a syntax error: this program just defines a function
returning an immediate object. I will have to look to see the real reason.
At least, it seems that replacing 'a by 'b in the type of self solves the
problem.
I fixed this problem in the 3.09 branch, files ctype.ml and typeclass.ml.
Can you try the CVS version, on branch release309?
I believe it should also solve your other problem with type annotations.
Original bug ID: 3856
Reporter: administrator
Status: closed (set by @garrigue on 2005-12-08T02:12:17Z)
Resolution: fixed
Priority: normal
Severity: minor
Category: ~DO NOT USE (was: OCaml general)
Monitored by: alexbaretta "Boris Yakokobowski"
Bug description
Full_Name: Alessandro Baretta
Version: 3.09.0
OS: Linux alex.barettadeit.com 2.6.14.ipw2200 #0 PREEMPT Tue Nov 1 13:29:36 CET 2005 i686 GNU/Linux
Submission from: h213-255-109-130.albacom.net (213.255.109.130)
It would have been easier to submit the bug report via caml-bugs@caml.inria.fr,
but this address seems to have been deactivated. I'll submit it with the web
interface. Hopefully, it will not be too hard to manually decipher the MIME
encoded attachments.
I'm working in a findlib-managed installation with patched versions of Ocamlnet
1.1 and PXP 1.1.95. I'm submitting a full test case containing the actual
script, a script packaging in a single file the various modules referenced by
the test case script, and the patches which I have applied to ocamlnet and
pxp-1.1.95. The following is quoted from the shell session I use to run the test
case.
alex@alex:~/meldolo_totale_2005$ ocaml -rectypes test_case_309_try_1.ml
Fatal error: exception Assert_failure("typing/typeclass.ml", 1348, 18)
(Program not linked with -g, cannot print stack backtrace)
The assertion-failure is caused by obvious syntax error at line 41 which
apparently the parser does not report. The error appears both in the native
ocamlyacc syntax and with the camlp4o preprocessor enabled.
Alex Baretta
Baretta DE&IT
--------------000900010702060808050907
Content-Type: text/x-patch;
name="ocamlnet-1.1.patch"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="ocamlnet-1.1.patch"
diff -Naur ocamlnet-1.1/src/cgi/netcgi.mli ocamlnet-1.1-deit/src/cgi/netcgi.mli
--- ocamlnet-1.1/src/cgi/netcgi.mli 2005-07-26 00:43:35.000000000 +0200
+++ ocamlnet-1.1-deit/src/cgi/netcgi.mli 2005-10-25 19:25:32.000000000 +0200
@@ -6,12 +6,13 @@
open Netcgi_env
open Netcgi_types
+val status_line : Nethttp.http_status -> string
+
(** Classical CGI implementation
*
*)
class simple_argument :
?ro:bool -> string -> string -> cgi_argument
(** [new simple_argument name value]: Creates an unstructured CGI
diff -Naur ocamlnet-1.1/src/netstring/netchannels.ml
ocamlnet-1.1-deit/src/netstring/netchannels.ml
--- ocamlnet-1.1/src/netstring/netchannels.ml 2005-07-26 00:43:34.000000000
+0200
+++ ocamlnet-1.1-deit/src/netstring/netchannels.ml 2005-10-25 19:28:40.000000000
+0200
@@ -967,6 +967,91 @@
end
;;
+class output_function ?(onclose = fun () -> ()) write : out_obj_channel =
+object(self)
+end
+;;
+
class output_netbuffer ?(onclose = fun () -> ()) buffer : out_obj_channel =
object(self)
diff -Naur ocamlnet-1.1/src/netstring/netchannels.mli
ocamlnet-1.1-deit/src/netstring/netchannels.mli
--- ocamlnet-1.1/src/netstring/netchannels.mli 2005-07-26 00:43:34.000000000
+0200
+++ ocamlnet-1.1-deit/src/netstring/netchannels.mli 2005-10-25
19:28:40.000000000 +0200
@@ -441,6 +441,14 @@
* invoked, just after the underlying descriptor has been closed.
*)
+class output_function :
class output_netbuffer :
?onclose:(unit -> unit) -> (* default: fun _ -> () *)
Netbuffer.t ->
--------------000900010702060808050907
Content-Type: text/x-patch;
name="pxp-1.1.95.patch"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="pxp-1.1.95.patch"
diff -Naur --exclude '~' --exclude '.cm*'
pxp-1.1.95/src/pxp-engine/pxp_document.ml
pxp-1.1.95-deit/src/pxp-engine/pxp_document.ml
--- pxp-1.1.95/src/pxp-engine/pxp_document.ml 2004-09-04 19:48:32.000000000
+0200
+++ pxp-1.1.95-deit/src/pxp-engine/pxp_document.ml 2005-10-28 11:28:03.000000000
+0200
@@ -1942,7 +1942,7 @@
| Implied_value -> raise Not_found
with
Not_found ->
%S: not found" n)
@@ -1962,7 +1962,7 @@
| Implied_value -> raise Not_found
with
Not_found ->
%S: not found" n)
diff -Naur --exclude '~' --exclude '.cm*'
pxp-1.1.95/src/pxp-engine/pxp_tree_parser.ml
pxp-1.1.95-deit/src/pxp-engine/pxp_tree_parser.ml
--- pxp-1.1.95/src/pxp-engine/pxp_tree_parser.ml 2004-09-04 19:48:32.000000000
+0200
+++ pxp-1.1.95-deit/src/pxp-engine/pxp_tree_parser.ml 2005-10-28
11:28:03.000000000 +0200
@@ -4,6 +4,11 @@
*)
+(* Portions of this code are contributions made to Ocamlnet by Alex Baretta.
open Pxp_types
open Pxp_lexers
open Pxp_lexer_types
@@ -23,6 +28,13 @@
method find : string -> 'ext node
end
+(* reverse_index is a contribution to Ocamlnet made by Baretta SRL DE&IT *)
+class type [ 'ext ] reverse_index =
+object
+end
class [ 'ext ] hash_index =
object
@@ -40,6 +52,25 @@
method index = ht
end
+(* reverse_hash_index is a contribution to Ocamlnet made by Baretta SRL DE&IT
*)
+class [ 'ext ] reverse_hash_index =
+object (self : 'ext #reverse_index )
+end
+(* fake_reverse_hash_index is a contribution to Ocamlnet made by Baretta SRL
DE&IT *)
+class [ 'ext ] fake_reverse_index (index : 'ext #index) =
+object (self : 'ext #reverse_index )
+end
class default_ext =
object(self : 'self)
@@ -93,7 +124,7 @@
val transform_dtd = transform_dtd
(* A function transforming the DTD *)
val id_index = (id_index : 'ext reverse_index option)
(* The ID index or None *)
val doc = init_doc
@@ -513,14 +544,14 @@
(fun att ->
match t # attribute att with
Value s ->
@@ -544,7 +575,7 @@
~document:doc
~specification:spec
~transform_dtd
@@ -557,7 +588,7 @@
cfg
spec
transform_dtd
let mgr = new entity_manager en dtd in
let gen_att_events = cfg.escape_attributes <> None in
@@ -637,6 +668,7 @@
dtd # validate; (* ensure that the DTD is valid *)
if cfg.accept_only_deterministic_models then dtd #
only_deterministic_models;
let doc = new document ?swarner:cfg.swarner cfg.warner cfg.encoding in
fake_reverse_index idx') in
let pobj =
call_tree_parser
~configuration:cfg
@@ -645,7 +677,32 @@
~document:doc
~specification:spec
~transform_dtd:(fun x -> x) (* Do not transform the DTD *)
+;;
+let parse_content_entity_with_reverse_index ~id_index cfg src dtd spec =
only_deterministic_models;
@@ -722,7 +779,7 @@
dtd' # only_deterministic_models;
dtd')
@@ -734,10 +791,19 @@
let parse_document_entity ?(transform_dtd = (fun x -> x))
?id_index
cfg src spec =
fake_reverse_index idx') in
option)
+let parse_document_entity_with_reverse_index ?(transform_dtd = (fun x -> x))
~transform_dtd:transform_dtd
let parse_wfdocument_entity ?(transform_dtd = (fun x -> x))
cfg src spec =
diff -Naur --exclude '~' --exclude '.cm*'
pxp-1.1.95/src/pxp-engine/pxp_tree_parser.mli
pxp-1.1.95-deit/src/pxp-engine/pxp_tree_parser.mli
--- pxp-1.1.95/src/pxp-engine/pxp_tree_parser.mli 2004-09-04 19:48:31.000000000
+0200
+++ pxp-1.1.95-deit/src/pxp-engine/pxp_tree_parser.mli 2005-10-28
11:28:03.000000000 +0200
@@ -4,6 +4,11 @@
*)
+(* Portions of this code are contributions made to Ocamlnet by Alex Baretta.
open Pxp_types
open Pxp_dtd
open Pxp_document
@@ -18,6 +23,10 @@
*)
constraint 'ext = 'ext node #extension
method add : string -> 'ext node -> unit
* the passed string value, the exception ID_not_unique should be
* raised. (But the index is free also to accept several identical IDs.)
@@ -26,7 +35,22 @@
(* Finds the node with the passed ID value, or raises Not_found *)
end
+(* reverse_index is a contribution to Ocamlnet made by Baretta SRL DE&IT *)
+class type [ 'ext ] reverse_index =
+object
+end
class [ 'ext ] hash_index :
object
@@ -40,6 +64,17 @@
(* Returns the hash table. *)
end
+(* reverse_hash_index is a contribution to Ocamlnet made by Baretta SRL DE&IT
*)
+class [ 'ext ] reverse_hash_index :
+object
+end
+class [ 'ext ] fake_reverse_index : 'ext #index -> [ 'ext ] reverse_index
+
val default_extension : ('a node extension) as 'a
(* A "null" extension; an extension that does not extend the functionality
*)
@@ -71,6 +106,18 @@
* violations of the uniqueness of IDs.
*)
+(* parse_document_entity_with_reverse_index is a contribution
+val parse_document_entity_with_reverse_index :
an
val parse_wfdocument_entity :
?transform_dtd:(dtd -> dtd) ->
config -> source -> 'ext spec -> 'ext document
@@ -83,6 +130,9 @@
* declarations).
*)
+(* parse_document_entity_with_reverse_index is a contribution
val parse_content_entity :
?id_index:('ext index) ->
config -> source -> dtd -> 'ext spec -> 'ext node
@@ -97,6 +147,14 @@
*)
+val parse_content_entity_with_reverse_index :
an
val parse_wfcontent_entity :
config -> source -> 'ext spec -> 'ext node
(* Parse a file representing a well-formed fragment of a document
diff -Naur --exclude '~' --exclude '.cm*'
pxp-1.1.95/src/pxp-engine/pxp_yacc.ml
pxp-1.1.95-deit/src/pxp-engine/pxp_yacc.ml
--- pxp-1.1.95/src/pxp-engine/pxp_yacc.ml 2004-09-04 19:48:31.000000000 +0200
+++ pxp-1.1.95-deit/src/pxp-engine/pxp_yacc.ml 2005-10-28 11:28:03.000000000
+0200
@@ -67,8 +67,11 @@
exception ID_not_unique = Pxp_tree_parser.ID_not_unique
class type [ 'ext ] index = [ 'ext ] Pxp_tree_parser.index
+class type [ 'ext ] reverse_index = [ 'ext ] Pxp_tree_parser.reverse_index
class [ 'ext ] hash_index = [ 'ext ] Pxp_tree_parser.hash_index
+class [ 'ext ] reverse_hash_index = [ 'ext ]
Pxp_tree_parser.reverse_hash_index
+class [ 'ext ] fake_reverse_index = [ 'ext ]
Pxp_tree_parser.fake_reverse_index
let default_extension = Pxp_tree_parser.default_extension
diff -Naur --exclude '~' --exclude '.cm*'
pxp-1.1.95/src/pxp-engine/pxp_yacc.mli
pxp-1.1.95-deit/src/pxp-engine/pxp_yacc.mli
--- pxp-1.1.95/src/pxp-engine/pxp_yacc.mli 2004-09-04 19:48:31.000000000 +0200
+++ pxp-1.1.95-deit/src/pxp-engine/pxp_yacc.mli 2005-10-28 11:28:03.000000000
+0200
@@ -110,8 +110,12 @@
(* now defined in Pxp_tree_parser *)
class type [ 'ext ] index = [ 'ext ] Pxp_tree_parser.index
+class type [ 'ext ] reverse_index = [ 'ext ] Pxp_tree_parser.reverse_index
class [ 'ext ] hash_index : [ 'ext ] Pxp_tree_parser.hash_index
+class [ 'ext ] reverse_hash_index : [ 'ext ]
Pxp_tree_parser.reverse_hash_index
+class [ 'ext ] fake_reverse_index : 'ext #index -> [ 'ext ]
Pxp_tree_parser.fake_reverse_index
+
val default_extension : ('a node extension) as 'a
(* now defined in Pxp_tree_parser )
diff -Naur --exclude '~' --exclude '.cm' pxp-1.1.95/src/pxp-pp/pxp_pp.ml
pxp-1.1.95-deit/src/pxp-pp/pxp_pp.ml
--- pxp-1.1.95/src/pxp-pp/pxp_pp.ml 2004-09-04 19:48:32.000000000 +0200
+++ pxp-1.1.95-deit/src/pxp-pp/pxp_pp.ml 2005-10-28 11:28:31.000000000 +0200
@@ -665,23 +665,23 @@
raise_at p1 p2 (Failure("pxp-pp: Typing error: " ^ msg))
;;
-let generate_list loc el =
-;;
-let generate_ann_list loc el =
+let generate_list _loc el =
+let generate_ann_list _loc el =
;;
-let generate_ident loc name =
+let generate_ident _loc name =
let loc = _loc in$lid:name$ >>
(* TODO: "." separation )
( TODO: Convert back to latin 1 *)
<:expr<
@@ -694,7 +694,8 @@
check_file();
let valcheck_expr =
if valcheck then <:expr< True >> else <:expr< False >> in
let to_rep s =
@@ -714,7 +715,8 @@
(* nsmode: Whether there is a variable [scope] in the environment *)
function
(`Element(name,attrs,subnodes),p1,p2) ->
@@ -740,28 +742,33 @@
node } >>
| (`Data text,p1,p2) ->
let text_expr = generate_for_string_expr text in
@@ -769,7 +776,8 @@
| _ -> assert false (* already caught above *)
)
| (`Ident name,p1,p2) ->
@@ -780,16 +788,19 @@
and generate_for_nodelist_expr nsmode : ast_node_list -> MLast.expr = (
function
(`Nodes l, p1, p2) ->
@@ -798,7 +809,8 @@
and generate_for_attr_expr : ast_attr -> [
Single|
List] * MLast.expr = (function
(`Attr(n,v), p1, p2) ->
@@ -808,6 +820,7 @@
)
and generate_scope loc attrs subnode : MLast.expr = (
let subexpr = generate_for_node_expr true subnode in
if attrs = [] then
subexpr
@@ -822,6 +835,7 @@
)
and generate_autoscope loc subnode : MLast.expr = (
let subexpr = generate_for_node_expr true subnode in
<:expr< let scope =
( let mng = dtd # namespace_manager in
@@ -830,6 +844,7 @@
)
and generate_emptyscope loc subnode : MLast.expr = (
let subexpr = generate_for_node_expr true subnode in
<:expr< let scope =
( let mng = dtd # namespace_manager in
@@ -840,16 +855,19 @@
and generate_for_string_expr : ast_string -> MLast.expr = (
function
(`Literal s, p1, p2) ->
@@ -863,7 +881,8 @@
let ast = call_parser parse_any_expr stream in
let ast' = check_any_expr ast in
let ocaml_expr = generate_for_any_expr ast' in
)
;;
@@ -912,6 +931,7 @@
~in_enc:`Enc_utf8 ~out_enc:(!current_decl.source_enc) s in
let rec generate_for_any_expr loc : ast_any_node -> MLast.expr =
let _loc = loc in
function
Node n -> let e = generate_tree (generate_for_node_expr false n) in @@ -924,7 +944,8 @@ (* nsmode: Whether there is a variable [scope] in the environment *) function (
Element(name,attrs,subnodes),p1,p2) ->@@ -943,25 +964,30 @@
[
Single, start_tag] @ subnodes_expr @ [
Single, end_tag]| (`Data text,p1,p2) ->
let text_expr = generate_for_string_expr text in
@@ -969,7 +995,8 @@
| _ -> assert false (* already caught above *)
)
| (`Ident name,p1,p2) ->
@@ -984,15 +1011,18 @@
ast_node_list -> (ann * MLast.expr) list = (
function
(`Nodes l, p1, p2) ->
@@ -1004,7 +1034,8 @@
and generate_for_attr_expr : ast_attr -> [
Single|
List] * MLast.expr = (function
(`Attr(n,v), p1, p2) ->
@@ -1014,6 +1045,7 @@
)
and generate_scope loc attrs subnode : (ann * MLast.expr) list = (
let subexpr = generate_for_node_expr true subnode in
if attrs = [] then
subexpr
@@ -1031,6 +1063,7 @@
)
and generate_autoscope loc subnode : (ann * MLast.expr) list = (
let subexpr = generate_for_node_expr true subnode in
let compiled_subexpr = generate_tree subexpr in
let scope_expr =
@@ -1041,6 +1074,7 @@
)
and generate_emptyscope loc subnode : (ann * MLast.expr) list = (
let subexpr = generate_for_node_expr true subnode in
let compiled_subexpr = generate_tree subexpr in
let scope_expr =
@@ -1053,16 +1087,19 @@
and generate_for_string_expr : ast_string -> MLast.expr = (
function
(`Literal s, p1, p2) ->
@@ -1075,7 +1112,8 @@
let stream = scan_string s in
let ast = call_parser parse_any_expr stream in
let ast' = check_any_expr ast in
@@ -1083,7 +1121,8 @@
let expand_evlist_expr s =
let rec generate_tree annlist =
match annlist with
(`Single, e) :: annlist' ->
@@ -1102,7 +1141,8 @@
let expand_evpull_expr s =
let generate_tree annlist =
let rec generate_match k annlist =
match annlist with
@@ -1156,7 +1196,8 @@
let stream = scan_string s in
let decl = call_parser parse_charset_decl stream in
current_decl := decl;
;;
@@ -1164,7 +1205,8 @@
let expand_text_expr s =
check_file();
<:expr<
;;
--------------000900010702060808050907
Content-Type: text/plain;
name="test_case_309_prerequisites.ml"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="test_case_309_prerequisites.ml"
(*
*)
#use "topfind";;
#require "pxp-engine";;
#camlp4o;;
module Duality = struct
external identity : 'a -> 'a = "%identity"
let (++) x f = f x
let (+>) f g = fun x -> x ++ f ++ g
let (+/>) f g = fun x y -> g (f x) (f y)
let (~%) f = fun y x -> f x y
end
module String_conversions = struct
exception Unable_to_escape of string
type char_escape_function = Buffer.t -> char -> bool
let xml_escape_char buffer char = match char with
| '&' -> Buffer.add_string buffer "&"; true
| '<' -> Buffer.add_string buffer "<"; true
| '>' -> Buffer.add_string buffer ">"; true
| '''-> Buffer.add_string buffer "'"; true
(* | '"' -> Buffer.add_string buffer """; true *)
| '%' -> Buffer.add_string buffer "%"; true
| _ -> false
let xml_quote_attribute_escape_char buffer char = match char with
| '&' -> Buffer.add_string buffer "&"; true
| ''' -> Buffer.add_string buffer "'"; true
| _ -> false
let xml_dquote_attribute_escape_char buffer char = match char with
| '&' -> Buffer.add_string buffer "&"; true
| '"' -> Buffer.add_string buffer """; true
| _ -> false
let js_escape_char buffer char =
let js_style_escape char = Printf.bprintf buffer "\x%02x" (Char.code char)
in
match char with
| x when x < '\x20' -> js_style_escape x; true
| '"'
| '\'
| '>'
| '<'
| '&'
| '%'
| '''-> js_style_escape char; true
| '\xA0' -> js_style_escape '\x20'; true (* Non breaking space gets
converted to a normal space *)
| _ -> false
let no_escape_char buffer c = Buffer.add_char buffer c; true
let generic_escape_string escape_functions s =
if String.length s = 0 then "" else
let buffer = Buffer.create (String.length s + 16) in
let folder char res funz = res || (funz buffer char) in
let composite_escape char = if (List.fold_left (folder char) false
escape_functions) = false then raise (Unable_to_escape s) in
let () = String.iter composite_escape s in
Buffer.contents buffer
let to_xml_complete = generic_escape_string [xml_quote_attribute_escape_char;
xml_dquote_attribute_escape_char; xml_escape_char; no_escape_char ]
let to_xml_data = generic_escape_string [xml_escape_char; no_escape_char ]
let to_xml_quote_attribute = generic_escape_string
[xml_quote_attribute_escape_char; no_escape_char ]
let to_xml_dquote_attribute = generic_escape_string
[xml_dquote_attribute_escape_char; no_escape_char ]
let to_js = generic_escape_string [js_escape_char; no_escape_char]
end
module Xdbs_base = struct
open Duality
open Pxp_types
open Pxp_document
open Pxp_dtd
open Pxp_tree_parser
open String_conversions
exception Validation_error_at_position of string * int * int
let lazy_error = lazy(assert false)
let list_of_opt = function
| None -> []
| Some x -> [x]
class warner =
object (self)
end
let rec handle_pxp_exn = function
| Pxp_core_types.At(s,exn) -> prerr_endline s; handle_pxp_exn exn
| exn -> prerr_endline (Printexc.to_string exn)
type out = { f : 'a. int -> ('a,unit,string,unit) format4 -> 'a;
nl : 'a. int -> ('a,unit,string,unit) format4 -> 'a;
raw : string -> unit;
filename: string option;
}
let rec copy_node (out : out) level node : unit = match node # node_type, node
sub_nodes with
iter_nodes (copy_node out 0); close_tag out 0 s
| _ -> ()
and open_tag (out : out) level name attributes : unit =
out.f level "<%s " name;
copy_attributes out attributes;
out.f level ">"
and close_tag (out : out) level name : unit =
out.f level "</%s>" name
and empty_tag (out : out) level name attributes : unit =
out.f level "<%s " name;
copy_attributes out attributes;
out.f level "/>"
and copy_attributes (out : out) attributes = match attributes with
| (name, Value v) :: [] -> out.f 0 "%s='%s'" name (to_xml_quote_attribute
v)
| (name, Value v) :: tl -> out.f 0 "%s='%s' " name (to_xml_quote_attribute
v); copy_attributes out tl
| (name, Valuelist vl) :: [] -> out.f 0 "%s='%s'" name
(to_xml_quote_attribute (String.concat " " vl))
| (name, Valuelist vl) :: tl -> out.f 0 "%s='%s' " name
(to_xml_quote_attribute (String.concat " " vl)); copy_attributes out tl
| (_, Implied_value) :: tl -> copy_attributes out tl
| [] -> ()
let rec clone_with_new_dtd (dtd : dtd) (node : 'a node) =
let position = node # position in
let valcheck = false in
let att_values = node # attributes in
let node_type = node # node_type in
let node' = node # create_element ~position ~valcheck ~att_values dtd
node_type [] in
let sub_nodes = List.map (clone_with_new_dtd dtd) node # sub_nodes in
node' # set_nodes sub_nodes;
node'
class counter = object
val mutable state = 0
method get = let n = state in state <- succ n; n
end
class base_ext (index : 'a reverse_hash_index) =
object (self : 'a node #extension as 'a )
(* constraint 'node = 'a node *)
val mutable node = lazy_error
val mutable elt_type = lazy_error
val mutable required_string_attribute = fun n -> assert false
val mutable optional_string_attribute = fun n -> assert false
val mutable required_list_attribute = fun n -> assert false
val mutable optional_list_attribute = fun n -> assert false
())
attributes in
let other_attributes = List.stable_sort Pervasives.compare node #
attributes in
if these_attributes <> other_attributes then false else
List.fold_left2 (fun flag n1 n2 -> flag && n1 # extension # equals n2)
true self # node # sub_nodes node # sub_nodes
end
end
--------------000900010702060808050907
Content-Type: text/plain;
name="test_case_309_try_1.ml"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="test_case_309_try_1.ml"
(*
*)
#use "topfind";;
#require "pxp-engine";;
#camlp4o;;
#use "test_case_309_prerequisites.ml"
;;
(* The real thing begins here. *)
open Pxp_types
open Pxp_document
open Pxp_tree_parser
class type_index =
object (self)
val table : (string*string, string) Hashtbl.t = Hashtbl.create 32
method add language er_type implementation =
Hashtbl.add table (language,er_type) implementation
method find language er_type = Hashtbl.find table (language,er_type)
end
;;
(* class xdbs_ext : ('a Pxp_document.node #Pxp_document.extension as 'a) = *)
fun (index : 'a reverse_hash_index) (type_index : type_index) ->
object (self : 'a Pxp_document.node #Pxp_document.extension as 'a )
inherit Xdbs_base.base_ext (index : 'a reverse_hash_index )
method scan_types = ()
method fragment = required_string_attribute "fragment"
method applications = optional_list_attribute "applications"
method from = required_string_attribute "from"
method table = required_string_attribute "table"
method alias = required_string_attribute "alias"
method ways = int_of_string (required_string_attribute "ways")
method criterion = required_string_attribute "criterion"
method member_ids = required_list_attribute "members"
method member_nodes = List.rev_map (fun id -> (self # find id)) self #
member_ids
method foreign_ids = required_list_attribute "foreign"
method foreign = List.rev_map (fun id -> (self # find id)) self # foreign_ids
method prefix = optional_list_attribute "prefix"
method join_type = optional_string_attribute "type"
method alias_opt = optional_string_attribute "alias"
method value_opt = optional_string_attribute "value"
method counter_opt = optional_string_attribute "counter"
method method_opt = optional_string_attribute "method"
method super = self # find self # from
method column_name =
String.concat "_" (self # prefix @ [self # name])
method sql_type db_driver =
let _type = self # _type in
try type_index # find db_driver self # _type with
| Not_found -> _type
method fragmentation_nodes =
let idrefs = self # idref_find in
let predicate n = match n # node_type with T_element "slice" -> true | _ ->
false in
List.filter predicate idrefs
end
;;
class data_implementation_ext (index : 'a reverse_hash_index) (type_index :
type_index) =
object (self : 'a node #extension as 'a)
inherit xdbs_ext index type_index
method private language = required_string_attribute "language"
method private is = required_string_attribute "is"
method scan_types = type_index # add (self # language) (self # _type) (self #
is)
end
--------------000900010702060808050907
Content-Type: text/plain;
name="test_case_309_try_2.ml"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="test_case_309_try_2.ml"
(*
*)
#use "topfind";;
#require "pxp-engine";;
(* #camlp4o;; *)
#use "test_case_309_prerequisites.ml"
;;
(* The real thing begins here. *)
open Pxp_types
open Pxp_document
open Pxp_tree_parser
class type_index =
object (self)
val table : (string*string, string) Hashtbl.t = Hashtbl.create 32
method add language er_type implementation =
Hashtbl.add table (language,er_type) implementation
method find language er_type = Hashtbl.find table (language,er_type)
end
;;
(* class xdbs_ext : ('a Pxp_document.node #Pxp_document.extension as 'a) = *)
fun (index : 'a reverse_hash_index) (type_index : type_index) ->
object (self : 'a Pxp_document.node #Pxp_document.extension as 'a )
inherit Xdbs_base.base_ext (index : 'a reverse_hash_index )
method scan_types = ()
method fragment = required_string_attribute "fragment"
method applications = optional_list_attribute "applications"
method from = required_string_attribute "from"
method table = required_string_attribute "table"
method alias = required_string_attribute "alias"
method ways = int_of_string (required_string_attribute "ways")
method criterion = required_string_attribute "criterion"
method member_ids = required_list_attribute "members"
method member_nodes = List.rev_map (fun id -> (self # find id)) self #
member_ids
method foreign_ids = required_list_attribute "foreign"
method foreign = List.rev_map (fun id -> (self # find id)) self # foreign_ids
method prefix = optional_list_attribute "prefix"
method join_type = optional_string_attribute "type"
method alias_opt = optional_string_attribute "alias"
method value_opt = optional_string_attribute "value"
method counter_opt = optional_string_attribute "counter"
method method_opt = optional_string_attribute "method"
method super = self # find self # from
method column_name =
String.concat "_" (self # prefix @ [self # name])
method sql_type db_driver =
let _type = self # _type in
try type_index # find db_driver self # _type with
| Not_found -> _type
method fragmentation_nodes =
let idrefs = self # idref_find in
let predicate n = match n # node_type with T_element "slice" -> true | _ ->
false in
List.filter predicate idrefs
end
;;
class data_implementation_ext (index : 'a reverse_hash_index) (type_index :
type_index) =
object (self : 'a node #extension as 'a)
inherit xdbs_ext index type_index
method private language = required_string_attribute "language"
method private is = required_string_attribute "is"
method scan_types = type_index # add (self # language) (self # _type) (self #
is)
end
--------------000900010702060808050907--
The text was updated successfully, but these errors were encountered: