1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
(* camlp4r *)
(****************************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2002-2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the Objective *)
(* Caml source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Ast : Sig.Camlp4Ast)
: Sig.Quotation with module Ast = Ast
= struct
module Ast = Ast;
module DynAst = DynAst.Make Ast;
module Loc = Ast.Loc;
open Format;
open Sig;
type expand_fun 'a = Loc.t -> option string -> string -> 'a;
module Exp_key = DynAst.Pack(struct
type t 'a = unit;
end);
module Exp_fun = DynAst.Pack(struct
type t 'a = expand_fun 'a;
end);
value expanders_table =
(ref [] : ref (list ((string * Exp_key.pack) * Exp_fun.pack)));
value default = ref "";
value translate = ref (fun x -> x);
value expander_name name =
match translate.val name with
[ "" -> default.val
| name -> name ];
value find name tag =
let key = (expander_name name, Exp_key.pack tag ()) in
Exp_fun.unpack tag (List.assoc key expanders_table.val);
value add name tag f =
let elt = ((name, Exp_key.pack tag ()), Exp_fun.pack tag f) in
expanders_table.val := [elt :: expanders_table.val];
value dump_file = ref None;
module Error = struct
type error =
[ Finding
| Expanding
| ParsingResult of Loc.t and string
| Locating ];
type t = (string * string * error * exn);
exception E of t;
value print ppf (name, position, ctx, exn) =
let name = if name = "" then default.val else name in
let pp x = fprintf ppf "@?@[<2>While %s %S in a position of %S:" x name position in
let () =
match ctx with
[ Finding -> begin
pp "finding quotation";
if expanders_table.val = [] then
fprintf ppf "@ There is no quotation expander available."
else
begin
fprintf ppf "@ @[<hv2>Available quotation expanders are:@\n";
List.iter begin fun ((s,t),_) ->
fprintf ppf "@[<2>%s@ (in@ a@ position@ of %a)@]@ "
s Exp_key.print_tag t
end expanders_table.val;
fprintf ppf "@]"
end
end
| Expanding -> pp "expanding quotation"
| Locating -> pp "parsing"
| ParsingResult loc str ->
let () = pp "parsing result of quotation" in
match dump_file.val with
[ Some dump_file ->
let () = fprintf ppf " dumping result...\n" in
try
let oc = open_out_bin dump_file in
begin
output_string oc str;
output_string oc "\n";
flush oc;
close_out oc;
fprintf ppf "%a:" Loc.print (Loc.set_file_name dump_file loc);
end
with _ ->
fprintf ppf
"Error while dumping result in file %S; dump aborted"
dump_file
| None ->
fprintf ppf
"\n(consider setting variable Quotation.dump_file, or using the -QD option)"
]
]
in fprintf ppf "@\n%a@]@." ErrorHandler.print exn;
value to_string x =
let b = Buffer.create 50 in
let () = bprintf b "%a" print x in Buffer.contents b;
end;
let module M = ErrorHandler.Register Error in ();
open Error;
value expand_quotation loc expander pos_tag quot =
debug quot "expand_quotation: name: %s, str: %S@." quot.q_name quot.q_contents in
let loc_name_opt = if quot.q_loc = "" then None else Some quot.q_loc in
try expander loc loc_name_opt quot.q_contents with
[ Loc.Exc_located _ (Error.E _) as exc ->
raise exc
| Loc.Exc_located iloc exc ->
let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in
raise (Loc.Exc_located iloc exc1)
| exc ->
let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in
raise (Loc.Exc_located loc exc1) ];
value parse_quotation_result parse loc quot pos_tag str =
try parse loc str with
[ Loc.Exc_located iloc (Error.E (n, pos_tag, Expanding, exc)) ->
let ctx = ParsingResult iloc quot.q_contents in
let exc1 = Error.E (n, pos_tag, ctx, exc) in
raise (Loc.Exc_located iloc exc1)
| Loc.Exc_located iloc (Error.E _ as exc) ->
raise (Loc.Exc_located iloc exc)
| Loc.Exc_located iloc exc ->
let ctx = ParsingResult iloc quot.q_contents in
let exc1 = Error.E (quot.q_name, pos_tag, ctx, exc) in
raise (Loc.Exc_located iloc exc1) ];
value expand loc quotation tag =
let pos_tag = DynAst.string_of_tag tag in
let name = quotation.q_name in
debug quot "handle_quotation: name: %s, str: %S@." name quotation.q_contents in
let expander =
try find name tag
with
[ Loc.Exc_located _ (Error.E _) as exc -> raise exc
| Loc.Exc_located qloc exc ->
raise (Loc.Exc_located qloc (Error.E (name, pos_tag, Finding, exc)))
| exc ->
raise (Loc.Exc_located loc (Error.E (name, pos_tag, Finding, exc))) ]
in
let loc = Loc.join (Loc.move `start quotation.q_shift loc) in
expand_quotation loc expander pos_tag quotation;
end;
|
