1 (* ------------------------------------------------------------------------- *)
3 (* ------------------------------------------------------------------------- *)
5 (* camlp5r pa_macro.cmo *)
6 (* $Id: pa_o.ml,v 6.50 2013-07-02 16:12:43 deraugla Exp $ *)
7 (* Copyright (c) INRIA 2007-2012 *)
15 Pcaml.syntax_name.val := "OCaml";
16 Pcaml.no_constructors_arity.val := True;
18 (* ------------------------------------------------------------------------- *)
19 (* The main/reloc.ml file. *)
20 (* ------------------------------------------------------------------------- *)
23 (* $Id: reloc.ml,v 6.26 2012-03-09 14:01:54 deraugla Exp $ *)
24 (* Copyright (c) INRIA 2007-2012 *)
32 [ Some x -> Some (f x)
41 [ Ploc.VaAnt s -> Ploc.VaAnt s
42 | Ploc.VaVal x -> Ploc.VaVal (f x) ]
46 value class_infos_map floc f x =
47 {ciLoc = floc x.ciLoc; ciVir = x.ciVir;
49 let (x1, x2) = x.ciPrm in
51 ciNam = x.ciNam; ciExp = f x.ciExp}
54 value anti_loc qloc sh loc loc1 =
56 ...<:reloc_expr<.....$lid:...xxxxxxxx...$...>>...
57 |..|-----------------------------------| qloc
59 |.........|------------| loc
62 let sh1 = Ploc.first_pos qloc + sh in
63 let sh2 = sh1 + Ploc.first_pos loc in
64 let line_nb_qloc = Ploc.line_nb qloc in
65 let line_nb_loc = Ploc.line_nb loc in
66 let line_nb_loc1 = Ploc.line_nb loc1 in
67 if line_nb_qloc < 0 || line_nb_loc < 0 || line_nb_loc1 < 0 then
69 (sh2 + Ploc.first_pos loc1, sh2 + Ploc.last_pos loc1)
71 Ploc.make_loc (Ploc.file_name loc)
72 (line_nb_qloc + line_nb_loc + line_nb_loc1 - 2)
73 (if line_nb_loc1 = 1 then
74 if line_nb_loc = 1 then Ploc.bol_pos qloc
75 else sh1 + Ploc.bol_pos loc
76 else sh2 + Ploc.bol_pos loc1)
77 (sh2 + Ploc.first_pos loc1, sh2 + Ploc.last_pos loc1) ""
80 value rec reloc_ctyp floc sh =
85 TyAcc loc (self x1) (self x2)
88 TyAli loc (self x1) (self x2)
94 TyApp loc (self x1) (self x2)
97 TyArr loc (self x1) (self x2)
102 let loc = floc loc in
103 TyLab loc x1 (self x2)
105 let loc = floc loc in
107 | TyMan loc x1 x2 x3 →
108 let loc = floc loc in
109 TyMan loc (self x1) x2 (self x3)
111 let loc = floc loc in
112 TyObj loc (vala_map (List.map (fun (x1, x2) → (x1, self x2))) x1) x2
114 let loc = floc loc in
115 TyOlb loc x1 (self x2)
117 let loc = floc loc in
118 TyPck loc (reloc_module_type floc sh x1)
120 let loc = floc loc in
121 TyPol loc x1 (self x2)
123 let loc = floc loc in
124 TyPot loc x1 (self x2)
126 let loc = floc loc in
129 let loc = floc loc in
132 (List.map (fun (loc, x1, x2, x3) → (floc loc, x1, x2, self x3)))
135 let loc = floc loc in
139 (fun (loc, x1, x2, x3) →
140 (floc loc, x1, vala_map (List.map self) x2,
141 option_map self x3)))
144 let loc = floc loc in
145 TyTup loc (vala_map (List.map self) x1)
147 let loc = floc loc in
150 let loc = floc loc in
151 TyVrn loc (vala_map (List.map (reloc_poly_variant floc sh)) x1) x2
153 let loc = floc loc in
154 TyXtr loc x1 (option_map (vala_map self) x2) ]
155 and reloc_poly_variant floc sh =
157 [ PvTag loc x1 x2 x3 →
158 let loc = floc loc in
159 PvTag loc x1 x2 (vala_map (List.map (reloc_ctyp floc sh)) x3)
161 let loc = floc loc in
162 PvInh loc (reloc_ctyp floc sh x1) ]
163 and reloc_patt floc sh =
164 self where rec self =
167 let loc = floc loc in
168 PaAcc loc (self x1) (self x2)
170 let loc = floc loc in
171 PaAli loc (self x1) (self x2)
173 let new_floc loc1 = anti_loc (floc loc) sh loc loc1 in
174 reloc_patt new_floc sh x1
176 let loc = floc loc in
179 let loc = floc loc in
180 PaApp loc (self x1) (self x2)
182 let loc = floc loc in
183 PaArr loc (vala_map (List.map self) x1)
185 let loc = floc loc in
188 let loc = floc loc in
191 let loc = floc loc in
194 let loc = floc loc in
198 (fun (x1, x2) → (self x1, vala_map (option_map self) x2)))
201 let loc = floc loc in
204 let loc = floc loc in
207 let loc = floc loc in
210 let loc = floc loc in
211 PaOlb loc (self x1) (vala_map (option_map (reloc_expr floc sh)) x2)
213 let loc = floc loc in
214 PaOrp loc (self x1) (self x2)
216 let loc = floc loc in
217 PaRec loc (vala_map (List.map (fun (x1, x2) → (self x1, self x2))) x1)
219 let loc = floc loc in
220 PaRng loc (self x1) (self x2)
222 let loc = floc loc in
225 let loc = floc loc in
226 PaTup loc (vala_map (List.map self) x1)
228 let loc = floc loc in
229 PaTyc loc (self x1) (reloc_ctyp floc sh x2)
231 let loc = floc loc in
234 let loc = floc loc in
237 let loc = floc loc in
238 PaUnp loc x1 (option_map (reloc_module_type floc sh) x2)
240 let loc = floc loc in
243 let loc = floc loc in
244 PaXtr loc x1 (option_map (vala_map self) x2) ]
245 and reloc_expr floc sh =
246 self where rec self =
249 let loc = floc loc in
250 ExAcc loc (self x1) (self x2)
252 let new_floc loc1 = anti_loc (floc loc) sh loc loc1 in
253 reloc_expr new_floc sh x1
255 let loc = floc loc in
256 ExApp loc (self x1) (self x2)
258 let loc = floc loc in
259 ExAre loc (self x1) (self x2)
261 let loc = floc loc in
262 ExArr loc (vala_map (List.map self) x1)
264 let loc = floc loc in
267 let loc = floc loc in
268 ExAss loc (self x1) (self x2)
270 let loc = floc loc in
271 ExBae loc (self x1) (vala_map (List.map self) x2)
273 let loc = floc loc in
275 | ExCoe loc x1 x2 x3 →
276 let loc = floc loc in
277 ExCoe loc (self x1) (option_map (reloc_ctyp floc sh) x2) (reloc_ctyp floc sh x3)
279 let loc = floc loc in
281 | ExFor loc x1 x2 x3 x4 x5 →
282 let loc = floc loc in
283 ExFor loc x1 (self x2) (self x3) x4 (vala_map (List.map self) x5)
285 let loc = floc loc in
290 (reloc_patt floc sh x1, vala_map (option_map self) x2, self x3)))
292 | ExIfe loc x1 x2 x3 →
293 let loc = floc loc in
294 ExIfe loc (self x1) (self x2) (self x3)
296 let loc = floc loc in
299 let loc = floc loc in
300 ExJdf loc (vala_map (List.map (reloc_joinclause floc sh)) x1) (self x2)
302 let loc = floc loc in
307 (reloc_patt floc sh x1, vala_map (option_map self) x2)))
310 let loc = floc loc in
312 | ExLet loc x1 x2 x3 →
313 let loc = floc loc in
315 (vala_map (List.map (fun (x1, x2) → (reloc_patt floc sh x1, self x2))) x2)
318 let loc = floc loc in
320 | ExLmd loc x1 x2 x3 →
321 let loc = floc loc in
322 ExLmd loc x1 (reloc_module_expr floc sh x2) (self x3)
324 let loc = floc loc in
329 (reloc_patt floc sh x1, vala_map (option_map self) x2, self x3)))
332 let loc = floc loc in
335 let loc = floc loc in
336 ExObj loc (vala_map (option_map (reloc_patt floc sh)) x1)
337 (vala_map (List.map (reloc_class_str_item floc sh)) x2)
339 let loc = floc loc in
340 ExOlb loc (reloc_patt floc sh x1) (vala_map (option_map self) x2)
342 let loc = floc loc in
343 ExOvr loc (vala_map (List.map (fun (x1, x2) → (x1, self x2))) x1)
345 let loc = floc loc in
346 ExPar loc (self x1) (self x2)
348 let loc = floc loc in
349 ExPck loc (reloc_module_expr floc sh x1)
350 (option_map (reloc_module_type floc sh) x2)
352 let loc = floc loc in
354 (vala_map (List.map (fun (x1, x2) → (reloc_patt floc sh x1, self x2))) x1)
357 let loc = floc loc in
358 ExRpl loc (vala_map (option_map self) x1)
359 ((fun (loc, x1) → (floc loc, x1)) x2)
361 let loc = floc loc in
362 ExSeq loc (vala_map (List.map self) x1)
364 let loc = floc loc in
367 let loc = floc loc in
368 ExSnd loc (self x1) x2
370 let loc = floc loc in
371 ExSte loc (self x1) (self x2)
373 let loc = floc loc in
376 let loc = floc loc in
381 (reloc_patt floc sh x1, vala_map (option_map self) x2, self x3)))
384 let loc = floc loc in
385 ExTup loc (vala_map (List.map self) x1)
387 let loc = floc loc in
388 ExTyc loc (self x1) (reloc_ctyp floc sh x2)
390 let loc = floc loc in
393 let loc = floc loc in
396 let loc = floc loc in
397 ExWhi loc (self x1) (vala_map (List.map self) x2)
399 let loc = floc loc in
400 ExXtr loc x1 (option_map (vala_map self) x2) ]
401 and reloc_module_type floc sh =
402 self where rec self =
405 let loc = floc loc in
406 MtAcc loc (self x1) (self x2)
408 let loc = floc loc in
409 MtApp loc (self x1) (self x2)
410 | MtFun loc x1 x2 x3 →
411 let loc = floc loc in
412 MtFun loc x1 (self x2) (self x3)
414 let loc = floc loc in
417 let loc = floc loc in
420 let loc = floc loc in
421 MtSig loc (vala_map (List.map (reloc_sig_item floc sh)) x1)
423 let loc = floc loc in
424 MtTyo loc (reloc_module_expr floc sh x1)
426 let loc = floc loc in
429 let loc = floc loc in
430 MtWit loc (self x1) (vala_map (List.map (reloc_with_constr floc sh)) x2)
432 let loc = floc loc in
433 MtXtr loc x1 (option_map (vala_map self) x2) ]
434 and reloc_sig_item floc sh =
435 self where rec self =
438 let loc = floc loc in
440 (vala_map (List.map (class_infos_map floc (reloc_class_type floc sh))) x1)
442 let loc = floc loc in
444 (vala_map (List.map (class_infos_map floc (reloc_class_type floc sh))) x1)
446 let loc = floc loc in
447 SgDcl loc (vala_map (List.map self) x1)
449 let loc = floc loc in
450 SgDir loc x1 (vala_map (option_map (reloc_expr floc sh)) x2)
452 let loc = floc loc in
453 SgExc loc x1 (vala_map (List.map (reloc_ctyp floc sh)) x2)
454 | SgExt loc x1 x2 x3 →
455 let loc = floc loc in
456 SgExt loc x1 (reloc_ctyp floc sh x2) x3
458 let loc = floc loc in
459 SgInc loc (reloc_module_type floc sh x1)
461 let loc = floc loc in
463 (vala_map (List.map (fun (x1, x2) → (x1, reloc_module_type floc sh x2)))
466 let loc = floc loc in
467 SgMty loc x1 (reloc_module_type floc sh x2)
469 let loc = floc loc in
472 let loc = floc loc in
473 SgTyp loc (vala_map (List.map (reloc_type_decl floc sh)) x1)
475 let loc = floc loc in
477 (vala_map (List.map (fun (x1, loc) → (self x1, floc loc))) x2)
479 let loc = floc loc in
480 SgVal loc x1 (reloc_ctyp floc sh x2)
482 let loc = floc loc in
483 SgXtr loc x1 (option_map (vala_map self) x2) ]
484 and reloc_with_constr floc sh =
487 let loc = floc loc in
488 WcMod loc x1 (reloc_module_expr floc sh x2)
490 let loc = floc loc in
491 WcMos loc x1 (reloc_module_expr floc sh x2)
492 | WcTyp loc x1 x2 x3 x4 →
493 let loc = floc loc in
494 WcTyp loc x1 x2 x3 (reloc_ctyp floc sh x4)
495 | WcTys loc x1 x2 x3 →
496 let loc = floc loc in
497 WcTys loc x1 x2 (reloc_ctyp floc sh x3) ]
498 and reloc_module_expr floc sh =
499 self where rec self =
502 let loc = floc loc in
503 MeAcc loc (self x1) (self x2)
505 let loc = floc loc in
506 MeApp loc (self x1) (self x2)
507 | MeFun loc x1 x2 x3 →
508 let loc = floc loc in
509 MeFun loc x1 (reloc_module_type floc sh x2) (self x3)
511 let loc = floc loc in
512 MeStr loc (vala_map (List.map (reloc_str_item floc sh)) x1)
514 let loc = floc loc in
515 MeTyc loc (self x1) (reloc_module_type floc sh x2)
517 let loc = floc loc in
520 let loc = floc loc in
521 MeUnp loc (reloc_expr floc sh x1) (option_map (reloc_module_type floc sh) x2)
523 let loc = floc loc in
524 MeXtr loc x1 (option_map (vala_map self) x2) ]
525 and reloc_str_item floc sh =
526 self where rec self =
529 let loc = floc loc in
531 (vala_map (List.map (class_infos_map floc (reloc_class_expr floc sh))) x1)
533 let loc = floc loc in
535 (vala_map (List.map (class_infos_map floc (reloc_class_type floc sh))) x1)
537 let loc = floc loc in
538 StDcl loc (vala_map (List.map self) x1)
540 let loc = floc loc in
541 StDef loc (vala_map (List.map (reloc_joinclause floc sh)) x1)
543 let loc = floc loc in
544 StDir loc x1 (vala_map (option_map (reloc_expr floc sh)) x2)
545 | StExc loc x1 x2 x3 →
546 let loc = floc loc in
547 StExc loc x1 (vala_map (List.map (reloc_ctyp floc sh)) x2) x3
549 let loc = floc loc in
550 StExp loc (reloc_expr floc sh x1)
551 | StExt loc x1 x2 x3 →
552 let loc = floc loc in
553 StExt loc x1 (reloc_ctyp floc sh x2) x3
555 let loc = floc loc in
556 StInc loc (reloc_module_expr floc sh x1)
558 let loc = floc loc in
560 (vala_map (List.map (fun (x1, x2) → (x1, reloc_module_expr floc sh x2)))
563 let loc = floc loc in
564 StMty loc x1 (reloc_module_type floc sh x2)
566 let loc = floc loc in
569 let loc = floc loc in
570 StTyp loc (vala_map (List.map (reloc_type_decl floc sh)) x1)
572 let loc = floc loc in
574 (vala_map (List.map (fun (x1, loc) → (self x1, floc loc))) x2)
576 let loc = floc loc in
579 (List.map (fun (x1, x2) → (reloc_patt floc sh x1, reloc_expr floc sh x2)))
582 let loc = floc loc in
583 StXtr loc x1 (option_map (vala_map self) x2) ]
584 and reloc_joinclause floc sh x =
585 {jcLoc = floc x.jcLoc;
594 (floc loc, (fun (loc, x1) → (floc loc, x1)) x1,
595 vala_map (option_map (reloc_patt floc sh)) x2)))
597 reloc_expr floc sh x2)))
599 and reloc_type_decl floc sh x =
600 {tdNam = vala_map (fun (loc, x1) → (floc loc, x1)) x.tdNam; tdPrm = x.tdPrm;
601 tdPrv = x.tdPrv; tdDef = reloc_ctyp floc sh x.tdDef;
603 vala_map (List.map (fun (x1, x2) → (reloc_ctyp floc sh x1, reloc_ctyp floc sh x2)))
605 and reloc_class_type floc sh =
606 self where rec self =
609 let loc = floc loc in
610 CtAcc loc (self x1) (self x2)
612 let loc = floc loc in
613 CtApp loc (self x1) (self x2)
615 let loc = floc loc in
616 CtCon loc (self x1) (vala_map (List.map (reloc_ctyp floc sh)) x2)
618 let loc = floc loc in
619 CtFun loc (reloc_ctyp floc sh x1) (self x2)
621 let loc = floc loc in
624 let loc = floc loc in
625 CtSig loc (vala_map (option_map (reloc_ctyp floc sh)) x1)
626 (vala_map (List.map (reloc_class_sig_item floc sh)) x2)
628 let loc = floc loc in
629 CtXtr loc x1 (option_map (vala_map self) x2) ]
630 and reloc_class_sig_item floc sh =
631 self where rec self =
634 let loc = floc loc in
635 CgCtr loc (reloc_ctyp floc sh x1) (reloc_ctyp floc sh x2)
637 let loc = floc loc in
638 CgDcl loc (vala_map (List.map self) x1)
640 let loc = floc loc in
641 CgInh loc (reloc_class_type floc sh x1)
642 | CgMth loc x1 x2 x3 →
643 let loc = floc loc in
644 CgMth loc x1 x2 (reloc_ctyp floc sh x3)
645 | CgVal loc x1 x2 x3 →
646 let loc = floc loc in
647 CgVal loc x1 x2 (reloc_ctyp floc sh x3)
648 | CgVir loc x1 x2 x3 →
649 let loc = floc loc in
650 CgVir loc x1 x2 (reloc_ctyp floc sh x3) ]
651 and reloc_class_expr floc sh =
652 self where rec self =
655 let loc = floc loc in
656 CeApp loc (self x1) (reloc_expr floc sh x2)
658 let loc = floc loc in
659 CeCon loc x1 (vala_map (List.map (reloc_ctyp floc sh)) x2)
661 let loc = floc loc in
662 CeFun loc (reloc_patt floc sh x1) (self x2)
663 | CeLet loc x1 x2 x3 →
664 let loc = floc loc in
667 (List.map (fun (x1, x2) → (reloc_patt floc sh x1, reloc_expr floc sh x2)))
671 let loc = floc loc in
672 CeStr loc (vala_map (option_map (reloc_patt floc sh)) x1)
673 (vala_map (List.map (reloc_class_str_item floc sh)) x2)
675 let loc = floc loc in
676 CeTyc loc (self x1) (reloc_class_type floc sh x2)
678 let loc = floc loc in
679 CeXtr loc x1 (option_map (vala_map self) x2) ]
680 and reloc_class_str_item floc sh =
681 self where rec self =
684 let loc = floc loc in
685 CrCtr loc (reloc_ctyp floc sh x1) (reloc_ctyp floc sh x2)
687 let loc = floc loc in
688 CrDcl loc (vala_map (List.map self) x1)
690 let loc = floc loc in
691 CrInh loc (reloc_class_expr floc sh x1) x2
693 let loc = floc loc in
694 CrIni loc (reloc_expr floc sh x1)
695 | CrMth loc x1 x2 x3 x4 x5 →
696 let loc = floc loc in
697 CrMth loc x1 x2 x3 (vala_map (option_map (reloc_ctyp floc sh)) x4)
698 (reloc_expr floc sh x5)
699 | CrVal loc x1 x2 x3 x4 →
700 let loc = floc loc in
701 CrVal loc x1 x2 x3 (reloc_expr floc sh x4)
702 | CrVav loc x1 x2 x3 →
703 let loc = floc loc in
704 CrVav loc x1 x2 (reloc_ctyp floc sh x3)
705 | CrVir loc x1 x2 x3 →
706 let loc = floc loc in
707 CrVir loc x1 x2 (reloc_ctyp floc sh x3) ]
710 (* Equality over syntax trees *)
713 reloc_expr (fun _ -> Ploc.dummy) 0 x =
714 reloc_expr (fun _ -> Ploc.dummy) 0 y
717 reloc_patt (fun _ -> Ploc.dummy) 0 x =
718 reloc_patt (fun _ -> Ploc.dummy) 0 y
721 reloc_ctyp (fun _ -> Ploc.dummy) 0 x =
722 reloc_ctyp (fun _ -> Ploc.dummy) 0 y
724 value eq_str_item x y =
725 reloc_str_item (fun _ -> Ploc.dummy) 0 x =
726 reloc_str_item (fun _ -> Ploc.dummy) 0 y
728 value eq_sig_item x y =
729 reloc_sig_item (fun _ -> Ploc.dummy) 0 x =
730 reloc_sig_item (fun _ -> Ploc.dummy) 0 y
732 value eq_module_expr x y =
733 reloc_module_expr (fun _ -> Ploc.dummy) 0 x =
734 reloc_module_expr (fun _ -> Ploc.dummy) 0 y
736 value eq_module_type x y =
737 reloc_module_type (fun _ -> Ploc.dummy) 0 x =
738 reloc_module_type (fun _ -> Ploc.dummy) 0 y
740 value eq_class_sig_item x y =
741 reloc_class_sig_item (fun _ -> Ploc.dummy) 0 x =
742 reloc_class_sig_item (fun _ -> Ploc.dummy) 0 y
744 value eq_class_str_item x y =
745 reloc_class_str_item (fun _ -> Ploc.dummy) 0 x =
746 reloc_class_str_item (fun _ -> Ploc.dummy) 0 y
748 value eq_reloc_class_type x y =
749 reloc_class_type (fun _ -> Ploc.dummy) 0 x =
750 reloc_class_type (fun _ -> Ploc.dummy) 0 y
752 value eq_class_expr x y =
753 reloc_class_expr (fun _ -> Ploc.dummy) 0 x =
754 reloc_class_expr (fun _ -> Ploc.dummy) 0 y
757 (* ------------------------------------------------------------------------- *)
759 (* ------------------------------------------------------------------------- *)
762 (* $Id: plexer.ml,v 6.19 2013-07-03 01:43:10 deraugla Exp $ *)
763 (* Copyright (c) INRIA 2007-2012 *)
765 #load "pa_lexer.cmo";
767 (* ------------------------------------------------------------------------- *)
768 (* Added by JRH as a backdoor to change lexical conventions. *)
769 (* ------------------------------------------------------------------------- *)
771 value jrh_lexer = ref False;
775 value no_quotations = ref False;
776 value error_on_unknown_keywords = ref False;
778 value dollar_for_antiquotation = ref True;
779 value specific_space_dot = ref False;
780 value dot_newline_is = ref ".";
782 value force_antiquot_loc = ref False;
785 { after_space : mutable bool;
786 dollar_for_antiquotation : bool;
787 specific_space_dot : bool;
788 dot_newline_is : string;
789 find_kwd : string -> string;
790 line_cnt : int -> char -> unit;
791 set_line_nb : unit -> unit;
792 make_lined_loc : (int * int) -> string -> Ploc.t }
795 value err ctx loc msg =
796 Ploc.raise (ctx.make_lined_loc loc "") (Plexing.Error msg)
799 (* ------------------------------------------------------------------------- *)
800 (* JRH's hack to make the case distinction "unmixed" versus "mixed" *)
801 (* ------------------------------------------------------------------------- *)
803 value is_uppercase s = String.uppercase s = s;
804 value is_only_lowercase s = String.lowercase s = s && not(is_uppercase s);
806 value jrh_identifier find_kwd id =
807 let jflag = jrh_lexer.val in
808 if id = "set_jrh_lexer" then
809 (let _ = jrh_lexer.val := True in ("",find_kwd "true"))
810 else if id = "unset_jrh_lexer" then
811 (let _ = jrh_lexer.val := False in ("",find_kwd "false"))
813 try ("", find_kwd id) with
816 if is_uppercase (String.sub id 0 1) then ("UIDENT", id)
818 else if is_uppercase (String.sub id 0 1) &&
819 is_only_lowercase (String.sub id 1 (String.length id - 1))
820 (***** JRH: Carl's alternative version
822 else if is_uppercase (String.sub id 0 1) then ("LIDENT", "__uc_"^id)
823 else ("LIDENT", id)];
825 then ("UIDENT", id) else ("LIDENT", id)];
827 (* ------------------------------------------------------------------------- *)
828 (* Back to original file with the mod of using the above. *)
829 (* ------------------------------------------------------------------------- *)
831 value keyword_or_error ctx loc s =
832 try ("", ctx.find_kwd s) with
834 if error_on_unknown_keywords.val then
835 err ctx loc ("illegal token: " ^ s)
839 value rev_implode l =
840 let s = String.create (List.length l) in
841 loop (String.length s - 1) l where rec loop i =
843 [ [c :: l] -> do { String.unsafe_set s i c; loop (i - 1) l }
847 value implode l = rev_implode (List.rev l);
849 value stream_peek_nth n strm =
850 loop n (Stream.npeek n strm) where rec loop n =
853 | [x] -> if n == 1 then Some x else None
854 | [_ :: l] -> loop (n - 1) l ]
857 value utf8_lexing = ref False;
860 ["α"; "β"; "γ"; "δ"; "ε"; "ζ"; "η"; "θ"; "ι"; "κ"; "λ"; "μ"; "ν"; "ξ";
861 "ο"; "π"; "ρ"; "σ"; "τ"; "υ"; "φ"; "χ"; "ψ"; "ω"]
864 value greek_letter buf strm =
865 if utf8_lexing.val then
866 match Stream.peek strm with
868 if Char.code c >= 128 then
869 let x = implode (Stream.npeek 2 strm) in
870 if List.mem x greek_tab then do { Stream.junk strm; $add c }
871 else raise Stream.Failure
872 else raise Stream.Failure
873 | None -> raise Stream.Failure ]
878 value misc_letter buf strm =
879 if utf8_lexing.val then
880 match Stream.peek strm with
882 if Char.code c >= 128 then
883 match implode (Stream.npeek 3 strm) with
884 [ "→" | "≤" | "≥" -> raise Stream.Failure
885 | _ -> do { Stream.junk strm; $add c } ]
886 else raise Stream.Failure
887 | None -> raise Stream.Failure ]
889 match strm with lexer [ '\128'-'\225' | '\227'-'\255' ]
892 value misc_punct buf strm =
893 if utf8_lexing.val then
894 match strm with lexer [ '\226' _ _ ]
896 match strm with parser []
899 value utf8_equiv ctx bp buf strm =
900 if utf8_lexing.val then
901 match strm with lexer
902 [ "→" -> keyword_or_error ctx (bp, $pos) "->"
903 | "≤" -> keyword_or_error ctx (bp, $pos) "<="
904 | "≥" -> keyword_or_error ctx (bp, $pos) ">=" ]
906 match strm with parser []
911 [ [ 'A'-'Z' | 'a'-'z' | '0'-'9' | '_' | ''' | misc_letter ] ident! | ]
916 [ [ '!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
917 '%' | '.' | ':' | '<' | '>' | '|' | '$' | misc_punct ]
924 [ [ '0'-'9' | 'A'-'Z' | 'a'-'z' | '_' | '!' | '%' | '&' | '*' | '+' | '-' |
925 '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | ''' |
926 '$' | '\128'-'\255' ] ident3!
930 value binary = lexer [ '0' | '1' ];
931 value octal = lexer [ '0'-'7' ];
932 value decimal = lexer [ '0'-'9' ];
933 value hexa = lexer [ '0'-'9' | 'a'-'f' | 'A'-'F' ];
937 [ "l"/ -> ("INT_l", $buf)
938 | "L"/ -> ("INT_L", $buf)
939 | "n"/ -> ("INT_n", $buf)
943 value rec digits_under kind =
945 [ kind (digits_under kind)!
946 | "_" (digits_under kind)!
952 [ kind (digits_under kind)!
953 | -> raise (Stream.Error "ill-formed integer constant") ]
956 value rec decimal_digits_under =
957 lexer [ [ '0'-'9' | '_' ] decimal_digits_under! | ]
960 value exponent_part =
962 [ [ 'e' | 'E' ] [ '+' | '-' | ]
963 '0'-'9' ? "ill-formed floating-point constant"
964 decimal_digits_under! ]
969 [ decimal_digits_under "." decimal_digits_under! exponent_part ->
971 | decimal_digits_under "." decimal_digits_under! -> ("FLOAT", $buf)
972 | decimal_digits_under exponent_part -> ("FLOAT", $buf)
973 | decimal_digits_under end_integer! ]
976 value char_after_bslash =
979 | _ [ "'"/ | _ [ "'"/ | ] ] ]
984 [ "\\" _ char_after_bslash!
985 | "\\" -> err ctx (bp, $pos) "char not terminated"
986 | ?= [ _ '''] _! "'"/ ]
990 parser bp [: `c :] -> do { ctx.line_cnt bp c; $add c }
993 value rec string ctx bp =
996 | "\\" (any ctx) (string ctx bp)!
997 | (any ctx) (string ctx bp)!
998 | -> err ctx (bp, $pos) "string not terminated" ]
1001 value rec qstring ctx bp =
1004 | (any ctx) (qstring ctx bp)!
1005 | -> err ctx (bp, $pos) "quotation not terminated" ]
1008 value comment ctx bp =
1009 comment where rec comment =
1013 | "(*" comment! comment!
1015 | "\"" (string ctx bp)! [ -> $add "\"" ] comment!
1018 | "'" (any ctx) comment!
1019 | (any ctx) comment!
1020 | -> err ctx (bp, $pos) "comment not terminated" ]
1023 value rec quotation ctx bp =
1026 | ">" (quotation ctx bp)!
1027 | "<<" (quotation ctx bp)! [ -> $add ">>" ]! (quotation ctx bp)!
1028 | "<:" ident! "<" (quotation ctx bp)! [ -> $add ">>" ]! (quotation ctx bp)!
1029 | "<:" ident! (quotation ctx bp)!
1030 | "<" (quotation ctx bp)!
1031 | "\\"/ [ '>' | '<' | '\\' ] (quotation ctx bp)!
1032 | "\\" (quotation ctx bp)!
1033 | (any ctx) (quotation ctx bp)!
1034 | -> err ctx (bp, $pos) "quotation not terminated" ]
1037 value less_expected = "character '<' expected";
1039 value less ctx bp buf strm =
1040 if no_quotations.val then
1041 match strm with lexer
1042 [ [ -> $add "<" ] ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
1044 match strm with lexer
1045 [ "<"/ (quotation ctx bp) -> ("QUOTATION", ":" ^ $buf)
1046 | ":"/ ident! "<"/ ? less_expected [ -> $add ":" ]! (quotation ctx bp) ->
1048 | ":"/ ident! ":<"/ ? less_expected [ -> $add "@" ]! (quotation ctx bp) ->
1050 | [ -> $add "<" ] ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
1053 value rec antiquot_rest ctx bp =
1056 | "\\"/ (any ctx) (antiquot_rest ctx bp)!
1057 | (any ctx) (antiquot_rest ctx bp)!
1058 | -> err ctx (bp, $pos) "antiquotation not terminated" ]
1061 value rec antiquot ctx bp =
1063 [ "$"/ -> ":" ^ $buf
1064 | [ 'a'-'z' | 'A'-'Z' | '0'-'9' | '!' | '_' ] (antiquot ctx bp)!
1065 | ":" (antiquot_rest ctx bp)! -> $buf
1066 | "\\"/ (any ctx) (antiquot_rest ctx bp)! -> ":" ^ $buf
1067 | (any ctx) (antiquot_rest ctx bp)! -> ":" ^ $buf
1068 | -> err ctx (bp, $pos) "antiquotation not terminated" ]
1071 value antiloc bp ep s = Printf.sprintf "%d,%d:%s" bp ep s;
1073 value rec antiquot_loc ctx bp =
1075 [ "$"/ -> antiloc bp $pos (":" ^ $buf)
1076 | [ 'a'-'z' | 'A'-'Z' | '0'-'9' | '!' | '_' ] (antiquot_loc ctx bp)!
1077 | ":" (antiquot_rest ctx bp)! -> antiloc bp $pos $buf
1078 | "\\"/ (any ctx) (antiquot_rest ctx bp)! -> antiloc bp $pos (":" ^ $buf)
1079 | (any ctx) (antiquot_rest ctx bp)! -> antiloc bp $pos (":" ^ $buf)
1080 | -> err ctx (bp, $pos) "antiquotation not terminated" ]
1083 value dollar ctx bp buf strm =
1084 if not no_quotations.val && ctx.dollar_for_antiquotation then
1085 ("ANTIQUOT", antiquot ctx bp buf strm)
1086 else if force_antiquot_loc.val then
1087 ("ANTIQUOT_LOC", antiquot_loc ctx bp buf strm)
1089 match strm with lexer
1090 [ [ -> $add "$" ] ident2! -> ("", $buf) ]
1093 (* ANTIQUOT - specific case for QUESTIONIDENT and QUESTIONIDENTCOLON
1096 ?$abc:d$ ?abc:d ?abc
1097 ?$abc:d$: ?abc:d: ?abc:
1102 (* ANTIQUOT_LOC - specific case for QUESTIONIDENT and QUESTIONIDENTCOLON
1105 ?$abc:d$ ?8,13:abc:d ?abc
1106 ?$abc:d$: ?8,13:abc:d: ?abc:
1111 value question ctx bp buf strm =
1112 if ctx.dollar_for_antiquotation then
1113 match strm with parser
1114 [ [: `'$'; s = antiquot ctx bp $empty; `':' :] ->
1115 ("ANTIQUOT", "?" ^ s ^ ":")
1116 | [: `'$'; s = antiquot ctx bp $empty :] ->
1117 ("ANTIQUOT", "?" ^ s)
1119 match strm with lexer
1120 [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
1121 else if force_antiquot_loc.val then
1122 match strm with parser
1123 [ [: `'$'; s = antiquot_loc ctx bp $empty; `':' :] ->
1124 ("ANTIQUOT_LOC", "?" ^ s ^ ":")
1125 | [: `'$'; s = antiquot_loc ctx bp $empty :] ->
1126 ("ANTIQUOT_LOC", "?" ^ s)
1128 match strm with lexer
1129 [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
1131 match strm with lexer
1132 [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
1135 value tilde ctx bp buf strm =
1136 if ctx.dollar_for_antiquotation then
1137 match strm with parser
1138 [ [: `'$'; s = antiquot ctx bp $empty; `':' :] ->
1139 ("ANTIQUOT", "~" ^ s ^ ":")
1140 | [: `'$'; s = antiquot ctx bp $empty :] ->
1141 ("ANTIQUOT", "~" ^ s)
1143 match strm with lexer
1144 [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
1145 else if force_antiquot_loc.val then
1146 match strm with parser
1147 [ [: `'$'; s = antiquot_loc ctx bp $empty; `':' :] ->
1148 ("ANTIQUOT_LOC", "~" ^ s ^ ":")
1149 | [: `'$'; s = antiquot_loc ctx bp $empty :] ->
1150 ("ANTIQUOT_LOC", "~" ^ s)
1152 match strm with lexer
1153 [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
1155 match strm with lexer
1156 [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
1161 [ ":"/ -> ("TILDEIDENTCOLON", $buf)
1162 | -> ("TILDEIDENT", $buf) ]
1165 value questionident =
1167 [ ":"/ -> ("QUESTIONIDENTCOLON", $buf)
1168 | -> ("QUESTIONIDENT", $buf) ]
1171 value rec linedir n s =
1172 match stream_peek_nth n s with
1173 [ Some (' ' | '\t') -> linedir (n + 1) s
1174 | Some ('0'..'9') -> linedir_digits (n + 1) s
1176 and linedir_digits n s =
1177 match stream_peek_nth n s with
1178 [ Some ('0'..'9') -> linedir_digits (n + 1) s
1179 | _ -> linedir_quote n s ]
1180 and linedir_quote n s =
1181 match stream_peek_nth n s with
1182 [ Some (' ' | '\t') -> linedir_quote (n + 1) s
1187 value rec any_to_nl =
1194 value next_token_after_spaces ctx bp =
1198 jrh_identifier ctx.find_kwd id
1199 (********** JRH: original was
1200 try ("", ctx.find_kwd id) with [ Not_found -> ("UIDENT", id) ]
1202 | greek_letter ident! -> ("GIDENT", $buf)
1203 | [ 'a'-'z' | '_' | misc_letter ] ident! ->
1205 jrh_identifier ctx.find_kwd id
1206 (********** JRH: original was
1207 try ("", ctx.find_kwd id) with [ Not_found -> ("LIDENT", id) ]
1210 | "0" [ 'o' | 'O' ] (digits octal)!
1211 | "0" [ 'x' | 'X' ] (digits hexa)!
1212 | "0" [ 'b' | 'B' ] (digits binary)!
1214 | "'"/ ?= [ '\\' 'a'-'z' 'a'-'z' ] -> keyword_or_error ctx (bp, $pos) "'"
1215 | "'"/ (char ctx bp) -> ("CHAR", $buf)
1216 | "'" -> keyword_or_error ctx (bp, $pos) "'"
1217 | "\""/ (string ctx bp)! -> ("STRING", $buf)
1218 (*** Line added by JRH ***)
1219 | "`"/ (qstring ctx bp)! -> ("QUOTATION", "tot:" ^ $buf)
1220 | "$"/ (dollar ctx bp)!
1221 | [ '!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' ] ident2! ->
1222 keyword_or_error ctx (bp, $pos) $buf
1223 | "~"/ 'a'-'z' ident! tildeident!
1224 | "~"/ '_' ident! tildeident!
1225 | "~" (tilde ctx bp)
1226 | "?"/ 'a'-'z' ident! questionident!
1227 | "?" (question ctx bp)!
1228 | "<"/ (less ctx bp)!
1229 | ":]" -> keyword_or_error ctx (bp, $pos) $buf
1230 | "::" -> keyword_or_error ctx (bp, $pos) $buf
1231 | ":=" -> keyword_or_error ctx (bp, $pos) $buf
1232 | ":>" -> keyword_or_error ctx (bp, $pos) $buf
1233 | ":" -> keyword_or_error ctx (bp, $pos) $buf
1234 | ">]" -> keyword_or_error ctx (bp, $pos) $buf
1235 | ">}" -> keyword_or_error ctx (bp, $pos) $buf
1236 | ">" ident2! -> keyword_or_error ctx (bp, $pos) $buf
1237 | "|]" -> keyword_or_error ctx (bp, $pos) $buf
1238 | "|}" -> keyword_or_error ctx (bp, $pos) $buf
1239 | "|" ident2! -> keyword_or_error ctx (bp, $pos) $buf
1240 | "[" ?= [ "<<" | "<:" ] -> keyword_or_error ctx (bp, $pos) $buf
1241 | "[|" -> keyword_or_error ctx (bp, $pos) $buf
1242 | "[<" -> keyword_or_error ctx (bp, $pos) $buf
1243 | "[:" -> keyword_or_error ctx (bp, $pos) $buf
1244 | "[" -> keyword_or_error ctx (bp, $pos) $buf
1245 | "{" ?= [ "<<" | "<:" ] -> keyword_or_error ctx (bp, $pos) $buf
1246 | "{|" -> keyword_or_error ctx (bp, $pos) $buf
1247 | "{<" -> keyword_or_error ctx (bp, $pos) $buf
1248 | "{:" -> keyword_or_error ctx (bp, $pos) $buf
1249 | "{" -> keyword_or_error ctx (bp, $pos) $buf
1250 | ".." -> keyword_or_error ctx (bp, $pos) ".."
1251 | "." ?= [ "\n" ] -> keyword_or_error ctx (bp, bp + 1) ctx.dot_newline_is
1254 if ctx.specific_space_dot && ctx.after_space then " ." else "."
1256 keyword_or_error ctx (bp, $pos) id
1257 | ";;" -> keyword_or_error ctx (bp, $pos) ";;"
1258 | ";" -> keyword_or_error ctx (bp, $pos) ";"
1259 | (utf8_equiv ctx bp)
1260 | misc_punct ident2! -> keyword_or_error ctx (bp, $pos) $buf
1261 | "\\"/ ident3! -> ("LIDENT", $buf)
1262 | (any ctx) -> keyword_or_error ctx (bp, $pos) $buf ]
1265 value get_comment buf strm = $buf;
1267 value rec next_token ctx buf =
1269 [ [: `('\n' | '\r' as c); s :] ep -> do {
1270 if c = '\n' then incr Plexing.line_nb.val else ();
1271 Plexing.bol_pos.val.val := ep;
1273 ctx.after_space := True;
1274 next_token ctx ($add c) s
1276 | [: `(' ' | '\t' | '\026' | '\012' as c); s :] -> do {
1277 ctx.after_space := True;
1278 next_token ctx ($add c) s
1280 | [: `'#' when bp = Plexing.bol_pos.val.val; s :] ->
1281 let comm = get_comment buf () in
1282 if linedir 1 s then do {
1283 let buf = any_to_nl ($add '#') s in
1284 incr Plexing.line_nb.val;
1285 Plexing.bol_pos.val.val := Stream.count s;
1287 ctx.after_space := True;
1288 next_token ctx buf s
1291 let loc = ctx.make_lined_loc (bp, bp + 1) comm in
1292 (keyword_or_error ctx (bp, bp + 1) "#", loc)
1296 [ [: `'*'; buf = comment ctx bp ($add "(*") !; s :] -> do {
1298 ctx.after_space := True;
1299 next_token ctx buf s
1302 let loc = ctx.make_lined_loc (bp, ep) $buf in
1303 (keyword_or_error ctx (bp, ep) "(", loc) ] ! :] -> a
1304 | [: comm = get_comment buf;
1305 tok = next_token_after_spaces ctx bp $empty :] ep ->
1306 let loc = ctx.make_lined_loc (bp, max (bp + 1) ep) comm in
1308 | [: comm = get_comment buf; _ = Stream.empty :] ->
1309 let loc = ctx.make_lined_loc (bp, bp + 1) comm in
1310 (("EOI", ""), loc) ]
1313 value next_token_fun ctx glexr (cstrm, s_line_nb, s_bol_pos) =
1315 match Plexing.restore_lexing_info.val with
1316 [ Some (line_nb, bol_pos) -> do {
1317 s_line_nb.val := line_nb;
1318 s_bol_pos.val := bol_pos;
1319 Plexing.restore_lexing_info.val := None;
1322 Plexing.line_nb.val := s_line_nb;
1323 Plexing.bol_pos.val := s_bol_pos;
1324 let comm_bp = Stream.count cstrm in
1326 ctx.after_space := False;
1327 let (r, loc) = next_token ctx $empty cstrm in
1328 match glexr.val.Plexing.tok_comm with
1330 if Ploc.first_pos loc > comm_bp then
1331 let comm_loc = Ploc.make_unlined (comm_bp, Ploc.last_pos loc) in
1332 glexr.val.Plexing.tok_comm := Some [comm_loc :: list]
1338 [ Stream.Error str ->
1339 err ctx (Stream.count cstrm, Stream.count cstrm + 1) str ]
1342 value func kwd_table glexr =
1344 let line_nb = ref 0 in
1345 let bol_pos = ref 0 in
1346 {after_space = False;
1347 dollar_for_antiquotation = dollar_for_antiquotation.val;
1348 specific_space_dot = specific_space_dot.val;
1349 dot_newline_is = dot_newline_is.val;
1350 find_kwd = Hashtbl.find kwd_table;
1353 [ '\n' | '\r' -> do {
1354 if c = '\n' then incr Plexing.line_nb.val else ();
1355 Plexing.bol_pos.val.val := bp1 + 1;
1358 set_line_nb () = do {
1359 line_nb.val := Plexing.line_nb.val.val;
1360 bol_pos.val := Plexing.bol_pos.val.val;
1362 make_lined_loc loc comm =
1363 Ploc.make_loc Plexing.input_file.val line_nb.val bol_pos.val loc comm}
1365 Plexing.lexer_func_of_parser (next_token_fun ctx glexr)
1368 value rec check_keyword_stream =
1369 parser [: _ = check $empty; _ = Stream.empty :] -> True
1372 [ [ 'A'-'Z' | 'a'-'z' | misc_letter ] check_ident!
1373 | [ '!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
1377 | "<" ?= [ ":" | "<" ]
1390 | "[" ?= [ "<<" | "<:" ]
1395 | "{" ?= [ "<<" | "<:" ]
1402 | misc_punct check_ident2!
1406 [ [ 'A'-'Z' | 'a'-'z' | '0'-'9' | '_' | ''' | misc_letter ]
1410 [ [ '!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
1411 '.' | ':' | '<' | '>' | '|' | misc_punct ]
1415 value check_keyword s =
1416 try check_keyword_stream (Stream.of_string s) with _ -> False
1419 value error_no_respect_rules p_con p_prm =
1423 (if p_con = "" then "\"" ^ p_prm ^ "\""
1424 else if p_prm = "" then p_con
1425 else p_con ^ " \"" ^ p_prm ^ "\"") ^
1426 " does not respect Plexer rules"))
1429 value error_ident_and_keyword p_con p_prm =
1432 ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^
1436 value using_token kwd_table ident_table (p_con, p_prm) =
1439 if not (hashtbl_mem kwd_table p_prm) then
1440 if check_keyword p_prm then
1441 if hashtbl_mem ident_table p_prm then
1442 error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm
1443 else Hashtbl.add kwd_table p_prm p_prm
1444 else error_no_respect_rules p_con p_prm
1447 if p_prm = "" then ()
1449 match p_prm.[0] with
1450 [ 'A'..'Z' -> error_no_respect_rules p_con p_prm
1452 if hashtbl_mem kwd_table p_prm then
1453 error_ident_and_keyword p_con p_prm
1454 else Hashtbl.add ident_table p_prm p_con ]
1456 if p_prm = "" then ()
1458 match p_prm.[0] with
1459 [ 'a'..'z' -> error_no_respect_rules p_con p_prm
1461 if hashtbl_mem kwd_table p_prm then
1462 error_ident_and_keyword p_con p_prm
1463 else Hashtbl.add ident_table p_prm p_con ]
1464 | "TILDEIDENT" | "TILDEIDENTCOLON" | "QUESTIONIDENT" |
1465 "QUESTIONIDENTCOLON" | "INT" | "INT_l" | "INT_L" | "INT_n" | "FLOAT" |
1466 "CHAR" | "STRING" | "QUOTATION" | "GIDENT" |
1467 "ANTIQUOT" | "ANTIQUOT_LOC" | "EOI" ->
1472 ("the constructor \"" ^ p_con ^
1473 "\" is not recognized by Plexer")) ]
1476 value removing_token kwd_table ident_table (p_con, p_prm) =
1478 [ "" -> Hashtbl.remove kwd_table p_prm
1479 | "LIDENT" | "UIDENT" ->
1480 if p_prm <> "" then Hashtbl.remove ident_table p_prm else ()
1486 [ ("", t) -> "'" ^ t ^ "'"
1487 | ("LIDENT", "") -> "lowercase identifier"
1488 | ("LIDENT", t) -> "'" ^ t ^ "'"
1489 | ("UIDENT", "") -> "uppercase identifier"
1490 | ("UIDENT", t) -> "'" ^ t ^ "'"
1491 | ("INT", "") -> "integer"
1492 | ("INT", s) -> "'" ^ s ^ "'"
1493 | ("FLOAT", "") -> "float"
1494 | ("STRING", "") -> "string"
1495 | ("CHAR", "") -> "char"
1496 | ("QUOTATION", "") -> "quotation"
1497 | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\""
1498 | ("EOI", "") -> "end of input"
1500 | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
1503 value eq_before_colon p e =
1504 loop 0 where rec loop i =
1505 if i == String.length e then
1506 failwith "Internal error in Plexer: incorrect ANTIQUOT"
1507 else if i == String.length p then e.[i] == ':'
1508 else if p.[i] == e.[i] then loop (i + 1)
1512 value after_colon e =
1514 let i = String.index e ':' in
1515 String.sub e (i + 1) (String.length e - i - 1)
1520 value after_colon_except_last e =
1522 let i = String.index e ':' in
1523 String.sub e (i + 1) (String.length e - i - 2)
1530 [ ("ANTIQUOT", p_prm) ->
1531 if p_prm <> "" && (p_prm.[0] = '~' || p_prm.[0] = '?') then
1532 if p_prm.[String.length p_prm - 1] = ':' then
1533 let p_prm = String.sub p_prm 0 (String.length p_prm - 1) in
1535 [ ("ANTIQUOT", prm) ->
1536 if prm <> "" && prm.[String.length prm - 1] = ':' then
1537 if eq_before_colon p_prm prm then after_colon_except_last prm
1538 else raise Stream.Failure
1539 else raise Stream.Failure
1540 | _ -> raise Stream.Failure ]
1543 [ ("ANTIQUOT", prm) ->
1544 if prm <> "" && prm.[String.length prm - 1] = ':' then
1545 raise Stream.Failure
1546 else if eq_before_colon p_prm prm then after_colon prm
1547 else raise Stream.Failure
1548 | _ -> raise Stream.Failure ]
1551 [ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm
1552 | _ -> raise Stream.Failure ]
1553 | tok -> Plexing.default_match tok ]
1557 let kwd_table = Hashtbl.create 301 in
1558 let id_table = Hashtbl.create 301 in
1561 {Plexing.tok_func = fun []; tok_using = fun []; tok_removing = fun [];
1562 tok_match = fun []; tok_text = fun []; tok_comm = None}
1565 {Plexing.tok_func = func kwd_table glexr;
1566 tok_using = using_token kwd_table id_table;
1567 tok_removing = removing_token kwd_table id_table; tok_match = tok_match;
1568 tok_text = text; tok_comm = None}
1570 do { glexr.val := glex; glex }
1573 (* ------------------------------------------------------------------------- *)
1574 (* Back to etc/pa_o.ml *)
1575 (* ------------------------------------------------------------------------- *)
1578 let odfa = dollar_for_antiquotation.val in
1579 dollar_for_antiquotation.val := False;
1580 Plexer.utf8_lexing.val := True;
1581 Grammar.Unsafe.gram_reinit gram (gmake ());
1582 dollar_for_antiquotation.val := odfa;
1583 Grammar.Unsafe.clear_entry interf;
1584 Grammar.Unsafe.clear_entry implem;
1585 Grammar.Unsafe.clear_entry top_phrase;
1586 Grammar.Unsafe.clear_entry use_file;
1587 Grammar.Unsafe.clear_entry module_type;
1588 Grammar.Unsafe.clear_entry module_expr;
1589 Grammar.Unsafe.clear_entry sig_item;
1590 Grammar.Unsafe.clear_entry str_item;
1591 Grammar.Unsafe.clear_entry signature;
1592 Grammar.Unsafe.clear_entry structure;
1593 Grammar.Unsafe.clear_entry expr;
1594 Grammar.Unsafe.clear_entry patt;
1595 Grammar.Unsafe.clear_entry ctyp;
1596 Grammar.Unsafe.clear_entry let_binding;
1597 Grammar.Unsafe.clear_entry type_decl;
1598 Grammar.Unsafe.clear_entry constructor_declaration;
1599 Grammar.Unsafe.clear_entry label_declaration;
1600 Grammar.Unsafe.clear_entry match_case;
1601 Grammar.Unsafe.clear_entry with_constr;
1602 Grammar.Unsafe.clear_entry poly_variant;
1603 Grammar.Unsafe.clear_entry class_type;
1604 Grammar.Unsafe.clear_entry class_expr;
1605 Grammar.Unsafe.clear_entry class_sig_item;
1606 Grammar.Unsafe.clear_entry class_str_item
1609 Pcaml.parse_interf.val := Grammar.Entry.parse interf;
1610 Pcaml.parse_implem.val := Grammar.Entry.parse implem;
1612 value mklistexp loc last =
1613 loop True where rec loop top =
1618 | None -> <:expr< [] >> ]
1621 if top then loc else Ploc.encl (MLast.loc_of_expr e1) loc
1623 <:expr< [$e1$ :: $loop False el$] >> ]
1626 value mklistpat loc last =
1627 loop True where rec loop top =
1632 | None -> <:patt< [] >> ]
1635 if top then loc else Ploc.encl (MLast.loc_of_patt p1) loc
1637 <:patt< [$p1$ :: $loop False pl$] >> ]
1640 (*** JRH pulled this outside so user can add new infixes here too ***)
1642 value ht = Hashtbl.create 73;
1644 (*** And JRH added all the new HOL Light infixes here already ***)
1646 value is_operator = do {
1647 let ct = Hashtbl.create 73 in
1648 List.iter (fun x -> Hashtbl.add ht x True)
1649 ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; "o"; "upto";
1650 "F_F"; "THENC"; "THEN"; "THENL"; "ORELSE"; "ORELSEC";
1651 "THEN_TCL"; "ORELSE_TCL"];
1652 List.iter (fun x -> Hashtbl.add ct x True)
1653 ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~';
1654 '?'; '%'; '.'; '$'];
1656 try Hashtbl.find ht x with
1657 [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ]
1660 (*** JRH added this so parenthesised operators undergo same mapping ***)
1662 value translate_operator =
1666 | "THENC" -> "thenc_"
1667 | "THENL" -> "thenl_"
1668 | "ORELSE" -> "orelse_"
1669 | "ORELSEC" -> "orelsec_"
1670 | "THEN_TCL" -> "then_tcl_"
1671 | "ORELSE_TCL" -> "orelse_tcl_"
1675 value operator_rparen =
1676 Grammar.Entry.of_parser gram "operator_rparen"
1678 match Stream.npeek 2 strm with
1679 [ [("", s); ("", ")")] when is_operator s -> do {
1682 translate_operator s
1684 | _ -> raise Stream.Failure ])
1687 value check_not_part_of_patt =
1688 Grammar.Entry.of_parser gram "check_not_part_of_patt"
1691 match Stream.npeek 4 strm with
1692 [ [("LIDENT", _); tok :: _] -> tok
1693 | [("", "("); ("", s); ("", ")"); tok] when is_operator s -> tok
1694 | _ -> raise Stream.Failure ]
1697 [ ("", "," | "as" | "|" | "::") -> raise Stream.Failure
1703 ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?';
1706 loop where rec loop s i =
1707 if i == String.length s then True
1708 else if List.mem s.[i] list then loop s (i + 1)
1713 let list = ['!'; '?'; '~'] in
1714 let excl = ["!="; "??"; "?!"] in
1715 Grammar.Entry.of_parser gram "prefixop"
1719 not (List.mem x excl) && String.length x >= 2 &&
1720 List.mem x.[0] list && symbolchar x 1 :] ->
1725 let list = ['='; '<'; '>'; '|'; '&'; '$'] in
1726 let excl = ["<-"; "||"; "&&"] in
1727 Grammar.Entry.of_parser gram "infixop0"
1731 not (List.mem x excl) && (x = "$" || String.length x >= 2) &&
1732 List.mem x.[0] list && symbolchar x 1 :] ->
1737 let list = ['@'; '^'] in
1738 Grammar.Entry.of_parser gram "infixop1"
1742 String.length x >= 2 && List.mem x.[0] list &&
1743 symbolchar x 1 :] ->
1748 let list = ['+'; '-'] in
1749 Grammar.Entry.of_parser gram "infixop2"
1753 x <> "->" && String.length x >= 2 && List.mem x.[0] list &&
1754 symbolchar x 1 :] ->
1759 let list = ['*'; '/'; '%'] in
1760 Grammar.Entry.of_parser gram "infixop3"
1764 String.length x >= 2 && List.mem x.[0] list &&
1765 symbolchar x 1 :] ->
1770 Grammar.Entry.of_parser gram "infixop4"
1774 String.length x >= 3 && x.[0] == '*' && x.[1] == '*' &&
1775 symbolchar x 2 :] ->
1779 value test_constr_decl =
1780 Grammar.Entry.of_parser gram "test_constr_decl"
1782 match Stream.npeek 1 strm with
1783 [ [("UIDENT", _)] ->
1784 match Stream.npeek 2 strm with
1785 [ [_; ("", ".")] -> raise Stream.Failure
1786 | [_; ("", "(")] -> raise Stream.Failure
1788 | _ -> raise Stream.Failure ]
1790 | _ -> raise Stream.Failure ])
1793 value stream_peek_nth n strm =
1794 loop n (Stream.npeek n strm) where rec loop n =
1797 | [x] -> if n == 1 then Some x else None
1798 | [_ :: l] -> loop (n - 1) l ]
1801 (* horrible hack to be able to parse class_types *)
1803 value test_ctyp_minusgreater =
1804 Grammar.Entry.of_parser gram "test_ctyp_minusgreater"
1806 let rec skip_simple_ctyp n =
1807 match stream_peek_nth n strm with
1808 [ Some ("", "->") -> n
1809 | Some ("", "[" | "[<") ->
1810 skip_simple_ctyp (ignore_upto "]" (n + 1) + 1)
1811 | Some ("", "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1)
1814 "as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" |
1816 skip_simple_ctyp (n + 1)
1817 | Some ("QUESTIONIDENT" | "LIDENT" | "UIDENT", _) ->
1818 skip_simple_ctyp (n + 1)
1819 | Some _ | None -> raise Stream.Failure ]
1820 and ignore_upto end_kwd n =
1821 match stream_peek_nth n strm with
1822 [ Some ("", prm) when prm = end_kwd -> n
1823 | Some ("", "[" | "[<") ->
1824 ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1)
1825 | Some ("", "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1)
1826 | Some _ -> ignore_upto end_kwd (n + 1)
1827 | None -> raise Stream.Failure ]
1829 match Stream.peek strm with
1830 [ Some (("", "[") | ("LIDENT" | "UIDENT", _)) -> skip_simple_ctyp 1
1831 | Some ("", "object") -> raise Stream.Failure
1835 value test_label_eq =
1836 Grammar.Entry.of_parser gram "test_label_eq"
1837 (test 1 where rec test lev strm =
1838 match stream_peek_nth lev strm with
1839 [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) ->
1841 | Some ("ANTIQUOT_LOC", _) -> ()
1842 | Some ("", "=") -> ()
1843 | _ -> raise Stream.Failure ])
1846 value test_typevar_list_dot =
1847 Grammar.Entry.of_parser gram "test_typevar_list_dot"
1848 (let rec test lev strm =
1849 match stream_peek_nth lev strm with
1850 [ Some ("", "'") -> test2 (lev + 1) strm
1851 | Some ("", ".") -> ()
1852 | _ -> raise Stream.Failure ]
1853 and test2 lev strm =
1854 match stream_peek_nth lev strm with
1855 [ Some ("UIDENT" | "LIDENT", _) -> test (lev + 1) strm
1856 | _ -> raise Stream.Failure ]
1862 Grammar.Entry.of_parser gram "e_phony"
1866 Grammar.Entry.of_parser gram "p_phony"
1870 value constr_arity = ref [("Some", 1); ("Match_Failure", 1)];
1872 value rec is_expr_constr_call =
1874 [ <:expr< $uid:_$ >> -> True
1875 | <:expr< $uid:_$.$e$ >> -> is_expr_constr_call e
1876 | <:expr< $e$ $_$ >> -> is_expr_constr_call e
1880 value rec constr_expr_arity loc =
1882 [ <:expr< $uid:c$ >> ->
1883 try List.assoc c constr_arity.val with [ Not_found -> 0 ]
1884 | <:expr< $uid:_$.$e$ >> -> constr_expr_arity loc e
1888 value rec constr_patt_arity loc =
1890 [ <:patt< $uid:c$ >> ->
1891 try List.assoc c constr_arity.val with [ Not_found -> 0 ]
1892 | <:patt< $uid:_$.$p$ >> -> constr_patt_arity loc p
1898 [ <:expr< do { $list:el$ } >> -> el
1902 value mem_tvar s tpl =
1903 List.exists (fun (t, _) -> Pcaml.unvala t = Some s) tpl
1906 value choose_tvar tpl =
1907 let rec find_alpha v =
1908 let s = String.make 1 v in
1909 if mem_tvar s tpl then
1910 if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
1911 else Some (String.make 1 v)
1914 let v = "a" ^ string_of_int n in
1915 if mem_tvar v tpl then make_n (succ n) else v
1917 match find_alpha 'a' with
1919 | None -> make_n 1 ]
1922 value quotation_content s = do {
1923 loop 0 where rec loop i =
1924 if i = String.length s then ("", s)
1925 else if s.[i] = ':' || s.[i] = '@' then
1927 (String.sub s 0 i, String.sub s i (String.length s - i))
1931 value concat_comm loc e =
1933 Ploc.with_comment loc
1934 (Ploc.comment loc ^ Ploc.comment (MLast.loc_of_expr e))
1937 let first = ref True in
1939 if first.val then do {first.val := False; loc}
1946 GLOBAL: sig_item str_item ctyp patt expr module_type module_expr
1947 signature structure class_type class_expr class_sig_item class_str_item
1948 let_binding type_decl constructor_declaration label_declaration
1949 match_case with_constr poly_variant;
1951 [ [ "functor"; "("; i = V UIDENT "uid" ""; ":"; t = module_type; ")";
1953 <:module_expr< functor ( $_uid:i$ : $t$ ) -> $me$ >>
1954 | "struct"; st = structure; "end" ->
1955 <:module_expr< struct $_list:st$ end >> ]
1956 | [ me1 = SELF; "."; me2 = SELF -> <:module_expr< $me1$ . $me2$ >> ]
1957 | [ me1 = SELF; "("; me2 = SELF; ")" -> <:module_expr< $me1$ $me2$ >> ]
1958 | [ i = mod_expr_ident -> i
1959 | "("; "val"; e = expr; ":"; mt = module_type; ")" ->
1960 <:module_expr< (value $e$ : $mt$) >>
1961 | "("; "val"; e = expr; ")" ->
1962 <:module_expr< (value $e$) >>
1963 | "("; me = SELF; ":"; mt = module_type; ")" ->
1964 <:module_expr< ( $me$ : $mt$ ) >>
1965 | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ]
1968 [ [ st = V (LIST0 [ s = str_item; OPT ";;" -> s ]) -> st ] ]
1972 [ i = SELF; "."; j = SELF -> <:module_expr< $i$ . $j$ >> ]
1973 | [ i = V UIDENT -> <:module_expr< $_uid:i$ >> ] ]
1977 [ "exception"; (_, c, tl, _) = constructor_declaration;
1979 <:str_item< exception $_uid:c$ of $_list:tl$ = $_list:b$ >>
1980 | "external"; i = V LIDENT "lid" ""; ":"; t = ctyp; "=";
1981 pd = V (LIST1 STRING) ->
1982 <:str_item< external $_lid:i$ : $t$ = $_list:pd$ >>
1983 | "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
1984 pd = V (LIST1 STRING) ->
1985 <:str_item< external $lid:i$ : $t$ = $_list:pd$ >>
1986 | "include"; me = module_expr -> <:str_item< include $me$ >>
1987 | "module"; r = V (FLAG "rec"); l = V (LIST1 mod_binding SEP "and") ->
1988 <:str_item< module $_flag:r$ $_list:l$ >>
1989 | "module"; "type"; i = V ident ""; "="; mt = module_type ->
1990 <:str_item< module type $_:i$ = $mt$ >>
1991 | "open"; i = V mod_ident "list" "" ->
1992 <:str_item< open $_:i$ >>
1993 | "type"; tdl = V (LIST1 type_decl SEP "and") ->
1994 <:str_item< type $_list:tdl$ >>
1995 | "let"; r = V (FLAG "rec"); l = V (LIST1 let_binding SEP "and"); "in";
1997 let e = <:expr< let $_flag:r$ $_list:l$ in $x$ >> in
1998 <:str_item< $exp:e$ >>
1999 | "let"; r = V (FLAG "rec"); l = V (LIST1 let_binding SEP "and") ->
2001 [ <:vala< [(p, e)] >> ->
2003 [ <:patt< _ >> -> <:str_item< $exp:e$ >>
2004 | _ -> <:str_item< value $_flag:r$ $_list:l$ >> ]
2005 | _ -> <:str_item< value $_flag:r$ $_list:l$ >> ]
2006 | "let"; "module"; m = V UIDENT; mb = mod_fun_binding; "in"; e = expr ->
2007 <:str_item< let module $_uid:m$ = $mb$ in $e$ >>
2008 | e = expr -> <:str_item< $exp:e$ >> ] ]
2011 [ [ "="; sl = V mod_ident "list" -> sl
2012 | -> <:vala< [] >> ] ]
2015 [ [ i = V UIDENT; me = mod_fun_binding -> (i, me) ] ]
2019 [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
2020 <:module_expr< functor ( $uid:m$ : $mt$ ) -> $mb$ >>
2021 | ":"; mt = module_type; "="; me = module_expr ->
2022 <:module_expr< ( $me$ : $mt$ ) >>
2023 | "="; me = module_expr -> <:module_expr< $me$ >> ] ]
2027 [ [ "functor"; "("; i = V UIDENT "uid" ""; ":"; t = SELF; ")"; "->";
2029 <:module_type< functor ( $_uid:i$ : $t$ ) -> $mt$ >> ]
2030 | [ mt = SELF; "with"; wcl = V (LIST1 with_constr SEP "and") ->
2031 <:module_type< $mt$ with $_list:wcl$ >> ]
2032 | [ "sig"; sg = signature; "end" ->
2033 <:module_type< sig $_list:sg$ end >>
2034 | "module"; "type"; "of"; me = module_expr ->
2035 <:module_type< module type of $me$ >>
2036 | i = mod_type_ident -> i
2037 | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ]
2040 [ [ sg = V (LIST0 [ s = sig_item; OPT ";;" -> s ]) -> sg ] ]
2044 [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >>
2045 | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ]
2046 | [ m = V UIDENT -> <:module_type< $_uid:m$ >>
2047 | m = V LIDENT -> <:module_type< $_lid:m$ >> ] ]
2051 [ "exception"; (_, c, tl, _) = constructor_declaration ->
2052 <:sig_item< exception $_uid:c$ of $_list:tl$ >>
2053 | "external"; i = V LIDENT "lid" ""; ":"; t = ctyp; "=";
2054 pd = V (LIST1 STRING) ->
2055 <:sig_item< external $_lid:i$ : $t$ = $_list:pd$ >>
2056 | "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
2057 pd = V (LIST1 STRING) ->
2058 <:sig_item< external $lid:i$ : $t$ = $_list:pd$ >>
2059 | "include"; mt = module_type ->
2060 <:sig_item< include $mt$ >>
2061 | "module"; rf = V (FLAG "rec");
2062 l = V (LIST1 mod_decl_binding SEP "and") ->
2063 <:sig_item< module $_flag:rf$ $_list:l$ >>
2064 | "module"; "type"; i = V ident ""; "="; mt = module_type ->
2065 <:sig_item< module type $_:i$ = $mt$ >>
2066 | "module"; "type"; i = V ident "" ->
2067 <:sig_item< module type $_:i$ = 'abstract >>
2068 | "open"; i = V mod_ident "list" "" ->
2069 <:sig_item< open $_:i$ >>
2070 | "type"; tdl = V (LIST1 type_decl SEP "and") ->
2071 <:sig_item< type $_list:tdl$ >>
2072 | "val"; i = V LIDENT "lid" ""; ":"; t = ctyp ->
2073 <:sig_item< value $_lid:i$ : $t$ >>
2074 | "val"; "("; i = operator_rparen; ":"; t = ctyp ->
2075 <:sig_item< value $lid:i$ : $t$ >> ] ]
2078 [ [ i = V UIDENT; mt = module_declaration -> (i, mt) ] ]
2082 [ ":"; mt = module_type -> <:module_type< $mt$ >>
2083 | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF ->
2084 <:module_type< functor ( $uid:i$ : $t$ ) -> $mt$ >> ] ]
2086 (* "with" constraints (additional type equations over signature
2089 [ [ "type"; tpl = V type_parameters "list"; i = V mod_ident ""; "=";
2090 pf = V (FLAG "private"); t = ctyp ->
2091 <:with_constr< type $_:i$ $_list:tpl$ = $_flag:pf$ $t$ >>
2092 | "type"; tpl = V type_parameters "list"; i = V mod_ident ""; ":=";
2094 <:with_constr< type $_:i$ $_list:tpl$ := $t$ >>
2095 | "module"; i = V mod_ident ""; "="; me = module_expr ->
2096 <:with_constr< module $_:i$ = $me$ >>
2097 | "module"; i = V mod_ident ""; ":="; me = module_expr ->
2098 <:with_constr< module $_:i$ := $me$ >> ] ]
2100 (* Core expressions *)
2103 [ e1 = SELF; ";"; e2 = SELF ->
2104 <:expr< do { $list:[e1 :: get_seq e2]$ } >>
2105 | e1 = SELF; ";" -> e1
2106 | el = V e_phony "list" -> <:expr< do { $_list:el$ } >> ]
2108 [ "let"; o = V (FLAG "rec"); l = V (LIST1 let_binding SEP "and"); "in";
2109 x = expr LEVEL "top" ->
2110 <:expr< let $_flag:o$ $_list:l$ in $x$ >>
2111 | "let"; "module"; m = V UIDENT; mb = mod_fun_binding; "in";
2112 e = expr LEVEL "top" ->
2113 <:expr< let module $_uid:m$ = $mb$ in $e$ >>
2114 | "function"; OPT "|"; l = V (LIST1 match_case SEP "|") ->
2115 <:expr< fun [ $_list:l$ ] >>
2116 | "fun"; p = patt LEVEL "simple"; (eo, e) = fun_def ->
2117 <:expr< fun [$p$ $opt:eo$ -> $e$] >>
2118 | "match"; e = SELF; "with"; OPT "|";
2119 l = V (LIST1 match_case SEP "|") ->
2120 <:expr< match $e$ with [ $_list:l$ ] >>
2121 | "try"; e = SELF; "with"; OPT "|"; l = V (LIST1 match_case SEP "|") ->
2122 <:expr< try $e$ with [ $_list:l$ ] >>
2123 | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1"; "else";
2124 e3 = expr LEVEL "expr1" ->
2125 <:expr< if $e1$ then $e2$ else $e3$ >>
2126 | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1" ->
2127 <:expr< if $e1$ then $e2$ else () >>
2128 | "for"; i = V LIDENT; "="; e1 = SELF; df = V direction_flag "to";
2129 e2 = SELF; "do"; e = V SELF "list"; "done" ->
2130 let el = Pcaml.vala_map get_seq e in
2131 <:expr< for $_lid:i$ = $e1$ $_to:df$ $e2$ do { $_list:el$ } >>
2132 | "while"; e1 = SELF; "do"; e2 = V SELF "list"; "done" ->
2133 let el = Pcaml.vala_map get_seq e2 in
2134 <:expr< while $e1$ do { $_list:el$ } >> ]
2135 | [ e = SELF; ","; el = LIST1 NEXT SEP "," ->
2136 <:expr< ( $list:[e :: el]$ ) >> ]
2138 [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" ->
2139 <:expr< $e1$.val := $e2$ >>
2140 | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> <:expr< $e1$ := $e2$ >> ]
2142 [ e1 = SELF; "or"; e2 = SELF -> <:expr< $lid:"or"$ $e1$ $e2$ >>
2143 | e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ]
2145 [ e1 = SELF; "&"; e2 = SELF -> <:expr< $lid:"&"$ $e1$ $e2$ >>
2146 | e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ]
2148 [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >>
2149 | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >>
2150 | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >>
2151 | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >>
2152 | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >>
2153 | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >>
2154 | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >>
2155 | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >>
2156 | e1 = SELF; op = infixop0; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
2158 [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >>
2159 | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >>
2160 | e1 = SELF; op = infixop1; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
2162 [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ]
2164 [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >>
2165 | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >>
2166 | e1 = SELF; op = infixop2; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
2168 [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >>
2169 | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >>
2170 | e1 = SELF; "%"; e2 = SELF -> <:expr< $lid:"%"$ $e1$ $e2$ >>
2171 | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >>
2172 | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >>
2173 | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >>
2174 | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >>
2175 | e1 = SELF; op = infixop3; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
2177 [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >>
2178 | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >>
2179 | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >>
2180 | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >>
2181 | e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
2182 | "unary minus" NONA
2183 [ "-"; e = SELF -> <:expr< - $e$ >>
2184 | "-."; e = SELF -> <:expr< -. $e$ >> ]
2186 [ e1 = SELF; e2 = SELF ->
2188 if is_expr_constr_call e1 then
2190 [ <:expr< $e11$ $e12$ >> -> (e11, <:expr< $e12$ $e2$ >>)
2194 match constr_expr_arity loc e1 with
2195 [ 1 -> <:expr< $e1$ $e2$ >>
2198 [ <:expr< ( $list:el$ ) >> ->
2199 List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el
2200 | _ -> <:expr< $e1$ $e2$ >> ] ]
2201 | "assert"; e = SELF -> <:expr< assert $e$ >>
2202 | "lazy"; e = SELF -> <:expr< lazy ($e$) >> ]
2204 [ e1 = SELF; "."; "("; op = operator_rparen ->
2205 <:expr< $e1$ .( $lid:op$ ) >>
2206 | e1 = SELF; "."; "("; e2 = SELF; ")" ->
2207 <:expr< $e1$ .( $e2$ ) >>
2208 | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>
2209 | e = SELF; "."; "{"; el = V (LIST1 expr LEVEL "+" SEP ","); "}" ->
2210 <:expr< $e$ .{ $_list:el$ } >>
2211 | e1 = SELF; "."; e2 = SELF ->
2214 [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
2215 | e -> <:expr< $m$ . $e$ >> ]
2219 [ "!"; e = SELF -> <:expr< $e$ . val >>
2220 | "~-"; e = SELF -> <:expr< ~- $e$ >>
2221 | "~-."; e = SELF -> <:expr< ~-. $e$ >>
2222 | f = prefixop; e = SELF -> <:expr< $lid:f$ $e$ >> ]
2224 [ s = V INT -> <:expr< $_int:s$ >>
2225 | s = V INT_l -> <:expr< $_int32:s$ >>
2226 | s = V INT_L -> <:expr< $_int64:s$ >>
2227 | s = V INT_n -> <:expr< $_nativeint:s$ >>
2228 | s = V FLOAT -> <:expr< $_flo:s$ >>
2229 | s = V STRING -> <:expr< $_str:s$ >>
2230 | c = V CHAR -> <:expr< $_chr:c$ >>
2231 | UIDENT "True" -> <:expr< True_ >>
2232 | UIDENT "False" -> <:expr< False_ >>
2233 | i = expr_ident -> i
2234 | "false" -> <:expr< False >>
2235 | "true" -> <:expr< True >>
2236 | "["; "]" -> <:expr< [] >>
2237 | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >>
2238 | "[|"; "|]" -> <:expr< [| |] >>
2239 | "[|"; el = V expr1_semi_list "list"; "|]" ->
2240 <:expr< [| $_list:el$ |] >>
2241 | "{"; test_label_eq; lel = V lbl_expr_list "list"; "}" ->
2242 <:expr< { $_list:lel$ } >>
2243 | "{"; e = expr LEVEL "."; "with"; lel = V lbl_expr_list "list"; "}" ->
2244 <:expr< { ($e$) with $_list:lel$ } >>
2245 | "("; ")" -> <:expr< () >>
2246 | "("; "module"; me = module_expr; ":"; mt = module_type; ")" ->
2247 <:expr< (module $me$ : $mt$) >>
2248 | "("; "module"; me = module_expr; ")" ->
2249 <:expr< (module $me$) >>
2250 | "("; op = operator_rparen -> <:expr< $lid:op$ >>
2251 | "("; el = V e_phony "list"; ")" -> <:expr< ($_list:el$) >>
2252 | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
2253 | "("; e = SELF; ")" -> concat_comm loc <:expr< $e$ >>
2254 | "begin"; e = SELF; "end" -> concat_comm loc <:expr< $e$ >>
2255 | "begin"; "end" -> <:expr< () >>
2257 let con = quotation_content x in
2258 Pcaml.handle_expr_quotation loc con ] ]
2261 [ [ p = val_ident; e = fun_binding -> (p, e)
2262 | p = patt; "="; e = expr -> (p, e)
2263 | p = patt; ":"; t = poly_type; "="; e = expr ->
2264 (<:patt< ($p$ : $t$) >>, e) ] ]
2266 (*** JRH added the "translate_operator" here ***)
2268 [ [ check_not_part_of_patt; s = LIDENT -> <:patt< $lid:s$ >>
2269 | check_not_part_of_patt; "("; s = ANY; ")" ->
2270 let s' = translate_operator s in <:patt< $lid:s'$ >> ] ]
2274 [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
2275 | "="; e = expr -> <:expr< $e$ >>
2276 | ":"; t = poly_type; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ]
2279 [ [ x1 = patt; w = V (OPT [ "when"; e = expr -> e ]); "->"; x2 = expr ->
2283 [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel]
2284 | le = lbl_expr; ";" -> [le]
2285 | le = lbl_expr -> [le] ] ]
2288 [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ]
2291 [ [ el = LIST1 (expr LEVEL "expr1") SEP ";" OPT_SEP -> el ] ]
2295 [ p = patt LEVEL "simple"; (eo, e) = SELF ->
2296 (None, <:expr< fun [ $p$ $opt:eo$ -> $e$ ] >>)
2297 | eo = OPT [ "when"; e = expr -> e ]; "->"; e = expr ->
2298 (eo, <:expr< $e$ >>) ] ]
2302 [ i = V LIDENT -> <:expr< $_lid:i$ >>
2303 | i = V UIDENT -> <:expr< $_uid:i$ >>
2304 | i = V UIDENT; "."; j = SELF ->
2307 [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
2308 | e -> <:expr< $m$ . $e$ >> ]
2310 loop <:expr< $_uid:i$ >> j
2311 | i = V UIDENT; "."; "("; j = operator_rparen ->
2312 <:expr< $_uid:i$ . $lid:j$ >>
2313 | i = V UIDENT; "."; "("; e = expr; ")" ->
2314 <:expr< $_uid:i$ . ( $e$ ) >> ] ]
2319 [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ]
2321 [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
2322 | [ p = SELF; ","; pl = LIST1 NEXT SEP "," ->
2323 <:patt< ( $list:[p :: pl]$) >> ]
2325 [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
2327 [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
2329 [ p1 = SELF; p2 = SELF ->
2332 [ <:patt< $p11$ $p12$ >> -> (p11, <:patt< $p12$ $p2$ >>)
2335 match constr_patt_arity loc p1 with
2336 [ 1 -> <:patt< $p1$ $p2$ >>
2340 [ <:patt< _ >> when n > 1 ->
2342 loop n where rec loop n =
2343 if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)]
2345 <:patt< ( $list:pl$ ) >>
2349 [ <:patt< ( $list:pl$ ) >> ->
2350 List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl
2351 | _ -> <:patt< $p1$ $p2$ >> ] ]
2352 | "lazy"; p = SELF -> <:patt< lazy $p$ >> ]
2354 [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
2356 [ s = V LIDENT -> <:patt< $_lid:s$ >>
2357 | s = V UIDENT -> <:patt< $_uid:s$ >>
2358 | s = V INT -> <:patt< $_int:s$ >>
2359 | s = V INT_l -> <:patt< $_int32:s$ >>
2360 | s = V INT_L -> <:patt< $_int64:s$ >>
2361 | s = V INT_n -> <:patt< $_nativeint:s$ >>
2362 | "-"; s = INT -> <:patt< $int:"-" ^ s$ >>
2363 | "-"; s = INT_l -> <:patt< $int32:"-" ^ s$ >>
2364 | "-"; s = INT_L -> <:patt< $int64:"-" ^ s$ >>
2365 | "-"; s = INT_n -> <:patt< $nativeint:"-" ^ s$ >>
2366 | "-"; s = FLOAT -> <:patt< $flo:"-" ^ s$ >>
2367 | s = V FLOAT -> <:patt< $_flo:s$ >>
2368 | s = V STRING -> <:patt< $_str:s$ >>
2369 | s = V CHAR -> <:patt< $_chr:s$ >>
2370 | UIDENT "True" -> <:patt< True_ >>
2371 | UIDENT "False" -> <:patt< False_ >>
2372 | "false" -> <:patt< False >>
2373 | "true" -> <:patt< True >>
2374 | "["; "]" -> <:patt< [] >>
2375 | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >>
2376 | "[|"; "|]" -> <:patt< [| |] >>
2377 | "[|"; pl = V patt_semi_list "list"; "|]" ->
2378 <:patt< [| $_list:pl$ |] >>
2379 | "{"; lpl = V lbl_patt_list "list"; "}" ->
2380 <:patt< { $_list:lpl$ } >>
2381 | "("; ")" -> <:patt< () >>
2382 | "("; op = operator_rparen -> <:patt< $lid:op$ >>
2383 | "("; pl = V p_phony "list"; ")" -> <:patt< ($_list:pl$) >>
2384 | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
2385 | "("; p = SELF; ")" -> <:patt< $p$ >>
2386 | "("; "type"; s = V LIDENT; ")" -> <:patt< (type $_lid:s$) >>
2387 | "("; "module"; s = V UIDENT; ":"; mt = module_type; ")" ->
2388 <:patt< (module $_uid:s$ : $mt$) >>
2389 | "("; "module"; s = V UIDENT; ")" ->
2390 <:patt< (module $_uid:s$) >>
2391 | "_" -> <:patt< _ >>
2393 let con = quotation_content x in
2394 Pcaml.handle_patt_quotation loc con ] ]
2397 [ [ p = patt; ";"; pl = SELF -> [p :: pl]
2398 | p = patt; ";" -> [p]
2399 | p = patt -> [p] ] ]
2402 [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel]
2403 | le = lbl_patt; ";" -> [le]
2404 | le = lbl_patt -> [le] ] ]
2407 [ [ i = patt_label_ident; "="; p = patt -> (i, p)
2408 | "_" -> (<:patt< _ >>, <:patt< _ >>) ] ]
2412 [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
2414 [ i = UIDENT -> <:patt< $uid:i$ >>
2415 | i = LIDENT -> <:patt< $lid:i$ >> ] ]
2417 (* Type declaration *)
2419 [ [ tpl = type_parameters; n = V type_patt; "="; pf = V (FLAG "private");
2420 tk = type_kind; cl = V (LIST0 constrain) ->
2421 <:type_decl< $_tp:n$ $list:tpl$ = $_priv:pf$ $tk$ $_list:cl$ >>
2422 | tpl = type_parameters; n = V type_patt; cl = V (LIST0 constrain) ->
2423 let tk = <:ctyp< '$choose_tvar tpl$ >> in
2424 <:type_decl< $_tp:n$ $list:tpl$ = $tk$ $_list:cl$ >> ] ]
2427 [ [ n = V LIDENT -> (loc, n) ] ]
2430 [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
2433 [ [ test_constr_decl; OPT "|";
2434 cdl = LIST1 constructor_declaration SEP "|" ->
2435 <:ctyp< [ $list:cdl$ ] >>
2438 | t = ctyp; "="; pf = FLAG "private"; "{";
2439 ldl = V label_declarations "list"; "}" ->
2440 <:ctyp< $t$ == $priv:pf$ { $_list:ldl$ } >>
2441 | t = ctyp; "="; pf = FLAG "private"; OPT "|";
2442 cdl = LIST1 constructor_declaration SEP "|" ->
2443 <:ctyp< $t$ == $priv:pf$ [ $list:cdl$ ] >>
2444 | "{"; ldl = V label_declarations "list"; "}" ->
2445 <:ctyp< { $_list:ldl$ } >> ] ]
2448 [ [ -> (* empty *) []
2449 | tp = type_parameter -> [tp]
2450 | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ]
2453 [ [ "+"; p = V simple_type_parameter -> (p, Some True)
2454 | "-"; p = V simple_type_parameter -> (p, Some False)
2455 | p = V simple_type_parameter -> (p, None) ] ]
2457 simple_type_parameter:
2458 [ [ "'"; i = ident -> Some i
2461 constructor_declaration:
2462 [ [ ci = cons_ident; "of"; cal = V (LIST1 (ctyp LEVEL "apply") SEP "*") ->
2463 (loc, ci, cal, None)
2464 | ci = cons_ident; ":"; cal = V (LIST1 (ctyp LEVEL "apply") SEP "*");
2466 (loc, ci, cal, Some t)
2467 | ci = cons_ident; ":"; cal = V (LIST1 (ctyp LEVEL "apply") SEP "*") ->
2470 [ <:vala< [t] >> -> t
2471 | <:vala< [t :: tl] >> -> <:ctyp< ($list:[t :: tl]$) >>
2472 | _ -> assert False ]
2474 (loc, ci, <:vala< [] >>, Some t)
2475 | ci = cons_ident -> (loc, ci, <:vala< [] >>, None) ] ]
2478 [ [ i = V UIDENT "uid" "" -> i
2479 | UIDENT "True" -> <:vala< "True_" >>
2480 | UIDENT "False" -> <:vala< "False_" >> ] ]
2483 [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl]
2484 | ld = label_declaration; ";" -> [ld]
2485 | ld = label_declaration -> [ld] ] ]
2488 [ [ i = LIDENT; ":"; t = poly_type -> (loc, i, False, t)
2489 | "mutable"; i = LIDENT; ":"; t = poly_type -> (loc, i, True, t) ] ]
2493 [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ]
2495 [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
2497 [ t = SELF; "*"; tl = LIST1 (ctyp LEVEL "apply") SEP "*" ->
2498 <:ctyp< ( $list:[t :: tl]$ ) >> ]
2500 [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ]
2502 [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >>
2503 | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ]
2505 [ "'"; i = V ident "" -> <:ctyp< '$_:i$ >>
2506 | "_" -> <:ctyp< _ >>
2507 | i = V LIDENT -> <:ctyp< $_lid:i$ >>
2508 | i = V UIDENT -> <:ctyp< $_uid:i$ >>
2509 | "("; "module"; mt = module_type; ")" -> <:ctyp< module $mt$ >>
2510 | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")";
2511 i = ctyp LEVEL "ctyp2" ->
2512 List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl]
2513 | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ]
2518 | i = UIDENT -> i ] ]
2524 | i = UIDENT; "."; j = SELF -> [i :: j] ] ]
2529 | "downto" -> False ] ]
2531 (* Objects and Classes *)
2533 [ [ "class"; cd = V (LIST1 class_declaration SEP "and") ->
2534 <:str_item< class $_list:cd$ >>
2535 | "class"; "type"; ctd = V (LIST1 class_type_declaration SEP "and") ->
2536 <:str_item< class type $_list:ctd$ >> ] ]
2539 [ [ "class"; cd = V (LIST1 class_description SEP "and") ->
2540 <:sig_item< class $_list:cd$ >>
2541 | "class"; "type"; ctd = V (LIST1 class_type_declaration SEP "and") ->
2542 <:sig_item< class type $_list:ctd$ >> ] ]
2544 (* Class expressions *)
2546 [ [ vf = V (FLAG "virtual"); ctp = class_type_parameters; i = V LIDENT;
2547 cfb = class_fun_binding ->
2548 {MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp;
2549 MLast.ciNam = i; MLast.ciExp = cfb} ] ]
2552 [ [ "="; ce = class_expr -> ce
2553 | ":"; ct = class_type; "="; ce = class_expr ->
2554 <:class_expr< ($ce$ : $ct$) >>
2555 | p = patt LEVEL "simple"; cfb = SELF ->
2556 <:class_expr< fun $p$ -> $cfb$ >> ] ]
2558 class_type_parameters:
2559 [ [ -> (loc, <:vala< [] >>)
2560 | "["; tpl = V (LIST1 type_parameter SEP ","); "]" -> (loc, tpl) ] ]
2563 [ [ p = patt LEVEL "simple"; "->"; ce = class_expr ->
2564 <:class_expr< fun $p$ -> $ce$ >>
2565 | p = patt LEVEL "simple"; cfd = SELF ->
2566 <:class_expr< fun $p$ -> $cfd$ >> ] ]
2570 [ "fun"; cfd = class_fun_def -> cfd
2571 | "let"; rf = V (FLAG "rec"); lb = V (LIST1 let_binding SEP "and");
2573 <:class_expr< let $_flag:rf$ $_list:lb$ in $ce$ >> ]
2575 [ ce = SELF; e = expr LEVEL "label" ->
2576 <:class_expr< $ce$ $e$ >> ]
2578 [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]";
2579 ci = class_longident ->
2580 <:class_expr< [ $list:[ct :: ctcl]$ ] $list:ci$ >>
2581 | "["; ct = ctyp; "]"; ci = class_longident ->
2582 <:class_expr< [ $ct$ ] $list:ci$ >>
2583 | ci = class_longident -> <:class_expr< $list:ci$ >>
2584 | "object"; cspo = V (OPT class_self_patt);
2585 cf = V class_structure "list"; "end" ->
2586 <:class_expr< object $_opt:cspo$ $_list:cf$ end >>
2587 | "("; ce = SELF; ":"; ct = class_type; ")" ->
2588 <:class_expr< ($ce$ : $ct$) >>
2589 | "("; ce = SELF; ")" -> ce ] ]
2592 [ [ cf = LIST0 class_str_item -> cf ] ]
2595 [ [ "("; p = patt; ")" -> p
2596 | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ]
2599 [ [ "inherit"; ce = class_expr; pb = V (OPT [ "as"; i = LIDENT -> i ]) ->
2600 <:class_str_item< inherit $ce$ $_opt:pb$ >>
2601 | "val"; ov = V (FLAG "!") "!"; mf = V (FLAG "mutable");
2602 lab = V LIDENT "lid" ""; e = cvalue_binding ->
2603 <:class_str_item< value $_!:ov$ $_flag:mf$ $_lid:lab$ = $e$ >>
2604 | "val"; ov = V (FLAG "!") "!"; mf = V (FLAG "mutable");
2605 "virtual"; lab = V LIDENT "lid" ""; ":"; t = ctyp ->
2606 if Pcaml.unvala ov then
2607 Ploc.raise loc (Stream.Error "virtual value cannot override")
2609 <:class_str_item< value virtual $_flag:mf$ $_lid:lab$ : $t$ >>
2610 | "val"; "virtual"; mf = V (FLAG "mutable"); lab = V LIDENT "lid" "";
2612 <:class_str_item< value virtual $_flag:mf$ $_lid:lab$ : $t$ >>
2613 | "method"; "private"; "virtual"; l = V LIDENT "lid" ""; ":";
2615 <:class_str_item< method virtual private $_lid:l$ : $t$ >>
2616 | "method"; "virtual"; "private"; l = V LIDENT "lid" ""; ":";
2618 <:class_str_item< method virtual private $_lid:l$ : $t$ >>
2619 | "method"; "virtual"; l = V LIDENT "lid" ""; ":"; t = poly_type ->
2620 <:class_str_item< method virtual $_lid:l$ : $t$ >>
2621 | "method"; ov = V (FLAG "!") "!"; "private"; l = V LIDENT "lid" "";
2622 ":"; t = poly_type; "="; e = expr ->
2623 <:class_str_item< method $_!:ov$ private $_lid:l$ : $t$ = $e$ >>
2624 | "method"; ov = V (FLAG "!") "!"; "private"; l = V LIDENT "lid" "";
2626 <:class_str_item< method $_!:ov$ private $_lid:l$ = $sb$ >>
2627 | "method"; ov = V (FLAG "!") "!"; l = V LIDENT "lid" ""; ":";
2628 t = poly_type; "="; e = expr ->
2629 <:class_str_item< method $_!:ov$ $_lid:l$ : $t$ = $e$ >>
2630 | "method"; ov = V (FLAG "!") "!"; l = V LIDENT "lid" "";
2632 <:class_str_item< method $_!:ov$ $_lid:l$ = $sb$ >>
2633 | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
2634 <:class_str_item< type $t1$ = $t2$ >>
2635 | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ]
2638 [ [ "="; e = expr -> e
2639 | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >>
2640 | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr ->
2641 <:expr< ($e$ : $t$ :> $t2$) >>
2642 | ":>"; t = ctyp; "="; e = expr ->
2643 <:expr< ($e$ :> $t$) >> ] ]
2646 [ [ i = LIDENT -> i ] ]
2650 [ [ test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2651 <:class_type< [ $t$ ] -> $ct$ >>
2652 | cs = class_signature -> cs ] ]
2655 [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = SELF ->
2656 <:class_type< $id$ [ $list:tl$ ] >>
2657 | "object"; cst = V (OPT class_self_type);
2658 csf = V (LIST0 class_sig_item); "end" ->
2659 <:class_type< object $_opt:cst$ $_list:csf$ end >> ]
2660 | [ ct1 = SELF; "."; ct2 = SELF -> <:class_type< $ct1$ . $ct2$ >>
2661 | ct1 = SELF; "("; ct2 = SELF; ")" -> <:class_type< $ct1$ $ct2$ >> ]
2662 | [ i = V LIDENT -> <:class_type< $_id: i$ >>
2663 | i = V UIDENT -> <:class_type< $_id: i$ >> ] ]
2666 [ [ "("; t = ctyp; ")" -> t ] ]
2669 [ [ "inherit"; cs = class_signature ->
2670 <:class_sig_item< inherit $cs$ >>
2671 | "val"; mf = V (FLAG "mutable"); l = V LIDENT "lid" ""; ":"; t = ctyp ->
2672 <:class_sig_item< value $_flag:mf$ $_lid:l$ : $t$ >>
2673 | "method"; "private"; "virtual"; l = V LIDENT "lid" ""; ":";
2675 <:class_sig_item< method virtual private $_lid:l$ : $t$ >>
2676 | "method"; "virtual"; "private"; l = V LIDENT "lid" ""; ":";
2678 <:class_sig_item< method virtual private $_lid:l$ : $t$ >>
2679 | "method"; "virtual"; l = V LIDENT "lid" ""; ":"; t = poly_type ->
2680 <:class_sig_item< method virtual $_lid:l$ : $t$ >>
2681 | "method"; "private"; l = V LIDENT "lid" ""; ":"; t = poly_type ->
2682 <:class_sig_item< method private $_lid:l$ : $t$ >>
2683 | "method"; l = V LIDENT "lid" ""; ":"; t = poly_type ->
2684 <:class_sig_item< method $_lid:l$ : $t$ >>
2685 | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
2686 <:class_sig_item< type $t1$ = $t2$ >> ] ]
2689 [ [ vf = V (FLAG "virtual"); ctp = class_type_parameters; n = V LIDENT;
2690 ":"; ct = class_type ->
2691 {MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp;
2692 MLast.ciNam = n; MLast.ciExp = ct} ] ]
2694 class_type_declaration:
2695 [ [ vf = V (FLAG "virtual"); ctp = class_type_parameters; n = V LIDENT;
2696 "="; cs = class_signature ->
2697 {MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp;
2698 MLast.ciNam = n; MLast.ciExp = cs} ] ]
2701 expr: LEVEL "simple"
2703 [ "new"; i = V class_longident "list" -> <:expr< new $_list:i$ >>
2704 | "object"; cspo = V (OPT class_self_patt);
2705 cf = V class_structure "list"; "end" ->
2706 <:expr< object $_opt:cspo$ $_list:cf$ end >> ] ]
2709 [ [ e = SELF; "#"; lab = V LIDENT "lid" -> <:expr< $e$ # $_lid:lab$ >> ] ]
2711 expr: LEVEL "simple"
2712 [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" ->
2713 <:expr< ($e$ : $t$ :> $t2$) >>
2714 | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >>
2715 | "{<"; ">}" -> <:expr< {< >} >>
2716 | "{<"; fel = V field_expr_list "list"; ">}" ->
2717 <:expr< {< $_list:fel$ >} >> ] ]
2720 [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF ->
2722 | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)]
2723 | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ]
2726 ctyp: LEVEL "simple"
2727 [ [ "#"; id = V class_longident "list" ->
2728 <:ctyp< # $_list:id$ >>
2729 | "<"; ml = V meth_list "list"; v = V (FLAG ".."); ">" ->
2730 <:ctyp< < $_list:ml$ $_flag:v$ > >>
2737 [ [ f = field; ";"; ml = SELF -> [f :: ml]
2738 | f = field; ";" -> [f]
2739 | f = field -> [f] ] ]
2742 [ [ lab = LIDENT; ":"; t = poly_type -> (lab, t) ] ]
2744 (* Polymorphic types *)
2746 [ [ "'"; i = ident -> i ] ]
2749 [ [ "type"; nt = LIST1 LIDENT; "."; ct = ctyp ->
2750 <:ctyp< type $list:nt$ . $ct$ >>
2751 | test_typevar_list_dot; tpl = LIST1 typevar; "."; t2 = ctyp ->
2752 <:ctyp< ! $list:tpl$ . $t2$ >>
2757 [ [ m = UIDENT; "."; l = SELF -> [m :: l]
2758 | i = LIDENT -> [i] ] ]
2763 [ i = V LIDENT; ":"; t = SELF -> <:ctyp< ~$_:i$: $t$ >>
2764 | i = V QUESTIONIDENTCOLON; t = SELF -> <:ctyp< ?$_:i$: $t$ >>
2765 | i = V QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ?$_:i$: $t$ >> ] ]
2767 ctyp: LEVEL "simple"
2768 [ [ "["; OPT "|"; rfl = V (LIST1 poly_variant SEP "|"); "]" ->
2769 <:ctyp< [ = $_list:rfl$ ] >>
2770 | "["; ">"; "]" -> <:ctyp< [ > $list:[]$ ] >>
2771 | "["; ">"; OPT "|"; rfl = V (LIST1 poly_variant SEP "|"); "]" ->
2772 <:ctyp< [ > $_list:rfl$ ] >>
2773 | "[<"; OPT "|"; rfl = V (LIST1 poly_variant SEP "|"); "]" ->
2774 <:ctyp< [ < $_list:rfl$ ] >>
2775 | "[<"; OPT "|"; rfl = V (LIST1 poly_variant SEP "|"); ">";
2776 ntl = V (LIST1 name_tag); "]" ->
2777 <:ctyp< [ < $_list:rfl$ > $_list:ntl$ ] >> ] ]
2780 [ [ "`"; i = V ident "" -> <:poly_variant< ` $_:i$ >>
2781 | "`"; i = V ident ""; "of"; ao = V (FLAG "&");
2782 l = V (LIST1 ctyp SEP "&") ->
2783 <:poly_variant< `$_:i$ of $_flag:ao$ $_list:l$ >>
2784 | t = ctyp -> <:poly_variant< $t$ >> ] ]
2787 [ [ "`"; i = ident -> i ] ]
2790 [ [ "fun"; p = labeled_patt; (eo, e) = fun_def ->
2791 <:expr< fun [ $p$ $opt:eo$ -> $e$ ] >> ] ]
2795 [ i = V TILDEIDENTCOLON; e = SELF -> <:expr< ~{$_:i$ = $e$} >>
2796 | i = V TILDEIDENT -> <:expr< ~{$_:i$} >>
2797 | i = V QUESTIONIDENTCOLON; e = SELF -> <:expr< ?{$_:i$ = $e$} >>
2798 | i = V QUESTIONIDENT -> <:expr< ?{$_:i$} >> ] ]
2800 expr: LEVEL "simple"
2801 [ [ "`"; s = V ident "" -> <:expr< ` $_:s$ >> ] ]
2804 [ [ p = labeled_patt; (eo, e) = SELF ->
2805 (None, <:expr< fun [ $p$ $opt:eo$ -> $e$ ] >>) ] ]
2808 [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
2810 patt: LEVEL "simple"
2811 [ [ "`"; s = V ident "" -> <:patt< ` $_:s$ >>
2812 | "#"; t = V mod_ident "list" "" -> <:patt< # $_list:t$ >>
2813 | p = labeled_patt -> p ] ]
2816 [ [ i = V TILDEIDENTCOLON; p = patt LEVEL "simple" ->
2817 <:patt< ~{$_:i$ = $p$} >>
2818 | i = V TILDEIDENT ->
2820 | "~"; "("; i = LIDENT; ")" ->
2821 <:patt< ~{$lid:i$} >>
2822 | "~"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
2823 <:patt< ~{$lid:i$ : $t$} >>
2824 | i = V QUESTIONIDENTCOLON; j = LIDENT ->
2825 <:patt< ?{$_:i$ = ?{$lid:j$}} >>
2826 | i = V QUESTIONIDENTCOLON; "_" ->
2828 | i = V QUESTIONIDENTCOLON; "("; p = patt; "="; e = expr; ")" ->
2829 <:patt< ?{$_:i$ = ?{$p$ = $e$}} >>
2830 | i = V QUESTIONIDENTCOLON; "("; p = patt; ":"; t = ctyp; ")" ->
2831 <:patt< ?{$_:i$ = ?{$p$ : $t$}} >>
2832 | i = V QUESTIONIDENTCOLON; "("; p = patt; ":"; t = ctyp; "=";
2834 <:patt< ?{$_:i$ = ?{$p$ : $t$ = $e$}} >>
2835 | i = V QUESTIONIDENTCOLON; "("; p = patt; ")" ->
2836 <:patt< ?{$_:i$ = ?{$p$}} >>
2837 | i = V QUESTIONIDENT -> <:patt< ?{$_:i$} >>
2838 | "?"; "("; i = LIDENT; "="; e = expr; ")" ->
2839 <:patt< ?{$lid:i$ = $e$} >>
2840 | "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" ->
2841 <:patt< ?{$lid:i$ : $t$ = $e$} >>
2842 | "?"; "("; i = LIDENT; ")" ->
2843 <:patt< ?{$lid:i$} >>
2844 | "?"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
2845 <:patt< ?{$lid:i$ : $t$} >> ] ]
2848 [ [ i = LIDENT; ":"; t = ctyp LEVEL "apply"; "->"; ct = SELF ->
2849 <:class_type< [ ~$i$: $t$ ] -> $ct$ >>
2850 | i = V QUESTIONIDENTCOLON; t = ctyp LEVEL "apply"; "->"; ct = SELF ->
2851 <:class_type< [ ?$_:i$: $t$ ] -> $ct$ >>
2852 | i = V QUESTIONIDENT; ":"; t = ctyp LEVEL "apply"; "->"; ct = SELF ->
2853 <:class_type< [ ?$_:i$: $t$ ] -> $ct$ >> ] ]
2856 [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
2859 [ [ p = labeled_patt; "->"; ce = class_expr ->
2860 <:class_expr< fun $p$ -> $ce$ >>
2861 | p = labeled_patt; cfd = SELF ->
2862 <:class_expr< fun $p$ -> $cfd$ >> ] ]
2867 DELETE_RULE expr: SELF; "or"; SELF END;
2868 DELETE_RULE expr: SELF; "&"; SELF END;
2870 GLOBAL: str_item expr;
2872 [ [ "def"; jal = V (LIST1 joinautomaton SEP "and") ->
2873 <:str_item< def $_list:jal$ >> ] ]
2876 [ [ "def"; jal = V (LIST1 joinautomaton SEP "and"); "in";
2877 e = expr LEVEL "top"->
2878 <:expr< def $_list:jal$ in $e$ >> ] ]
2881 [ [ "reply"; eo = V (OPT expr); "to"; ji = joinident ->
2882 <:expr< reply $_opt:eo$ to $jid:ji$ >> ] ]
2885 [ [ "spawn"; e = SELF -> <:expr< spawn $e$ >> ] ]
2888 [ [ e1 = SELF; "&"; e2 = SELF -> <:expr< $e1$ & $e2$ >> ] ]
2891 [ [ jcl = V (LIST1 joinclause SEP "or") ->
2892 {MLast.jcLoc = loc; MLast.jcVal = jcl} ] ]
2895 [ [ jpl = V (LIST1 joinpattern SEP "&"); "="; e = expr ->
2899 [ [ ji = joinident; "("; op = V (OPT patt); ")" -> (loc, ji, op) ] ]
2902 [ [ i = V LIDENT -> (loc, i) ] ]
2907 (* Main entry points *)
2910 GLOBAL: interf implem use_file top_phrase expr patt;
2912 [ [ si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
2913 | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2914 ([(<:sig_item< # $lid:n$ $opt:dp$ >>, loc)], None)
2915 | EOI -> ([], Some loc) ] ]
2918 [ [ si = sig_item; OPT ";;" -> (si, loc) ] ]
2921 [ [ si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
2922 | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2923 ([(<:str_item< # $lid:n$ $opt:dp$ >>, loc)], None)
2924 | EOI -> ([], Some loc) ] ]
2927 [ [ si = str_item; OPT ";;" -> (si, loc) ] ]
2930 [ [ ph = phrase; ";;" -> Some ph
2934 [ [ si = str_item; OPT ";;"; (sil, stopped) = SELF ->
2935 ([si :: sil], stopped)
2936 | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2937 ([<:str_item< # $lid:n$ $opt:dp$ >>], True)
2938 | EOI -> ([], False) ] ]
2941 [ [ sti = str_item -> sti
2942 | "#"; n = LIDENT; dp = OPT expr ->
2943 <:str_item< # $lid:n$ $opt:dp$ >> ] ]
2947 Pcaml.add_option "-no_quot" (Arg.Set no_quotations)
2948 "Don't parse quotations, allowing to use, e.g. \"<:>\" as token";
2950 (* ------------------------------------------------------------------------- *)
2951 (* Added by JRH *** *)
2952 (* ------------------------------------------------------------------------- *)
2956 [[ f = expr; "o"; g = expr -> <:expr< ((o $f$) $g$) >>
2957 | f = expr; "upto"; g = expr -> <:expr< ((upto $f$) $g$) >>
2958 | f = expr; "F_F"; g = expr -> <:expr< ((f_f_ $f$) $g$) >>
2959 | f = expr; "THENC"; g = expr -> <:expr< ((thenc_ $f$) $g$) >>
2960 | f = expr; "THEN"; g = expr -> <:expr< ((then_ $f$) $g$) >>
2961 | f = expr; "THENL"; g = expr -> <:expr< ((thenl_ $f$) $g$) >>
2962 | f = expr; "ORELSE"; g = expr -> <:expr< ((orelse_ $f$) $g$) >>
2963 | f = expr; "ORELSEC"; g = expr -> <:expr< ((orelsec_ $f$) $g$) >>
2964 | f = expr; "THEN_TCL"; g = expr -> <:expr< ((then_tcl_ $f$) $g$) >>
2965 | f = expr; "ORELSE_TCL"; g = expr -> <:expr< ((orelse_tcl_ $f$) $g$) >>
2971 [ [ sti = str_item; ";;" ->
2973 [ <:str_item< $exp:e$ >> -> Some <:str_item< value it = $e$ >>