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.54 2003/09/30 14:39:38 mauny 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 | [: :] -> ("INT", get_buff len) ]
103 and octal = parser [ [: `('0'..'7' as d) :] -> d ]
104 and hexa = parser [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d) :] -> d ]
105 and binary = parser [ [: `('0'..'1' as d) :] -> d ]
108 [ [: `('0'..'9' as c); s :] -> number (store len c) s
109 | [: `'_'; s :] -> number len s
110 | [: `'.'; s :] -> decimal_part (store len '.') s
111 | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
112 | [: `'l' :] -> ("INT32", get_buff len)
113 | [: `'L' :] -> ("INT64", get_buff len)
114 | [: `'n' :] -> ("NATIVEINT", get_buff len)
115 | [: :] -> ("INT", get_buff len) ]
116 and decimal_part len =
118 [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s
119 | [: `'_'; s :] -> decimal_part len s
120 | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
121 | [: :] -> ("FLOAT", get_buff len) ]
122 and exponent_part len =
124 [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s
125 | [: a = end_exponent_part len :] -> a ]
126 and end_exponent_part len =
128 [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s
129 | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ]
130 and end_exponent_part_under len =
132 [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s
133 | [: `'_'; s :] -> end_exponent_part_under len s
134 | [: :] -> ("FLOAT", get_buff len) ]
137 value error_on_unknown_keywords = ref False;
138 value err loc msg = raise_with_loc loc (Token.Error msg);
140 (* ------------------------------------------------------------------------- *)
141 (* JRH's hack to make the case distinction "unmixed" versus "mixed" *)
142 (* ------------------------------------------------------------------------- *)
144 value is_uppercase s = String.uppercase s = s;
145 value is_only_lowercase s = String.lowercase s = s && not(is_uppercase s);
147 value jrh_identifier find_kwd id =
148 let jflag = jrh_lexer.val in
149 if id = "set_jrh_lexer" then
150 (let _ = jrh_lexer.val := True in ("",find_kwd "true"))
151 else if id = "unset_jrh_lexer" then
152 (let _ = jrh_lexer.val := False in ("",find_kwd "false"))
154 try ("", find_kwd id) with
157 if is_uppercase (String.sub id 0 1) then ("UIDENT", id)
159 else if is_uppercase (String.sub id 0 1) &&
160 is_only_lowercase (String.sub id 1 (String.length id - 1))
161 then ("UIDENT", id) else ("LIDENT", id)];
163 (* ------------------------------------------------------------------------- *)
164 (* Back to original file with the mod of using the above. *)
165 (* ------------------------------------------------------------------------- *)
168 value next_token_fun dfa find_kwd =
169 let keyword_or_error loc s =
170 try (("", find_kwd s), loc) with
172 if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s)
173 else (("", s), loc) ]
177 [ [: `' ' | '\010' | '\013' | '\t' | '\026' | '\012'; s :] ->
179 | [: `'('; s :] -> left_paren bp s
180 | [: `'#'; s :] -> do { spaces_tabs s; linenum bp s }
181 | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] ->
182 let id = get_buff (ident (store 0 c) s) in
183 let loc = (bp, Stream.count s) in
184 (jrh_identifier find_kwd id, loc)
187 (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc)
191 | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] ->
192 let id = get_buff (ident (store 0 c) s) in
193 let loc = (bp, Stream.count s) in
194 (jrh_identifier find_kwd id, loc)
197 (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc)
200 | [: `('1'..'9' as c); s :] ->
201 let tok = number (store 0 c) s in
202 let loc = (bp, Stream.count s) in
205 let tok = base_number (store 0 '0') s in
206 let loc = (bp, Stream.count s) in
209 match Stream.npeek 3 s with
210 [ [_; '''; _] | ['\\'; _; _] | ['\x0D'; '\x0A'; '''] ->
211 let tok = ("CHAR", get_buff (char bp 0 s)) in
212 let loc = (bp, Stream.count s) in
214 | _ -> keyword_or_error (bp, Stream.count s) "'" ]
216 let tok = ("STRING", get_buff (string bp 0 s)) in
217 let loc = (bp, Stream.count s) in
220 let tok = ("QUOTATION", "tot:"^(qstring bp 0 s)) in
221 let loc = (bp, Stream.count s) in
224 let tok = dollar bp 0 s in
225 let loc = (bp, Stream.count s) in
227 | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c);
229 let id = get_buff (ident2 (store 0 c) s) in
230 keyword_or_error (bp, Stream.count s) id
234 [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep ->
235 (("TILDEIDENT", get_buff len), (bp, ep))
237 let id = get_buff (ident2 (store 0 c) s) in
238 keyword_or_error (bp, Stream.count s) id ] :] ->
243 [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep ->
244 (("QUESTIONIDENT", get_buff len), (bp, ep))
246 let id = get_buff (ident2 (store 0 c) s) in
247 keyword_or_error (bp, Stream.count s) id ] :] ->
249 | [: `'<'; s :] -> less bp s
253 [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2
254 | [: :] -> store 0 c1 ] :] ep ->
255 let id = get_buff len in
256 keyword_or_error (bp, ep) id
257 | [: `('>' | '|' as c1);
260 [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
261 | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
262 let id = get_buff len in
263 keyword_or_error (bp, ep) id
264 | [: `('[' | '{' as c1); s :] ->
266 match Stream.npeek 2 s with
267 [ ['<'; '<' | ':'] -> store 0 c1
270 [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
271 | [: :] -> store 0 c1 ] ]
273 let ep = Stream.count s in
274 let id = get_buff len in
275 keyword_or_error (bp, ep) id
280 | [: :] -> if ssd && after_space then " ." else "." ] :] ep ->
281 keyword_or_error (bp, ep) id
286 | [: :] -> ";" ] :] ep ->
287 keyword_or_error (bp, ep) id
288 | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep))
289 | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c)
290 | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ]
292 if no_quotations.val then
293 match strm with parser
294 [ [: len = ident2 (store 0 '<') :] ep ->
295 let id = get_buff len in
296 keyword_or_error (bp, ep) id ]
298 match strm with parser
299 [ [: `'<'; len = quotation bp 0 :] ep ->
300 (("QUOTATION", ":" ^ get_buff len), (bp, ep))
301 | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
302 `'<' ? "character '<' expected"; len = quotation bp 0 :] ep ->
303 (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep))
304 | [: len = ident2 (store 0 '<') :] ep ->
305 let id = get_buff len in
306 keyword_or_error (bp, ep) id ]
310 | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s
311 | [: `c; s :] -> string bp (store len c) s
312 | [: :] ep -> err (bp, ep) "string not terminated" ]
315 [ [: `'`' :] -> get_buff len
316 | [: `c; s :] -> qstring bp (store len c) s
317 | [: :] ep -> err (bp, ep) "quotation not terminated" ]
320 [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len
321 | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s
322 | [: `c; s :] -> char bp (store len c) s
323 | [: :] ep -> err (bp, ep) "char not terminated" ]
326 [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
327 | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s
328 | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
330 let k = get_buff len in
331 ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
332 | [: `'\\'; `c; s :] ->
333 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
338 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
339 | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
340 else ("", get_buff (ident2 (store 0 '$') s)) ]
341 and maybe_locate bp len =
343 [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
344 | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
346 ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s)
347 | [: `'\\'; `c; s :] ->
348 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
350 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
351 | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
352 and antiquot bp len =
354 [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
355 | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
356 antiquot bp (store len c) s
358 let k = get_buff len in
359 ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
360 | [: `'\\'; `c; s :] ->
361 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
363 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
364 | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
365 and locate_or_antiquot_rest bp len =
367 [ [: `'$' :] -> get_buff len
368 | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s
369 | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s
370 | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
371 and quotation bp len =
373 [ [: `'>'; s :] -> maybe_end_quotation bp len s
375 quotation bp (maybe_nested_quotation bp (store len '<') s) s
379 [ [: `('>' | '<' | '\\' as c) :] -> store len c
380 | [: :] -> store len '\\' ];
383 | [: `c; s :] -> quotation bp (store len c) s
384 | [: :] ep -> err (bp, ep) "quotation not terminated" ]
385 and maybe_nested_quotation bp len =
387 [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
388 | [: `':'; len = ident (store len ':');
391 [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
392 | [: :] -> len ] :] ->
395 and maybe_end_quotation bp len =
398 | [: a = quotation bp (store len '>') :] -> a ]
401 [ [: `'*'; _ = comment bp; a = next_token True :] -> a
402 | [: :] ep -> keyword_or_error (bp, ep) "(" ]
405 [ [: `'('; s :] -> left_paren_in_comment bp s
406 | [: `'*'; s :] -> star_in_comment bp s
407 | [: `'"'; _ = string bp 0; s :] -> comment bp s
408 | [: `'''; s :] -> quote_in_comment bp s
409 | [: `c; s :] -> comment bp s
410 | [: :] ep -> err (bp, ep) "comment not terminated" ]
411 and quote_in_comment bp =
413 [ [: `'''; s :] -> comment bp s
414 | [: `'\013'; s :] -> quote_cr_in_comment bp s
415 | [: `'\\'; s :] -> quote_antislash_in_comment bp s
416 | [: `'('; s :] -> quote_left_paren_in_comment bp s
417 | [: `'*'; s :] -> quote_star_in_comment bp s
418 | [: `'"'; s :] -> quote_doublequote_in_comment bp s
419 | [: `_; s :] -> quote_any_in_comment bp s
420 | [: s :] -> comment bp s ]
421 and quote_any_in_comment bp =
423 [ [: `'''; s :] -> comment bp s
424 | [: s :] -> comment bp s ]
425 and quote_cr_in_comment bp =
427 [ [: `'\010'; s :] -> quote_any_in_comment bp s
428 | [: s :] -> quote_any_in_comment bp s ]
429 and quote_left_paren_in_comment bp =
431 [ [: `'''; s :] -> comment bp s
432 | [: s :] -> left_paren_in_comment bp s ]
433 and quote_star_in_comment bp =
435 [ [: `'''; s :] -> comment bp s
436 | [: s :] -> star_in_comment bp s ]
437 and quote_doublequote_in_comment bp =
439 [ [: `'''; s :] -> comment bp s
440 | [: _ = string bp 0; s :] -> comment bp s ]
441 and quote_antislash_in_comment bp =
443 [ [: `'''; s :] -> quote_antislash_quote_in_comment bp s
444 | [: `('\\' | '"' | 'n' | 't' | 'b' | 'r'); s :] ->
445 quote_any_in_comment bp s
446 | [: `('0'..'9'); s :] -> quote_antislash_digit_in_comment bp s
447 | [: `'x'; s :] -> quote_antislash_x_in_comment bp s
448 | [: s :] -> comment bp s ]
449 and quote_antislash_quote_in_comment bp =
451 [ [: `'''; s :] -> comment bp s
452 | [: s :] -> quote_in_comment bp s ]
453 and quote_antislash_digit_in_comment bp =
455 [ [: `('0'..'9'); s :] -> quote_antislash_digit2_in_comment bp s
456 | [: s :] -> comment bp s ]
457 and quote_antislash_digit2_in_comment bp =
459 [ [: `('0'..'9'); s :] -> quote_any_in_comment bp s
460 | [: s :] -> comment bp s ]
461 and quote_antislash_x_in_comment bp =
463 [ [: _ = hexa; s :] -> quote_antislash_x_digit_in_comment bp s
464 | [: s :] -> comment bp s ]
465 and quote_antislash_x_digit_in_comment bp =
467 [ [: _ = hexa; s :] -> quote_any_in_comment bp s
468 | [: s :] -> comment bp s ]
469 and left_paren_in_comment bp =
471 [ [: `'*'; s :] -> do { comment bp s; comment bp s }
472 | [: a = comment bp :] -> a ]
473 and star_in_comment bp =
476 | [: a = comment bp :] -> a ]
478 match stream_peek_nth n s with
479 [ Some (' ' | '\t') -> linedir (n + 1) s
480 | Some ('0'..'9') -> linedir_digits (n + 1) s
482 and linedir_digits n s =
483 match stream_peek_nth n s with
484 [ Some ('0'..'9') -> linedir_digits (n + 1) s
485 | _ -> linedir_quote n s ]
486 and linedir_quote n s =
487 match stream_peek_nth n s with
488 [ Some (' ' | '\t') -> linedir_quote (n + 1) s
493 [ [: `'\013' | '\010' :] ep -> bolpos.val := ep
494 | [: `_; s :] -> any_to_nl s
499 let glex = glexr.val in
500 let comm_bp = Stream.count cstrm in
501 let r = next_token False cstrm in
503 match glex.tok_comm with
505 if fst (snd r) > comm_bp then
506 let comm_loc = (comm_bp, fst (snd r)) in
507 glex.tok_comm := Some [comm_loc :: list]
513 [ Stream.Error str ->
514 err (Stream.count cstrm, Stream.count cstrm + 1) str ]
518 value next_token_fun dfa ssd find_kwd bolpos glexr =
519 let keyword_or_error loc s =
520 try (("", find_kwd s), loc) with
522 if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s)
523 else (("", s), loc) ] in
524 let error_if_keyword ( ((_,id), loc) as a) =
527 err loc ("illegal use of a keyword as a label: " ^ id) }
528 with [ Not_found -> a ]
530 let rec next_token after_space =
532 [ [: `'\010' | '\013'; s :] ep ->
533 do { bolpos.val := ep; next_token True s }
534 | [: `' ' | '\t' | '\026' | '\012'; s :] -> next_token True s
535 | [: `'#' when bp = bolpos.val; s :] ->
536 if linedir 1 s then do { any_to_nl s; next_token True s }
537 else keyword_or_error (bp, bp + 1) "#"
538 | [: `'('; s :] -> left_paren bp s
539 | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] ->
540 let id = get_buff (ident (store 0 c) s) in
541 let loc = (bp, Stream.count s) in
542 (jrh_identifier find_kwd id, loc)
545 (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc)
548 | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] ->
549 let id = get_buff (ident (store 0 c) s) in
550 let loc = (bp, Stream.count s) in
551 (jrh_identifier find_kwd id, loc)
554 (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc)
557 | [: `('1'..'9' as c); s :] ->
558 let tok = number (store 0 c) s in
559 let loc = (bp, Stream.count s) in
562 let tok = base_number (store 0 '0') s in
563 let loc = (bp, Stream.count s) in
566 match Stream.npeek 2 s with
567 [ [_; '''] | ['\\'; _] ->
568 let tok = ("CHAR", get_buff (char bp 0 s)) in
569 let loc = (bp, Stream.count s) in
571 | _ -> keyword_or_error (bp, Stream.count s) "'" ]
573 let tok = ("STRING", get_buff (string bp 0 s)) in
574 let loc = (bp, Stream.count s) in
577 let tok = ("QUOTATION", "tot:"^(qstring bp 0 s)) in
578 let loc = (bp, Stream.count s) in
581 let tok = dollar bp 0 s in
582 let loc = (bp, Stream.count s) in
584 | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c);
586 let id = get_buff (ident2 (store 0 c) s) in
587 keyword_or_error (bp, Stream.count s) id
591 [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep ->
592 let id = get_buff len in
594 [ [: `':' :] eb -> error_if_keyword (("LABEL", id), (bp,ep))
595 | [: :] -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) ]
597 let id = get_buff (ident2 (store 0 c) s) in
598 keyword_or_error (bp, Stream.count s) id ] :] ->
604 [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep ->
605 let id = get_buff len in
607 [ [: `':' :] eb -> error_if_keyword (("OPTLABEL", id), (bp,ep))
608 | [: :] -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep)) ]
610 let id = get_buff (ident2 (store 0 c) s) in
611 keyword_or_error (bp, Stream.count s) id ] :] ->
613 | [: `'<'; s :] -> less bp s
617 [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2
618 | [: :] -> store 0 c1 ] :] ep ->
619 let id = get_buff len in
620 keyword_or_error (bp, ep) id
621 | [: `('>' | '|' as c1);
624 [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
625 | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
626 let id = get_buff len in
627 keyword_or_error (bp, ep) id
628 | [: `('[' | '{' as c1); s :] ->
630 match Stream.npeek 2 s with
631 [ ['<'; '<' | ':'] -> store 0 c1
634 [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
635 | [: :] -> store 0 c1 ] ]
637 let ep = Stream.count s in
638 let id = get_buff len in
639 keyword_or_error (bp, ep) id
644 | [: :] -> if ssd && after_space then " ." else "." ] :] ep ->
645 keyword_or_error (bp, ep) id
650 | [: :] -> ";" ] :] ep ->
651 keyword_or_error (bp, ep) id
652 | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep))
653 | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c)
654 | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ]
656 if no_quotations.val then
657 match strm with parser
658 [ [: len = ident2 (store 0 '<') :] ep ->
659 let id = get_buff len in
660 keyword_or_error (bp, ep) id ]
662 match strm with parser
663 [ [: `'<'; len = quotation bp 0 :] ep ->
664 (("QUOTATION", ":" ^ get_buff len), (bp, ep))
665 | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
666 `'<' ? "character '<' expected"; len = quotation bp 0 :] ep ->
667 (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep))
668 | [: len = ident2 (store 0 '<') :] ep ->
669 let id = get_buff len in
670 keyword_or_error (bp, ep) id ]
674 | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s
675 | [: `c; s :] -> string bp (store len c) s
676 | [: :] ep -> err (bp, ep) "string not terminated" ]
679 [ [: `'`' :] -> get_buff len
680 | [: `c; s :] -> qstring bp (store len c) s
681 | [: :] ep -> err (bp, ep) "quotation not terminated" ]
684 [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len
685 | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s
686 | [: `c; s :] -> char bp (store len c) s
687 | [: :] ep -> err (bp, ep) "char not terminated" ]
690 [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
691 | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s
692 | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
694 let k = get_buff len in
695 ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
696 | [: `'\\'; `c; s :] ->
697 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
702 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
703 | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
704 else ("", get_buff (ident2 (store 0 '$') s)) ]
705 and maybe_locate bp len =
707 [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
708 | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
710 ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s)
711 | [: `'\\'; `c; s :] ->
712 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
714 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
715 | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
716 and antiquot bp len =
718 [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
719 | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
720 antiquot bp (store len c) s
722 let k = get_buff len in
723 ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
724 | [: `'\\'; `c; s :] ->
725 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
727 ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
728 | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
729 and locate_or_antiquot_rest bp len =
731 [ [: `'$' :] -> get_buff len
732 | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s
733 | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s
734 | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
735 and quotation bp len =
737 [ [: `'>'; s :] -> maybe_end_quotation bp len s
739 quotation bp (maybe_nested_quotation bp (store len '<') s) s
743 [ [: `('>' | '<' | '\\' as c) :] -> store len c
744 | [: :] -> store len '\\' ];
747 | [: `c; s :] -> quotation bp (store len c) s
748 | [: :] ep -> err (bp, ep) "quotation not terminated" ]
749 and maybe_nested_quotation bp len =
751 [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
752 | [: `':'; len = ident (store len ':');
755 [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
756 | [: :] -> len ] :] ->
759 and maybe_end_quotation bp len =
762 | [: a = quotation bp (store len '>') :] -> a ]
765 [ [: `'*'; _ = comment bp; a = next_token True :] -> a
766 | [: :] ep -> keyword_or_error (bp, ep) "(" ]
769 [ [: `'('; s :] -> left_paren_in_comment bp s
770 | [: `'*'; s :] -> star_in_comment bp s
771 | [: `'"'; _ = string bp 0; s :] -> comment bp s
772 | [: `'''; s :] -> quote_in_comment bp s
773 | [: `c; s :] -> comment bp s
774 | [: :] ep -> err (bp, ep) "comment not terminated" ]
775 and quote_in_comment bp =
777 [ [: `'''; s :] -> comment bp s
778 | [: `'\\'; s :] -> quote_antislash_in_comment bp 0 s
781 match Stream.npeek 2 s with
782 [ [_; '''] -> do { Stream.junk s; Stream.junk s }
786 and quote_any_in_comment bp =
788 [ [: `'''; s :] -> comment bp s
789 | [: a = comment bp :] -> a ]
790 and quote_antislash_in_comment bp len =
792 [ [: `'''; s :] -> comment bp s
793 | [: `'\\' | '"' | 'n' | 't' | 'b' | 'r'; s :] ->
794 quote_any_in_comment bp s
795 | [: `'0'..'9'; s :] -> quote_antislash_digit_in_comment bp s
796 | [: a = comment bp :] -> a ]
797 and quote_antislash_digit_in_comment bp =
799 [ [: `'0'..'9'; s :] -> quote_antislash_digit2_in_comment bp s
800 | [: a = comment bp :] -> a ]
801 and quote_antislash_digit2_in_comment bp =
803 [ [: `'0'..'9'; s :] -> quote_any_in_comment bp s
804 | [: a = comment bp :] -> a ]
805 and left_paren_in_comment bp =
807 [ [: `'*'; s :] -> do { comment bp s; comment bp s }
808 | [: a = comment bp :] -> a ]
809 and star_in_comment bp =
812 | [: a = comment bp :] -> a ]
814 match stream_peek_nth n s with
815 [ Some (' ' | '\t') -> linedir (n + 1) s
816 | Some ('0'..'9') -> linedir_digits (n + 1) s
818 and linedir_digits n s =
819 match stream_peek_nth n s with
820 [ Some ('0'..'9') -> linedir_digits (n + 1) s
821 | _ -> linedir_quote n s ]
822 and linedir_quote n s =
823 match stream_peek_nth n s with
824 [ Some (' ' | '\t') -> linedir_quote (n + 1) s
829 [ [: `'\013' | '\010' :] ep -> bolpos.val := ep
830 | [: `_; s :] -> any_to_nl s
835 let glex = glexr.val in
836 let comm_bp = Stream.count cstrm in
837 let r = next_token False cstrm in
839 match glex.tok_comm with
841 if fst (snd r) > comm_bp then
842 let comm_loc = (comm_bp, fst (snd r)) in
843 glex.tok_comm := Some [comm_loc :: list]
849 [ Stream.Error str ->
850 err (Stream.count cstrm, Stream.count cstrm + 1) str ]
854 value dollar_for_antiquotation = ref True;
855 value specific_space_dot = ref False;
857 value func kwd_table glexr =
858 let bolpos = ref 0 in
859 let find = Hashtbl.find kwd_table in
860 let dfa = dollar_for_antiquotation.val in
861 let ssd = specific_space_dot.val in
862 Token.lexer_func_of_parser (next_token_fun dfa ssd find bolpos glexr)
865 value rec check_keyword_stream =
866 parser [: _ = check; _ = Stream.empty :] -> True
869 [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255'
873 | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
879 match Stream.npeek 1 s with
881 | _ -> check_ident2 s ]
885 [ [: `']' | ':' | '=' | '>' :] -> ()
886 | [: :] -> () ] :] ep ->
891 [ [: `']' | '}' :] -> ()
892 | [: a = check_ident2 :] -> a ] :] ->
894 | [: `'[' | '{'; s :] ->
895 match Stream.npeek 2 s with
896 [ ['<'; '<' | ':'] -> ()
899 [ [: `'|' | '<' | ':' :] -> ()
905 | [: :] -> () ] :] ->
910 [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
911 '\248'..'\255' | '0'..'9' | '_' | '''
918 [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
919 '%' | '.' | ':' | '<' | '>' | '|'
926 value check_keyword s =
927 try check_keyword_stream (Stream.of_string s) with _ -> False
930 value error_no_respect_rules p_con p_prm =
934 (if p_con = "" then "\"" ^ p_prm ^ "\""
935 else if p_prm = "" then p_con
936 else p_con ^ " \"" ^ p_prm ^ "\"") ^
937 " does not respect Plexer rules"))
940 value error_ident_and_keyword p_con p_prm =
943 ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^
947 value using_token kwd_table ident_table (p_con, p_prm) =
950 if not (Hashtbl.mem kwd_table p_prm) then
951 if check_keyword p_prm then
952 if Hashtbl.mem ident_table p_prm then
953 error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm
954 else Hashtbl.add kwd_table p_prm p_prm
955 else error_no_respect_rules p_con p_prm
958 if p_prm = "" then ()
961 [ 'A'..'Z' -> error_no_respect_rules p_con p_prm
963 if Hashtbl.mem kwd_table p_prm then
964 error_ident_and_keyword p_con p_prm
965 else Hashtbl.add ident_table p_prm p_con ]
967 if p_prm = "" then ()
970 [ 'a'..'z' -> error_no_respect_rules p_con p_prm
972 if Hashtbl.mem kwd_table p_prm then
973 error_ident_and_keyword p_con p_prm
974 else Hashtbl.add ident_table p_prm p_con ]
975 | "INT" | "INT32" | "INT64" | "NATIVEINT"
976 | "FLOAT" | "CHAR" | "STRING"
977 | "TILDEIDENT" | "QUESTIONIDENT" | "LABEL" | "OPTLABEL"
978 | "QUOTATION" | "ANTIQUOT" | "LOCATE" | "EOI" ->
983 ("the constructor \"" ^ p_con ^
984 "\" is not recognized by Plexer")) ]
987 value removing_token kwd_table ident_table (p_con, p_prm) =
989 [ "" -> Hashtbl.remove kwd_table p_prm
990 | "LIDENT" | "UIDENT" ->
991 if p_prm <> "" then Hashtbl.remove ident_table p_prm else ()
997 [ ("", t) -> "'" ^ t ^ "'"
998 | ("LIDENT", "") -> "lowercase identifier"
999 | ("LIDENT", t) -> "'" ^ t ^ "'"
1000 | ("UIDENT", "") -> "uppercase identifier"
1001 | ("UIDENT", t) -> "'" ^ t ^ "'"
1002 | ("INT", "") -> "integer"
1003 | ("INT32", "") -> "32 bits integer"
1004 | ("INT64", "") -> "64 bits integer"
1005 | ("NATIVEINT", "") -> "native integer"
1006 | (("INT" | "INT32" | "NATIVEINT"), s) -> "'" ^ s ^ "'"
1007 | ("FLOAT", "") -> "float"
1008 | ("STRING", "") -> "string"
1009 | ("CHAR", "") -> "char"
1010 | ("QUOTATION", "") -> "quotation"
1011 | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\""
1012 | ("LOCATE", "") -> "locate"
1013 | ("EOI", "") -> "end of input"
1015 | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
1018 value eq_before_colon p e =
1019 loop 0 where rec loop i =
1020 if i == String.length e then
1021 failwith "Internal error in Plexer: incorrect ANTIQUOT"
1022 else if i == String.length p then e.[i] == ':'
1023 else if p.[i] == e.[i] then loop (i + 1)
1027 value after_colon e =
1029 let i = String.index e ':' in
1030 String.sub e (i + 1) (String.length e - i - 1)
1037 [ ("ANTIQUOT", p_prm) ->
1039 [ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm
1040 | _ -> raise Stream.Failure ]
1041 | tok -> Token.default_match tok ]
1045 let kwd_table = Hashtbl.create 301 in
1046 let id_table = Hashtbl.create 301 in
1049 {tok_func = fun []; tok_using = fun []; tok_removing = fun [];
1050 tok_match = fun []; tok_text = fun []; tok_comm = None}
1053 {tok_func = func kwd_table glexr;
1054 tok_using = using_token kwd_table id_table;
1055 tok_removing = removing_token kwd_table id_table; tok_match = tok_match;
1056 tok_text = text; tok_comm = None}
1058 do { glexr.val := glex; glex }
1063 [ ("ANTIQUOT", p_prm) ->
1066 [: `("ANTIQUOT", prm) when eq_before_colon p_prm prm :] ->
1074 let kwd_table = Hashtbl.create 301 in
1075 let id_table = Hashtbl.create 301 in
1078 {tok_func = fun []; tok_using = fun []; tok_removing = fun [];
1079 tok_match = fun []; tok_text = fun []; tok_comm = None}
1081 {func = func kwd_table glexr; using = using_token kwd_table id_table;
1082 removing = removing_token kwd_table id_table; tparse = tparse; text = text}
1085 (* ------------------------------------------------------------------------- *)
1086 (* Resume the main file. *)
1087 (* ------------------------------------------------------------------------- *)
1090 let odfa = dollar_for_antiquotation.val in
1091 dollar_for_antiquotation.val := False;
1092 Grammar.Unsafe.gram_reinit gram (gmake ());
1093 dollar_for_antiquotation.val := odfa;
1094 Grammar.Unsafe.clear_entry interf;
1095 Grammar.Unsafe.clear_entry implem;
1096 Grammar.Unsafe.clear_entry top_phrase;
1097 Grammar.Unsafe.clear_entry use_file;
1098 Grammar.Unsafe.clear_entry module_type;
1099 Grammar.Unsafe.clear_entry module_expr;
1100 Grammar.Unsafe.clear_entry sig_item;
1101 Grammar.Unsafe.clear_entry str_item;
1102 Grammar.Unsafe.clear_entry expr;
1103 Grammar.Unsafe.clear_entry patt;
1104 Grammar.Unsafe.clear_entry ctyp;
1105 Grammar.Unsafe.clear_entry let_binding;
1106 Grammar.Unsafe.clear_entry type_declaration;
1107 Grammar.Unsafe.clear_entry class_type;
1108 Grammar.Unsafe.clear_entry class_expr;
1109 Grammar.Unsafe.clear_entry class_sig_item;
1110 Grammar.Unsafe.clear_entry class_str_item
1113 Pcaml.parse_interf.val := Grammar.Entry.parse interf;
1114 Pcaml.parse_implem.val := Grammar.Entry.parse implem;
1122 value mkumin loc f arg =
1124 [ ("-", <:expr< $int:n$ >>) when int_of_string n > 0 ->
1127 | ("-", MLast.ExInt32 loc n) when (Int32.of_string n) > 0l ->
1128 MLast.ExInt32 loc ("-" ^ n)
1129 | ("-", MLast.ExInt64 loc n) when (Int64.of_string n) > 0L ->
1130 MLast.ExInt64 loc ("-" ^ n)
1131 | ("-", MLast.ExNativeInt loc n) when (Nativeint.of_string n) > 0n ->
1132 MLast.ExNativeInt loc ("-" ^ n)
1133 | (_, <:expr< $flo:n$ >>) when float_of_string n > 0.0 ->
1138 <:expr< $lid:f$ $arg$ >> ]
1141 value mklistexp loc last =
1142 loop True where rec loop top =
1147 | None -> <:expr< [] >> ]
1149 let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in
1150 <:expr< [$e1$ :: $loop False el$] >> ]
1153 value mklistpat loc last =
1154 loop True where rec loop top =
1159 | None -> <:patt< [] >> ]
1161 let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in
1162 <:patt< [$p1$ :: $loop False pl$] >> ]
1165 (*** JRH pulled this outside so user can add new infixes here too ***)
1167 value ht = Hashtbl.create 73;
1169 (*** And JRH added all the new HOL Light infixes here already ***)
1172 let ct = Hashtbl.create 73 in
1174 List.iter (fun x -> Hashtbl.add ht x True)
1175 ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; "o"; "upto";
1176 "F_F"; "THENC"; "THEN"; "THENL"; "ORELSE"; "ORELSEC";
1177 "THEN_TCL"; "ORELSE_TCL"];
1178 List.iter (fun x -> Hashtbl.add ct x True)
1179 ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~';
1180 '?'; '%'; '.'; '$'];
1182 try Hashtbl.find ht x with
1183 [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ]
1186 (*** JRH added this so parenthesised operators undergo same mapping ***)
1188 value translate_operator =
1192 | "THENC" -> "thenc_"
1193 | "THENL" -> "thenl_"
1194 | "ORELSE" -> "orelse_"
1195 | "ORELSEC" -> "orelsec_"
1196 | "THEN_TCL" -> "then_tcl_"
1197 | "ORELSE_TCL" -> "orelse_tcl_"
1201 (*** And JRH inserted it in here ***)
1203 value operator_rparen =
1204 Grammar.Entry.of_parser gram "operator_rparen"
1206 match Stream.npeek 2 strm with
1207 [ [("", s); ("", ")")] when is_operator s ->
1208 do { Stream.junk strm; Stream.junk strm; translate_operator s }
1209 | _ -> raise Stream.Failure ])
1212 value lident_colon =
1213 Grammar.Entry.of_parser gram "lident_colon"
1215 match Stream.npeek 2 strm with
1216 [ [("LIDENT", i); ("", ":")] ->
1217 do { Stream.junk strm; Stream.junk strm; i }
1218 | _ -> raise Stream.Failure ])
1223 ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?';
1227 if i == String.length s then True
1228 else if List.mem s.[i] list then loop s (i + 1)
1235 let list = ['!'; '?'; '~'] in
1236 let excl = ["!="; "??"] in
1237 Grammar.Entry.of_parser gram "prefixop"
1241 not (List.mem x excl) && String.length x >= 2 &&
1242 List.mem x.[0] list && symbolchar x 1 :] ->
1247 let list = ['='; '<'; '>'; '|'; '&'; '$'] in
1248 let excl = ["<-"; "||"; "&&"] in
1249 Grammar.Entry.of_parser gram "infixop0"
1253 not (List.mem x excl) && String.length x >= 2 &&
1254 List.mem x.[0] list && symbolchar x 1 :] ->
1259 let list = ['@'; '^'] in
1260 Grammar.Entry.of_parser gram "infixop1"
1264 String.length x >= 2 && List.mem x.[0] list &&
1265 symbolchar x 1 :] ->
1270 let list = ['+'; '-'] in
1271 Grammar.Entry.of_parser gram "infixop2"
1275 x <> "->" && String.length x >= 2 && List.mem x.[0] list &&
1276 symbolchar x 1 :] ->
1281 let list = ['*'; '/'; '%'] in
1282 Grammar.Entry.of_parser gram "infixop3"
1286 String.length x >= 2 && List.mem x.[0] list &&
1287 symbolchar x 1 :] ->
1292 Grammar.Entry.of_parser gram "infixop4"
1296 String.length x >= 3 && x.[0] == '*' && x.[1] == '*' &&
1297 symbolchar x 2 :] ->
1301 value test_constr_decl =
1302 Grammar.Entry.of_parser gram "test_constr_decl"
1304 match Stream.npeek 1 strm with
1305 [ [("UIDENT", _)] ->
1306 match Stream.npeek 2 strm with
1307 [ [_; ("", ".")] -> raise Stream.Failure
1308 | [_; ("", "(")] -> raise Stream.Failure
1310 | _ -> raise Stream.Failure ]
1312 | _ -> raise Stream.Failure ])
1315 value stream_peek_nth n strm =
1316 loop n (Stream.npeek n strm) where rec loop n =
1319 | [x] -> if n == 1 then Some x else None
1320 | [_ :: l] -> loop (n - 1) l ]
1323 (* horrible hack to be able to parse class_types *)
1325 value test_ctyp_minusgreater =
1326 Grammar.Entry.of_parser gram "test_ctyp_minusgreater"
1328 let rec skip_simple_ctyp n =
1329 match stream_peek_nth n strm with
1330 [ Some ("", "->") -> n
1331 | Some ("", "[" | "[<") ->
1332 skip_simple_ctyp (ignore_upto "]" (n + 1) + 1)
1333 | Some ("", "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1)
1336 "as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" |
1338 skip_simple_ctyp (n + 1)
1339 | Some ("QUESTIONIDENT" | "LIDENT" | "UIDENT", _) ->
1340 skip_simple_ctyp (n + 1)
1341 | Some _ | None -> raise Stream.Failure ]
1342 and ignore_upto end_kwd n =
1343 match stream_peek_nth n strm with
1344 [ Some ("", prm) when prm = end_kwd -> n
1345 | Some ("", "[" | "[<") ->
1346 ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1)
1347 | Some ("", "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1)
1348 | Some _ -> ignore_upto end_kwd (n + 1)
1349 | None -> raise Stream.Failure ]
1351 match Stream.peek strm with
1352 [ Some (("", "[") | ("LIDENT" | "UIDENT", _)) -> skip_simple_ctyp 1
1353 | Some ("", "object") -> raise Stream.Failure
1357 value test_label_eq =
1358 Grammar.Entry.of_parser gram "test_label_eq"
1359 (test 1 where rec test lev strm =
1360 match stream_peek_nth lev strm with
1361 [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) ->
1363 | Some ("", "=") -> ()
1364 | _ -> raise Stream.Failure ])
1367 value test_typevar_list_dot =
1368 Grammar.Entry.of_parser gram "test_typevar_list_dot"
1369 (let rec test lev strm =
1370 match stream_peek_nth lev strm with
1371 [ Some ("", "'") -> test2 (lev + 1) strm
1372 | Some ("", ".") -> ()
1373 | _ -> raise Stream.Failure ]
1374 and test2 lev strm =
1375 match stream_peek_nth lev strm with
1376 [ Some ("UIDENT" | "LIDENT", _) -> test (lev + 1) strm
1377 | _ -> raise Stream.Failure ]
1382 value constr_arity = ref [("Some", 1); ("Match_Failure", 1)];
1384 value rec is_expr_constr_call =
1386 [ <:expr< $uid:_$ >> -> True
1387 | <:expr< $uid:_$.$e$ >> -> is_expr_constr_call e
1388 | <:expr< $e$ $_$ >> -> is_expr_constr_call e
1392 value rec constr_expr_arity loc =
1394 [ <:expr< $uid:c$ >> ->
1395 try List.assoc c constr_arity.val with [ Not_found -> 0 ]
1396 | <:expr< $uid:_$.$e$ >> -> constr_expr_arity loc e
1397 | <:expr< $e$ $_$ >> ->
1398 if is_expr_constr_call e then
1399 Stdpp.raise_with_loc loc (Stream.Error "currified constructor")
1404 value rec is_patt_constr_call =
1406 [ <:patt< $uid:_$ >> -> True
1407 | <:patt< $uid:_$.$p$ >> -> is_patt_constr_call p
1408 | <:patt< $p$ $_$ >> -> is_patt_constr_call p
1412 value rec constr_patt_arity loc =
1414 [ <:patt< $uid:c$ >> ->
1415 try List.assoc c constr_arity.val with [ Not_found -> 0 ]
1416 | <:patt< $uid:_$.$p$ >> -> constr_patt_arity loc p
1417 | <:patt< $p$ $_$ >> ->
1418 if is_patt_constr_call p then
1419 Stdpp.raise_with_loc loc (Stream.Error "currified constructor")
1426 [ <:expr< do { $list:el$ } >> -> el
1430 value choose_tvar tpl =
1431 let rec find_alpha v =
1432 let s = String.make 1 v in
1433 if List.mem_assoc s tpl then
1434 if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
1435 else Some (String.make 1 v)
1438 let v = "a" ^ string_of_int n in
1439 if List.mem_assoc v tpl then make_n (succ n) else v
1441 match find_alpha 'a' with
1443 | None -> make_n 1 ]
1446 value rec patt_lid =
1448 [ <:patt< $p1$ $p2$ >> ->
1450 [ <:patt< $lid:i$ >> -> Some (MLast.loc_of_patt p1, i, [p2])
1452 match patt_lid p1 with
1453 [ Some (loc, i, pl) -> Some (loc, i, [p2 :: pl])
1458 value bigarray_get loc arr arg =
1461 [ <:expr< ($list:el$) >> -> el
1465 [ [c1] -> <:expr< Bigarray.Array1.get $arr$ $c1$ >>
1466 | [c1; c2] -> <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >>
1467 | [c1; c2; c3] -> <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >>
1468 | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ]
1471 value bigarray_set loc var newval =
1473 [ <:expr< Bigarray.Array1.get $arr$ $c1$ >> ->
1474 Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >>
1475 | <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> ->
1476 Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >>
1477 | <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> ->
1478 Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >>
1479 | <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ->
1480 Some <:expr< Bigarray.Genarray.set $arr$ [| $list:coords$ |] $newval$ >>
1486 match cs with parser
1487 [ [: `';' :] -> sync_semi cs
1488 | [: `_ :] -> sync cs ]
1490 match cs with parser
1491 [ [: `';' :] -> sync_semisemi cs
1492 | [: :] -> sync cs ]
1493 and sync_semisemi cs =
1494 match Stream.peek cs with
1495 [ Some ('\010' | '\013') -> ()
1496 | _ -> sync_semi cs ]
1498 Pcaml.sync.val := sync;
1502 GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type
1503 class_expr class_sig_item class_str_item let_binding type_declaration;
1505 [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->";
1507 <:module_expr< functor ( $i$ : $t$ ) -> $me$ >>
1508 | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" ->
1509 <:module_expr< struct $list:st$ end >> ]
1510 | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ]
1511 | [ i = mod_expr_ident -> i
1512 | "("; me = SELF; ":"; mt = module_type; ")" ->
1513 <:module_expr< ( $me$ : $mt$ ) >>
1514 | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ]
1518 [ i = SELF; "."; j = SELF -> <:module_expr< $i$ . $j$ >> ]
1519 | [ i = UIDENT -> <:module_expr< $uid:i$ >> ] ]
1523 [ "exception"; (_, c, tl) = constructor_declaration; b = rebind_exn ->
1524 <:str_item< exception $c$ of $list:tl$ = $b$ >>
1525 | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
1526 <:str_item< external $i$ : $t$ = $list:pd$ >>
1527 | "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
1528 pd = LIST1 STRING ->
1529 <:str_item< external $i$ : $t$ = $list:pd$ >>
1530 | "include"; me = module_expr -> <:str_item< include $me$ >>
1531 | "module"; i = UIDENT; mb = module_binding ->
1532 <:str_item< module $i$ = $mb$ >>
1533 | "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" ->
1534 MLast.StRecMod loc nmtmes
1535 | "module"; "type"; i = UIDENT; "="; mt = module_type ->
1536 <:str_item< module type $i$ = $mt$ >>
1537 | "open"; i = mod_ident -> <:str_item< open $i$ >>
1538 | "type"; tdl = LIST1 type_declaration SEP "and" ->
1539 <:str_item< type $list:tdl$ >>
1540 | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
1542 let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in
1543 <:str_item< $exp:e$ >>
1544 | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" ->
1546 [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >>
1547 | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ]
1548 | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr ->
1549 <:str_item< let module $m$ = $mb$ in $e$ >>
1550 | e = expr -> <:str_item< $exp:e$ >> ] ]
1553 [ [ "="; sl = mod_ident -> sl
1558 [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
1559 <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >>
1560 | ":"; mt = module_type; "="; me = module_expr ->
1561 <:module_expr< ( $me$ : $mt$ ) >>
1562 | "="; me = module_expr -> <:module_expr< $me$ >> ] ]
1565 [ [ m = UIDENT; ":"; mt = module_type; "="; me = module_expr ->
1570 [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF ->
1571 <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ]
1572 | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" ->
1573 <:module_type< $mt$ with $list:wcl$ >> ]
1574 | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" ->
1575 <:module_type< sig $list:sg$ end >>
1576 | i = mod_type_ident -> i
1577 | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ]
1581 [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >>
1582 | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ]
1583 | [ m = UIDENT -> <:module_type< $uid:m$ >>
1584 | m = LIDENT -> <:module_type< $lid:m$ >> ] ]
1588 [ "exception"; (_, c, tl) = constructor_declaration ->
1589 <:sig_item< exception $c$ of $list:tl$ >>
1590 | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
1591 <:sig_item< external $i$ : $t$ = $list:pd$ >>
1592 | "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
1593 pd = LIST1 STRING ->
1594 <:sig_item< external $i$ : $t$ = $list:pd$ >>
1595 | "include"; mt = module_type -> <:sig_item< include $mt$ >>
1596 | "module"; i = UIDENT; mt = module_declaration ->
1597 <:sig_item< module $i$ : $mt$ >>
1598 | "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" ->
1599 MLast.SgRecMod loc mds
1600 | "module"; "type"; i = UIDENT; "="; mt = module_type ->
1601 <:sig_item< module type $i$ = $mt$ >>
1602 | "module"; "type"; i = UIDENT ->
1603 <:sig_item< module type $i$ = 'abstract >>
1604 | "open"; i = mod_ident -> <:sig_item< open $i$ >>
1605 | "type"; tdl = LIST1 type_declaration SEP "and" ->
1606 <:sig_item< type $list:tdl$ >>
1607 | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >>
1608 | "val"; "("; i = operator_rparen; ":"; t = ctyp ->
1609 <:sig_item< value $i$ : $t$ >> ] ]
1613 [ ":"; mt = module_type -> <:module_type< $mt$ >>
1614 | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF ->
1615 <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ]
1617 module_rec_declaration:
1618 [ [ m = UIDENT; ":"; mt = module_type -> (m, mt)] ]
1620 (* "with" constraints (additional type equations over signature
1623 [ [ "type"; tpl = type_parameters; i = mod_ident; "="; t = ctyp ->
1624 MLast.WcTyp loc i tpl t
1625 | "module"; i = mod_ident; "="; me = module_expr ->
1626 MLast.WcMod loc i me ] ]
1628 (* Core expressions *)
1631 [ e1 = SELF; ";"; e2 = SELF ->
1632 <:expr< do { $list:[e1 :: get_seq e2]$ } >>
1633 | e1 = SELF; ";" -> e1 ]
1635 [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
1636 x = expr LEVEL "top" ->
1637 <:expr< let $opt:o2b o$ $list:l$ in $x$ >>
1638 | "let"; "module"; m = UIDENT; mb = module_binding; "in";
1639 e = expr LEVEL "top" ->
1640 <:expr< let module $m$ = $mb$ in $e$ >>
1641 | "function"; OPT "|"; l = LIST1 match_case SEP "|" ->
1642 <:expr< fun [ $list:l$ ] >>
1643 | "fun"; p = patt LEVEL "simple"; e = fun_def ->
1644 <:expr< fun [$p$ -> $e$] >>
1645 | "match"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
1646 <:expr< match $e$ with [ $list:l$ ] >>
1647 | "try"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
1648 <:expr< try $e$ with [ $list:l$ ] >>
1649 | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1";
1650 "else"; e3 = expr LEVEL "expr1" ->
1651 <:expr< if $e1$ then $e2$ else $e3$ >>
1652 | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1" ->
1653 <:expr< if $e1$ then $e2$ else () >>
1654 | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
1655 "do"; e = SELF; "done" ->
1656 <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >>
1657 | "while"; e1 = SELF; "do"; e2 = SELF; "done" ->
1658 <:expr< while $e1$ do { $list:get_seq e2$ } >> ]
1659 | [ e = SELF; ","; el = LIST1 NEXT SEP "," ->
1660 <:expr< ( $list:[e :: el]$ ) >> ]
1662 [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" ->
1663 <:expr< $e1$.val := $e2$ >>
1664 | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" ->
1665 match bigarray_set loc e1 e2 with
1667 | None -> <:expr< $e1$ := $e2$ >> ] ]
1669 [ e1 = SELF; "or"; e2 = SELF -> <:expr< $lid:"or"$ $e1$ $e2$ >>
1670 | e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ]
1672 [ e1 = SELF; "&"; e2 = SELF -> <:expr< $lid:"&"$ $e1$ $e2$ >>
1673 | e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ]
1675 [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >>
1676 | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >>
1677 | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >>
1678 | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >>
1679 | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >>
1680 | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >>
1681 | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >>
1682 | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >>
1683 | e1 = SELF; "$"; e2 = SELF -> <:expr< $lid:"\$"$ $e1$ $e2$ >>
1684 | e1 = SELF; op = infixop0; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1686 [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >>
1687 | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >>
1688 | e1 = SELF; op = infixop1; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1690 [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ]
1692 [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >>
1693 | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >>
1694 | e1 = SELF; op = infixop2; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1696 [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >>
1697 | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >>
1698 | e1 = SELF; "%"; e2 = SELF -> <:expr< $lid:"%"$ $e1$ $e2$ >>
1699 | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >>
1700 | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >>
1701 | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >>
1702 | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >>
1703 | e1 = SELF; op = infixop3; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1705 [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >>
1706 | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >>
1707 | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >>
1708 | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >>
1709 | e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1710 | "unary minus" NONA
1711 [ "-"; e = SELF -> <:expr< $mkumin loc "-" e$ >>
1712 | "-."; e = SELF -> <:expr< $mkumin loc "-." e$ >> ]
1714 [ e1 = SELF; e2 = SELF ->
1715 match constr_expr_arity loc e1 with
1716 [ 1 -> <:expr< $e1$ $e2$ >>
1719 [ <:expr< ( $list:el$ ) >> ->
1720 List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el
1721 | _ -> <:expr< $e1$ $e2$ >> ] ]
1722 | "assert"; e = SELF ->
1724 [ <:expr< False >> -> <:expr< assert False >>
1725 | _ -> <:expr< assert ($e$) >> ]
1726 | "lazy"; e = SELF ->
1727 <:expr< lazy ($e$) >> ]
1729 [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
1730 | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>
1731 | e1 = SELF; "."; "{"; e2 = SELF; "}" -> bigarray_get loc e1 e2
1732 | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ]
1734 [ "!"; e = SELF -> <:expr< $e$ . val>>
1735 | "~-"; e = SELF -> <:expr< ~- $e$ >>
1736 | "~-."; e = SELF -> <:expr< ~-. $e$ >>
1737 | f = prefixop; e = SELF -> <:expr< $lid:f$ $e$ >> ]
1739 [ s = INT -> <:expr< $int:s$ >>
1740 | s = INT32 -> MLast.ExInt32 loc s
1741 | s = INT64 -> MLast.ExInt64 loc s
1742 | s = NATIVEINT -> MLast.ExNativeInt loc s
1743 | s = FLOAT -> <:expr< $flo:s$ >>
1744 | s = STRING -> <:expr< $str:s$ >>
1745 | c = CHAR -> <:expr< $chr:c$ >>
1746 | UIDENT "True" -> <:expr< $uid:" True"$ >>
1747 | UIDENT "False" -> <:expr< $uid:" False"$ >>
1748 | i = expr_ident -> i
1749 | s = "false" -> <:expr< False >>
1750 | s = "true" -> <:expr< True >>
1751 | "["; "]" -> <:expr< [] >>
1752 | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >>
1753 | "[|"; "|]" -> <:expr< [| |] >>
1754 | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >>
1755 | "{"; test_label_eq; lel = lbl_expr_list; "}" ->
1756 <:expr< { $list:lel$ } >>
1757 | "{"; e = expr LEVEL "."; "with"; lel = lbl_expr_list; "}" ->
1758 <:expr< { ($e$) with $list:lel$ } >>
1759 | "("; ")" -> <:expr< () >>
1760 | "("; op = operator_rparen -> <:expr< $lid:op$ >>
1761 | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
1762 | "("; e = SELF; ")" -> <:expr< $e$ >>
1763 | "begin"; e = SELF; "end" -> <:expr< $e$ >>
1764 | "begin"; "end" -> <:expr< () >>
1768 let i = String.index x ':' in
1769 (int_of_string (String.sub x 0 i),
1770 String.sub x (i + 1) (String.length x - i - 1))
1772 [ Not_found | Failure _ -> (0, x) ]
1774 Pcaml.handle_expr_locate loc x
1778 let i = String.index x ':' in
1780 String.sub x (i + 1) (String.length x - i - 1))
1782 [ Not_found -> ("", x) ]
1784 Pcaml.handle_expr_quotation loc x ] ]
1787 [ [ p = patt; e = fun_binding ->
1788 match patt_lid p with
1789 [ Some (loc, i, pl) ->
1791 List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl
1793 (<:patt< $lid:i$ >>, e)
1794 | None -> (p, e) ] ] ]
1798 [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
1799 | "="; e = expr -> <:expr< $e$ >>
1800 | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ]
1803 [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr ->
1807 [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel]
1808 | le = lbl_expr; ";" -> [le]
1809 | le = lbl_expr -> [le] ] ]
1812 [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ]
1815 [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el]
1816 | e = expr LEVEL "expr1"; ";" -> [e]
1817 | e = expr LEVEL "expr1" -> [e] ] ]
1821 [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
1822 | "->"; e = expr -> <:expr< $e$ >> ] ]
1826 [ i = LIDENT -> <:expr< $lid:i$ >>
1827 | i = UIDENT -> <:expr< $uid:i$ >>
1828 | i = UIDENT; "."; j = SELF ->
1831 [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
1832 | e -> <:expr< $m$ . $e$ >> ]
1834 loop <:expr< $uid:i$ >> j
1835 | i = UIDENT; "."; "("; j = operator_rparen ->
1836 <:expr< $uid:i$ . $lid:j$ >> ] ]
1841 [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ]
1843 [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
1844 | [ p = SELF; ","; pl = LIST1 NEXT SEP "," ->
1845 <:patt< ( $list:[p :: pl]$) >> ]
1847 [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
1849 [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
1851 [ p1 = SELF; p2 = SELF ->
1852 match constr_patt_arity loc p1 with
1853 [ 1 -> <:patt< $p1$ $p2$ >>
1857 [ <:patt< _ >> when n > 1 ->
1859 loop n where rec loop n =
1860 if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)]
1862 <:patt< ( $list:pl$ ) >>
1866 [ <:patt< ( $list:pl$ ) >> ->
1867 List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl
1868 | _ -> <:patt< $p1$ $p2$ >> ] ] ]
1870 [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
1872 [ s = LIDENT -> <:patt< $lid:s$ >>
1873 | s = UIDENT -> <:patt< $uid:s$ >>
1874 | s = INT -> <:patt< $int:s$ >>
1875 | s = INT32 -> MLast.PaInt32 loc s
1876 | s = INT64 -> MLast.PaInt64 loc s
1877 | s = NATIVEINT -> MLast.PaNativeInt loc s
1878 | "-"; s = INT -> <:patt< $int:"-" ^ s$ >>
1879 | "-"; s = INT32 -> MLast.PaInt32 loc ("-" ^ s)
1880 | "-"; s = INT64 -> MLast.PaInt64 loc ("-" ^ s)
1881 | "-"; s = NATIVEINT -> MLast.PaNativeInt loc ("-" ^ s)
1882 | "-"; s = FLOAT -> <:patt< $flo:"-" ^ s$ >>
1883 | s = FLOAT -> <:patt< $flo:s$ >>
1884 | s = STRING -> <:patt< $str:s$ >>
1885 | s = CHAR -> <:patt< $chr:s$ >>
1886 | UIDENT "True" -> <:patt< $uid:" True"$ >>
1887 | UIDENT "False" -> <:patt< $uid:" False"$ >>
1888 | s = "false" -> <:patt< False >>
1889 | s = "true" -> <:patt< True >>
1890 | "["; "]" -> <:patt< [] >>
1891 | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >>
1892 | "[|"; "|]" -> <:patt< [| |] >>
1893 | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >>
1894 | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >>
1895 | "("; ")" -> <:patt< () >>
1896 | "("; op = operator_rparen -> <:patt< $lid:op$ >>
1897 | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
1898 | "("; p = SELF; ")" -> <:patt< $p$ >>
1899 | "_" -> <:patt< _ >>
1903 let i = String.index x ':' in
1904 (int_of_string (String.sub x 0 i),
1905 String.sub x (i + 1) (String.length x - i - 1))
1907 [ Not_found | Failure _ -> (0, x) ]
1909 Pcaml.handle_patt_locate loc x
1913 let i = String.index x ':' in
1915 String.sub x (i + 1) (String.length x - i - 1))
1917 [ Not_found -> ("", x) ]
1919 Pcaml.handle_patt_quotation loc x ] ]
1922 [ [ p = patt; ";"; pl = SELF -> [p :: pl]
1923 | p = patt; ";" -> [p]
1924 | p = patt -> [p] ] ]
1927 [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel]
1928 | le = lbl_patt; ";" -> [le]
1929 | le = lbl_patt -> [le] ] ]
1932 [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ]
1936 [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
1938 [ i = UIDENT -> <:patt< $uid:i$ >>
1939 | i = LIDENT -> <:patt< $lid:i$ >> ] ]
1941 (* Type declaration *)
1943 [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind;
1944 cl = LIST0 constrain ->
1946 | tpl = type_parameters; n = type_patt; cl = LIST0 constrain ->
1947 (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ]
1950 [ [ n = LIDENT -> (loc, n) ] ]
1953 [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
1956 [ [ "private"; "{"; ldl = label_declarations; "}" ->
1957 <:ctyp< private { $list:ldl$ } >>
1958 | "private"; OPT "|";
1959 cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< private [ $list:cdl$ ] >>
1960 | test_constr_decl; OPT "|";
1961 cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< [ $list:cdl$ ] >>
1962 | t = ctyp -> <:ctyp< $t$ >>
1963 | t = ctyp; "="; "private"; "{"; ldl = label_declarations; "}" ->
1964 <:ctyp< $t$ == private { $list:ldl$ } >>
1965 | t = ctyp; "="; "{"; ldl = label_declarations; "}" ->
1966 <:ctyp< $t$ == { $list:ldl$ } >>
1967 | t = ctyp; "="; "private"; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" ->
1968 <:ctyp< $t$ == private [ $list:cdl$ ] >>
1969 | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" ->
1970 <:ctyp< $t$ == [ $list:cdl$ ] >>
1971 | "{"; ldl = label_declarations; "}" ->
1972 <:ctyp< { $list:ldl$ } >> ] ]
1975 [ [ -> (* empty *) []
1976 | tp = type_parameter -> [tp]
1977 | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ]
1980 [ [ "'"; i = ident -> (i, (False, False))
1981 | "+"; "'"; i = ident -> (i, (True, False))
1982 | "-"; "'"; i = ident -> (i, (False, True)) ] ]
1984 constructor_declaration:
1985 [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" ->
1987 | ci = UIDENT -> (loc, ci, []) ] ]
1990 [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl]
1991 | ld = label_declaration; ";" -> [ld]
1992 | ld = label_declaration -> [ld] ] ]
1995 [ [ i = LIDENT; ":"; t = poly_type -> (loc, i, False, t)
1996 | "mutable"; i = LIDENT; ":"; t = poly_type -> (loc, i, True, t) ] ]
2000 [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ]
2002 [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
2004 [ t = SELF; "*"; tl = LIST1 (ctyp LEVEL "ctyp1") SEP "*" ->
2005 <:ctyp< ( $list:[t :: tl]$ ) >> ]
2007 [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ]
2009 [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >>
2010 | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ]
2012 [ "'"; i = ident -> <:ctyp< '$i$ >>
2013 | "_" -> <:ctyp< _ >>
2014 | i = LIDENT -> <:ctyp< $lid:i$ >>
2015 | i = UIDENT -> <:ctyp< $uid:i$ >>
2016 | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")";
2017 i = ctyp LEVEL "ctyp2" ->
2018 List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl]
2019 | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ]
2024 | i = UIDENT -> i ] ]
2030 | i = UIDENT; "."; j = SELF -> [i :: j] ] ]
2035 | "downto" -> False ] ]
2037 (* Objects and Classes *)
2039 [ [ "class"; cd = LIST1 class_declaration SEP "and" ->
2040 <:str_item< class $list:cd$ >>
2041 | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
2042 <:str_item< class type $list:ctd$ >> ] ]
2045 [ [ "class"; cd = LIST1 class_description SEP "and" ->
2046 <:sig_item< class $list:cd$ >>
2047 | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
2048 <:sig_item< class type $list:ctd$ >> ] ]
2050 (* Class expressions *)
2052 [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT;
2053 cfb = class_fun_binding ->
2054 {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
2055 MLast.ciNam = i; MLast.ciExp = cfb} ] ]
2058 [ [ "="; ce = class_expr -> ce
2059 | ":"; ct = class_type; "="; ce = class_expr ->
2060 <:class_expr< ($ce$ : $ct$) >>
2061 | p = patt LEVEL "simple"; cfb = SELF ->
2062 <:class_expr< fun $p$ -> $cfb$ >> ] ]
2064 class_type_parameters:
2066 | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ]
2069 [ [ p = patt LEVEL "simple"; "->"; ce = class_expr ->
2070 <:class_expr< fun $p$ -> $ce$ >>
2071 | p = labeled_patt; "->"; ce = class_expr ->
2072 <:class_expr< fun $p$ -> $ce$ >>
2073 | p = patt LEVEL "simple"; cfd = SELF ->
2074 <:class_expr< fun $p$ -> $cfd$ >>
2075 | p = labeled_patt; cfd = SELF ->
2076 <:class_expr< fun $p$ -> $cfd$ >> ] ]
2080 [ "fun"; cfd = class_fun_def -> cfd
2081 | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in";
2083 <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ]
2085 [ ce = SELF; e = expr LEVEL "label" ->
2086 <:class_expr< $ce$ $e$ >> ]
2088 [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]";
2089 ci = class_longident ->
2090 <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >>
2091 | "["; ct = ctyp; "]"; ci = class_longident ->
2092 <:class_expr< $list:ci$ [ $ct$ ] >>
2093 | ci = class_longident -> <:class_expr< $list:ci$ >>
2094 | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
2095 <:class_expr< object $opt:cspo$ $list:cf$ end >>
2096 | "("; ce = SELF; ":"; ct = class_type; ")" ->
2097 <:class_expr< ($ce$ : $ct$) >>
2098 | "("; ce = SELF; ")" -> ce ] ]
2101 [ [ cf = LIST0 class_str_item -> cf ] ]
2104 [ [ "("; p = patt; ")" -> p
2105 | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ]
2108 [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] ->
2109 <:class_str_item< inherit $ce$ $opt:pb$ >>
2110 | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
2111 <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
2112 | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
2113 <:class_str_item< method virtual private $l$ : $t$ >>
2114 | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
2115 <:class_str_item< method virtual private $l$ : $t$ >>
2116 | "method"; "virtual"; l = label; ":"; t = poly_type ->
2117 <:class_str_item< method virtual $l$ : $t$ >>
2118 | "method"; "private"; l = label; ":"; t = poly_type; "="; e = expr ->
2119 MLast.CrMth loc l True e (Some t)
2120 | "method"; "private"; l = label; sb = fun_binding ->
2121 MLast.CrMth loc l True sb None
2122 | "method"; l = label; ":"; t = poly_type; "="; e = expr ->
2123 MLast.CrMth loc l False e (Some t)
2124 | "method"; l = label; sb = fun_binding ->
2125 MLast.CrMth loc l False sb None
2126 | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
2127 <:class_str_item< type $t1$ = $t2$ >>
2128 | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ]
2131 [ [ "="; e = expr -> e
2132 | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >>
2133 | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr ->
2134 <:expr< ($e$ : $t$ :> $t2$) >>
2135 | ":>"; t = ctyp; "="; e = expr ->
2136 <:expr< ($e$ :> $t$) >> ] ]
2139 [ [ i = LIDENT -> i ] ]
2143 [ [ test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2144 <:class_type< [ $t$ ] -> $ct$ >>
2145 | cs = class_signature -> cs ] ]
2148 [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident ->
2149 <:class_type< $list:id$ [ $list:tl$ ] >>
2150 | id = clty_longident -> <:class_type< $list:id$ >>
2151 | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item;
2153 <:class_type< object $opt:cst$ $list:csf$ end >> ] ]
2156 [ [ "("; t = ctyp; ")" -> t ] ]
2159 [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >>
2160 | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
2161 <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
2162 | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
2163 <:class_sig_item< method virtual private $l$ : $t$ >>
2164 | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
2165 <:class_sig_item< method virtual private $l$ : $t$ >>
2166 | "method"; "virtual"; l = label; ":"; t = poly_type ->
2167 <:class_sig_item< method virtual $l$ : $t$ >>
2168 | "method"; "private"; l = label; ":"; t = poly_type ->
2169 <:class_sig_item< method private $l$ : $t$ >>
2170 | "method"; l = label; ":"; t = poly_type ->
2171 <:class_sig_item< method $l$ : $t$ >>
2172 | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
2173 <:class_sig_item< type $t1$ = $t2$ >> ] ]
2176 [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":";
2178 {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
2179 MLast.ciNam = n; MLast.ciExp = ct} ] ]
2181 class_type_declaration:
2182 [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "=";
2183 cs = class_signature ->
2184 {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
2185 MLast.ciNam = n; MLast.ciExp = cs} ] ]
2188 expr: LEVEL "simple"
2190 [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ]
2193 [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ]
2195 expr: LEVEL "simple"
2196 [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" ->
2197 <:expr< ($e$ : $t$ :> $t2$) >>
2198 | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >>
2199 | "{<"; ">}" -> <:expr< {< >} >>
2200 | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ]
2203 [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF ->
2205 | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)]
2206 | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ]
2209 ctyp: LEVEL "simple"
2210 [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >>
2211 | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >>
2212 | "<"; ">" -> <:ctyp< < > >> ] ]
2215 [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v)
2216 | f = field; ";" -> ([f], False)
2217 | f = field -> ([f], False)
2218 | ".." -> ([], True) ] ]
2221 [ [ lab = LIDENT; ":"; t = poly_type -> (lab, t) ] ]
2223 (* Polymorphic types *)
2225 [ [ "'"; i = ident -> i ] ]
2228 [ [ test_typevar_list_dot; tpl = LIST1 typevar; "."; t2 = ctyp ->
2229 <:ctyp< ! $list:tpl$ . $t2$ >>
2234 [ [ m = UIDENT; "."; l = SELF -> [m :: l]
2235 | i = LIDENT -> [i] ] ]
2238 [ [ m = UIDENT; "."; l = SELF -> [m :: l]
2239 | i = LIDENT -> [i] ] ]
2244 [ i = lident_colon; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
2245 <:ctyp< ( ~ $i$ : $t1$ ) -> $t2$ >>
2246 | i = OPTLABEL; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
2247 <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >>
2248 | i = QUESTIONIDENT; ":"; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
2249 <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >>
2250 | "?"; i=lident_colon;t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
2251 <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> ] ]
2253 ctyp: LEVEL "simple"
2254 [ [ "["; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
2255 <:ctyp< [ = $list:rfl$ ] >>
2256 | "["; ">"; "]" -> <:ctyp< [ > $list:[]$ ] >>
2257 | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
2258 <:ctyp< [ > $list:rfl$ ] >>
2259 | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
2260 <:ctyp< [ < $list:rfl$ ] >>
2261 | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">";
2262 ntl = LIST1 name_tag; "]" ->
2263 <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ]
2266 [ [ "`"; i = ident -> MLast.RfTag i True []
2267 | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" ->
2268 MLast.RfTag i (o2b ao) l
2269 | t = ctyp -> MLast.RfInh t ] ]
2272 [ [ "`"; i = ident -> i ] ]
2275 [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ]
2279 [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >>
2280 | i = TILDEIDENT -> <:expr< ~ $i$ >>
2281 | "~"; i = LIDENT -> <:expr< ~ $i$ >>
2282 | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >>
2283 | i = QUESTIONIDENT -> <:expr< ? $i$ >>
2284 | "?"; i = LIDENT -> <:expr< ? $i$ >> ] ]
2286 expr: LEVEL "simple"
2287 [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ]
2290 [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
2293 [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
2295 patt: LEVEL "simple"
2296 [ [ "`"; s = ident -> <:patt< ` $s$ >>
2297 | "#"; t = mod_ident -> <:patt< # $list:t$ >> ] ]
2300 [ [ i = LABEL; p = patt LEVEL "simple" ->
2301 <:patt< ~ $i$ : $p$ >>
2304 | "~"; i=LIDENT -> <:patt< ~ $i$ >>
2305 | "~"; "("; i = LIDENT; ")" ->
2307 | "~"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
2308 <:patt< ~ $i$ : ($lid:i$ : $t$) >>
2309 | i = OPTLABEL; j = LIDENT ->
2310 <:patt< ? $i$ : ($lid:j$) >>
2311 | i = OPTLABEL; "("; p = patt; "="; e = expr; ")" ->
2312 <:patt< ? $i$ : ( $p$ = $e$ ) >>
2313 | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; ")" ->
2314 <:patt< ? $i$ : ( $p$ : $t$ ) >>
2315 | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; "=";
2317 <:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >>
2318 | i = QUESTIONIDENT -> <:patt< ? $i$ >>
2319 | "?"; i = LIDENT -> <:patt< ? $i$ >>
2320 | "?"; "("; i = LIDENT; "="; e = expr; ")" ->
2321 <:patt< ? ( $lid:i$ = $e$ ) >>
2322 | "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" ->
2323 <:patt< ? ( $lid:i$ : $t$ = $e$ ) >>
2324 | "?"; "("; i = LIDENT; ")" ->
2326 | "?"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
2327 <:patt< ? ( $lid:i$ : $t$ ) >> ] ]
2330 [ [ i = lident_colon; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2331 <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >>
2332 | i = OPTLABEL; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2333 <:class_type< [ ? $i$ : $t$ ] -> $ct$ >>
2334 | i = QUESTIONIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2335 <:class_type< [ ? $i$ : $t$ ] -> $ct$ >>
2336 | "?"; i = LIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2337 <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ]
2340 [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
2344 (* Main entry points *)
2347 GLOBAL: interf implem use_file top_phrase expr patt;
2349 [ [ si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
2350 | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2351 ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True)
2352 | EOI -> ([], False) ] ]
2355 [ [ si = sig_item; OPT ";;" -> (si, loc) ] ]
2358 [ [ si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
2359 | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2360 ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True)
2361 | EOI -> ([], False) ] ]
2364 [ [ si = str_item; OPT ";;" -> (si, loc) ] ]
2367 [ [ ph = phrase; ";;" -> Some ph
2371 [ [ si = str_item; OPT ";;"; (sil, stopped) = SELF ->
2372 ([si :: sil], stopped)
2373 | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2374 ([<:str_item< # $n$ $opt:dp$ >>], True)
2375 | EOI -> ([], False) ] ]
2378 [ [ sti = str_item -> sti
2379 | "#"; n = LIDENT; dp = OPT expr -> <:str_item< # $n$ $opt:dp$ >> ] ]
2383 Pcaml.add_option "-no_quot" (Arg.Set Plexer.no_quotations)
2384 "Don't parse quotations, allowing to use, e.g. \"<:>\" as token";
2389 [[ f = expr; "o"; g = expr -> <:expr< ((o $f$) $g$) >>
2390 | f = expr; "upto"; g = expr -> <:expr< ((upto $f$) $g$) >>
2391 | f = expr; "F_F"; g = expr -> <:expr< ((f_f_ $f$) $g$) >>
2392 | f = expr; "THENC"; g = expr -> <:expr< ((thenc_ $f$) $g$) >>
2393 | f = expr; "THEN"; g = expr -> <:expr< ((then_ $f$) $g$) >>
2394 | f = expr; "THENL"; g = expr -> <:expr< ((thenl_ $f$) $g$) >>
2395 | f = expr; "ORELSE"; g = expr -> <:expr< ((orelse_ $f$) $g$) >>
2396 | f = expr; "ORELSEC"; g = expr -> <:expr< ((orelsec_ $f$) $g$) >>
2397 | f = expr; "THEN_TCL"; g = expr -> <:expr< ((then_tcl_ $f$) $g$) >>
2398 | f = expr; "ORELSE_TCL"; g = expr -> <:expr< ((orelse_tcl_ $f$) $g$) >>
2404 [ [ sti = str_item; ";;" ->
2406 [ <:str_item< $exp:e$ >> -> Some <:str_item< value it = $e$ >>