Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[3.09.0] Assert failure in typeclass.ml: Parser bug? #3856

Closed
vicuna opened this issue Nov 10, 2005 · 3 comments
Closed

[3.09.0] Assert failure in typeclass.ml: Parser bug? #3856

vicuna opened this issue Nov 10, 2005 · 3 comments
Labels

Comments

@vicuna
Copy link

vicuna commented Nov 10, 2005

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
*

  • For in introduction, see the guide "Introduction into OcamlNet".
    *)

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)

  • val write : string -> unit = write
  • val onclose = onclose
  • val mutable channel_count = 0
  • val mutable closed = false
  • method private complain_closed() =
  • raise Closed_channel
  • method output buf pos len =
  • if closed then self # complain_closed();
  • write (String.sub buf pos len);
  • channel_count <- channel_count + len;
  • len
  • method really_output buf pos len =
  • if closed then self # complain_closed();
  • write (String.sub buf pos len);
  • channel_count <- channel_count + len
  • method output_char c =
  • if closed then self # complain_closed();
  • write (String.make 1 c);
  • channel_count <- channel_count + 1
  • method output_string s =
  • if closed then self # complain_closed();
  • write s;
  • channel_count <- channel_count + (String.length s)
  • method output_byte b =
  • if closed then self # complain_closed();
  • write (String.make 1 (Char.chr b));
  • channel_count <- channel_count + 1
  • method output_buffer b =
  • if closed then self # complain_closed();
  • let s = Buffer.contents b in
  •  write s;
    
  •  channel_count <- channel_count + (String.length s)
    
  • method output_channel ?len ch =
  • if closed then self # complain_closed();
  • let buf_len = 4096 in
  • let buffer = String.create buf_len in
  • let rec copy space_used =
  •  match len with
    
  • | None ->
  •   let card_read = ch # input buffer 0 buf_len in
    
  •     if card_read = 0 then
    
  •   space_used
    
  •     else begin
    
  •   write (String.sub buffer 0 card_read);
    
  •   copy (space_used + card_read)
    
  •     end
    
  • | Some n when space_used < n ->
  •   let max_read = min (n - space_used) buf_len  in
    
  •   let card_read = ch # input buffer 0 max_read in
    
  •     if card_read = 0 then
    
  •   space_used
    
  •     else begin
    
  •   write (String.sub buffer 0 card_read);
    
  •   copy (space_used + card_read)
    
  •     end
    
  • | Some n when space_used = n -> space_used
  • | _ -> assert false
  • in channel_count <- channel_count + (copy 0)
  • method flush() =
  • if closed then self # complain_closed();
  • ()
  • method close_out() =
  • if closed then self # complain_closed();
  • closed <- true;
  • onclose()
  • method pos_out =
  • if closed then self # complain_closed();
  • channel_count

+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 :

  • ?onclose:(unit -> unit) -> (* default: fun _ -> () *)
  • (string -> unit) ->
  • out_obj_channel
  • (* This out_obj_channel writes the data onto the passed function.
    • ~onclose: this function is called when the close_out method is invoked
  • *)

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 ->

  •     failwith "Pxp_document, method required_string_attribute: not found"
    
  •     failwith (Printf.sprintf "Pxp_document, method required_string_attribute
    

%S: not found" n)

   method optional_string_attribute n =
try

@@ -1962,7 +1962,7 @@
| Implied_value -> raise Not_found
with
Not_found ->

  •     failwith "Pxp_document, method required_list_attribute: not found"
    
  •     failwith (Printf.sprintf "Pxp_document, method required_list_attribute
    

%S: not found" n)

   method optional_list_attribute n =
try

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 @@

  • 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
       )
    

@@ -544,7 +575,7 @@
~document:doc
~specification:spec
~transform_dtd

  •            ~(id_index : 'ext #index option)
    
  •            ~(id_index : 'ext #reverse_index option)
      ~use_document_entity
               ~entry
      ~init_lexer =
    

@@ -557,7 +588,7 @@
cfg
spec
transform_dtd

  •  (id_index :> 'ext index option)
    
  •  (id_index :> 'ext reverse_index option)
    
    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 *)
    
  • in
  • match pobj # root with
  •  Some r -> r
    
  • | None -> raise(WF_error("No root element"))
    +;;

+let parse_content_entity_with_reverse_index ~id_index cfg src dtd spec =

  • (* Parse an element given as separate entity *)
  • 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 *)
    

@@ -722,7 +779,7 @@
dtd' # only_deterministic_models;
dtd')

  •  ~id_index:(id_index :> 'ext index option)
    
  •  ~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
  • iparse_document_entity
  •  ~transform_dtd:transform_dtd
    
  •  ?id_index:(idx : 'ext #reverse_index option :> 'ext reverse_index
    

option)

  •  cfg src spec false;;
    

+let parse_document_entity_with_reverse_index ?(transform_dtd = (fun x -> x))

  •                      ~id_index
    
  •                      cfg src spec =
    
    iparse_document_entity
    ~transform_dtd:transform_dtd
  • ?id_index:(id_index : 'ext #index option :> 'ext index option)
  • cfg src spec false;;
  • ~id_index:(id_index : 'ext #reverse_index :> 'ext reverse_index)
  • {cfg with idref_pass = true} src spec false;;

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 @@

  • 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

  • inherit [ 'ext ] hash_index
  • method ref_add : string -> 'ext node -> unit
  • method ref_find : string -> 'ext node list
  • method ref_index : (string, 'ext node) Hashtbl.t
    +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

    • to Ocamlnet made by Baretta SRL DE&IT.
  • *)
    +val parse_document_entity_with_reverse_index :
  • ?transform_dtd:(dtd -> dtd) ->
  • id_index:('ext reverse_index) ->
  • config -> source -> 'ext spec -> 'ext document
  • (* Like parse_document_entity except that the index object is required to be
    • a reverse_index, although it might be a fake reverse_index. In any case,
      an
    • idref_pass is done, even if config.idref_pass is false.
  • *)

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

    • to Ocamlnet made by Baretta SRL DE&IT.
  • *)
    val parse_content_entity :
    ?id_index:('ext index) ->
    config -> source -> dtd -> 'ext spec -> 'ext node
    @@ -97,6 +147,14 @@
    • violations of the uniqueness of IDs.
      *)

+val parse_content_entity_with_reverse_index :

  • id_index:('ext reverse_index) ->
  • config -> source -> dtd -> 'ext spec -> 'ext node
  • (* Like parse_content_entity except that the index object is required to be
    • a reverse_index, although it might be a fake reverse_index. In any case,
      an
    • idref_pass is done, even if config.idref_pass is false.
  • *)

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 =

  • 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
    

@@ -769,7 +776,8 @@
| _ -> assert false (* already caught above *)
)
| (`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))
    

@@ -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
    

@@ -969,7 +995,8 @@
| _ -> assert false (* already caught above *)
)
| (`Ident name,p1,p2) ->

  • let loc = mkloc p1 p2 in
    
  • let _loc = mkloc p1 p2 in
    
  •      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;
  •   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< () >>
    
    )
    ;;
    @@ -1164,7 +1205,8 @@

let expand_text_expr s =
check_file();

  • let loc = mkloc (1,0,0) (1,0,String.length s) in
  • let _loc = mkloc (1,0,0) (1,0,String.length s) in
  • let loc = _loc in
    <:expr< $str:s$ >>
    ;;

--------------000900010702060808050907
Content-Type: text/plain;
name="test_case_309_prerequisites.ml"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="test_case_309_prerequisites.ml"

(*

  •             AS/Xcaml snippets
    
  •             Copyright (c) 2003--2005 Baretta SRL
    
  •             Via Lago d'Orta 3
    
  •             20098 San Giuliano Milanese -- Italy
    
  • This code is free software. You may use it, modify it,
  • and redistribute it under the terms of the
  • GNU General Public License, Version 2. You may obtain
  • a copy of this license by writing to
  • Free Software Foundation, Inc.
  • 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  • Alessandro Baretta (Baretta DE&IT) a.baretta@barettadeit.com

*)

#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)

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

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"

(*

  •             AS/Xcaml snippets
    
  •             Copyright (c) 2003--2005 Baretta SRL
    
  •             Via Lago d'Orta 3
    
  •             20098 San Giuliano Milanese -- Italy
    
  • This code is free software. You may use it, modify it,
  • and redistribute it under the terms of the
  • GNU General Public License, Version 2. You may obtain
  • a copy of this license by writing to
  • Free Software Foundation, Inc.
  • 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  • Alessandro Baretta (Baretta DE&IT) a.baretta@barettadeit.com

*)

#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"

(*

  •             AS/Xcaml snippets
    
  •             Copyright (c) 2003--2005 Baretta SRL
    
  •             Via Lago d'Orta 3
    
  •             20098 San Giuliano Milanese -- Italy
    
  • This code is free software. You may use it, modify it,
  • and redistribute it under the terms of the
  • GNU General Public License, Version 2. You may obtain
  • a copy of this license by writing to
  • Free Software Foundation, Inc.
  • 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  • Alessandro Baretta (Baretta DE&IT) a.baretta@barettadeit.com

*)

#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--

@vicuna
Copy link
Author

vicuna commented Nov 14, 2005

Comment author: administrator

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.

Jacques

@vicuna
Copy link
Author

vicuna commented Nov 14, 2005

Comment author: administrator

Typing of immediate objects

@vicuna
Copy link
Author

vicuna commented Nov 21, 2005

Comment author: anonymous

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.

Jacques

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
Projects
None yet
Development

No branches or pull requests

1 participant