pa_j_3.1x_6.11.ml

   1 (* ------------------------------------------------------------------------- *)
   2 (* New version.                                                              *)
   3 (* ------------------------------------------------------------------------- *)
   4
   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 *)
   8
   9 #load "pa_extend.cmo";
  10 #load "q_MLast.cmo";
  11 #load "pa_reloc.cmo";
  12
  13 open Pcaml;
  14
  15 Pcaml.syntax_name.val := "OCaml";
  16 Pcaml.no_constructors_arity.val := True;
  17
  18 (* ------------------------------------------------------------------------- *)
  19 (* The main/reloc.ml file.                                                   *)
  20 (* ------------------------------------------------------------------------- *)
  21
  22 (* camlp5r *)
  23 (* $Id: reloc.ml,v 6.26 2012-03-09 14:01:54 deraugla Exp $ *)
  24 (* Copyright (c) INRIA 2007-2012 *)
  25
  26 #load "pa_macro.cmo";
  27
  28 open MLast;
  29
  30 value option_map f =
  31   fun
  32   [ Some x -> Some (f x)
  33   | None -> None ]
  34 ;
  35
  36 value vala_map f =
  37   IFNDEF STRICT THEN
  38     fun x -> f x
  39   ELSE
  40     fun
  41     [ Ploc.VaAnt s -> Ploc.VaAnt s
  42     | Ploc.VaVal x -> Ploc.VaVal (f x) ]
  43   END
  44 ;
  45
  46 value class_infos_map floc f x =
  47   {ciLoc = floc x.ciLoc; ciVir = x.ciVir;
  48    ciPrm =
  49      let (x1, x2) = x.ciPrm in
  50      (floc x1, x2);
  51    ciNam = x.ciNam; ciExp = f x.ciExp}
  52 ;
  53
  54 value anti_loc qloc sh loc loc1 =
  55   (*
  56     ...<:reloc_expr<.....$lid:...xxxxxxxx...$...>>...
  57     |..|-----------------------------------|    qloc
  58        <----->                                  sh
  59               |.........|------------|          loc
  60                         |..|------|             loc1
  61   *)
  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
  68     Ploc.make_unlined
  69       (sh2 + Ploc.first_pos loc1, sh2 + Ploc.last_pos loc1)
  70   else
  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) ""
  78 ;
  79
  80 value rec reloc_ctyp floc sh =
  81   self where rec self =
  82     fun
  83     [ TyAcc loc x1 x2 →
  84         let loc = floc loc in
  85         TyAcc loc (self x1) (self x2)
  86     | TyAli loc x1 x2 →
  87         let loc = floc loc in
  88         TyAli loc (self x1) (self x2)
  89     | TyAny loc →
  90         let loc = floc loc in
  91         TyAny loc
  92     | TyApp loc x1 x2 →
  93         let loc = floc loc in
  94         TyApp loc (self x1) (self x2)
  95     | TyArr loc x1 x2 →
  96         let loc = floc loc in
  97         TyArr loc (self x1) (self x2)
  98     | TyCls loc x1 →
  99         let loc = floc loc in
 100         TyCls loc x1
 101     | TyLab loc x1 x2 →
 102         let loc = floc loc in
 103         TyLab loc x1 (self x2)
 104     | TyLid loc x1 →
 105         let loc = floc loc in
 106         TyLid loc x1
 107     | TyMan loc x1 x2 x3 →
 108         let loc = floc loc in
 109         TyMan loc (self x1) x2 (self x3)
 110     | TyObj loc x1 x2 →
 111         let loc = floc loc in
 112         TyObj loc (vala_map (List.map (fun (x1, x2) → (x1, self x2))) x1) x2
 113     | TyOlb loc x1 x2 →
 114         let loc = floc loc in
 115         TyOlb loc x1 (self x2)
 116     | TyPck loc x1 →
 117         let loc = floc loc in
 118         TyPck loc (reloc_module_type floc sh x1)
 119     | TyPol loc x1 x2 →
 120         let loc = floc loc in
 121         TyPol loc x1 (self x2)
 122     | TyPot loc x1 x2 →
 123         let loc = floc loc in
 124         TyPot loc x1 (self x2)
 125     | TyQuo loc x1 →
 126         let loc = floc loc in
 127         TyQuo loc x1
 128     | TyRec loc x1 →
 129         let loc = floc loc in
 130         TyRec loc
 131           (vala_map
 132              (List.map (fun (loc, x1, x2, x3) → (floc loc, x1, x2, self x3)))
 133              x1)
 134     | TySum loc x1 →
 135         let loc = floc loc in
 136         TySum loc
 137           (vala_map
 138              (List.map
 139                 (fun (loc, x1, x2, x3) →
 140                    (floc loc, x1, vala_map (List.map self) x2,
 141                     option_map self x3)))
 142              x1)
 143     | TyTup loc x1 →
 144         let loc = floc loc in
 145         TyTup loc (vala_map (List.map self) x1)
 146     | TyUid loc x1 →
 147         let loc = floc loc in
 148         TyUid loc x1
 149     | TyVrn loc x1 x2 →
 150         let loc = floc loc in
 151         TyVrn loc (vala_map (List.map (reloc_poly_variant floc sh)) x1) x2
 152     | TyXtr loc 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 =
 156   fun
 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)
 160   | PvInh loc x1 →
 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 =
 165     fun
 166     [ PaAcc loc x1 x2 →
 167         let loc = floc loc in
 168         PaAcc loc (self x1) (self x2)
 169     | PaAli loc x1 x2 →
 170         let loc = floc loc in
 171         PaAli loc (self x1) (self x2)
 172     | PaAnt loc x1 →
 173         let new_floc loc1 = anti_loc (floc loc) sh loc loc1 in
 174         reloc_patt new_floc sh x1
 175     | PaAny loc →
 176         let loc = floc loc in
 177         PaAny loc
 178     | PaApp loc x1 x2 →
 179         let loc = floc loc in
 180         PaApp loc (self x1) (self x2)
 181     | PaArr loc x1 →
 182         let loc = floc loc in
 183         PaArr loc (vala_map (List.map self) x1)
 184     | PaChr loc x1 →
 185         let loc = floc loc in
 186         PaChr loc x1
 187     | PaFlo loc x1 →
 188         let loc = floc loc in
 189         PaFlo loc x1
 190     | PaInt loc x1 x2 →
 191         let loc = floc loc in
 192         PaInt loc x1 x2
 193     | PaLab loc x1 →
 194         let loc = floc loc in
 195         PaLab loc
 196           (vala_map
 197              (List.map
 198                 (fun (x1, x2) → (self x1, vala_map (option_map self) x2)))
 199              x1)
 200     | PaLaz loc x1 →
 201         let loc = floc loc in
 202         PaLaz loc (self x1)
 203     | PaLid loc x1 →
 204         let loc = floc loc in
 205         PaLid loc x1
 206     | PaNty loc x1 →
 207         let loc = floc loc in
 208         PaNty loc x1
 209     | PaOlb loc x1 x2 →
 210         let loc = floc loc in
 211         PaOlb loc (self x1) (vala_map (option_map (reloc_expr floc sh)) x2)
 212     | PaOrp loc x1 x2 →
 213         let loc = floc loc in
 214         PaOrp loc (self x1) (self x2)
 215     | PaRec loc x1 →
 216         let loc = floc loc in
 217         PaRec loc (vala_map (List.map (fun (x1, x2) → (self x1, self x2))) x1)
 218     | PaRng loc x1 x2 →
 219         let loc = floc loc in
 220         PaRng loc (self x1) (self x2)
 221     | PaStr loc x1 →
 222         let loc = floc loc in
 223         PaStr loc x1
 224     | PaTup loc x1 →
 225         let loc = floc loc in
 226         PaTup loc (vala_map (List.map self) x1)
 227     | PaTyc loc x1 x2 →
 228         let loc = floc loc in
 229         PaTyc loc (self x1) (reloc_ctyp floc sh x2)
 230     | PaTyp loc x1 →
 231         let loc = floc loc in
 232         PaTyp loc x1
 233     | PaUid loc x1 →
 234         let loc = floc loc in
 235         PaUid loc x1
 236     | PaUnp loc x1 x2 →
 237         let loc = floc loc in
 238         PaUnp loc x1 (option_map (reloc_module_type floc sh) x2)
 239     | PaVrn loc x1 →
 240         let loc = floc loc in
 241         PaVrn loc x1
 242     | PaXtr loc x1 x2 →
 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 =
 247     fun
 248     [ ExAcc loc x1 x2 →
 249         let loc = floc loc in
 250         ExAcc loc (self x1) (self x2)
 251     | ExAnt loc x1 →
 252         let new_floc loc1 = anti_loc (floc loc) sh loc loc1 in
 253         reloc_expr new_floc sh x1
 254     | ExApp loc x1 x2 →
 255         let loc = floc loc in
 256         ExApp loc (self x1) (self x2)
 257     | ExAre loc x1 x2 →
 258         let loc = floc loc in
 259         ExAre loc (self x1) (self x2)
 260     | ExArr loc x1 →
 261         let loc = floc loc in
 262         ExArr loc (vala_map (List.map self) x1)
 263     | ExAsr loc x1 →
 264         let loc = floc loc in
 265         ExAsr loc (self x1)
 266     | ExAss loc x1 x2 →
 267         let loc = floc loc in
 268         ExAss loc (self x1) (self x2)
 269     | ExBae loc x1 x2 →
 270         let loc = floc loc in
 271         ExBae loc (self x1) (vala_map (List.map self) x2)
 272     | ExChr loc x1 →
 273         let loc = floc loc in
 274         ExChr loc x1
 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)
 278     | ExFlo loc x1 →
 279         let loc = floc loc in
 280         ExFlo loc x1
 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)
 284     | ExFun loc x1 →
 285         let loc = floc loc in
 286         ExFun loc
 287           (vala_map
 288              (List.map
 289                 (fun (x1, x2, x3) →
 290                    (reloc_patt floc sh x1, vala_map (option_map self) x2, self x3)))
 291              x1)
 292     | ExIfe loc x1 x2 x3 →
 293         let loc = floc loc in
 294         ExIfe loc (self x1) (self x2) (self x3)
 295     | ExInt loc x1 x2 →
 296         let loc = floc loc in
 297         ExInt loc x1 x2
 298     | ExJdf loc x1 x2 →
 299         let loc = floc loc in
 300         ExJdf loc (vala_map (List.map (reloc_joinclause floc sh)) x1) (self x2)
 301     | ExLab loc x1 →
 302         let loc = floc loc in
 303         ExLab loc
 304           (vala_map
 305              (List.map
 306                 (fun (x1, x2) →
 307                    (reloc_patt floc sh x1, vala_map (option_map self) x2)))
 308              x1)
 309     | ExLaz loc x1 →
 310         let loc = floc loc in
 311         ExLaz loc (self x1)
 312     | ExLet loc x1 x2 x3 →
 313         let loc = floc loc in
 314         ExLet loc x1
 315           (vala_map (List.map (fun (x1, x2) → (reloc_patt floc sh x1, self x2))) x2)
 316           (self x3)
 317     | ExLid loc x1 →
 318         let loc = floc loc in
 319         ExLid loc x1
 320     | ExLmd loc x1 x2 x3 →
 321         let loc = floc loc in
 322         ExLmd loc x1 (reloc_module_expr floc sh x2) (self x3)
 323     | ExMat loc x1 x2 →
 324         let loc = floc loc in
 325         ExMat loc (self x1)
 326           (vala_map
 327              (List.map
 328                 (fun (x1, x2, x3) →
 329                    (reloc_patt floc sh x1, vala_map (option_map self) x2, self x3)))
 330              x2)
 331     | ExNew loc x1 →
 332         let loc = floc loc in
 333         ExNew loc x1
 334     | ExObj loc x1 x2 →
 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)
 338     | ExOlb loc x1 x2 →
 339         let loc = floc loc in
 340         ExOlb loc (reloc_patt floc sh x1) (vala_map (option_map self) x2)
 341     | ExOvr loc x1 →
 342         let loc = floc loc in
 343         ExOvr loc (vala_map (List.map (fun (x1, x2) → (x1, self x2))) x1)
 344     | ExPar loc x1 x2 →
 345         let loc = floc loc in
 346         ExPar loc (self x1) (self x2)
 347     | ExPck loc x1 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)
 351     | ExRec loc x1 x2 →
 352         let loc = floc loc in
 353         ExRec loc
 354           (vala_map (List.map (fun (x1, x2) → (reloc_patt floc sh x1, self x2))) x1)
 355           (option_map self x2)
 356     | ExRpl loc x1 x2 →
 357         let loc = floc loc in
 358         ExRpl loc (vala_map (option_map self) x1)
 359           ((fun (loc, x1) → (floc loc, x1)) x2)
 360     | ExSeq loc x1 →
 361         let loc = floc loc in
 362         ExSeq loc (vala_map (List.map self) x1)
 363     | ExSpw loc x1 →
 364         let loc = floc loc in
 365         ExSpw loc (self x1)
 366     | ExSnd loc x1 x2 →
 367         let loc = floc loc in
 368         ExSnd loc (self x1) x2
 369     | ExSte loc x1 x2 →
 370         let loc = floc loc in
 371         ExSte loc (self x1) (self x2)
 372     | ExStr loc x1 →
 373         let loc = floc loc in
 374         ExStr loc x1
 375     | ExTry loc x1 x2 →
 376         let loc = floc loc in
 377         ExTry loc (self x1)
 378           (vala_map
 379              (List.map
 380                 (fun (x1, x2, x3) →
 381                    (reloc_patt floc sh x1, vala_map (option_map self) x2, self x3)))
 382              x2)
 383     | ExTup loc x1 →
 384         let loc = floc loc in
 385         ExTup loc (vala_map (List.map self) x1)
 386     | ExTyc loc x1 x2 →
 387         let loc = floc loc in
 388         ExTyc loc (self x1) (reloc_ctyp floc sh x2)
 389     | ExUid loc x1 →
 390         let loc = floc loc in
 391         ExUid loc x1
 392     | ExVrn loc x1 →
 393         let loc = floc loc in
 394         ExVrn loc x1
 395     | ExWhi loc x1 x2 →
 396         let loc = floc loc in
 397         ExWhi loc (self x1) (vala_map (List.map self) x2)
 398     | ExXtr loc x1 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 =
 403     fun
 404     [ MtAcc loc x1 x2 →
 405         let loc = floc loc in
 406         MtAcc loc (self x1) (self x2)
 407     | MtApp loc x1 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)
 413     | MtLid loc x1 →
 414         let loc = floc loc in
 415         MtLid loc x1
 416     | MtQuo loc x1 →
 417         let loc = floc loc in
 418         MtQuo loc x1
 419     | MtSig loc x1 →
 420         let loc = floc loc in
 421         MtSig loc (vala_map (List.map (reloc_sig_item floc sh)) x1)
 422     | MtTyo loc x1 →
 423         let loc = floc loc in
 424         MtTyo loc (reloc_module_expr floc sh x1)
 425     | MtUid loc x1 →
 426         let loc = floc loc in
 427         MtUid loc x1
 428     | MtWit loc x1 x2 →
 429         let loc = floc loc in
 430         MtWit loc (self x1) (vala_map (List.map (reloc_with_constr floc sh)) x2)
 431     | MtXtr loc x1 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 =
 436     fun
 437     [ SgCls loc x1 →
 438         let loc = floc loc in
 439         SgCls loc
 440           (vala_map (List.map (class_infos_map floc (reloc_class_type floc sh))) x1)
 441     | SgClt loc x1 →
 442         let loc = floc loc in
 443         SgClt loc
 444           (vala_map (List.map (class_infos_map floc (reloc_class_type floc sh))) x1)
 445     | SgDcl loc x1 →
 446         let loc = floc loc in
 447         SgDcl loc (vala_map (List.map self) x1)
 448     | SgDir loc x1 x2 →
 449         let loc = floc loc in
 450         SgDir loc x1 (vala_map (option_map (reloc_expr floc sh)) x2)
 451     | SgExc loc x1 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
 457     | SgInc loc x1 →
 458         let loc = floc loc in
 459         SgInc loc (reloc_module_type floc sh x1)
 460     | SgMod loc x1 x2 →
 461         let loc = floc loc in
 462         SgMod loc x1
 463           (vala_map (List.map (fun (x1, x2) → (x1, reloc_module_type floc sh x2)))
 464              x2)
 465     | SgMty loc x1 x2 →
 466         let loc = floc loc in
 467         SgMty loc x1 (reloc_module_type floc sh x2)
 468     | SgOpn loc x1 →
 469         let loc = floc loc in
 470         SgOpn loc x1
 471     | SgTyp loc x1 →
 472         let loc = floc loc in
 473         SgTyp loc (vala_map (List.map (reloc_type_decl floc sh)) x1)
 474     | SgUse loc x1 x2 →
 475         let loc = floc loc in
 476         SgUse loc x1
 477           (vala_map (List.map (fun (x1, loc) → (self x1, floc loc))) x2)
 478     | SgVal loc x1 x2 →
 479         let loc = floc loc in
 480         SgVal loc x1 (reloc_ctyp floc sh x2)
 481     | SgXtr loc x1 x2 →
 482         let loc = floc loc in
 483         SgXtr loc x1 (option_map (vala_map self) x2) ]
 484 and reloc_with_constr floc sh =
 485   fun
 486   [ WcMod loc x1 x2 →
 487       let loc = floc loc in
 488       WcMod loc x1 (reloc_module_expr floc sh x2)
 489   | WcMos loc x1 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 =
 500     fun
 501     [ MeAcc loc x1 x2 →
 502         let loc = floc loc in
 503         MeAcc loc (self x1) (self x2)
 504     | MeApp loc x1 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)
 510     | MeStr loc x1 →
 511         let loc = floc loc in
 512         MeStr loc (vala_map (List.map (reloc_str_item floc sh)) x1)
 513     | MeTyc loc x1 x2 →
 514         let loc = floc loc in
 515         MeTyc loc (self x1) (reloc_module_type floc sh x2)
 516     | MeUid loc x1 →
 517         let loc = floc loc in
 518         MeUid loc x1
 519     | MeUnp loc x1 x2 →
 520         let loc = floc loc in
 521         MeUnp loc (reloc_expr floc sh x1) (option_map (reloc_module_type floc sh) x2)
 522     | MeXtr loc x1 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 =
 527     fun
 528     [ StCls loc x1 →
 529         let loc = floc loc in
 530         StCls loc
 531           (vala_map (List.map (class_infos_map floc (reloc_class_expr floc sh))) x1)
 532     | StClt loc x1 →
 533         let loc = floc loc in
 534         StClt loc
 535           (vala_map (List.map (class_infos_map floc (reloc_class_type floc sh))) x1)
 536     | StDcl loc x1 →
 537         let loc = floc loc in
 538         StDcl loc (vala_map (List.map self) x1)
 539     | StDef loc x1 →
 540         let loc = floc loc in
 541         StDef loc (vala_map (List.map (reloc_joinclause floc sh)) x1)
 542     | StDir loc x1 x2 →
 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
 548     | StExp loc x1 →
 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
 554     | StInc loc x1 →
 555         let loc = floc loc in
 556         StInc loc (reloc_module_expr floc sh x1)
 557     | StMod loc x1 x2 →
 558         let loc = floc loc in
 559         StMod loc x1
 560           (vala_map (List.map (fun (x1, x2) → (x1, reloc_module_expr floc sh x2)))
 561              x2)
 562     | StMty loc x1 x2 →
 563         let loc = floc loc in
 564         StMty loc x1 (reloc_module_type floc sh x2)
 565     | StOpn loc x1 →
 566         let loc = floc loc in
 567         StOpn loc x1
 568     | StTyp loc x1 →
 569         let loc = floc loc in
 570         StTyp loc (vala_map (List.map (reloc_type_decl floc sh)) x1)
 571     | StUse loc x1 x2 →
 572         let loc = floc loc in
 573         StUse loc x1
 574           (vala_map (List.map (fun (x1, loc) → (self x1, floc loc))) x2)
 575     | StVal loc x1 x2 →
 576         let loc = floc loc in
 577         StVal loc x1
 578           (vala_map
 579              (List.map (fun (x1, x2) → (reloc_patt floc sh x1, reloc_expr floc sh x2)))
 580              x2)
 581     | StXtr loc x1 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;
 586    jcVal =
 587      vala_map
 588        (List.map
 589           (fun (loc, x1, x2) →
 590              (floc loc,
 591               vala_map
 592                 (List.map
 593                    (fun (loc, x1, x2) →
 594                       (floc loc, (fun (loc, x1) → (floc loc, x1)) x1,
 595                        vala_map (option_map (reloc_patt floc sh)) x2)))
 596                 x1,
 597               reloc_expr floc sh x2)))
 598        x.jcVal}
 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;
 602    tdCon =
 603      vala_map (List.map (fun (x1, x2) → (reloc_ctyp floc sh x1, reloc_ctyp floc sh x2)))
 604        x.tdCon}
 605 and reloc_class_type floc sh =
 606   self where rec self =
 607     fun
 608     [ CtAcc loc x1 x2 →
 609         let loc = floc loc in
 610         CtAcc loc (self x1) (self x2)
 611     | CtApp loc x1 x2 →
 612         let loc = floc loc in
 613         CtApp loc (self x1) (self x2)
 614     | CtCon loc x1 x2 →
 615         let loc = floc loc in
 616         CtCon loc (self x1) (vala_map (List.map (reloc_ctyp floc sh)) x2)
 617     | CtFun loc x1 x2 →
 618         let loc = floc loc in
 619         CtFun loc (reloc_ctyp floc sh x1) (self x2)
 620     | CtIde loc x1 →
 621         let loc = floc loc in
 622         CtIde loc x1
 623     | CtSig loc x1 x2 →
 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)
 627     | CtXtr loc x1 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 =
 632     fun
 633     [ CgCtr loc x1 x2 →
 634         let loc = floc loc in
 635         CgCtr loc (reloc_ctyp floc sh x1) (reloc_ctyp floc sh x2)
 636     | CgDcl loc x1 →
 637         let loc = floc loc in
 638         CgDcl loc (vala_map (List.map self) x1)
 639     | CgInh loc 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 =
 653     fun
 654     [ CeApp loc x1 x2 →
 655         let loc = floc loc in
 656         CeApp loc (self x1) (reloc_expr floc sh x2)
 657     | CeCon loc x1 x2 →
 658         let loc = floc loc in
 659         CeCon loc x1 (vala_map (List.map (reloc_ctyp floc sh)) x2)
 660     | CeFun loc x1 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
 665         CeLet loc x1
 666           (vala_map
 667              (List.map (fun (x1, x2) → (reloc_patt floc sh x1, reloc_expr floc sh x2)))
 668              x2)
 669           (self x3)
 670     | CeStr loc x1 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)
 674     | CeTyc loc x1 x2 →
 675         let loc = floc loc in
 676         CeTyc loc (self x1) (reloc_class_type floc sh x2)
 677     | CeXtr loc x1 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 =
 682     fun
 683     [ CrCtr loc x1 x2 →
 684         let loc = floc loc in
 685         CrCtr loc (reloc_ctyp floc sh x1) (reloc_ctyp floc sh x2)
 686     | CrDcl loc x1 →
 687         let loc = floc loc in
 688         CrDcl loc (vala_map (List.map self) x1)
 689     | CrInh loc x1 x2 →
 690         let loc = floc loc in
 691         CrInh loc (reloc_class_expr floc sh x1) x2
 692     | CrIni loc x1 →
 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) ]
 708 ;
 709
 710 (* Equality over syntax trees *)
 711
 712 value eq_expr x y =
 713   reloc_expr (fun _ -> Ploc.dummy) 0 x =
 714   reloc_expr (fun _ -> Ploc.dummy) 0 y
 715 ;
 716 value eq_patt x y =
 717   reloc_patt (fun _ -> Ploc.dummy) 0 x =
 718   reloc_patt (fun _ -> Ploc.dummy) 0 y
 719 ;
 720 value eq_ctyp x y =
 721   reloc_ctyp (fun _ -> Ploc.dummy) 0 x =
 722   reloc_ctyp (fun _ -> Ploc.dummy) 0 y
 723 ;
 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
 727 ;
 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
 731 ;
 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
 735 ;
 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
 739 ;
 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
 743 ;
 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
 747 ;
 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
 751 ;
 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
 755 ;
 756
 757 (* ------------------------------------------------------------------------- *)
 758 (* Now the lexer.                                                            *)
 759 (* ------------------------------------------------------------------------- *)
 760
 761 (* camlp5r *)
 762 (* $Id: plexer.ml,v 6.19 2013-07-03 01:43:10 deraugla Exp $ *)
 763 (* Copyright (c) INRIA 2007-2012 *)
 764
 765 #load "pa_lexer.cmo";
 766
 767 (* ------------------------------------------------------------------------- *)
 768 (* Added by JRH as a backdoor to change lexical conventions.                 *)
 769 (* ------------------------------------------------------------------------- *)
 770
 771 value jrh_lexer = ref False;
 772
 773 open Versdep;
 774
 775 value no_quotations = ref False;
 776 value error_on_unknown_keywords = ref False;
 777
 778 value dollar_for_antiquotation = ref True;
 779 value specific_space_dot = ref False;
 780 value dot_newline_is = ref ".";
 781
 782 value force_antiquot_loc = ref False;
 783
 784 type context =
 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 }
 793 ;
 794
 795 value err ctx loc msg =
 796   Ploc.raise (ctx.make_lined_loc loc "") (Plexing.Error msg)
 797 ;
 798
 799 (* ------------------------------------------------------------------------- *)
 800 (* JRH's hack to make the case distinction "unmixed" versus "mixed"          *)
 801 (* ------------------------------------------------------------------------- *)
 802
 803 value is_uppercase s = String.uppercase s = s;
 804 value is_only_lowercase s = String.lowercase s = s && not(is_uppercase s);
 805
 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"))
 812   else
 813   try ("", find_kwd id) with
 814    [ Not_found ->
 815         if not(jflag) then
 816           if is_uppercase (String.sub id 0 1) then ("UIDENT", id)
 817           else ("LIDENT", 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
 821         then ("UIDENT", id)
 822         else if is_uppercase (String.sub id 0 1) then ("LIDENT", "__uc_"^id)
 823         else ("LIDENT", id)];
 824  *****)
 825         then ("UIDENT", id) else ("LIDENT", id)];
 826
 827 (* ------------------------------------------------------------------------- *)
 828 (* Back to original file with the mod of using the above.                    *)
 829 (* ------------------------------------------------------------------------- *)
 830
 831 value keyword_or_error ctx loc s =
 832   try ("", ctx.find_kwd s) with
 833   [ Not_found ->
 834       if error_on_unknown_keywords.val then
 835         err ctx loc ("illegal token: " ^ s)
 836       else ("", s) ]
 837 ;
 838
 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 =
 842     fun
 843     [ [c :: l] -> do { String.unsafe_set s i c; loop (i - 1) l }
 844     | [] -> s ]
 845 ;
 846
 847 value implode l = rev_implode (List.rev l);
 848
 849 value stream_peek_nth n strm =
 850   loop n (Stream.npeek n strm) where rec loop n =
 851     fun
 852     [ [] -> None
 853     | [x] -> if n == 1 then Some x else None
 854     | [_ :: l] -> loop (n - 1) l ]
 855 ;
 856
 857 value utf8_lexing = ref False;
 858
 859 value greek_tab =
 860   ["α"; "β"; "γ"; "δ"; "ε"; "ζ"; "η"; "θ"; "ι"; "κ"; "λ"; "μ"; "ν"; "ξ";
 861    "ο"; "π"; "ρ"; "σ"; "τ"; "υ"; "φ"; "χ"; "ψ"; "ω"]
 862 ;
 863
 864 value greek_letter buf strm =
 865   if utf8_lexing.val then
 866     match Stream.peek strm with
 867     [ Some c ->
 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 ]
 874   else
 875     raise Stream.Failure
 876 ;
 877
 878 value misc_letter buf strm =
 879   if utf8_lexing.val then
 880     match Stream.peek strm with
 881     [ Some c ->
 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 ]
 888   else
 889     match strm with lexer [ '\128'-'\225' | '\227'-'\255' ]
 890 ;
 891
 892 value misc_punct buf strm =
 893   if utf8_lexing.val then
 894     match strm with lexer [ '\226' _ _ ]
 895   else
 896     match strm with parser []
 897 ;
 898
 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) ">=" ]
 905   else
 906     match strm with parser []
 907 ;
 908
 909 value rec ident =
 910   lexer
 911   [ [ 'A'-'Z' | 'a'-'z' | '0'-'9' | '_' | ''' | misc_letter ] ident! | ]
 912 ;
 913
 914 value rec ident2 =
 915   lexer
 916   [ [ '!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
 917       '%' | '.' | ':' | '<' | '>' | '|' | '$' | misc_punct ]
 918       ident2!
 919   | ]
 920 ;
 921
 922 value rec ident3 =
 923   lexer
 924   [ [ '0'-'9' | 'A'-'Z' | 'a'-'z' | '_' | '!' | '%' | '&' | '*' | '+' | '-' |
 925       '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | ''' |
 926       '$' | '\128'-'\255' ] ident3!
 927   | ]
 928 ;
 929
 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' ];
 934
 935 value end_integer =
 936   lexer
 937   [ "l"/ -> ("INT_l", $buf)
 938   | "L"/ -> ("INT_L", $buf)
 939   | "n"/ -> ("INT_n", $buf)
 940   | -> ("INT", $buf) ]
 941 ;
 942
 943 value rec digits_under kind =
 944   lexer
 945   [ kind (digits_under kind)!
 946   | "_" (digits_under kind)!
 947   | end_integer ]
 948 ;
 949
 950 value digits kind =
 951   lexer
 952   [ kind (digits_under kind)!
 953   | -> raise (Stream.Error "ill-formed integer constant") ]
 954 ;
 955
 956 value rec decimal_digits_under =
 957   lexer [ [ '0'-'9' | '_' ] decimal_digits_under! | ]
 958 ;
 959
 960 value exponent_part =
 961   lexer
 962   [ [ 'e' | 'E' ] [ '+' | '-' | ]
 963     '0'-'9' ? "ill-formed floating-point constant"
 964     decimal_digits_under! ]
 965 ;
 966
 967 value number =
 968   lexer
 969   [ decimal_digits_under "." decimal_digits_under! exponent_part ->
 970       ("FLOAT", $buf)
 971   | decimal_digits_under "." decimal_digits_under! -> ("FLOAT", $buf)
 972   | decimal_digits_under exponent_part -> ("FLOAT", $buf)
 973   | decimal_digits_under end_integer! ]
 974 ;
 975
 976 value char_after_bslash =
 977   lexer
 978   [ "'"/
 979   | _ [ "'"/ | _ [ "'"/ | ] ] ]
 980 ;
 981
 982 value char ctx bp =
 983   lexer
 984   [ "\\" _ char_after_bslash!
 985   | "\\" -> err ctx (bp, $pos) "char not terminated"
 986   | ?= [ _ '''] _! "'"/ ]
 987 ;
 988
 989 value any ctx buf =
 990   parser bp [: `c :] -> do { ctx.line_cnt bp c; $add c }
 991 ;
 992
 993 value rec string ctx bp =
 994   lexer
 995   [ "\""/
 996   | "\\" (any ctx) (string ctx bp)!
 997   | (any ctx) (string ctx bp)!
 998   | -> err ctx (bp, $pos) "string not terminated" ]
 999 ;
1000
1001 value rec qstring ctx bp =
1002   lexer
1003   [ "`"/
1004   | (any ctx) (qstring ctx bp)!
1005   | -> err ctx (bp, $pos) "quotation not terminated" ]
1006 ;
1007
1008 value comment ctx bp =
1009   comment where rec comment =
1010     lexer
1011     [ "*)"
1012     | "*" comment!
1013     | "(*" comment! comment!
1014     | "(" comment!
1015     | "\"" (string ctx bp)! [ -> $add "\"" ] comment!
1016     | "'*)"
1017     | "'*" comment!
1018     | "'" (any ctx) comment!
1019     | (any ctx) comment!
1020     | -> err ctx (bp, $pos) "comment not terminated" ]
1021 ;
1022
1023 value rec quotation ctx bp =
1024   lexer
1025   [ ">>"/
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" ]
1035 ;
1036
1037 value less_expected = "character '<' expected";
1038
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 ]
1043   else
1044     match strm with lexer
1045     [ "<"/ (quotation ctx bp) -> ("QUOTATION", ":" ^ $buf)
1046     | ":"/ ident! "<"/ ? less_expected [ -> $add ":" ]! (quotation ctx bp) ->
1047         ("QUOTATION", $buf)
1048     | ":"/ ident! ":<"/ ? less_expected [ -> $add "@" ]! (quotation ctx bp) ->
1049         ("QUOTATION", $buf)
1050     | [ -> $add "<" ] ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
1051 ;
1052
1053 value rec antiquot_rest ctx bp =
1054   lexer
1055   [ "$"/
1056   | "\\"/ (any ctx) (antiquot_rest ctx bp)!
1057   | (any ctx) (antiquot_rest ctx bp)!
1058   | -> err ctx (bp, $pos) "antiquotation not terminated" ]
1059 ;
1060
1061 value rec antiquot ctx bp =
1062   lexer
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" ]
1069 ;
1070
1071 value antiloc bp ep s = Printf.sprintf "%d,%d:%s" bp ep s;
1072
1073 value rec antiquot_loc ctx bp =
1074   lexer
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" ]
1081 ;
1082
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)
1088   else
1089     match strm with lexer
1090     [ [ -> $add "$" ] ident2! -> ("", $buf) ]
1091 ;
1092
1093 (* ANTIQUOT - specific case for QUESTIONIDENT and QUESTIONIDENTCOLON
1094     input         expr        patt
1095     -----         ----        ----
1096     ?$abc:d$      ?abc:d      ?abc
1097     ?$abc:d$:     ?abc:d:     ?abc:
1098     ?$d$          ?:d         ?
1099     ?$d$:         ?:d:        ?:
1100 *)
1101
1102 (* ANTIQUOT_LOC - specific case for QUESTIONIDENT and QUESTIONIDENTCOLON
1103     input         expr             patt
1104     -----         ----             ----
1105     ?$abc:d$      ?8,13:abc:d      ?abc
1106     ?$abc:d$:     ?8,13:abc:d:     ?abc:
1107     ?$d$          ?8,9::d          ?
1108     ?$d$:         ?8,9::d:         ?:
1109 *)
1110
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)
1118     | [: :] ->
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)
1127     | [: :] ->
1128         match strm with lexer
1129         [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
1130   else
1131     match strm with lexer
1132     [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
1133 ;
1134
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)
1142     | [: :] ->
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)
1151     | [: :] ->
1152         match strm with lexer
1153         [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
1154   else
1155     match strm with lexer
1156     [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
1157 ;
1158
1159 value tildeident =
1160   lexer
1161   [ ":"/ -> ("TILDEIDENTCOLON", $buf)
1162   | -> ("TILDEIDENT", $buf) ]
1163 ;
1164
1165 value questionident =
1166   lexer
1167   [ ":"/ -> ("QUESTIONIDENTCOLON", $buf)
1168   | -> ("QUESTIONIDENT", $buf) ]
1169 ;
1170
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
1175   | _ -> False ]
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
1183   | Some '"' -> True
1184   | _ -> False ]
1185 ;
1186
1187 value rec any_to_nl =
1188   lexer
1189   [ "\r" | "\n"
1190   | _ any_to_nl!
1191   | ]
1192 ;
1193
1194 value next_token_after_spaces ctx bp =
1195   lexer
1196   [ 'A'-'Z' ident! ->
1197       let id = $buf in
1198      jrh_identifier ctx.find_kwd id
1199 (********** JRH: original was
1200       try ("", ctx.find_kwd id) with [ Not_found -> ("UIDENT", id) ]
1201  *********)
1202   | greek_letter ident! -> ("GIDENT", $buf)
1203   | [ 'a'-'z' | '_' | misc_letter ] ident! ->
1204       let id = $buf in
1205       jrh_identifier ctx.find_kwd id
1206 (********** JRH: original was
1207       try ("", ctx.find_kwd id) with [ Not_found -> ("LIDENT", id) ]
1208  *********)
1209   | '1'-'9' number!
1210   | "0" [ 'o' | 'O' ] (digits octal)!
1211   | "0" [ 'x' | 'X' ] (digits hexa)!
1212   | "0" [ 'b' | 'B' ] (digits binary)!
1213   | "0" number!
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
1252   | "." ->
1253       let id =
1254         if ctx.specific_space_dot && ctx.after_space then " ." else "."
1255       in
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 ]
1263 ;
1264
1265 value get_comment buf strm = $buf;
1266
1267 value rec next_token ctx buf =
1268   parser bp
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;
1272       ctx.set_line_nb ();
1273       ctx.after_space := True;
1274       next_token ctx ($add c) s
1275     }
1276   | [: `(' ' | '\t' | '\026' | '\012' as c); s :] -> do {
1277       ctx.after_space := True;
1278       next_token ctx ($add c) s
1279     }
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;
1286         ctx.set_line_nb ();
1287         ctx.after_space := True;
1288         next_token ctx buf s
1289       }
1290       else
1291         let loc = ctx.make_lined_loc (bp, bp + 1) comm in
1292         (keyword_or_error ctx (bp, bp + 1) "#", loc)
1293   | [: `'(';
1294        a =
1295          parser
1296          [ [: `'*'; buf = comment ctx bp ($add "(*") !; s :] -> do {
1297              ctx.set_line_nb ();
1298              ctx.after_space := True;
1299              next_token ctx buf s
1300            }
1301          | [: :] ep ->
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
1307       (tok, loc)
1308   | [: comm = get_comment buf; _ = Stream.empty :] ->
1309       let loc = ctx.make_lined_loc (bp, bp + 1) comm in
1310       (("EOI", ""), loc) ]
1311 ;
1312
1313 value next_token_fun ctx glexr (cstrm, s_line_nb, s_bol_pos) =
1314   try do {
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;
1320       }
1321     | 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
1325     ctx.set_line_nb ();
1326     ctx.after_space := False;
1327     let (r, loc) = next_token ctx $empty cstrm in
1328     match glexr.val.Plexing.tok_comm with
1329     [ Some list ->
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]
1333         else ()
1334     | None -> () ];
1335     (r, loc)
1336   }
1337   with
1338   [ Stream.Error str ->
1339       err ctx (Stream.count cstrm, Stream.count cstrm + 1) str ]
1340 ;
1341
1342 value func kwd_table glexr =
1343   let ctx =
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;
1351      line_cnt bp1 c =
1352        match c with
1353        [ '\n' | '\r' -> do {
1354            if c = '\n' then incr Plexing.line_nb.val else ();
1355            Plexing.bol_pos.val.val := bp1 + 1;
1356          }
1357        | c -> () ];
1358      set_line_nb () = do {
1359        line_nb.val := Plexing.line_nb.val.val;
1360        bol_pos.val := Plexing.bol_pos.val.val;
1361      };
1362      make_lined_loc loc comm =
1363        Ploc.make_loc Plexing.input_file.val line_nb.val bol_pos.val loc comm}
1364   in
1365   Plexing.lexer_func_of_parser (next_token_fun ctx glexr)
1366 ;
1367
1368 value rec check_keyword_stream =
1369   parser [: _ = check $empty; _ = Stream.empty :] -> True
1370 and check =
1371   lexer
1372   [ [ 'A'-'Z' | 'a'-'z' | misc_letter ] check_ident!
1373   | [ '!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
1374       '.' ]
1375       check_ident2!
1376   | "$" check_ident2!
1377   | "<" ?= [ ":" | "<" ]
1378   | "<" check_ident2!
1379   | ":]"
1380   | "::"
1381   | ":="
1382   | ":>"
1383   | ":"
1384   | ">]"
1385   | ">}"
1386   | ">" check_ident2!
1387   | "|]"
1388   | "|}"
1389   | "|" check_ident2!
1390   | "[" ?= [ "<<" | "<:" ]
1391   | "[|"
1392   | "[<"
1393   | "[:"
1394   | "["
1395   | "{" ?= [ "<<" | "<:" ]
1396   | "{|"
1397   | "{<"
1398   | "{:"
1399   | "{"
1400   | ";;"
1401   | ";"
1402   | misc_punct check_ident2!
1403   | _ ]
1404 and check_ident =
1405   lexer
1406   [ [ 'A'-'Z' | 'a'-'z' | '0'-'9' | '_' | ''' | misc_letter ]
1407     check_ident! | ]
1408 and check_ident2 =
1409   lexer
1410   [ [ '!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
1411       '.' | ':' | '<' | '>' | '|' | misc_punct ]
1412     check_ident2! | ]
1413 ;
1414
1415 value check_keyword s =
1416   try check_keyword_stream (Stream.of_string s) with _ -> False
1417 ;
1418
1419 value error_no_respect_rules p_con p_prm =
1420   raise
1421     (Plexing.Error
1422        ("the token " ^
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"))
1427 ;
1428
1429 value error_ident_and_keyword p_con p_prm =
1430   raise
1431     (Plexing.Error
1432        ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^
1433           " and as keyword"))
1434 ;
1435
1436 value using_token kwd_table ident_table (p_con, p_prm) =
1437   match p_con with
1438   [ "" ->
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
1445       else ()
1446   | "LIDENT" ->
1447       if p_prm = "" then ()
1448       else
1449         match p_prm.[0] with
1450         [ 'A'..'Z' -> error_no_respect_rules p_con p_prm
1451         | _ ->
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 ]
1455   | "UIDENT" ->
1456       if p_prm = "" then ()
1457       else
1458         match p_prm.[0] with
1459         [ 'a'..'z' -> error_no_respect_rules p_con p_prm
1460         | _ ->
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" ->
1468       ()
1469   | _ ->
1470       raise
1471         (Plexing.Error
1472            ("the constructor \"" ^ p_con ^
1473               "\" is not recognized by Plexer")) ]
1474 ;
1475
1476 value removing_token kwd_table ident_table (p_con, p_prm) =
1477   match p_con with
1478   [ "" -> Hashtbl.remove kwd_table p_prm
1479   | "LIDENT" | "UIDENT" ->
1480       if p_prm <> "" then Hashtbl.remove ident_table p_prm else ()
1481   | _ -> () ]
1482 ;
1483
1484 value text =
1485   fun
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"
1499   | (con, "") -> con
1500   | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
1501 ;
1502
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)
1509     else False
1510 ;
1511
1512 value after_colon e =
1513   try
1514     let i = String.index e ':' in
1515     String.sub e (i + 1) (String.length e - i - 1)
1516   with
1517   [ Not_found -> "" ]
1518 ;
1519
1520 value after_colon_except_last e =
1521   try
1522     let i = String.index e ':' in
1523     String.sub e (i + 1) (String.length e - i - 2)
1524   with
1525   [ Not_found -> "" ]
1526 ;
1527
1528 value tok_match =
1529   fun
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
1534           fun
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 ]
1541         else
1542           fun
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 ]
1549       else
1550         fun
1551         [ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm
1552         | _ -> raise Stream.Failure ]
1553   | tok -> Plexing.default_match tok ]
1554 ;
1555
1556 value gmake () =
1557   let kwd_table = Hashtbl.create 301 in
1558   let id_table = Hashtbl.create 301 in
1559   let glexr =
1560     ref
1561      {Plexing.tok_func = fun []; tok_using = fun []; tok_removing = fun [];
1562       tok_match = fun []; tok_text = fun []; tok_comm = None}
1563   in
1564   let glex =
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}
1569   in
1570   do { glexr.val := glex; glex }
1571 ;
1572
1573 (* ------------------------------------------------------------------------- *)
1574 (* Back to etc/pa_o.ml                                                       *)
1575 (* ------------------------------------------------------------------------- *)
1576
1577 do {
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
1607 };
1608
1609 Pcaml.parse_interf.val := Grammar.Entry.parse interf;
1610 Pcaml.parse_implem.val := Grammar.Entry.parse implem;
1611
1612 value mklistexp loc last =
1613   loop True where rec loop top =
1614     fun
1615     [ [] ->
1616         match last with
1617         [ Some e -> e
1618         | None -> <:expr< [] >> ]
1619     | [e1 :: el] ->
1620         let loc =
1621           if top then loc else Ploc.encl (MLast.loc_of_expr e1) loc
1622         in
1623         <:expr< [$e1$ :: $loop False el$] >> ]
1624 ;
1625
1626 value mklistpat loc last =
1627   loop True where rec loop top =
1628     fun
1629     [ [] ->
1630         match last with
1631         [ Some p -> p
1632         | None -> <:patt< [] >> ]
1633     | [p1 :: pl] ->
1634         let loc =
1635           if top then loc else Ploc.encl (MLast.loc_of_patt p1) loc
1636         in
1637         <:patt< [$p1$ :: $loop False pl$] >> ]
1638 ;
1639
1640 (*** JRH pulled this outside so user can add new infixes here too ***)
1641
1642 value ht = Hashtbl.create 73;
1643
1644 (*** And JRH added all the new HOL Light infixes here already ***)
1645
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      '?'; '%'; '.'; '$'];
1655   fun x ->
1656     try Hashtbl.find ht x with
1657     [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ]
1658 };
1659
1660 (*** JRH added this so parenthesised operators undergo same mapping ***)
1661
1662 value translate_operator =
1663   fun s ->
1664    match s with
1665     [ "THEN" -> "then_"
1666     | "THENC" -> "thenc_"
1667     | "THENL" -> "thenl_"
1668     | "ORELSE" -> "orelse_"
1669     | "ORELSEC" -> "orelsec_"
1670     | "THEN_TCL" -> "then_tcl_"
1671     | "ORELSE_TCL" -> "orelse_tcl_"
1672     | "F_F" -> "f_f_"
1673     | _ -> s];
1674
1675 value operator_rparen =
1676   Grammar.Entry.of_parser gram "operator_rparen"
1677     (fun strm ->
1678        match Stream.npeek 2 strm with
1679        [ [("", s); ("", ")")] when is_operator s -> do {
1680            Stream.junk strm;
1681            Stream.junk strm;
1682            translate_operator s
1683          }
1684        | _ -> raise Stream.Failure ])
1685 ;
1686
1687 value check_not_part_of_patt =
1688   Grammar.Entry.of_parser gram "check_not_part_of_patt"
1689     (fun strm ->
1690        let tok =
1691          match Stream.npeek 4 strm with
1692          [ [("LIDENT", _); tok :: _] -> tok
1693          | [("", "("); ("", s); ("", ")"); tok] when is_operator s -> tok
1694          | _ -> raise Stream.Failure ]
1695        in
1696        match tok with
1697        [ ("", "," | "as" | "|" | "::") -> raise Stream.Failure
1698        | _ -> () ])
1699 ;
1700
1701 value symbolchar =
1702   let list =
1703     ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?';
1704      '@'; '^'; '|'; '~']
1705   in
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)
1709     else False
1710 ;
1711
1712 value prefixop =
1713   let list = ['!'; '?'; '~'] in
1714   let excl = ["!="; "??"; "?!"] in
1715   Grammar.Entry.of_parser gram "prefixop"
1716     (parser
1717        [: `("", x)
1718            when
1719              not (List.mem x excl) && String.length x >= 2 &&
1720              List.mem x.[0] list && symbolchar x 1 :] ->
1721          x)
1722 ;
1723
1724 value infixop0 =
1725   let list = ['='; '<'; '>'; '|'; '&'; '$'] in
1726   let excl = ["<-"; "||"; "&&"] in
1727   Grammar.Entry.of_parser gram "infixop0"
1728     (parser
1729        [: `("", x)
1730            when
1731              not (List.mem x excl) && (x = "$" || String.length x >= 2) &&
1732              List.mem x.[0] list && symbolchar x 1 :] ->
1733          x)
1734 ;
1735
1736 value infixop1 =
1737   let list = ['@'; '^'] in
1738   Grammar.Entry.of_parser gram "infixop1"
1739     (parser
1740        [: `("", x)
1741            when
1742              String.length x >= 2 && List.mem x.[0] list &&
1743              symbolchar x 1 :] ->
1744          x)
1745 ;
1746
1747 value infixop2 =
1748   let list = ['+'; '-'] in
1749   Grammar.Entry.of_parser gram "infixop2"
1750     (parser
1751        [: `("", x)
1752            when
1753              x <> "->" && String.length x >= 2 && List.mem x.[0] list &&
1754              symbolchar x 1 :] ->
1755          x)
1756 ;
1757
1758 value infixop3 =
1759   let list = ['*'; '/'; '%'] in
1760   Grammar.Entry.of_parser gram "infixop3"
1761     (parser
1762        [: `("", x)
1763            when
1764              String.length x >= 2 && List.mem x.[0] list &&
1765              symbolchar x 1 :] ->
1766          x)
1767 ;
1768
1769 value infixop4 =
1770   Grammar.Entry.of_parser gram "infixop4"
1771     (parser
1772        [: `("", x)
1773            when
1774              String.length x >= 3 && x.[0] == '*' && x.[1] == '*' &&
1775              symbolchar x 2 :] ->
1776          x)
1777 ;
1778
1779 value test_constr_decl =
1780   Grammar.Entry.of_parser gram "test_constr_decl"
1781     (fun strm ->
1782        match Stream.npeek 1 strm with
1783        [ [("UIDENT", _)] ->
1784            match Stream.npeek 2 strm with
1785            [ [_; ("", ".")] -> raise Stream.Failure
1786            | [_; ("", "(")] -> raise Stream.Failure
1787            | [_ :: _] -> ()
1788            | _ -> raise Stream.Failure ]
1789        | [("", "|")] -> ()
1790        | _ -> raise Stream.Failure ])
1791 ;
1792
1793 value stream_peek_nth n strm =
1794   loop n (Stream.npeek n strm) where rec loop n =
1795     fun
1796     [ [] -> None
1797     | [x] -> if n == 1 then Some x else None
1798     | [_ :: l] -> loop (n - 1) l ]
1799 ;
1800
1801 (* horrible hack to be able to parse class_types *)
1802
1803 value test_ctyp_minusgreater =
1804   Grammar.Entry.of_parser gram "test_ctyp_minusgreater"
1805     (fun strm ->
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)
1812          | Some
1813              ("",
1814               "as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" |
1815               "_") ->
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 ]
1828        in
1829        match Stream.peek strm with
1830        [ Some (("", "[") | ("LIDENT" | "UIDENT", _)) -> skip_simple_ctyp 1
1831        | Some ("", "object") -> raise Stream.Failure
1832        | _ -> 1 ])
1833 ;
1834
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", _) | ("", ".")) ->
1840            test (lev + 1) strm
1841        | Some ("ANTIQUOT_LOC", _) -> ()
1842        | Some ("", "=") -> ()
1843        | _ -> raise Stream.Failure ])
1844 ;
1845
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 ]
1857      in
1858      test 1)
1859 ;
1860
1861 value e_phony =
1862   Grammar.Entry.of_parser gram "e_phony"
1863     (parser [])
1864 ;
1865 value p_phony =
1866   Grammar.Entry.of_parser gram "p_phony"
1867     (parser [])
1868 ;
1869
1870 value constr_arity = ref [("Some", 1); ("Match_Failure", 1)];
1871
1872 value rec is_expr_constr_call =
1873   fun
1874   [ <:expr< $uid:_$ >> -> True
1875   | <:expr< $uid:_$.$e$ >> -> is_expr_constr_call e
1876   | <:expr< $e$ $_$ >> -> is_expr_constr_call e
1877   | _ -> False ]
1878 ;
1879
1880 value rec constr_expr_arity loc =
1881   fun
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
1885   | _ -> 1 ]
1886 ;
1887
1888 value rec constr_patt_arity loc =
1889   fun
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
1893   | _ -> 1 ]
1894 ;
1895
1896 value get_seq =
1897   fun
1898   [ <:expr< do { $list:el$ } >> -> el
1899   | e -> [e] ]
1900 ;
1901
1902 value mem_tvar s tpl =
1903   List.exists (fun (t, _) -> Pcaml.unvala t = Some s) tpl
1904 ;
1905
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)
1912   in
1913   let rec make_n n =
1914     let v = "a" ^ string_of_int n in
1915     if mem_tvar v tpl then make_n (succ n) else v
1916   in
1917   match find_alpha 'a' with
1918   [ Some x -> x
1919   | None -> make_n 1 ]
1920 ;
1921
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
1926       let i = i + 1 in
1927       (String.sub s 0 i, String.sub s i (String.length s - i))
1928     else loop (i + 1)
1929 };
1930
1931 value concat_comm loc e =
1932   let loc =
1933     Ploc.with_comment loc
1934       (Ploc.comment loc ^ Ploc.comment (MLast.loc_of_expr e))
1935   in
1936   let floc =
1937     let first = ref True in
1938     fun loc1 ->
1939       if first.val then do {first.val := False; loc}
1940       else loc1
1941   in
1942   reloc_expr floc 0 e
1943 ;
1944
1945 EXTEND
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;
1950   module_expr:
1951     [ [ "functor"; "("; i = V UIDENT "uid" ""; ":"; t = module_type; ")";
1952         "->"; me = SELF ->
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$ >> ] ]
1966   ;
1967   structure:
1968     [ [ st = V (LIST0 [ s = str_item; OPT ";;" -> s ]) -> st ] ]
1969   ;
1970   mod_expr_ident:
1971     [ LEFTA
1972       [ i = SELF; "."; j = SELF -> <:module_expr< $i$ . $j$ >> ]
1973     | [ i = V UIDENT -> <:module_expr< $_uid:i$ >> ] ]
1974   ;
1975   str_item:
1976     [ "top"
1977       [ "exception"; (_, c, tl, _) = constructor_declaration;
1978         b = rebind_exn ->
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";
1996         x = expr ->
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") ->
2000           match l with
2001           [ <:vala< [(p, e)] >> ->
2002               match p with
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$ >> ] ]
2009   ;
2010   rebind_exn:
2011     [ [ "="; sl = V mod_ident "list" -> sl
2012       | -> <:vala< [] >> ] ]
2013   ;
2014   mod_binding:
2015     [ [ i = V UIDENT; me = mod_fun_binding -> (i, me) ] ]
2016   ;
2017   mod_fun_binding:
2018     [ RIGHTA
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$ >> ] ]
2024   ;
2025   (* Module types *)
2026   module_type:
2027     [ [ "functor"; "("; i = V UIDENT "uid" ""; ":"; t = SELF; ")"; "->";
2028         mt = 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$ >> ] ]
2038   ;
2039   signature:
2040     [ [ sg = V (LIST0 [ s = sig_item; OPT ";;" -> s ]) -> sg ] ]
2041   ;
2042   mod_type_ident:
2043     [ LEFTA
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$ >> ] ]
2048   ;
2049   sig_item:
2050     [ "top"
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$ >> ] ]
2076   ;
2077   mod_decl_binding:
2078     [ [ i = V UIDENT; mt = module_declaration -> (i, mt) ] ]
2079   ;
2080   module_declaration:
2081     [ RIGHTA
2082       [ ":"; mt = module_type -> <:module_type< $mt$ >>
2083       | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF ->
2084           <:module_type< functor ( $uid:i$ : $t$ ) -> $mt$ >> ] ]
2085   ;
2086   (* "with" constraints (additional type equations over signature
2087      components) *)
2088   with_constr:
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 ""; ":=";
2093         t = ctyp ->
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$ >> ] ]
2099   ;
2100   (* Core expressions *)
2101   expr:
2102     [ "top" RIGHTA
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$ } >> ]
2107     | "expr1"
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]$ ) >> ]
2137     | ":=" NONA
2138       [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" ->
2139           <:expr< $e1$.val := $e2$ >>
2140       | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> <:expr< $e1$ := $e2$ >> ]
2141     | "||" RIGHTA
2142       [ e1 = SELF; "or"; e2 = SELF -> <:expr< $lid:"or"$ $e1$ $e2$ >>
2143       | e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ]
2144     | "&&" RIGHTA
2145       [ e1 = SELF; "&"; e2 = SELF -> <:expr< $lid:"&"$ $e1$ $e2$ >>
2146       | e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ]
2147     | "<" LEFTA
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$ >> ]
2157     | "^" RIGHTA
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$ >> ]
2161     | RIGHTA
2162       [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ]
2163     | "+" LEFTA
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$ >> ]
2167     | "*" LEFTA
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$ >> ]
2176     | "**" RIGHTA
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$ >> ]
2185     | "apply" LEFTA
2186       [ e1 = SELF; e2 = SELF ->
2187           let (e1, e2) =
2188             if is_expr_constr_call e1 then
2189               match e1 with
2190               [ <:expr< $e11$ $e12$ >> -> (e11, <:expr< $e12$ $e2$ >>)
2191               | _ -> (e1, e2) ]
2192             else (e1, e2)
2193           in
2194           match constr_expr_arity loc e1 with
2195           [ 1 -> <:expr< $e1$ $e2$ >>
2196           | _ ->
2197               match e2 with
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$) >> ]
2203     | "." LEFTA
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 ->
2212           let rec loop m =
2213             fun
2214             [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
2215             | e -> <:expr< $m$ . $e$ >> ]
2216           in
2217           loop e1 e2 ]
2218     | "~-" NONA
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$ >> ]
2223     | "simple" LEFTA
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< () >>
2256       | x = QUOTATION ->
2257           let con = quotation_content x in
2258           Pcaml.handle_expr_quotation loc con ] ]
2259   ;
2260   let_binding:
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) ] ]
2265   ;
2266 (*** JRH added the "translate_operator" here ***)
2267   val_ident:
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'$ >> ] ]
2271   ;
2272   fun_binding:
2273     [ RIGHTA
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$) >> ] ]
2277   ;
2278   match_case:
2279     [ [ x1 = patt; w = V (OPT [ "when"; e = expr -> e ]); "->"; x2 = expr ->
2280           (x1, w, x2) ] ]
2281   ;
2282   lbl_expr_list:
2283     [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel]
2284       | le = lbl_expr; ";" -> [le]
2285       | le = lbl_expr -> [le] ] ]
2286   ;
2287   lbl_expr:
2288     [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ]
2289   ;
2290   expr1_semi_list:
2291     [ [ el = LIST1 (expr LEVEL "expr1") SEP ";" OPT_SEP -> el ] ]
2292   ;
2293   fun_def:
2294     [ RIGHTA
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$ >>) ] ]
2299   ;
2300   expr_ident:
2301     [ RIGHTA
2302       [ i = V LIDENT -> <:expr< $_lid:i$ >>
2303       | i = V UIDENT -> <:expr< $_uid:i$ >>
2304       | i = V UIDENT; "."; j = SELF ->
2305           let rec loop m =
2306             fun
2307             [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
2308             | e -> <:expr< $m$ . $e$ >> ]
2309           in
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$ ) >> ] ]
2315   ;
2316   (* Patterns *)
2317   patt:
2318     [ LEFTA
2319       [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ]
2320     | LEFTA
2321       [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
2322     | [ p = SELF; ","; pl = LIST1 NEXT SEP "," ->
2323           <:patt< ( $list:[p :: pl]$) >> ]
2324     | NONA
2325       [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
2326     | RIGHTA
2327       [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
2328     | LEFTA
2329       [ p1 = SELF; p2 = SELF ->
2330           let (p1, p2) =
2331             match p1 with
2332             [ <:patt< $p11$ $p12$ >> -> (p11, <:patt< $p12$ $p2$ >>)
2333             | _ -> (p1, p2) ]
2334           in
2335           match constr_patt_arity loc p1 with
2336           [ 1 -> <:patt< $p1$ $p2$ >>
2337           | n ->
2338               let p2 =
2339                 match p2 with
2340                 [ <:patt< _ >> when n > 1 ->
2341                     let pl =
2342                       loop n where rec loop n =
2343                         if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)]
2344                     in
2345                     <:patt< ( $list:pl$ ) >>
2346                 | _ -> p2 ]
2347               in
2348               match p2 with
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$ >> ]
2353     | LEFTA
2354       [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
2355     | "simple"
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< _ >>
2392       | x = QUOTATION ->
2393           let con = quotation_content x in
2394           Pcaml.handle_patt_quotation loc con ] ]
2395   ;
2396   patt_semi_list:
2397     [ [ p = patt; ";"; pl = SELF -> [p :: pl]
2398       | p = patt; ";" -> [p]
2399       | p = patt -> [p] ] ]
2400   ;
2401   lbl_patt_list:
2402     [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel]
2403       | le = lbl_patt; ";" -> [le]
2404       | le = lbl_patt -> [le] ] ]
2405   ;
2406   lbl_patt:
2407     [ [ i = patt_label_ident; "="; p = patt -> (i, p)
2408       | "_" -> (<:patt< _ >>, <:patt< _ >>) ] ]
2409   ;
2410   patt_label_ident:
2411     [ LEFTA
2412       [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
2413     | RIGHTA
2414       [ i = UIDENT -> <:patt< $uid:i$ >>
2415       | i = LIDENT -> <:patt< $lid:i$ >> ] ]
2416   ;
2417   (* Type declaration *)
2418   type_decl:
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$ >> ] ]
2425   ;
2426   type_patt:
2427     [ [ n = V LIDENT -> (loc, n) ] ]
2428   ;
2429   constrain:
2430     [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
2431   ;
2432   type_kind:
2433     [ [ test_constr_decl; OPT "|";
2434         cdl = LIST1 constructor_declaration SEP "|" ->
2435           <:ctyp< [ $list:cdl$ ] >>
2436       | t = ctyp ->
2437           <:ctyp< $t$ >>
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$ } >> ] ]
2446   ;
2447   type_parameters:
2448     [ [ -> (* empty *) []
2449       | tp = type_parameter -> [tp]
2450       | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ]
2451   ;
2452   type_parameter:
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) ] ]
2456   ;
2457   simple_type_parameter:
2458     [ [ "'"; i = ident -> Some i
2459       | "_" -> None ] ]
2460   ;
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 "*");
2465         "->"; t = ctyp ->
2466           (loc, ci, cal, Some t)
2467       | ci = cons_ident; ":"; cal = V (LIST1 (ctyp LEVEL "apply") SEP "*") ->
2468           let t =
2469             match cal with
2470             [ <:vala< [t] >> -> t
2471             | <:vala< [t :: tl] >> -> <:ctyp< ($list:[t :: tl]$) >>
2472             | _ -> assert False ]
2473           in
2474           (loc, ci, <:vala< [] >>, Some t)
2475       | ci = cons_ident -> (loc, ci, <:vala< [] >>, None) ] ]
2476   ;
2477   cons_ident:
2478     [ [ i = V UIDENT "uid" "" -> i
2479       | UIDENT "True" -> <:vala< "True_" >>
2480       | UIDENT "False" -> <:vala< "False_" >> ] ]
2481   ;
2482   label_declarations:
2483     [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl]
2484       | ld = label_declaration; ";" -> [ld]
2485       | ld = label_declaration -> [ld] ] ]
2486   ;
2487   label_declaration:
2488     [ [ i = LIDENT; ":"; t = poly_type -> (loc, i, False, t)
2489       | "mutable"; i = LIDENT; ":"; t = poly_type -> (loc, i, True, t) ] ]
2490   ;
2491   (* Core types *)
2492   ctyp:
2493     [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ]
2494     | "arrow" RIGHTA
2495       [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
2496     | "star"
2497       [ t = SELF; "*"; tl = LIST1 (ctyp LEVEL "apply") SEP "*" ->
2498           <:ctyp< ( $list:[t :: tl]$ ) >> ]
2499     | "apply"
2500       [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ]
2501     | "ctyp2"
2502       [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >>
2503       | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ]
2504     | "simple"
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$ >> ] ]
2514   ;
2515   (* Identifiers *)
2516   ident:
2517     [ [ i = LIDENT -> i
2518       | i = UIDENT -> i ] ]
2519   ;
2520   mod_ident:
2521     [ RIGHTA
2522       [ i = UIDENT -> [i]
2523       | i = LIDENT -> [i]
2524       | i = UIDENT; "."; j = SELF -> [i :: j] ] ]
2525   ;
2526   (* Miscellaneous *)
2527   direction_flag:
2528     [ [ "to" -> True
2529       | "downto" -> False ] ]
2530   ;
2531   (* Objects and Classes *)
2532   str_item:
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$ >> ] ]
2537   ;
2538   sig_item:
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$ >> ] ]
2543   ;
2544   (* Class expressions *)
2545   class_declaration:
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} ] ]
2550   ;
2551   class_fun_binding:
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$ >> ] ]
2557   ;
2558   class_type_parameters:
2559     [ [ -> (loc, <:vala< [] >>)
2560       | "["; tpl = V (LIST1 type_parameter SEP ","); "]" -> (loc, tpl) ] ]
2561   ;
2562   class_fun_def:
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$ >> ] ]
2567   ;
2568   class_expr:
2569     [ "top"
2570       [ "fun"; cfd = class_fun_def -> cfd
2571       | "let"; rf = V (FLAG "rec"); lb = V (LIST1 let_binding SEP "and");
2572         "in"; ce = SELF ->
2573           <:class_expr< let $_flag:rf$ $_list:lb$ in $ce$ >> ]
2574     | "apply" LEFTA
2575       [ ce = SELF; e = expr LEVEL "label" ->
2576           <:class_expr< $ce$ $e$ >> ]
2577     | "simple"
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 ] ]
2590   ;
2591   class_structure:
2592     [ [ cf = LIST0 class_str_item -> cf ] ]
2593   ;
2594   class_self_patt:
2595     [ [ "("; p = patt; ")" -> p
2596       | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ]
2597   ;
2598   class_str_item:
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")
2608           else
2609             <:class_str_item< value virtual $_flag:mf$ $_lid:lab$ : $t$ >>
2610       | "val"; "virtual"; mf = V (FLAG "mutable"); lab = V LIDENT "lid" "";
2611         ":"; t = ctyp ->
2612           <:class_str_item< value virtual $_flag:mf$ $_lid:lab$ : $t$ >>
2613       | "method"; "private"; "virtual"; l = V LIDENT "lid" ""; ":";
2614         t = poly_type ->
2615           <:class_str_item< method virtual private $_lid:l$ : $t$ >>
2616       | "method"; "virtual"; "private"; l = V LIDENT "lid" ""; ":";
2617         t = poly_type ->
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" "";
2625         sb = fun_binding ->
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" "";
2631         sb = fun_binding ->
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$ >> ] ]
2636   ;
2637   cvalue_binding:
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$) >> ] ]
2644   ;
2645   label:
2646     [ [ i = LIDENT -> i ] ]
2647   ;
2648   (* Class types *)
2649   class_type:
2650     [ [ test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2651           <:class_type< [ $t$ ] -> $ct$ >>
2652       | cs = class_signature -> cs ] ]
2653   ;
2654   class_signature:
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$ >> ] ]
2664   ;
2665   class_self_type:
2666     [ [ "("; t = ctyp; ")" -> t ] ]
2667   ;
2668   class_sig_item:
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" ""; ":";
2674         t = poly_type ->
2675           <:class_sig_item< method virtual private $_lid:l$ : $t$ >>
2676       | "method"; "virtual"; "private"; l = V LIDENT "lid" ""; ":";
2677         t = poly_type ->
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$ >> ] ]
2687   ;
2688   class_description:
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} ] ]
2693   ;
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} ] ]
2699   ;
2700   (* Expressions *)
2701   expr: LEVEL "simple"
2702     [ LEFTA
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 >> ] ]
2707   ;
2708   expr: LEVEL "."
2709     [ [ e = SELF; "#"; lab = V LIDENT "lid" -> <:expr< $e$ # $_lid:lab$ >> ] ]
2710   ;
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$ >} >> ] ]
2718   ;
2719   field_expr_list:
2720     [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF ->
2721           [(l, e) :: fel]
2722       | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)]
2723       | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ]
2724   ;
2725   (* Core types *)
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$ > >>
2731       | "<"; ".."; ">" ->
2732          <:ctyp< < .. > >>
2733       | "<"; ">" ->
2734           <:ctyp< < > >> ] ]
2735   ;
2736   meth_list:
2737     [ [ f = field; ";"; ml = SELF -> [f :: ml]
2738       | f = field; ";" -> [f]
2739       | f = field -> [f] ] ]
2740   ;
2741   field:
2742     [ [ lab = LIDENT; ":"; t = poly_type -> (lab, t) ] ]
2743   ;
2744   (* Polymorphic types *)
2745   typevar:
2746     [ [ "'"; i = ident -> i ] ]
2747   ;
2748   poly_type:
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$ >>
2753       | t = ctyp -> t ] ]
2754   ;
2755   (* Identifiers *)
2756   class_longident:
2757     [ [ m = UIDENT; "."; l = SELF -> [m :: l]
2758       | i = LIDENT -> [i] ] ]
2759   ;
2760   (* Labels *)
2761   ctyp: AFTER "arrow"
2762     [ NONA
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$ >> ] ]
2766   ;
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$ ] >> ] ]
2778   ;
2779   poly_variant:
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$ >> ] ]
2785   ;
2786   name_tag:
2787     [ [ "`"; i = ident -> i ] ]
2788   ;
2789   expr: LEVEL "expr1"
2790     [ [ "fun"; p = labeled_patt; (eo, e) = fun_def ->
2791           <:expr< fun [ $p$ $opt:eo$ -> $e$ ] >> ] ]
2792   ;
2793   expr: AFTER "apply"
2794     [ "label"
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$} >> ] ]
2799   ;
2800   expr: LEVEL "simple"
2801     [ [ "`"; s = V ident "" -> <:expr< ` $_:s$ >> ] ]
2802   ;
2803   fun_def:
2804     [ [ p = labeled_patt; (eo, e) = SELF ->
2805           (None, <:expr< fun [ $p$ $opt:eo$ -> $e$ ] >>) ] ]
2806   ;
2807   fun_binding:
2808     [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
2809   ;
2810   patt: LEVEL "simple"
2811     [ [ "`"; s = V ident "" -> <:patt< ` $_:s$ >>
2812       | "#"; t = V mod_ident "list" "" -> <:patt< # $_list:t$ >>
2813       | p = labeled_patt -> p ] ]
2814   ;
2815   labeled_patt:
2816     [ [ i = V TILDEIDENTCOLON; p = patt LEVEL "simple" ->
2817            <:patt< ~{$_:i$ = $p$} >>
2818       | i = V TILDEIDENT ->
2819            <:patt< ~{$_:i$} >>
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; "_" ->
2827            <:patt< ?{$_:i$} >>
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; "=";
2833         e = expr; ")" ->
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$} >> ] ]
2846   ;
2847   class_type:
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$ >> ] ]
2854   ;
2855   class_fun_binding:
2856     [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
2857   ;
2858   class_fun_def:
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$ >> ] ]
2863   ;
2864 END;
2865
2866 IFDEF JOCAML THEN
2867   DELETE_RULE expr: SELF; "or"; SELF END;
2868   DELETE_RULE expr: SELF; "&"; SELF END;
2869   EXTEND
2870     GLOBAL: str_item expr;
2871     str_item:
2872       [ [ "def"; jal = V (LIST1 joinautomaton SEP "and") ->
2873             <:str_item< def $_list:jal$ >> ] ]
2874     ;
2875     expr: LEVEL "top"
2876       [ [ "def"; jal = V (LIST1 joinautomaton SEP "and"); "in";
2877           e = expr LEVEL "top"->
2878             <:expr< def $_list:jal$ in $e$ >> ] ]
2879     ;
2880     expr: LEVEL "apply"
2881       [ [ "reply"; eo = V (OPT expr); "to"; ji = joinident ->
2882             <:expr< reply $_opt:eo$ to $jid:ji$ >> ] ]
2883     ;
2884     expr: BEFORE ":="
2885       [ [ "spawn"; e = SELF -> <:expr< spawn $e$ >> ] ]
2886     ;
2887     expr: LEVEL "&&"
2888       [ [ e1 = SELF; "&"; e2 = SELF -> <:expr< $e1$ & $e2$ >> ] ]
2889     ;
2890     joinautomaton:
2891       [ [ jcl = V (LIST1 joinclause SEP "or") ->
2892             {MLast.jcLoc = loc; MLast.jcVal = jcl} ] ]
2893     ;
2894     joinclause:
2895       [ [ jpl = V (LIST1 joinpattern SEP "&"); "="; e = expr ->
2896             (loc, jpl, e) ] ]
2897     ;
2898     joinpattern:
2899       [ [ ji = joinident; "("; op = V (OPT patt); ")" -> (loc, ji, op) ] ]
2900     ;
2901     joinident:
2902       [ [ i = V LIDENT -> (loc, i) ] ]
2903     ;
2904   END;
2905 END;
2906
2907 (* Main entry points *)
2908
2909 EXTEND
2910   GLOBAL: interf implem use_file top_phrase expr patt;
2911   interf:
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) ] ]
2916   ;
2917   sig_item_semi:
2918     [ [ si = sig_item; OPT ";;" -> (si, loc) ] ]
2919   ;
2920   implem:
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) ] ]
2925   ;
2926   str_item_semi:
2927     [ [ si = str_item; OPT ";;" -> (si, loc) ] ]
2928   ;
2929   top_phrase:
2930     [ [ ph = phrase; ";;" -> Some ph
2931       | EOI -> None ] ]
2932   ;
2933   use_file:
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) ] ]
2939   ;
2940   phrase:
2941     [ [ sti = str_item -> sti
2942       | "#"; n = LIDENT; dp = OPT expr ->
2943           <:str_item< # $lid:n$ $opt:dp$ >> ] ]
2944   ;
2945 END;
2946
2947 Pcaml.add_option "-no_quot" (Arg.Set no_quotations)
2948   "Don't parse quotations, allowing to use, e.g. \"<:>\" as token";
2949
2950 (* ------------------------------------------------------------------------- *)
2951 (* Added by JRH ***                                                          *)
2952 (* ------------------------------------------------------------------------- *)
2953
2954 EXTEND
2955   expr: AFTER "<"
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$) >>
2966 ]];
2967 END;
2968
2969 EXTEND
2970   top_phrase:
2971    [ [ sti = str_item; ";;" ->
2972          match sti with
2973          [ <:str_item< $exp:e$ >> -> Some <:str_item< value it = $e$ >>
2974          | x -> Some x ] ] ]
2975   ;
2976 END;