1 (* camlp4r pa_extend.cmo q_MLast.cmo *)
2 (***********************************************************************)
6 (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
8 (* Copyright 2002 Institut National de Recherche en Informatique et *)
9 (* Automatique. Distributed only by permission. *)
11 (***********************************************************************)
13 (* $Id: pa_o.ml,v 1.66 2005/06/29 04:11:26 garrigue Exp $ *)
18 Pcaml.syntax_name.val := "OCaml";
19 Pcaml.no_constructors_arity.val := True;
21 (* ------------------------------------------------------------------------- *)
22 (* Hacked version of the lexer. *)
23 (* ------------------------------------------------------------------------- *)
27 value jrh_lexer = ref False;
29 value no_quotations = ref False;
31 (* The string buffering machinery *)
33 value buff = ref (String.create 80);
36 if len >= String.length buff.val then
37 buff.val := buff.val ^ String.create (String.length buff.val)
44 add_rec len 0 where rec add_rec len i =
45 if i == String.length s then len else add_rec (store len s.[i]) (succ i)
47 value get_buff len = String.sub buff.val 0 len;
51 value stream_peek_nth n strm =
52 loop n (Stream.npeek n strm) where rec loop n =
55 | [x] -> if n == 1 then Some x else None
56 | [_ :: l] -> loop (n - 1) l ]
61 [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
62 '\248'..'\255' | '0'..'9' | '_' | ''' as
70 [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
71 '%' | '.' | ':' | '<' | '>' | '|' | '$' as
75 ident2 (store len c) s
79 [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
80 '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' |
81 '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | ''' |
86 ident3 (store len c) s
90 [ [: `'o' | 'O'; s :] -> digits octal (store len 'o') s
91 | [: `'x' | 'X'; s :] -> digits hexa (store len 'x') s
92 | [: `'b' | 'B'; s :] -> digits binary (store len 'b') s
93 | [: a = number len :] -> a ]
96 [ [: d = kind; s :] -> digits_under kind (store len d) s
97 | [: :] -> raise (Stream.Error "ill-formed integer constant") ]
98 and digits_under kind len =
100 [ [: d = kind; s :] -> digits_under kind (store len d) s
101 | [: `'_'; s :] -> digits_under kind len s
102 | [: `'l' :] -> ("INT32", get_buff len)
103 | [: `'L' :] -> ("INT64", get_buff len)
104 | [: `'n' :] -> ("NATIVEINT", get_buff len)
105 | [: :] -> ("INT", get_buff len) ]
106 and octal = parser [ [: `('0'..'7' as d) :] -> d ]
107 and hexa = parser [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d) :] -> d ]
108 and binary = parser [ [: `('0'..'1' as d) :] -> d ]
111 [ [: `('0'..'9' as c); s :] -> number (store len c) s
112 | [: `'_'; s :] -> number len s
113 | [: `'.'; s :] -> decimal_part (store len '.') s
114 | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
115 | [: `'l' :] -> ("INT32", get_buff len)
116 | [: `'L' :] -> ("INT64", get_buff len)
117 | [: `'n' :] -> ("NATIVEINT", get_buff len)
118 | [: :] -> ("INT", get_buff len) ]
119 and decimal_part len =
121 [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s
122 | [: `'_'; s :] -> decimal_part len s
123 | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
124 | [: :] -> ("FLOAT", get_buff len) ]
125 and exponent_part len =
127 [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s
128 | [: a = end_exponent_part len :] -> a ]
129 and end_exponent_part len =
131 [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s
132 | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ]
133 and end_exponent_part_under len =
135 [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s
136 | [: `'_'; s :] -> end_exponent_part_under len s
137 | [: :] -> ("FLOAT", get_buff len) ]
140 value error_on_unknown_keywords = ref False;
141 value err loc msg = raise_with_loc loc (Token.Error msg);
143 (* ------------------------------------------------------------------------- *)
144 (* JRH's hack to make the case distinction "unmixed" versus "mixed" *)
145 (* ------------------------------------------------------------------------- *)
147 value is_uppercase s = String.uppercase s = s;
148 value is_only_lowercase s = String.lowercase s = s && not(is_uppercase s);
150 value jrh_identifier find_kwd id =
151 let jflag = jrh_lexer.val in
152 if id = "set_jrh_lexer" then
153 (let _ = jrh_lexer.val := True in ("",find_kwd "true"))
154 else if id = "unset_jrh_lexer" then
155 (let _ = jrh_lexer.val := False in ("",find_kwd "false"))
157 try ("", find_kwd id) with
160 if is_uppercase (String.sub id 0 1) then ("UIDENT", id)
162 else if is_uppercase (String.sub id 0 1) &&
163 is_only_lowercase (String.sub id 1 (String.length id - 1))
164 (***** Carl's alternative version
165 then ("UIDENT", id) else if is_uppercase (String.sub id 0 1) then ("LIDENT", "__uc_"^id) else ("LIDENT", id)];
167 then ("UIDENT", id) else ("LIDENT", id)];
169 (* ------------------------------------------------------------------------- *)
170 (* Back to original file with the mod of using the above. *)
171 (* ------------------------------------------------------------------------- *)
173 (* Debugging positions and locations *)
174 value eprint_pos msg p =
175 Printf.eprintf "%s: fname=%s; lnum=%d; bol=%d; cnum=%d%!"
176 msg p.Lexing.pos_fname p.Lexing.pos_lnum p.Lexing.pos_bol p.Lexing.pos_cnum
179 value eprint_loc (bp, ep) =
180 do { eprint_pos "P1=" bp; eprint_pos " --P2=" ep }
183 value check_location msg ((bp, ep) as loc) =
185 if (bp.Lexing.pos_lnum > ep.Lexing.pos_lnum ||
186 bp.Lexing.pos_bol > ep.Lexing.pos_bol ||
187 bp.Lexing.pos_cnum > ep.Lexing.pos_cnum ||
188 bp.Lexing.pos_lnum < 0 || ep.Lexing.pos_lnum < 0 ||
189 bp.Lexing.pos_bol < 0 || ep.Lexing.pos_bol < 0 ||
190 bp.Lexing.pos_cnum < 0 || ep.Lexing.pos_cnum < 0)
191 (* Here, we don't check
192 bp.Lexing.pos_cnum < bp.Lexing.pos_bol || ep.Lexing.pos_cnum < bp.Lexing.pos_bol
193 since the lexer is called on antiquotations, with cnum=0, but lnum and bolpos
194 have "correct" values *)
197 Printf.eprintf "*** Warning: (%s) strange positions ***\n" msg;
206 value debug_token ((kind, tok), loc) = do {
207 Printf.eprintf "%s(%s) at " kind tok;
209 Printf.eprintf "\n%!"
212 value rec next_token_fun dfa ssd find_kwd fname lnum bolpos glexr =
214 {Lexing.pos_fname = fname.val; Lexing.pos_lnum = lnum.val;
215 Lexing.pos_bol = bolpos.val; Lexing.pos_cnum = p} in
216 let mkloc (bp, ep) = (make_pos bp, make_pos ep) in
217 let keyword_or_error (bp,ep) s =
218 let loc = mkloc (bp, ep) in
219 try (("", find_kwd s), loc) with
221 if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s)
222 else (("", s), loc) ] in
223 let error_if_keyword ( ((_,id) as a), bep) =
224 let loc = mkloc bep in
227 err loc ("illegal use of a keyword as a label: " ^ id) }
228 with [ Not_found -> (a, loc) ]
230 let rec next_token after_space =
232 [ [: `'\010'; s :] ep ->
233 do { bolpos.val := ep; incr lnum; next_token True s }
234 | [: `'\013'; s :] ep ->
236 match Stream.peek s with
237 [ Some '\010' -> do { Stream.junk s; ep+1 }
239 do { bolpos.val := ep; incr lnum; next_token True s }
240 | [: `' ' | '\t' | '\026' | '\012'; s :] -> next_token True s
241 | [: `'#' when bp = bolpos.val; s :] ->
242 if linedir 1 s then do { line_directive s; next_token True s }
243 else keyword_or_error (bp, bp + 1) "#"
244 | [: `'('; s :] -> left_paren bp s
245 | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] ->
246 let id = get_buff (ident (store 0 c) s) in
247 let loc = mkloc (bp, (Stream.count s)) in
248 (jrh_identifier find_kwd id, loc)
250 (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc)
252 | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] ->
253 let id = get_buff (ident (store 0 c) s) in
254 let loc = mkloc (bp, (Stream.count s)) in
255 (jrh_identifier find_kwd id, loc)
257 (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc)
259 | [: `('1'..'9' as c); s :] ->
260 let tok = number (store 0 c) s in
261 let loc = mkloc (bp, (Stream.count s)) in
264 let tok = base_number (store 0 '0') s in
265 let loc = mkloc (bp, (Stream.count s)) in
268 match Stream.npeek 2 s with
269 [ [_; '''] | ['\\'; _] ->
270 let tok = ("CHAR", get_buff (char bp 0 s)) in
271 let loc = mkloc (bp, (Stream.count s)) in
273 | _ -> keyword_or_error (bp, Stream.count s) "'" ]
275 let bpos = make_pos bp in
276 let tok = ("STRING", get_buff (string bpos 0 s)) in
277 let loc = mkloc (bp, Stream.count s) in
280 let tok = ("QUOTATION", "tot:"^(qstring bp 0 s)) in
281 let loc = mkloc (bp, Stream.count s) in
284 let bpos = make_pos bp in
285 let tok = dollar bpos 0 s in
286 let loc = (bpos, make_pos (Stream.count s)) in
288 | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c);
290 let id = get_buff (ident2 (store 0 c) s) in
291 keyword_or_error (bp, Stream.count s) id
295 [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep ->
296 let id = get_buff len in
298 [ [: `':' :] ep -> error_if_keyword (("LABEL", id), (bp, ep))
299 | [: :] -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) ]
301 let id = get_buff (ident2 (store 0 c) s) in
302 keyword_or_error (bp, Stream.count s) id ] :] ->
308 [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep ->
309 let id = get_buff len in
311 [ [: `':' :] ep -> error_if_keyword (("OPTLABEL", id), (bp,ep))
312 | [: :] -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep)) ]
314 let id = get_buff (ident2 (store 0 c) s) in
315 keyword_or_error (bp, Stream.count s) id ] :] ->
317 | [: `'<'; s :] -> less bp s
321 [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2
322 | [: :] -> store 0 c1 ] :] ep ->
323 let id = get_buff len in
324 keyword_or_error (bp, ep) id
325 | [: `('>' | '|' as c1);
328 [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
329 | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
330 let id = get_buff len in
331 keyword_or_error (bp, ep) id
332 | [: `('[' | '{' as c1); s :] ->
334 match Stream.npeek 2 s with
335 [ ['<'; '<' | ':'] -> store 0 c1
338 [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
339 | [: :] -> store 0 c1 ] ]
341 let ep = Stream.count s in
342 let id = get_buff len in
343 keyword_or_error (bp, ep) id
348 | [: :] -> if ssd && after_space then " ." else "." ] :] ep ->
349 keyword_or_error (bp, ep) id
354 | [: :] -> ";" ] :] ep ->
355 keyword_or_error (bp, ep) id
356 | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), mkloc (bp, ep))
357 | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c)
358 | [: _ = Stream.empty :] -> (("EOI", ""), mkloc (bp, succ bp)) ]
360 if no_quotations.val then
361 match strm with parser
362 [ [: len = ident2 (store 0 '<') :] ep ->
363 let id = get_buff len in
364 keyword_or_error (bp, ep) id ]
366 let bpos = make_pos bp in
367 match strm with parser
368 [ [: `'<'; len = quotation bpos 0 :] ep ->
369 (("QUOTATION", ":" ^ get_buff len), (bpos, make_pos ep))
370 | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
371 `'<' ? "character '<' expected"; len = quotation bpos 0 :] ep ->
372 (("QUOTATION", i ^ ":" ^ get_buff len), (bpos, make_pos ep))
373 | [: len = ident2 (store 0 '<') :] ep ->
374 let id = get_buff len in
375 keyword_or_error (bp, ep) id ]
378 [ [: `'`' :] -> get_buff len
379 | [: `c; s :] -> qstring bp (store len c) s
380 | [: :] ep -> err (mkloc (bp, ep)) "quotation not terminated" ]
381 and string bpos len =
384 | [: `'\\'; `c; s :] ep ->
385 let len = store len '\\' in
387 '\010' -> do { bolpos.val := ep; incr lnum; string bpos (store len c) s }
390 match Stream.peek s with [
391 Some '\010' -> do { Stream.junk s; (store (store len '\013') '\010', ep+1) }
392 | _ -> (store len '\013', ep) ] in
393 do { bolpos.val := ep; incr lnum; string bpos len s }
394 | c -> string bpos (store len c) s
396 | [: `'\010'; s :] ep -> do { bolpos.val := ep; incr lnum; string bpos (store len '\010') s }
397 | [: `'\013'; s :] ep ->
399 match Stream.peek s with
400 [ Some '\010' -> do { Stream.junk s; (store (store len '\013') '\010', ep+1) }
401 | _ -> (store len '\013', ep) ] in
402 do { bolpos.val := ep; incr lnum; string bpos len s }
403 | [: `c; s :] -> string bpos (store len c) s
404 | [: :] ep -> err (bpos, make_pos ep) "string not terminated" ]
407 [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len
408 | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s
409 | [: `'\010'; s :] -> do {bolpos.val := bp+1; incr lnum; char bp (store len '\010') s}
410 | [: `'\013'; s :] ->
412 match Stream.peek s with
413 [ Some '\010' -> do { Stream.junk s; bp+2 }
415 do { bolpos.val := bol; incr lnum; char bp (store len '\013') s}
416 | [: `c; s :] -> char bp (store len c) s
417 | [: :] ep -> err (mkloc (bp, ep)) "char not terminated" ]
418 and dollar bpos len s =
419 if no_quotations.val then
420 ("", get_buff (ident2 (store 0 '$') s))
421 else match s with parser
422 [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
423 | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bpos (store len c) s
424 | [: `('0'..'9' as c); s :] -> maybe_locate bpos (store len c) s
426 let k = get_buff len in
427 ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bpos 0 s)
428 | [: `'\\'; `c; s :] ->
429 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s)
434 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s)
435 | [: :] ep -> err (bpos, make_pos ep) "antiquotation not terminated" ]
436 else ("", get_buff (ident2 (store 0 '$') s)) ]
437 and maybe_locate bpos len =
439 [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
440 | [: `('0'..'9' as c); s :] -> maybe_locate bpos (store len c) s
442 ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bpos 0 s)
443 | [: `'\\'; `c; s :] ->
444 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s)
446 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s)
447 | [: :] ep -> err (bpos, make_pos ep) "antiquotation not terminated" ]
448 and antiquot bpos len =
450 [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
451 | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
452 antiquot bpos (store len c) s
454 let k = get_buff len in
455 ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bpos 0 s)
456 | [: `'\\'; `c; s :] ->
457 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s)
459 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s)
460 | [: :] ep -> err (bpos, make_pos ep) "antiquotation not terminated" ]
461 and locate_or_antiquot_rest bpos len =
463 [ [: `'$' :] -> get_buff len
464 | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bpos (store len c) s
465 | [: `c; s :] -> locate_or_antiquot_rest bpos (store len c) s
466 | [: :] ep -> err (bpos, make_pos ep) "antiquotation not terminated" ]
467 and quotation bpos len =
469 [ [: `'>'; s :] -> maybe_end_quotation bpos len s
471 quotation bpos (maybe_nested_quotation bpos (store len '<') s) s
475 [ [: `('>' | '<' | '\\' as c) :] -> store len c
476 | [: :] -> store len '\\' ];
479 | [: `'\010'; s :] ep -> do {bolpos.val := ep; incr lnum; quotation bpos (store len '\010') s}
480 | [: `'\013'; s :] ep ->
482 match Stream.peek s with
483 [ Some '\010' -> do { Stream.junk s; ep+1 }
485 do { bolpos.val := bol; incr lnum; quotation bpos (store len '\013') s}
486 | [: `c; s :] -> quotation bpos (store len c) s
487 | [: :] ep -> err (bpos, make_pos ep) "quotation not terminated" ]
488 and maybe_nested_quotation bpos len =
490 [ [: `'<'; s :] -> mstore (quotation bpos (store len '<') s) ">>"
491 | [: `':'; len = ident (store len ':');
494 [ [: `'<'; s :] -> mstore (quotation bpos (store len '<') s) ">>"
495 | [: :] -> len ] :] ->
498 and maybe_end_quotation bpos len =
501 | [: a = quotation bpos (store len '>') :] -> a ]
504 [ [: `'*'; _ = comment (make_pos bp); a = next_token True :] -> a
505 | [: :] ep -> keyword_or_error (bp, ep) "(" ]
508 [ [: `'('; s :] -> left_paren_in_comment bpos s
509 | [: `'*'; s :] -> star_in_comment bpos s
510 | [: `'"'; _ = string bpos 0; s :] -> comment bpos s
511 | [: `'''; s :] -> quote_in_comment bpos s
512 | [: `'\010'; s :] ep -> do { bolpos.val := ep; incr lnum; comment bpos s }
513 | [: `'\013'; s :] ep ->
515 match Stream.peek s with
516 [ Some '\010' -> do { Stream.junk s; ep+1 }
518 do { bolpos.val := ep; incr lnum; comment bpos s }
519 | [: `c; s :] -> comment bpos s
520 | [: :] ep -> err (bpos, make_pos ep) "comment not terminated" ]
521 and quote_in_comment bpos =
523 [ [: `'''; s :] -> comment bpos s
524 | [: `'\\'; s :] -> quote_antislash_in_comment bpos 0 s
527 match Stream.npeek 2 s with
528 [ [ ( '\013' | '\010' ); '''] ->
529 do { bolpos.val := ep; incr lnum;
530 Stream.junk s; Stream.junk s }
531 | [ '\013'; '\010' ] ->
532 match Stream.npeek 3 s with
533 [ [_; _; '''] -> do { bolpos.val := ep + 1; incr lnum;
534 Stream.junk s; Stream.junk s; Stream.junk s }
536 | [_; '''] -> do { Stream.junk s; Stream.junk s }
540 and quote_any_in_comment bp =
542 [ [: `'''; s :] -> comment bp s
543 | [: a = comment bp :] -> a ]
544 and quote_antislash_in_comment bp len =
546 [ [: `'''; s :] -> comment bp s
547 | [: `'\\' | '"' | 'n' | 't' | 'b' | 'r'; s :] ->
548 quote_any_in_comment bp s
549 | [: `'0'..'9'; s :] -> quote_antislash_digit_in_comment bp s
550 | [: a = comment bp :] -> a ]
551 and quote_antislash_digit_in_comment bp =
553 [ [: `'0'..'9'; s :] -> quote_antislash_digit2_in_comment bp s
554 | [: a = comment bp :] -> a ]
555 and quote_antislash_digit2_in_comment bp =
557 [ [: `'0'..'9'; s :] -> quote_any_in_comment bp s
558 | [: a = comment bp :] -> a ]
559 and left_paren_in_comment bpos =
561 [ [: `'*'; s :] -> do { comment bpos s; comment bpos s }
562 | [: a = comment bpos :] -> a ]
563 and star_in_comment bpos =
566 | [: a = comment bpos :] -> a ]
568 match stream_peek_nth n s with
569 [ Some (' ' | '\t') -> linedir (n + 1) s
570 | Some ('0'..'9') -> True
574 [ [: `'\010'; _s :] ep ->
575 do { bolpos.val := ep; incr lnum }
576 | [: `'\013'; s :] ep ->
578 match Stream.peek s with
579 [ Some '\010' -> do { Stream.junk s; ep+1 }
581 do { bolpos.val := ep; incr lnum }
582 | [: `_; s :] -> any_to_nl s
584 and line_directive = parser (* we are sure that there is a line directive here *)
585 [ [: _ = skip_spaces; n = line_directive_number 0;
586 _ = skip_spaces; _ = line_directive_string;
588 -> do { (* fname has been updated by by line_directive_string *)
589 bolpos.val := ep; lnum.val := n
592 and skip_spaces = parser
593 [ [: `' ' | '\t'; s :] -> skip_spaces s
595 and line_directive_number n = parser
596 [ [: `('0'..'9' as c) ; s :]
597 -> line_directive_number (10*n + (Char.code c - Char.code '0')) s
599 and line_directive_string = parser
600 [ [: ` '"' ; _ = line_directive_string_contents 0 :] -> ()
603 and line_directive_string_contents len = parser
604 [ [: ` '\010' | '\013' :] -> ()
605 | [: ` '"' :] -> fname.val := get_buff len
606 | [: `c; s :] -> line_directive_string_contents (store len c) s
611 let glex = glexr.val in
612 let comm_bp = Stream.count cstrm in
613 let r = next_token False cstrm in
615 match glex.tok_comm with
617 let next_bp = (fst (snd r)).Lexing.pos_cnum in
618 if next_bp > comm_bp then
619 let comm_loc = mkloc (comm_bp, next_bp) in
620 glex.tok_comm := Some [comm_loc :: list]
627 [ Stream.Error str ->
628 err (mkloc (Stream.count cstrm, Stream.count cstrm + 1)) str ]
632 value dollar_for_antiquotation = ref True;
633 value specific_space_dot = ref False;
635 value func kwd_table glexr =
636 let bolpos = ref 0 in
638 let fname = ref "" in
639 let find = Hashtbl.find kwd_table in
640 let dfa = dollar_for_antiquotation.val in
641 let ssd = specific_space_dot.val in
642 (Token.lexer_func_of_parser (next_token_fun dfa ssd find fname lnum bolpos glexr),
643 (bolpos, lnum, fname))
646 value rec check_keyword_stream =
647 parser [: _ = check; _ = Stream.empty :] -> True
650 [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255'
654 | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
660 match Stream.npeek 1 s with
662 | _ -> check_ident2 s ]
666 [ [: `']' | ':' | '=' | '>' :] -> ()
667 | [: :] -> () ] :] ->
672 [ [: `']' | '}' :] -> ()
673 | [: a = check_ident2 :] -> a ] :] ->
675 | [: `'[' | '{'; s :] ->
676 match Stream.npeek 2 s with
677 [ ['<'; '<' | ':'] -> ()
680 [ [: `'|' | '<' | ':' :] -> ()
686 | [: :] -> () ] :] ->
691 [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
692 '\248'..'\255' | '0'..'9' | '_' | '''
699 [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
700 '%' | '.' | ':' | '<' | '>' | '|'
707 value check_keyword s =
708 try check_keyword_stream (Stream.of_string s) with _ -> False
711 value error_no_respect_rules p_con p_prm =
715 (if p_con = "" then "\"" ^ p_prm ^ "\""
716 else if p_prm = "" then p_con
717 else p_con ^ " \"" ^ p_prm ^ "\"") ^
718 " does not respect Plexer rules"))
721 value error_ident_and_keyword p_con p_prm =
724 ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^
728 value using_token kwd_table ident_table (p_con, p_prm) =
731 if not (Hashtbl.mem kwd_table p_prm) then
732 if check_keyword p_prm then
733 if Hashtbl.mem ident_table p_prm then
734 error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm
735 else Hashtbl.add kwd_table p_prm p_prm
736 else error_no_respect_rules p_con p_prm
739 if p_prm = "" then ()
742 [ 'A'..'Z' -> error_no_respect_rules p_con p_prm
744 if Hashtbl.mem kwd_table p_prm then
745 error_ident_and_keyword p_con p_prm
746 else Hashtbl.add ident_table p_prm p_con ]
748 if p_prm = "" then ()
751 [ 'a'..'z' -> error_no_respect_rules p_con p_prm
753 if Hashtbl.mem kwd_table p_prm then
754 error_ident_and_keyword p_con p_prm
755 else Hashtbl.add ident_table p_prm p_con ]
756 | "INT" | "INT32" | "INT64" | "NATIVEINT"
757 | "FLOAT" | "CHAR" | "STRING"
758 | "TILDEIDENT" | "QUESTIONIDENT" | "LABEL" | "OPTLABEL"
759 | "QUOTATION" | "ANTIQUOT" | "LOCATE" | "EOI" ->
764 ("the constructor \"" ^ p_con ^
765 "\" is not recognized by Plexer")) ]
768 value removing_token kwd_table ident_table (p_con, p_prm) =
770 [ "" -> Hashtbl.remove kwd_table p_prm
771 | "LIDENT" | "UIDENT" ->
772 if p_prm <> "" then Hashtbl.remove ident_table p_prm else ()
778 [ ("", t) -> "'" ^ t ^ "'"
779 | ("LIDENT", "") -> "lowercase identifier"
780 | ("LIDENT", t) -> "'" ^ t ^ "'"
781 | ("UIDENT", "") -> "uppercase identifier"
782 | ("UIDENT", t) -> "'" ^ t ^ "'"
783 | ("INT", "") -> "integer"
784 | ("INT32", "") -> "32 bits integer"
785 | ("INT64", "") -> "64 bits integer"
786 | ("NATIVEINT", "") -> "native integer"
787 | (("INT" | "INT32" | "NATIVEINT"), s) -> "'" ^ s ^ "'"
788 | ("FLOAT", "") -> "float"
789 | ("STRING", "") -> "string"
790 | ("CHAR", "") -> "char"
791 | ("QUOTATION", "") -> "quotation"
792 | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\""
793 | ("LOCATE", "") -> "locate"
794 | ("EOI", "") -> "end of input"
796 | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
799 value eq_before_colon p e =
800 loop 0 where rec loop i =
801 if i == String.length e then
802 failwith "Internal error in Plexer: incorrect ANTIQUOT"
803 else if i == String.length p then e.[i] == ':'
804 else if p.[i] == e.[i] then loop (i + 1)
808 value after_colon e =
810 let i = String.index e ':' in
811 String.sub e (i + 1) (String.length e - i - 1)
818 [ ("ANTIQUOT", p_prm) ->
820 [ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm
821 | _ -> raise Stream.Failure ]
822 | tok -> Token.default_match tok ]
825 value make_lexer () =
826 let kwd_table = Hashtbl.create 301 in
827 let id_table = Hashtbl.create 301 in
830 {tok_func = fun []; tok_using = fun []; tok_removing = fun [];
831 tok_match = fun []; tok_text = fun []; tok_comm = None}
833 let (f,pos) = func kwd_table glexr in
836 tok_using = using_token kwd_table id_table;
837 tok_removing = removing_token kwd_table id_table; tok_match = tok_match;
838 tok_text = text; tok_comm = None}
840 do { glexr.val := glex; (glex, pos) }
844 let (p,_) = make_lexer () in p
849 [ ("ANTIQUOT", p_prm) ->
852 [: `("ANTIQUOT", prm) when eq_before_colon p_prm prm :] ->
860 let kwd_table = Hashtbl.create 301 in
861 let id_table = Hashtbl.create 301 in
864 {tok_func = fun []; tok_using = fun []; tok_removing = fun [];
865 tok_match = fun []; tok_text = fun []; tok_comm = None}
867 {func = fst(func kwd_table glexr); using = using_token kwd_table id_table;
868 removing = removing_token kwd_table id_table; tparse = tparse; text = text}
871 (* ------------------------------------------------------------------------- *)
872 (* Resume the main file. *)
873 (* ------------------------------------------------------------------------- *)
876 let odfa = dollar_for_antiquotation.val in
877 dollar_for_antiquotation.val := False;
878 let (lexer, pos) = make_lexer () in
879 Pcaml.position.val := pos;
880 Grammar.Unsafe.gram_reinit gram lexer;
881 dollar_for_antiquotation.val := odfa;
882 Grammar.Unsafe.clear_entry interf;
883 Grammar.Unsafe.clear_entry implem;
884 Grammar.Unsafe.clear_entry top_phrase;
885 Grammar.Unsafe.clear_entry use_file;
886 Grammar.Unsafe.clear_entry module_type;
887 Grammar.Unsafe.clear_entry module_expr;
888 Grammar.Unsafe.clear_entry sig_item;
889 Grammar.Unsafe.clear_entry str_item;
890 Grammar.Unsafe.clear_entry expr;
891 Grammar.Unsafe.clear_entry patt;
892 Grammar.Unsafe.clear_entry ctyp;
893 Grammar.Unsafe.clear_entry let_binding;
894 Grammar.Unsafe.clear_entry type_declaration;
895 Grammar.Unsafe.clear_entry class_type;
896 Grammar.Unsafe.clear_entry class_expr;
897 Grammar.Unsafe.clear_entry class_sig_item;
898 Grammar.Unsafe.clear_entry class_str_item
901 Pcaml.parse_interf.val := Grammar.Entry.parse interf;
902 Pcaml.parse_implem.val := Grammar.Entry.parse implem;
910 value mkexprident _loc ids = match ids with
911 [ [] -> Stdpp.raise_with_loc _loc (Stream.Error "illegal long identifier")
914 [ [ id :: ids ] -> loop <:expr< $m$ . $id$ >> ids
920 value mkumin _loc f arg =
922 [ ("-", <:expr< $int:n$ >>) when int_of_string n > 0 ->
925 | ("-", MLast.ExInt32 loc n) when (Int32.of_string n) > 0l ->
926 MLast.ExInt32 loc ("-" ^ n)
927 | ("-", MLast.ExInt64 loc n) when (Int64.of_string n) > 0L ->
928 MLast.ExInt64 loc ("-" ^ n)
929 | ("-", MLast.ExNativeInt loc n) when (Nativeint.of_string n) > 0n ->
930 MLast.ExNativeInt loc ("-" ^ n)
931 | (_, <:expr< $flo:n$ >>) when float_of_string n > 0.0 ->
936 <:expr< $lid:f$ $arg$ >> ]
940 value mklistexp _loc last =
941 loop True where rec loop top =
946 | None -> <:expr< [] >> ]
948 let _loc = if top then _loc else (fst (MLast.loc_of_expr e1), snd _loc) in
949 <:expr< [$e1$ :: $loop False el$] >> ]
952 value mklistpat _loc last =
953 loop True where rec loop top =
958 | None -> <:patt< [] >> ]
960 let _loc = if top then _loc else (fst (MLast.loc_of_patt p1), snd _loc) in
961 <:patt< [$p1$ :: $loop False pl$] >> ]
964 (*** JRH pulled this outside so user can add new infixes here too ***)
966 value ht = Hashtbl.create 73;
968 (*** And JRH added all the new HOL Light infixes here already ***)
971 let ct = Hashtbl.create 73 in
973 List.iter (fun x -> Hashtbl.add ht x True)
974 ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; "o"; "upto";
975 "F_F"; "THENC"; "THEN"; "THENL"; "ORELSE"; "ORELSEC";
976 "THEN_TCL"; "ORELSE_TCL"];
977 List.iter (fun x -> Hashtbl.add ct x True)
978 ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~';
981 try Hashtbl.find ht x with
982 [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ]
986 (*** JRH added this so parenthesised operators undergo same mapping ***)
988 value translate_operator =
992 | "THENC" -> "thenc_"
993 | "THENL" -> "thenl_"
994 | "ORELSE" -> "orelse_"
995 | "ORELSEC" -> "orelsec_"
996 | "THEN_TCL" -> "then_tcl_"
997 | "ORELSE_TCL" -> "orelse_tcl_"
1001 (*** And JRH inserted it in here ***)
1003 value operator_rparen =
1004 Grammar.Entry.of_parser gram "operator_rparen"
1006 match Stream.npeek 2 strm with
1007 [ [("", s); ("", ")")] when is_operator s ->
1008 do { Stream.junk strm; Stream.junk strm; translate_operator s }
1009 | _ -> raise Stream.Failure ])
1012 value lident_colon =
1013 Grammar.Entry.of_parser gram "lident_colon"
1015 match Stream.npeek 2 strm with
1016 [ [("LIDENT", i); ("", ":")] ->
1017 do { Stream.junk strm; Stream.junk strm; i }
1018 | _ -> raise Stream.Failure ])
1023 ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?';
1027 if i == String.length s then True
1028 else if List.mem s.[i] list then loop s (i + 1)
1035 let list = ['!'; '?'; '~'] in
1036 let excl = ["!="; "??"] in
1037 Grammar.Entry.of_parser gram "prefixop"
1041 not (List.mem x excl) && String.length x >= 2 &&
1042 List.mem x.[0] list && symbolchar x 1 :] ->
1047 let list = ['='; '<'; '>'; '|'; '&'; '$'] in
1048 let excl = ["<-"; "||"; "&&"] in
1049 Grammar.Entry.of_parser gram "infixop0"
1053 not (List.mem x excl) && String.length x >= 2 &&
1054 List.mem x.[0] list && symbolchar x 1 :] ->
1059 let list = ['@'; '^'] in
1060 Grammar.Entry.of_parser gram "infixop1"
1064 String.length x >= 2 && List.mem x.[0] list &&
1065 symbolchar x 1 :] ->
1070 let list = ['+'; '-'] in
1071 Grammar.Entry.of_parser gram "infixop2"
1075 x <> "->" && String.length x >= 2 && List.mem x.[0] list &&
1076 symbolchar x 1 :] ->
1081 let list = ['*'; '/'; '%'] in
1082 Grammar.Entry.of_parser gram "infixop3"
1086 String.length x >= 2 && List.mem x.[0] list &&
1087 symbolchar x 1 :] ->
1092 Grammar.Entry.of_parser gram "infixop4"
1096 String.length x >= 3 && x.[0] == '*' && x.[1] == '*' &&
1097 symbolchar x 2 :] ->
1101 value test_constr_decl =
1102 Grammar.Entry.of_parser gram "test_constr_decl"
1104 match Stream.npeek 1 strm with
1105 [ [("UIDENT", _)] ->
1106 match Stream.npeek 2 strm with
1107 [ [_; ("", ".")] -> raise Stream.Failure
1108 | [_; ("", "(")] -> raise Stream.Failure
1110 | _ -> raise Stream.Failure ]
1112 | _ -> raise Stream.Failure ])
1115 value stream_peek_nth n strm =
1116 loop n (Stream.npeek n strm) where rec loop n =
1119 | [x] -> if n == 1 then Some x else None
1120 | [_ :: l] -> loop (n - 1) l ]
1123 (* horrible hack to be able to parse class_types *)
1125 value test_ctyp_minusgreater =
1126 Grammar.Entry.of_parser gram "test_ctyp_minusgreater"
1128 let rec skip_simple_ctyp n =
1129 match stream_peek_nth n strm with
1130 [ Some ("", "->") -> n
1131 | Some ("", "[" | "[<") ->
1132 skip_simple_ctyp (ignore_upto "]" (n + 1) + 1)
1133 | Some ("", "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1)
1136 "as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" |
1138 skip_simple_ctyp (n + 1)
1139 | Some ("QUESTIONIDENT" | "LIDENT" | "UIDENT", _) ->
1140 skip_simple_ctyp (n + 1)
1141 | Some _ | None -> raise Stream.Failure ]
1142 and ignore_upto end_kwd n =
1143 match stream_peek_nth n strm with
1144 [ Some ("", prm) when prm = end_kwd -> n
1145 | Some ("", "[" | "[<") ->
1146 ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1)
1147 | Some ("", "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1)
1148 | Some _ -> ignore_upto end_kwd (n + 1)
1149 | None -> raise Stream.Failure ]
1151 match Stream.peek strm with
1152 [ Some (("", "[") | ("LIDENT" | "UIDENT", _)) -> skip_simple_ctyp 1
1153 | Some ("", "object") -> raise Stream.Failure
1157 value test_label_eq =
1158 Grammar.Entry.of_parser gram "test_label_eq"
1159 (test 1 where rec test lev strm =
1160 match stream_peek_nth lev strm with
1161 [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) ->
1163 | Some ("", "=") -> ()
1164 | _ -> raise Stream.Failure ])
1167 value test_typevar_list_dot =
1168 Grammar.Entry.of_parser gram "test_typevar_list_dot"
1169 (let rec test lev strm =
1170 match stream_peek_nth lev strm with
1171 [ Some ("", "'") -> test2 (lev + 1) strm
1172 | Some ("", ".") -> ()
1173 | _ -> raise Stream.Failure ]
1174 and test2 lev strm =
1175 match stream_peek_nth lev strm with
1176 [ Some ("UIDENT" | "LIDENT", _) -> test (lev + 1) strm
1177 | _ -> raise Stream.Failure ]
1182 value constr_arity = ref [("Some", 1); ("Match_Failure", 1)];
1184 value rec is_expr_constr_call =
1186 [ <:expr< $uid:_$ >> -> True
1187 | <:expr< $uid:_$.$e$ >> -> is_expr_constr_call e
1188 | <:expr< $e$ $_$ >> -> is_expr_constr_call e
1192 value rec constr_expr_arity _loc =
1194 [ <:expr< $uid:c$ >> ->
1195 try List.assoc c constr_arity.val with [ Not_found -> 0 ]
1196 | <:expr< $uid:_$.$e$ >> -> constr_expr_arity _loc e
1197 | <:expr< $e$ $_$ >> ->
1198 if is_expr_constr_call e then
1199 Stdpp.raise_with_loc _loc (Stream.Error "currified constructor")
1204 value rec is_patt_constr_call =
1206 [ <:patt< $uid:_$ >> -> True
1207 | <:patt< $uid:_$.$p$ >> -> is_patt_constr_call p
1208 | <:patt< $p$ $_$ >> -> is_patt_constr_call p
1212 value rec constr_patt_arity _loc =
1214 [ <:patt< $uid:c$ >> ->
1215 try List.assoc c constr_arity.val with [ Not_found -> 0 ]
1216 | <:patt< $uid:_$.$p$ >> -> constr_patt_arity _loc p
1217 | <:patt< $p$ $_$ >> ->
1218 if is_patt_constr_call p then
1219 Stdpp.raise_with_loc _loc (Stream.Error "currified constructor")
1226 [ <:expr< do { $list:el$ } >> -> el
1230 value choose_tvar tpl =
1231 let rec find_alpha v =
1232 let s = String.make 1 v in
1233 if List.mem_assoc s tpl then
1234 if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
1235 else Some (String.make 1 v)
1238 let v = "a" ^ string_of_int n in
1239 if List.mem_assoc v tpl then make_n (succ n) else v
1241 match find_alpha 'a' with
1243 | None -> make_n 1 ]
1246 value rec patt_lid =
1248 [ <:patt< $p1$ $p2$ >> ->
1250 [ <:patt< $lid:i$ >> -> Some (MLast.loc_of_patt p1, i, [p2])
1252 match patt_lid p1 with
1253 [ Some (loc, i, pl) -> Some (loc, i, [p2 :: pl])
1258 value bigarray_get _loc arr arg =
1261 [ <:expr< ($list:el$) >> -> el
1265 [ [c1] -> <:expr< Bigarray.Array1.get $arr$ $c1$ >>
1266 | [c1; c2] -> <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >>
1267 | [c1; c2; c3] -> <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >>
1268 | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ]
1271 value bigarray_set _loc var newval =
1273 [ <:expr< Bigarray.Array1.get $arr$ $c1$ >> ->
1274 Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >>
1275 | <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> ->
1276 Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >>
1277 | <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> ->
1278 Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >>
1279 | <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ->
1280 Some <:expr< Bigarray.Genarray.set $arr$ [| $list:coords$ |] $newval$ >>
1286 match cs with parser
1287 [ [: `';' :] -> sync_semi cs
1288 | [: `_ :] -> sync cs ]
1290 match cs with parser
1291 [ [: `';' :] -> sync_semisemi cs
1292 | [: :] -> sync cs ]
1293 and sync_semisemi cs =
1294 match Stream.peek cs with
1295 [ Some ('\010' | '\013') -> ()
1296 | _ -> sync_semi cs ]
1298 Pcaml.sync.val := sync;
1303 GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type
1304 class_expr class_sig_item class_str_item let_binding type_declaration;
1306 [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->";
1308 <:module_expr< functor ( $i$ : $t$ ) -> $me$ >>
1309 | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" ->
1310 <:module_expr< struct $list:st$ end >> ]
1311 | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ]
1312 | [ i = mod_expr_ident -> i
1313 | "("; me = SELF; ":"; mt = module_type; ")" ->
1314 <:module_expr< ( $me$ : $mt$ ) >>
1315 | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ]
1320 [ i = SELF; "."; j = SELF -> <:module_expr< $i$ . $j$ >> ]
1321 | [ i = UIDENT -> <:module_expr< $uid:i$ >> ] ]
1326 [ "exception"; (_, c, tl) = constructor_declaration; b = rebind_exn ->
1327 <:str_item< exception $c$ of $list:tl$ = $b$ >>
1328 | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
1329 <:str_item< external $i$ : $t$ = $list:pd$ >>
1330 | "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
1331 pd = LIST1 STRING ->
1332 <:str_item< external $i$ : $t$ = $list:pd$ >>
1333 | "include"; me = module_expr -> <:str_item< include $me$ >>
1334 | "module"; i = UIDENT; mb = module_binding ->
1335 <:str_item< module $i$ = $mb$ >>
1336 | "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" ->
1337 MLast.StRecMod _loc nmtmes
1338 | "module"; "type"; i = UIDENT; "="; mt = module_type ->
1339 <:str_item< module type $i$ = $mt$ >>
1340 | "open"; i = mod_ident -> <:str_item< open $i$ >>
1341 | "type"; tdl = LIST1 type_declaration SEP "and" ->
1342 <:str_item< type $list:tdl$ >>
1343 | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
1345 let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in
1346 <:str_item< $exp:e$ >>
1347 | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" ->
1349 [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >>
1350 | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ]
1351 | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr ->
1352 <:str_item< let module $m$ = $mb$ in $e$ >>
1353 | e = expr -> <:str_item< $exp:e$ >> ] ]
1357 [ [ "="; sl = mod_ident -> sl
1362 [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
1363 <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >>
1364 | ":"; mt = module_type; "="; me = module_expr ->
1365 <:module_expr< ( $me$ : $mt$ ) >>
1366 | "="; me = module_expr -> <:module_expr< $me$ >> ] ]
1369 [ [ m = UIDENT; ":"; mt = module_type; "="; me = module_expr ->
1374 [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF ->
1375 <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ]
1376 | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" ->
1377 <:module_type< $mt$ with $list:wcl$ >> ]
1378 | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" ->
1379 <:module_type< sig $list:sg$ end >>
1380 | i = mod_type_ident -> i
1381 | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ]
1385 [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >>
1386 | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ]
1387 | [ m = UIDENT -> <:module_type< $uid:m$ >>
1388 | m = LIDENT -> <:module_type< $lid:m$ >> ] ]
1392 [ "exception"; (_, c, tl) = constructor_declaration ->
1393 <:sig_item< exception $c$ of $list:tl$ >>
1394 | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
1395 <:sig_item< external $i$ : $t$ = $list:pd$ >>
1396 | "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
1397 pd = LIST1 STRING ->
1398 <:sig_item< external $i$ : $t$ = $list:pd$ >>
1399 | "include"; mt = module_type -> <:sig_item< include $mt$ >>
1400 | "module"; i = UIDENT; mt = module_declaration ->
1401 <:sig_item< module $i$ : $mt$ >>
1402 | "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" ->
1403 MLast.SgRecMod _loc mds
1404 | "module"; "type"; i = UIDENT; "="; mt = module_type ->
1405 <:sig_item< module type $i$ = $mt$ >>
1406 | "module"; "type"; i = UIDENT ->
1407 <:sig_item< module type $i$ = 'abstract >>
1408 | "open"; i = mod_ident -> <:sig_item< open $i$ >>
1409 | "type"; tdl = LIST1 type_declaration SEP "and" ->
1410 <:sig_item< type $list:tdl$ >>
1411 | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >>
1412 | "val"; "("; i = operator_rparen; ":"; t = ctyp ->
1413 <:sig_item< value $i$ : $t$ >> ] ]
1417 [ ":"; mt = module_type -> <:module_type< $mt$ >>
1418 | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF ->
1419 <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ]
1421 module_rec_declaration:
1422 [ [ m = UIDENT; ":"; mt = module_type -> (m, mt)] ]
1424 (* "with" constraints (additional type equations over signature
1427 [ [ "type"; tpl = type_parameters; i = mod_ident; "="; t = ctyp ->
1428 MLast.WcTyp _loc i tpl t
1429 | "module"; i = mod_ident; "="; me = module_expr ->
1430 MLast.WcMod _loc i me ] ]
1432 (* Core expressions *)
1435 [ e1 = SELF; ";"; e2 = SELF ->
1436 <:expr< do { $list:[e1 :: get_seq e2]$ } >>
1437 | e1 = SELF; ";" -> e1 ]
1439 [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
1440 x = expr LEVEL "top" ->
1441 <:expr< let $opt:o2b o$ $list:l$ in $x$ >>
1442 | "let"; "module"; m = UIDENT; mb = module_binding; "in";
1443 e = expr LEVEL "top" ->
1444 <:expr< let module $m$ = $mb$ in $e$ >>
1445 | "function"; OPT "|"; l = LIST1 match_case SEP "|" ->
1446 <:expr< fun [ $list:l$ ] >>
1447 | "fun"; p = patt LEVEL "simple"; e = fun_def ->
1448 <:expr< fun [$p$ -> $e$] >>
1449 | "match"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
1450 <:expr< match $e$ with [ $list:l$ ] >>
1451 | "try"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
1452 <:expr< try $e$ with [ $list:l$ ] >>
1453 | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1";
1454 "else"; e3 = expr LEVEL "expr1" ->
1455 <:expr< if $e1$ then $e2$ else $e3$ >>
1456 | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1" ->
1457 <:expr< if $e1$ then $e2$ else () >>
1458 | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
1459 "do"; e = SELF; "done" ->
1460 <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >>
1461 | "while"; e1 = SELF; "do"; e2 = SELF; "done" ->
1462 <:expr< while $e1$ do { $list:get_seq e2$ } >>
1463 | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
1464 (* <:expr< object $opt:cspo$ $list:cf$ end >> *)
1465 MLast.ExObj _loc cspo cf ]
1466 | [ e = SELF; ","; el = LIST1 NEXT SEP "," ->
1467 <:expr< ( $list:[e :: el]$ ) >> ]
1469 [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" ->
1470 <:expr< $e1$.val := $e2$ >>
1471 | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" ->
1472 match bigarray_set _loc e1 e2 with
1474 | None -> <:expr< $e1$ := $e2$ >> ] ]
1476 [ e1 = SELF; "or"; e2 = SELF -> <:expr< $lid:"or"$ $e1$ $e2$ >>
1477 | e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ]
1479 [ e1 = SELF; "&"; e2 = SELF -> <:expr< $lid:"&"$ $e1$ $e2$ >>
1480 | e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ]
1482 [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >>
1483 | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >>
1484 | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >>
1485 | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >>
1486 | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >>
1487 | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >>
1488 | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >>
1489 | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >>
1490 | e1 = SELF; "$"; e2 = SELF -> <:expr< $lid:"\$"$ $e1$ $e2$ >>
1491 | e1 = SELF; op = infixop0; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1493 [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >>
1494 | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >>
1495 | e1 = SELF; op = infixop1; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1497 [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ]
1499 [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >>
1500 | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >>
1501 | e1 = SELF; op = infixop2; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1503 [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >>
1504 | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >>
1505 | e1 = SELF; "%"; e2 = SELF -> <:expr< $lid:"%"$ $e1$ $e2$ >>
1506 | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >>
1507 | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >>
1508 | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >>
1509 | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >>
1510 | e1 = SELF; op = infixop3; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1512 [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >>
1513 | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >>
1514 | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >>
1515 | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >>
1516 | e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1517 | "unary minus" NONA
1518 [ "-"; e = SELF -> <:expr< $mkumin _loc "-" e$ >>
1519 | "-."; e = SELF -> <:expr< $mkumin _loc "-." e$ >> ]
1521 [ e1 = SELF; e2 = SELF ->
1522 match constr_expr_arity _loc e1 with
1523 [ 1 -> <:expr< $e1$ $e2$ >>
1526 [ <:expr< ( $list:el$ ) >> ->
1527 List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el
1528 | _ -> <:expr< $e1$ $e2$ >> ] ]
1529 | "assert"; e = SELF ->
1531 [ <:expr< False >> -> <:expr< assert False >>
1532 | _ -> <:expr< assert ($e$) >> ]
1533 | "lazy"; e = SELF ->
1534 <:expr< lazy ($e$) >> ]
1536 [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
1537 | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>
1538 | e1 = SELF; "."; "{"; e2 = SELF; "}" -> bigarray_get _loc e1 e2
1539 | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ]
1541 [ "!"; e = SELF -> <:expr< $e$ . val>>
1542 | "~-"; e = SELF -> <:expr< ~- $e$ >>
1543 | "~-."; e = SELF -> <:expr< ~-. $e$ >>
1544 | f = prefixop; e = SELF -> <:expr< $lid:f$ $e$ >> ]
1546 [ s = INT -> <:expr< $int:s$ >>
1547 | s = INT32 -> MLast.ExInt32 _loc s
1548 | s = INT64 -> MLast.ExInt64 _loc s
1549 | s = NATIVEINT -> MLast.ExNativeInt _loc s
1550 | s = FLOAT -> <:expr< $flo:s$ >>
1551 | s = STRING -> <:expr< $str:s$ >>
1552 | c = CHAR -> <:expr< $chr:c$ >>
1553 | UIDENT "True" -> <:expr< $uid:" True"$ >>
1554 | UIDENT "False" -> <:expr< $uid:" False"$ >>
1555 | ids = expr_ident -> mkexprident _loc ids
1556 | s = "false" -> <:expr< False >>
1557 | s = "true" -> <:expr< True >>
1558 | "["; "]" -> <:expr< [] >>
1559 | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp _loc None el$ >>
1560 | "[|"; "|]" -> <:expr< [| |] >>
1561 | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >>
1562 | "{"; test_label_eq; lel = lbl_expr_list; "}" ->
1563 <:expr< { $list:lel$ } >>
1564 | "{"; e = expr LEVEL "."; "with"; lel = lbl_expr_list; "}" ->
1565 <:expr< { ($e$) with $list:lel$ } >>
1566 | "("; ")" -> <:expr< () >>
1567 | "("; op = operator_rparen -> <:expr< $lid:op$ >>
1568 | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
1569 | "("; e = SELF; ")" -> <:expr< $e$ >>
1570 | "begin"; e = SELF; "end" -> <:expr< $e$ >>
1571 | "begin"; "end" -> <:expr< () >>
1575 let i = String.index x ':' in
1576 ({Lexing.pos_fname = "";
1577 Lexing.pos_lnum = 0;
1579 Lexing.pos_cnum = int_of_string (String.sub x 0 i)},
1580 String.sub x (i + 1) (String.length x - i - 1))
1582 [ Not_found | Failure _ -> (Token.nowhere, x) ]
1584 Pcaml.handle_expr_locate _loc x
1588 let i = String.index x ':' in
1590 String.sub x (i + 1) (String.length x - i - 1))
1592 [ Not_found -> ("", x) ]
1594 Pcaml.handle_expr_quotation _loc x ] ]
1597 [ [ p = patt; e = fun_binding ->
1598 match patt_lid p with
1599 [ Some (_loc, i, pl) ->
1601 List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl
1603 (<:patt< $lid:i$ >>, e)
1604 | None -> (p, e) ] ] ]
1608 [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
1609 | "="; e = expr -> <:expr< $e$ >>
1610 | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >>
1611 | ":>"; t = ctyp; "="; e = expr -> <:expr< ($e$ :> $t$) >> ] ]
1614 [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr ->
1618 [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel]
1619 | le = lbl_expr; ";" -> [le]
1620 | le = lbl_expr -> [le] ] ]
1623 [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ]
1626 [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el]
1627 | e = expr LEVEL "expr1"; ";" -> [e]
1628 | e = expr LEVEL "expr1" -> [e] ] ]
1632 [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
1633 | "->"; e = expr -> <:expr< $e$ >> ] ]
1637 [ i = LIDENT -> [ <:expr< $lid:i$ >> ]
1638 | i = UIDENT -> [ <:expr< $uid:i$ >> ]
1639 | i = UIDENT; "."; "("; j = operator_rparen ->
1640 [ <:expr< $uid:i$ >> ; <:expr< $lid:j$ >> ]
1641 | i = UIDENT; "."; j = SELF -> [ <:expr< $uid:i$ >> :: j ]
1648 [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ]
1650 [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
1651 | [ p = SELF; ","; pl = LIST1 NEXT SEP "," ->
1652 <:patt< ( $list:[p :: pl]$) >> ]
1654 [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
1656 [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
1658 [ p1 = SELF; p2 = SELF ->
1659 match constr_patt_arity _loc p1 with
1660 [ 1 -> <:patt< $p1$ $p2$ >>
1664 [ <:patt< _ >> when n > 1 ->
1666 loop n where rec loop n =
1667 if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)]
1669 <:patt< ( $list:pl$ ) >>
1673 [ <:patt< ( $list:pl$ ) >> ->
1674 List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl
1675 | _ -> <:patt< $p1$ $p2$ >> ] ] ]
1677 [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
1679 [ s = LIDENT -> <:patt< $lid:s$ >>
1680 | s = UIDENT -> <:patt< $uid:s$ >>
1681 | s = INT -> <:patt< $int:s$ >>
1682 | s = INT32 -> MLast.PaInt32 _loc s
1683 | s = INT64 -> MLast.PaInt64 _loc s
1684 | s = NATIVEINT -> MLast.PaNativeInt _loc s
1685 | "-"; s = INT -> <:patt< $int:"-" ^ s$ >>
1686 | "-"; s = INT32 -> MLast.PaInt32 _loc ("-" ^ s)
1687 | "-"; s = INT64 -> MLast.PaInt64 _loc ("-" ^ s)
1688 | "-"; s = NATIVEINT -> MLast.PaNativeInt _loc ("-" ^ s)
1689 | "-"; s = FLOAT -> <:patt< $flo:"-" ^ s$ >>
1690 | s = FLOAT -> <:patt< $flo:s$ >>
1691 | s = STRING -> <:patt< $str:s$ >>
1692 | s = CHAR -> <:patt< $chr:s$ >>
1693 | UIDENT "True" -> <:patt< $uid:" True"$ >>
1694 | UIDENT "False" -> <:patt< $uid:" False"$ >>
1695 | s = "false" -> <:patt< False >>
1696 | s = "true" -> <:patt< True >>
1697 | "["; "]" -> <:patt< [] >>
1698 | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat _loc None pl$ >>
1699 | "[|"; "|]" -> <:patt< [| |] >>
1700 | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >>
1701 | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >>
1702 | "("; ")" -> <:patt< () >>
1703 | "("; op = operator_rparen -> <:patt< $lid:op$ >>
1704 | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
1705 | "("; p = patt; ")" -> <:patt< $p$ >>
1706 | "_" -> <:patt< _ >>
1707 | "`"; s = ident -> <:patt< ` $s$ >>
1708 | "#"; t = mod_ident -> <:patt< # $list:t$ >>
1712 let i = String.index x ':' in
1713 ({Lexing.pos_fname = "";
1714 Lexing.pos_lnum = 0;
1716 Lexing.pos_cnum = int_of_string (String.sub x 0 i)},
1717 String.sub x (i + 1) (String.length x - i - 1))
1719 [ Not_found | Failure _ -> (Token.nowhere, x) ]
1721 Pcaml.handle_patt_locate _loc x
1725 let i = String.index x ':' in
1727 String.sub x (i + 1) (String.length x - i - 1))
1729 [ Not_found -> ("", x) ]
1731 Pcaml.handle_patt_quotation _loc x ] ]
1735 [ [ p = patt; ";"; pl = SELF -> [p :: pl]
1736 | p = patt; ";" -> [p]
1737 | p = patt -> [p] ] ]
1740 [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel]
1741 | le = lbl_patt; ";" -> [le]
1742 | le = lbl_patt -> [le] ] ]
1745 [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ]
1749 [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
1751 [ i = UIDENT -> <:patt< $uid:i$ >>
1752 | i = LIDENT -> <:patt< $lid:i$ >> ] ]
1754 (* Type declaration *)
1756 [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind;
1757 cl = LIST0 constrain ->
1759 | tpl = type_parameters; n = type_patt; cl = LIST0 constrain ->
1760 (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ]
1763 [ [ n = LIDENT -> (_loc, n) ] ]
1766 [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
1769 [ [ "private"; tk = type_kind -> <:ctyp< private $tk$ >>
1770 | test_constr_decl; OPT "|";
1771 cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< [ $list:cdl$ ] >>
1772 | t = ctyp -> <:ctyp< $t$ >>
1773 | t = ctyp; "="; "private"; tk = type_kind ->
1774 <:ctyp< $t$ == private $tk$ >>
1775 | t = ctyp; "="; "{"; ldl = label_declarations; "}" ->
1776 <:ctyp< $t$ == { $list:ldl$ } >>
1777 | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" ->
1778 <:ctyp< $t$ == [ $list:cdl$ ] >>
1779 | "{"; ldl = label_declarations; "}" ->
1780 <:ctyp< { $list:ldl$ } >> ] ]
1783 [ [ -> (* empty *) []
1784 | tp = type_parameter -> [tp]
1785 | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ]
1788 [ [ "'"; i = ident -> (i, (False, False))
1789 | "+"; "'"; i = ident -> (i, (True, False))
1790 | "-"; "'"; i = ident -> (i, (False, True)) ] ]
1792 constructor_declaration:
1793 [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" ->
1795 | ci = UIDENT -> (_loc, ci, []) ] ]
1798 [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl]
1799 | ld = label_declaration; ";" -> [ld]
1800 | ld = label_declaration -> [ld] ] ]
1803 [ [ i = LIDENT; ":"; t = poly_type -> (_loc, i, False, t)
1804 | "mutable"; i = LIDENT; ":"; t = poly_type -> (_loc, i, True, t) ] ]
1808 [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ]
1810 [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
1812 [ t = SELF; "*"; tl = LIST1 (ctyp LEVEL "ctyp1") SEP "*" ->
1813 <:ctyp< ( $list:[t :: tl]$ ) >> ]
1815 [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ]
1817 [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >>
1818 | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ]
1820 [ "'"; i = ident -> <:ctyp< '$i$ >>
1821 | "_" -> <:ctyp< _ >>
1822 | i = LIDENT -> <:ctyp< $lid:i$ >>
1823 | i = UIDENT -> <:ctyp< $uid:i$ >>
1824 | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")";
1825 i = ctyp LEVEL "ctyp2" ->
1826 List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl]
1827 | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ]
1832 | i = UIDENT -> i ] ]
1838 | i = UIDENT; "."; j = SELF -> [i :: j] ] ]
1843 | "downto" -> False ] ]
1845 (* Objects and Classes *)
1847 [ [ "class"; cd = LIST1 class_declaration SEP "and" ->
1848 <:str_item< class $list:cd$ >>
1849 | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
1850 <:str_item< class type $list:ctd$ >> ] ]
1853 [ [ "class"; cd = LIST1 class_description SEP "and" ->
1854 <:sig_item< class $list:cd$ >>
1855 | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
1856 <:sig_item< class type $list:ctd$ >> ] ]
1858 (* Class expressions *)
1860 [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT;
1861 cfb = class_fun_binding ->
1862 {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
1863 MLast.ciNam = i; MLast.ciExp = cfb} ] ]
1866 [ [ "="; ce = class_expr -> ce
1867 | ":"; ct = class_type; "="; ce = class_expr ->
1868 <:class_expr< ($ce$ : $ct$) >>
1869 | p = patt LEVEL "simple"; cfb = SELF ->
1870 <:class_expr< fun $p$ -> $cfb$ >> ] ]
1872 class_type_parameters:
1874 | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (_loc, tpl) ] ]
1877 [ [ p = patt LEVEL "simple"; "->"; ce = class_expr ->
1878 <:class_expr< fun $p$ -> $ce$ >>
1879 | p = labeled_patt; "->"; ce = class_expr ->
1880 <:class_expr< fun $p$ -> $ce$ >>
1881 | p = patt LEVEL "simple"; cfd = SELF ->
1882 <:class_expr< fun $p$ -> $cfd$ >>
1883 | p = labeled_patt; cfd = SELF ->
1884 <:class_expr< fun $p$ -> $cfd$ >> ] ]
1888 [ "fun"; cfd = class_fun_def -> cfd
1889 | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in";
1891 <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ]
1893 [ ce = SELF; e = expr LEVEL "label" ->
1894 <:class_expr< $ce$ $e$ >> ]
1896 [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]";
1897 ci = class_longident ->
1898 <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >>
1899 | "["; ct = ctyp; "]"; ci = class_longident ->
1900 <:class_expr< $list:ci$ [ $ct$ ] >>
1901 | ci = class_longident -> <:class_expr< $list:ci$ >>
1902 | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
1903 <:class_expr< object $opt:cspo$ $list:cf$ end >>
1904 | "("; ce = SELF; ":"; ct = class_type; ")" ->
1905 <:class_expr< ($ce$ : $ct$) >>
1906 | "("; ce = SELF; ")" -> ce ] ]
1909 [ [ cf = LIST0 class_str_item -> cf ] ]
1912 [ [ "("; p = patt; ")" -> p
1913 | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ]
1916 [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] ->
1917 <:class_str_item< inherit $ce$ $opt:pb$ >>
1918 | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
1919 <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
1920 | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
1921 <:class_str_item< method virtual private $l$ : $t$ >>
1922 | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
1923 <:class_str_item< method virtual private $l$ : $t$ >>
1924 | "method"; "virtual"; l = label; ":"; t = poly_type ->
1925 <:class_str_item< method virtual $l$ : $t$ >>
1926 | "method"; "private"; l = label; ":"; t = poly_type; "="; e = expr ->
1927 MLast.CrMth _loc l True e (Some t)
1928 | "method"; "private"; l = label; sb = fun_binding ->
1929 MLast.CrMth _loc l True sb None
1930 | "method"; l = label; ":"; t = poly_type; "="; e = expr ->
1931 MLast.CrMth _loc l False e (Some t)
1932 | "method"; l = label; sb = fun_binding ->
1933 MLast.CrMth _loc l False sb None
1934 | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
1935 <:class_str_item< type $t1$ = $t2$ >>
1936 | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ]
1939 [ [ "="; e = expr -> e
1940 | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >>
1941 | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr ->
1942 <:expr< ($e$ : $t$ :> $t2$) >>
1943 | ":>"; t = ctyp; "="; e = expr ->
1944 <:expr< ($e$ :> $t$) >> ] ]
1947 [ [ i = LIDENT -> i ] ]
1951 [ [ test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF ->
1952 <:class_type< [ $t$ ] -> $ct$ >>
1953 | cs = class_signature -> cs ] ]
1956 [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident ->
1957 <:class_type< $list:id$ [ $list:tl$ ] >>
1958 | id = clty_longident -> <:class_type< $list:id$ >>
1959 | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item;
1961 <:class_type< object $opt:cst$ $list:csf$ end >> ] ]
1964 [ [ "("; t = ctyp; ")" -> t ] ]
1967 [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >>
1968 | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
1969 <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
1970 | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
1971 <:class_sig_item< method virtual private $l$ : $t$ >>
1972 | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
1973 <:class_sig_item< method virtual private $l$ : $t$ >>
1974 | "method"; "virtual"; l = label; ":"; t = poly_type ->
1975 <:class_sig_item< method virtual $l$ : $t$ >>
1976 | "method"; "private"; l = label; ":"; t = poly_type ->
1977 <:class_sig_item< method private $l$ : $t$ >>
1978 | "method"; l = label; ":"; t = poly_type ->
1979 <:class_sig_item< method $l$ : $t$ >>
1980 | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
1981 <:class_sig_item< type $t1$ = $t2$ >> ] ]
1984 [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":";
1986 {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
1987 MLast.ciNam = n; MLast.ciExp = ct} ] ]
1989 class_type_declaration:
1990 [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "=";
1991 cs = class_signature ->
1992 {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
1993 MLast.ciNam = n; MLast.ciExp = cs} ] ]
1996 expr: LEVEL "simple"
1998 [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ]
2001 [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ]
2003 expr: LEVEL "simple"
2004 [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" ->
2005 <:expr< ($e$ : $t$ :> $t2$) >>
2006 | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >>
2007 | "{<"; ">}" -> <:expr< {< >} >>
2008 | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ]
2011 [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF ->
2013 | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)]
2014 | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ]
2017 ctyp: LEVEL "simple"
2018 [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >>
2019 | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >>
2020 | "<"; ">" -> <:ctyp< < > >> ] ]
2023 [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v)
2024 | f = field; ";" -> ([f], False)
2025 | f = field -> ([f], False)
2026 | ".." -> ([], True) ] ]
2029 [ [ lab = LIDENT; ":"; t = poly_type -> (lab, t) ] ]
2031 (* Polymorphic types *)
2033 [ [ "'"; i = ident -> i ] ]
2036 [ [ test_typevar_list_dot; tpl = LIST1 typevar; "."; t2 = ctyp ->
2037 <:ctyp< ! $list:tpl$ . $t2$ >>
2042 [ [ m = UIDENT; "."; l = SELF -> [m :: l]
2043 | i = LIDENT -> [i] ] ]
2046 [ [ m = UIDENT; "."; l = SELF -> [m :: l]
2047 | i = LIDENT -> [i] ] ]
2052 [ i = lident_colon; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
2053 <:ctyp< ( ~ $i$ : $t1$ ) -> $t2$ >>
2054 | i = OPTLABEL; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
2055 <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >>
2056 | i = QUESTIONIDENT; ":"; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
2057 <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >>
2058 | "?"; i=lident_colon;t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
2059 <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> ] ]
2061 ctyp: LEVEL "simple"
2062 [ [ "["; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
2063 <:ctyp< [ = $list:rfl$ ] >>
2064 | "["; ">"; "]" -> <:ctyp< [ > $list:[]$ ] >>
2065 | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
2066 <:ctyp< [ > $list:rfl$ ] >>
2067 | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
2068 <:ctyp< [ < $list:rfl$ ] >>
2069 | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">";
2070 ntl = LIST1 name_tag; "]" ->
2071 <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ]
2074 [ [ "`"; i = ident -> MLast.RfTag i True []
2075 | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" ->
2076 MLast.RfTag i (o2b ao) l
2077 | t = ctyp -> MLast.RfInh t ] ]
2080 [ [ "`"; i = ident -> i ] ]
2083 [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ]
2087 [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >>
2088 | i = TILDEIDENT -> <:expr< ~ $i$ >>
2089 | "~"; i = LIDENT -> <:expr< ~ $i$ >>
2090 | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >>
2091 | i = QUESTIONIDENT -> <:expr< ? $i$ >>
2092 | "?"; i = LIDENT -> <:expr< ? $i$ >> ] ]
2094 expr: LEVEL "simple"
2095 [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ]
2098 [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
2101 [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
2104 [ [ i = LABEL; p = patt LEVEL "simple" ->
2105 <:patt< ~ $i$ : $p$ >>
2108 | "~"; i=LIDENT -> <:patt< ~ $i$ >>
2109 | "~"; "("; i = LIDENT; ")" ->
2111 | "~"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
2112 <:patt< ~ $i$ : ($lid:i$ : $t$) >>
2113 | i = OPTLABEL; j = LIDENT ->
2114 <:patt< ? $i$ : ($lid:j$) >>
2115 | i = OPTLABEL; "("; p = patt; "="; e = expr; ")" ->
2116 <:patt< ? $i$ : ( $p$ = $e$ ) >>
2117 | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; ")" ->
2118 <:patt< ? $i$ : ( $p$ : $t$ ) >>
2119 | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; "=";
2121 <:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >>
2122 | i = QUESTIONIDENT -> <:patt< ? $i$ >>
2123 | "?"; i = LIDENT -> <:patt< ? $i$ >>
2124 | "?"; "("; i = LIDENT; "="; e = expr; ")" ->
2125 <:patt< ? ( $lid:i$ = $e$ ) >>
2126 | "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" ->
2127 <:patt< ? ( $lid:i$ : $t$ = $e$ ) >>
2128 | "?"; "("; i = LIDENT; ")" ->
2130 | "?"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
2131 <:patt< ? ( $lid:i$ : $t$ ) >> ] ]
2134 [ [ i = lident_colon; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2135 <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >>
2136 | i = OPTLABEL; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2137 <:class_type< [ ? $i$ : $t$ ] -> $ct$ >>
2138 | i = QUESTIONIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2139 <:class_type< [ ? $i$ : $t$ ] -> $ct$ >>
2140 | "?"; i = LIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2141 <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ]
2144 [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
2148 (* Main entry points *)
2151 GLOBAL: interf implem use_file top_phrase expr patt;
2153 [ [ si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
2154 | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2155 ([(<:sig_item< # $n$ $opt:dp$ >>, _loc)], True)
2156 | EOI -> ([], False) ] ]
2159 [ [ si = sig_item; OPT ";;" -> (si, _loc) ] ]
2162 [ [ si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
2163 | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2164 ([(<:str_item< # $n$ $opt:dp$ >>, _loc)], True)
2165 | EOI -> ([], False) ] ]
2168 [ [ si = str_item; OPT ";;" -> (si, _loc) ] ]
2171 [ [ ph = phrase; ";;" -> Some ph
2175 [ [ si = str_item; OPT ";;"; (sil, stopped) = SELF ->
2176 ([si :: sil], stopped)
2177 | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2178 ([<:str_item< # $n$ $opt:dp$ >>], True)
2179 | EOI -> ([], False) ] ]
2182 [ [ sti = str_item -> sti
2183 | "#"; n = LIDENT; dp = OPT expr -> <:str_item< # $n$ $opt:dp$ >> ] ]
2187 Pcaml.add_option "-no_quot" (Arg.Set no_quotations)
2188 "Don't parse quotations, allowing to use, e.g. \"<:>\" as token";
2192 [[ f = expr; "o"; g = expr -> <:expr< ((o $f$) $g$) >>
2193 | f = expr; "upto"; g = expr -> <:expr< ((upto $f$) $g$) >>
2194 | f = expr; "F_F"; g = expr -> <:expr< ((f_f_ $f$) $g$) >>
2195 | f = expr; "THENC"; g = expr -> <:expr< ((thenc_ $f$) $g$) >>
2196 | f = expr; "THEN"; g = expr -> <:expr< ((then_ $f$) $g$) >>
2197 | f = expr; "THENL"; g = expr -> <:expr< ((thenl_ $f$) $g$) >>
2198 | f = expr; "ORELSE"; g = expr -> <:expr< ((orelse_ $f$) $g$) >>
2199 | f = expr; "ORELSEC"; g = expr -> <:expr< ((orelsec_ $f$) $g$) >>
2200 | f = expr; "THEN_TCL"; g = expr -> <:expr< ((then_tcl_ $f$) $g$) >>
2201 | f = expr; "ORELSE_TCL"; g = expr -> <:expr< ((orelse_tcl_ $f$) $g$) >>
2207 [ [ sti = str_item; ";;" ->
2209 [ <:str_item< $exp:e$ >> -> Some <:str_item< value it = $e$ >>