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
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
|
(* (C) 1999-2004 *)
(* Cuihtlauac Alvarado, France Telecon, Recherche & Developement *)
(* Jean-Franois Monin, Universit Joseph Fourier - VERIMAG *)
(* $Id: pr.ml,v 1.16 2007-03-15 22:40:43 tews Exp $ *)
(* ocamlc options: !-pp "camlp4o q_MLast.cmo" -I `camlp4 -where`!*)
(* ocamldep options: !-pp "camlp4o q_MLast.cmo"!*)
module type Tags_param = sig
val add : string -> int * int -> unit
end
module Tags = functor (T : Tags_param) -> struct
(*
let _ =
try Sys.getenv Argcamlp4.tmp
with Not_found -> failwith ("Environment variable " ^ Argcamlp4.tmp ^ " not set")
in ()
*)
(* TODO: remove this crap *)
let kludge (a, b) = a.Lexing.pos_cnum, b.Lexing.pos_cnum
let rec pe_patt ast =
let loc = kludge (MLast.loc_of_patt ast) in
match ast with
| <:patt< ( $p1$ as $p2$ ) >> -> pe_patt p1; pe_patt p2
| <:patt< $lid:i$ >> -> T.add i loc
| <:patt< ( $list:pl$ ) >> -> List.iter pe_patt pl
| <:patt< ( $p$ : $t$ ) >> -> pe_patt p
| <:patt< $_$ >> -> ()
let rec pe_ctyp ast =
(* let loc = kludge (MLast.loc_of_ctyp ast) in *)
match ast with
| <:ctyp< $t1$ as $t2$ >> -> pe_ctyp t1; pe_ctyp t2
| <:ctyp< $t1$ == $t2$ >> -> pe_ctyp t1; pe_ctyp t2
| <:ctyp< { $list:sbtl$ } >> ->
List.iter (fun (loc,s,_,c) -> T.add s (kludge loc); pe_ctyp c) sbtl
| <:ctyp< [ $list:stll$ ] >> ->
List.iter (fun (loc,s,l) -> T.add s (kludge loc); List.iter pe_ctyp l) stll
| _ -> ()
let pe_class_str_item ast =
let loc = kludge (MLast.loc_of_class_str_item ast) in
match ast with
| <:class_str_item< value $opt:mf$ $lab$ = $e$ >> -> T.add lab loc
| <:class_str_item< method virtual private $s$ : $t$ >> -> T.add s loc
| <:class_str_item< method virtual $l$ : $t$ >> -> T.add l loc
| <:class_str_item< method private $l$ = $fb$ >> -> T.add l loc
| <:class_str_item< method $l$ = $fb$ >> -> T.add l loc
| _ -> ()
let rec pe_class_expr ast =
(* let loc = kludge (MLast.loc_of_class_expr ast) in *)
match ast with
| <:class_expr< object $opt:cspo$ $list:cf$ end >> -> List.iter pe_class_str_item cf
| <:class_expr< let $opt:rf$ $list:_$ in $ce$ >> -> pe_class_expr ce
| <:class_expr< $ce$ $expr$ >> -> pe_class_expr ce
| <:class_expr< fun $p$ -> $cfb$ >> -> pe_class_expr cfb
| <:class_expr< ($ce$ : $ct$) >> -> pe_class_expr ce
| <:class_expr< $list:id$ [ $list:tl$ ] >> -> ()
(* next one is possible but not neccessary *)
(* | <:class_expr< $list:id$ >> -> () *)
let etag_class_info {MLast.ciNam = s; MLast.ciExp = c; MLast.ciLoc = loc} =
T.add s (kludge loc); pe_class_expr c
let rec pe_class_sig_item ast =
let loc = kludge (MLast.loc_of_class_sig_item ast) in
match ast with
(* CgCtr *)
| <:class_sig_item< type $t1$ = $t2$ >> ->
()
| <:class_sig_item< declare $list:csil$ end >> ->
List.iter pe_class_sig_item csil
(* CgInh *)
| <:class_sig_item< inherit $cs$ >> -> ()
(* CgMth *)
| <:class_sig_item< method private $name$ : $t$ >> ->
T.add name loc
| <:class_sig_item< method $name$ : $t$ >> ->
T.add name loc
(* CgVal *)
| <:class_sig_item< value $opt:mf$ $name$ : $t$ >> ->
T.add name loc
(* CgVir *)
| <:class_sig_item< method virtual private $name$ : $t$ >> ->
T.add name loc
| <:class_sig_item< method virtual $name$ : $t$ >> ->
T.add name loc
let rec pe_class_type ast =
(* let loc = kludge (MLast.loc_of_class_type ast) in *)
match ast with
| <:class_type< $list:id$ [ $list:tl$ ] >> -> ()
(* possible but not necessary
* | <:class_type< $list:id$ >> -> ()
*)
(* functional class types occur in class specifications in mli files *)
| <:class_type< [ $typ$ ] -> $ct$ >> -> pe_class_type ct
| <:class_type< object $opt:cst$ $list:csf$ end >> ->
List.iter pe_class_sig_item csf
let etag_class_type_info
{MLast.ciNam = s; MLast.ciExp = c; MLast.ciLoc = loc} =
T.add s (kludge loc); pe_class_type c
let rec pe_str_item ast =
let loc = kludge (MLast.loc_of_str_item ast) in
match ast with
| <:str_item< declare $list:stl$ end >> -> List.iter pe_str_item stl
| <:str_item< exception $s$ of $list:tl$ >> -> T.add s loc
| <:str_item< $exp:e$ >> -> () (* toplevel expression *)
| <:str_item< external $s$ : $t$ = $list:sl$ >> -> T.add s loc
| <:str_item< module $s$ = $me$ >> -> T.add s loc; pe_module_expr me
| <:str_item< module type $i$ = $mt$ >>
-> T.add i loc; pe_module_type_expr mt
| <:str_item< type $list:ssltl$ >> ->
List.iter (fun ((loc,s),_,c,_) -> T.add s (kludge loc); pe_ctyp c) ssltl
| <:str_item< value $opt:rf$ $list:pel$ >> -> List.iter (fun (p, _) -> pe_patt p) pel
| <:str_item< class $list:cd$ >> ->
List.iter (etag_class_info) cd
| <:str_item< class type $list:ctd$ >> ->
List.iter (etag_class_type_info) ctd
(* missing constructors
StOpn (_, _)|StInc (_, _)|StDir (_, _, _)
*)
| _ -> ()
and pe_module_expr ast =
(* let loc = kludge (MLast.loc_of_module_expr ast) in *)
match ast with
| <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> -> pe_module_expr me
| <:module_expr< struct $list:st$ end >> -> List.iter pe_str_item st
| _ -> ()
and pe_module_type_expr ast =
(* let loc = kludge (MLast.loc_of_module_type ast) in *)
match ast with
| <:module_type< $mt1$ . $mt2$ >>
(*
* if I understand the grammar right, mt1 and mt2 can
* only be (sequences) of identifiers. Recurse anyway.
*)
-> pe_module_type_expr mt1; pe_module_type_expr mt2
| <:module_type< $mt1$ $mt2$ >> (* same comment as above *)
-> pe_module_type_expr mt1; pe_module_type_expr mt2
| <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >>
-> pe_module_type_expr mt1; pe_module_type_expr mt2
| <:module_type< $lid:i$ >> -> ()
| <:module_type< sig $list:sil$ end >> -> List.iter pe_sig_item sil
| <:module_type< $uid:i$ >> -> ()
| <:module_type< $mt$ with $list:wcl$ >> ->
pe_module_type_expr mt
(* missing constructor
MtQuo (_, _)
*)
| _ -> ()
and pe_sig_item ast =
let loc = kludge (MLast.loc_of_sig_item ast) in
match ast with
| <:sig_item< declare $list:stl$ end >> -> List.iter pe_sig_item stl
| <:sig_item< exception $s$ of $list:tl$ >> -> T.add s loc
| <:sig_item< external $s$ : $t$ = $list:sl$ >> -> T.add s loc
| <:sig_item< module $s$ : $mt$ >> -> T.add s loc; pe_module_type_expr mt
| <:sig_item< module type $i$ = $mt$ >>
-> T.add i loc; pe_module_type_expr mt
| <:sig_item< open $sl$ >> -> ()
| <:sig_item< type $list:ssltl$ >> ->
List.iter (fun ((loc,s),_,c,_) -> T.add s (kludge loc); pe_ctyp c) ssltl
| <:sig_item< value $s$ : $t$ >> -> T.add s loc
| <:sig_item< class $list:cd$ >> -> List.iter (etag_class_type_info) cd
| <:sig_item< class type $list:cd$ >> -> List.iter etag_class_type_info cd
(* missing Constructors
SgInc (_, _)|SgDir (_, _, _)
*)
| _ -> ()
let rec implem = function
| [] -> ()
| (a, _) :: l -> pe_str_item a; implem l
let rec interf = function
| [] -> ()
| (a, _) :: l -> pe_sig_item a; interf l
let _ = Pcaml.print_implem := implem
let _ = Pcaml.print_interf := interf
(* switch off lexing of quotations *)
let _ = Plexer.no_quotations := true
let _ = Pcaml.add_option "-with-quotations"
(Arg.Clear Plexer.no_quotations) "Enable quotation parsing"
let _ = Pcaml.add_option "-mli-only-module"
(Arg.Unit (fun () -> Pcaml.print_interf := (fun _ -> ())))
"do not process interface content"
end (* Tags *)
|
