pa_j_3.1x_6.02.1.ml

   1 (* ------------------------------------------------------------------------- *)
   2 (* New version.                                                              *)
   3 (* ------------------------------------------------------------------------- *)
   4
   5 (* camlp5r *)
   6 (* $Id: pa_o.ml,v 6.33 2010-11-16 16:48:21 deraugla Exp $ *)
   7 (* Copyright (c) INRIA 2007-2010 *)
   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.16 2010-11-21 17:17:45 deraugla Exp $ *)
  24 (* Copyright (c) INRIA 2007-2010 *)
  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     ...<: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     | IFDEF STRICT THEN
 153         TyXtr loc x1 x2 ->
 154           let loc = floc loc in
 155           TyXtr loc x1 (option_map (vala_map self) x2)
 156       END ]
 157 and reloc_poly_variant floc sh =
 158   fun
 159   [ PvTag loc x1 x2 x3 ->
 160       let loc = floc loc in
 161       PvTag loc x1 x2 (vala_map (List.map (reloc_ctyp floc sh)) x3)
 162   | PvInh loc x1 ->
 163       let loc = floc loc in
 164       PvInh loc (reloc_ctyp floc sh x1) ]
 165 and reloc_patt floc sh =
 166   self where rec self =
 167     fun
 168     [ PaAcc loc x1 x2 ->
 169         let loc = floc loc in
 170         PaAcc loc (self x1) (self x2)
 171     | PaAli loc x1 x2 ->
 172         let loc = floc loc in
 173         PaAli loc (self x1) (self x2)
 174     | PaAnt loc x1 ->
 175         let new_floc loc1 = anti_loc (floc loc) sh loc loc1 in
 176         reloc_patt new_floc sh x1
 177     | PaAny loc ->
 178         let loc = floc loc in
 179         PaAny loc
 180     | PaApp loc x1 x2 ->
 181         let loc = floc loc in
 182         PaApp loc (self x1) (self x2)
 183     | PaArr loc x1 ->
 184         let loc = floc loc in
 185         PaArr loc (vala_map (List.map self) x1)
 186     | PaChr loc x1 ->
 187         let loc = floc loc in
 188         PaChr loc x1
 189     | PaFlo loc x1 ->
 190         let loc = floc loc in
 191         PaFlo loc x1
 192     | PaInt loc x1 x2 ->
 193         let loc = floc loc in
 194         PaInt loc x1 x2
 195     | PaLab loc x1 x2 ->
 196         let loc = floc loc in
 197         PaLab loc (self x1) (vala_map (option_map self) x2)
 198     | PaLaz loc x1 ->
 199         let loc = floc loc in
 200         PaLaz loc (self x1)
 201     | PaLid loc x1 ->
 202         let loc = floc loc in
 203         PaLid loc x1
 204     | PaNty loc x1 ->
 205         let loc = floc loc in
 206         PaNty loc x1
 207     | PaOlb loc x1 x2 ->
 208         let loc = floc loc in
 209         PaOlb loc (self x1) (vala_map (option_map (reloc_expr floc sh)) x2)
 210     | PaOrp loc x1 x2 ->
 211         let loc = floc loc in
 212         PaOrp loc (self x1) (self x2)
 213     | PaRec loc x1 ->
 214         let loc = floc loc in
 215         PaRec loc
 216           (vala_map (List.map (fun (x1, x2) -> (self x1, self x2))) x1)
 217     | PaRng loc x1 x2 ->
 218         let loc = floc loc in
 219         PaRng loc (self x1) (self x2)
 220     | PaStr loc x1 ->
 221         let loc = floc loc in
 222         PaStr loc x1
 223     | PaTup loc x1 ->
 224         let loc = floc loc in
 225         PaTup loc (vala_map (List.map self) x1)
 226     | PaTyc loc x1 x2 ->
 227         let loc = floc loc in
 228         PaTyc loc (self x1) (reloc_ctyp floc sh x2)
 229     | PaTyp loc x1 ->
 230         let loc = floc loc in
 231         PaTyp loc x1
 232     | PaUid loc x1 ->
 233         let loc = floc loc in
 234         PaUid loc x1
 235     | PaUnp loc x1 x2 ->
 236         let loc = floc loc in
 237         PaUnp loc x1 (option_map (reloc_module_type floc sh) x2)
 238     | PaVrn loc x1 ->
 239         let loc = floc loc in
 240         PaVrn loc x1
 241     | IFDEF STRICT THEN
 242         PaXtr loc x1 x2 ->
 243           let loc = floc loc in
 244           PaXtr loc x1 (option_map (vala_map self) x2)
 245       END ]
 246 and reloc_expr floc sh =
 247   self where rec self =
 248     fun
 249     [ ExAcc loc x1 x2 ->
 250         let loc = floc loc in
 251         ExAcc loc (self x1) (self x2)
 252     | ExAnt loc x1 ->
 253         let new_floc loc1 = anti_loc (floc loc) sh loc loc1 in
 254         reloc_expr new_floc sh x1
 255     | ExApp loc x1 x2 ->
 256         let loc = floc loc in
 257         ExApp loc (self x1) (self x2)
 258     | ExAre loc x1 x2 ->
 259         let loc = floc loc in
 260         ExAre loc (self x1) (self x2)
 261     | ExArr loc x1 ->
 262         let loc = floc loc in
 263         ExArr loc (vala_map (List.map self) x1)
 264     | ExAsr loc x1 ->
 265         let loc = floc loc in
 266         ExAsr loc (self x1)
 267     | ExAss loc x1 x2 ->
 268         let loc = floc loc in
 269         ExAss loc (self x1) (self x2)
 270     | ExBae loc x1 x2 ->
 271         let loc = floc loc in
 272         ExBae loc (self x1) (vala_map (List.map self) x2)
 273     | ExChr loc x1 ->
 274         let loc = floc loc in
 275         ExChr loc x1
 276     | ExCoe loc x1 x2 x3 ->
 277         let loc = floc loc in
 278         ExCoe loc (self x1) (option_map (reloc_ctyp floc sh) x2) (reloc_ctyp floc sh x3)
 279     | ExFlo loc x1 ->
 280         let loc = floc loc in
 281         ExFlo loc x1
 282     | ExFor loc x1 x2 x3 x4 x5 ->
 283         let loc = floc loc in
 284         ExFor loc x1 (self x2) (self x3) x4 (vala_map (List.map self) x5)
 285     | ExFun loc x1 ->
 286         let loc = floc loc in
 287         ExFun loc
 288           (vala_map
 289              (List.map
 290                 (fun (x1, x2, x3) ->
 291                    (reloc_patt floc sh x1, vala_map (option_map self) x2, self x3)))
 292              x1)
 293     | ExIfe loc x1 x2 x3 ->
 294         let loc = floc loc in
 295         ExIfe loc (self x1) (self x2) (self x3)
 296     | ExInt loc x1 x2 ->
 297         let loc = floc loc in
 298         ExInt loc x1 x2
 299     | ExLab loc x1 ->
 300         let loc = floc loc in
 301        ExLab loc
 302            (vala_map
 303               (List.map
 304                  (fun (x1, x2) ->
 305                     (reloc_patt floc sh x1, vala_map (option_map self) x2)))
 306               x1)
 307
 308     | ExLaz loc x1 ->
 309         let loc = floc loc in
 310         ExLaz loc (self x1)
 311     | ExLet loc x1 x2 x3 ->
 312         let loc = floc loc in
 313         ExLet loc x1
 314           (vala_map (List.map (fun (x1, x2) -> (reloc_patt floc sh x1, self x2)))
 315              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     | ExPck loc x1 x2 ->
 345         let loc = floc loc in
 346         ExPck loc (reloc_module_expr floc sh x1)
 347           (option_map (reloc_module_type floc sh) x2)
 348     | ExRec loc x1 x2 ->
 349         let loc = floc loc in
 350         ExRec loc
 351           (vala_map (List.map (fun (x1, x2) -> (reloc_patt floc sh x1, self x2)))
 352              x1)
 353           (option_map self x2)
 354     | ExSeq loc x1 ->
 355         let loc = floc loc in
 356         ExSeq loc (vala_map (List.map self) x1)
 357     | ExSnd loc x1 x2 ->
 358         let loc = floc loc in
 359         ExSnd loc (self x1) x2
 360     | ExSte loc x1 x2 ->
 361         let loc = floc loc in
 362         ExSte loc (self x1) (self x2)
 363     | ExStr loc x1 ->
 364         let loc = floc loc in
 365         ExStr loc x1
 366     | ExTry loc x1 x2 ->
 367         let loc = floc loc in
 368         ExTry loc (self x1)
 369           (vala_map
 370              (List.map
 371                 (fun (x1, x2, x3) ->
 372                    (reloc_patt floc sh x1, vala_map (option_map self) x2, self x3)))
 373              x2)
 374     | ExTup loc x1 ->
 375         let loc = floc loc in
 376         ExTup loc (vala_map (List.map self) x1)
 377     | ExTyc loc x1 x2 ->
 378         let loc = floc loc in
 379         ExTyc loc (self x1) (reloc_ctyp floc sh x2)
 380     | ExUid loc x1 ->
 381         let loc = floc loc in
 382         ExUid loc x1
 383     | ExVrn loc x1 ->
 384         let loc = floc loc in
 385         ExVrn loc x1
 386     | ExWhi loc x1 x2 ->
 387         let loc = floc loc in
 388         ExWhi loc (self x1) (vala_map (List.map self) x2)
 389     | IFDEF STRICT THEN
 390         ExXtr loc x1 x2 ->
 391           let loc = floc loc in
 392           ExXtr loc x1 (option_map (vala_map self) x2)
 393       END ]
 394 and reloc_module_type floc sh =
 395   self where rec self =
 396     fun
 397     [ MtAcc loc x1 x2 ->
 398         let loc = floc loc in
 399         MtAcc loc (self x1) (self x2)
 400     | MtApp loc x1 x2 ->
 401         let loc = floc loc in
 402         MtApp loc (self x1) (self x2)
 403     | MtFun loc x1 x2 x3 ->
 404         let loc = floc loc in
 405         MtFun loc x1 (self x2) (self x3)
 406     | MtLid loc x1 ->
 407         let loc = floc loc in
 408         MtLid loc x1
 409     | MtQuo loc x1 ->
 410         let loc = floc loc in
 411         MtQuo loc x1
 412     | MtSig loc x1 ->
 413         let loc = floc loc in
 414         MtSig loc (vala_map (List.map (reloc_sig_item floc sh)) x1)
 415     | MtTyo loc x1 ->
 416         let loc = floc loc in
 417         MtTyo loc (reloc_module_expr floc sh x1)
 418     | MtUid loc x1 ->
 419         let loc = floc loc in
 420         MtUid loc x1
 421     | MtWit loc x1 x2 ->
 422         let loc = floc loc in
 423         MtWit loc (self x1) (vala_map (List.map (reloc_with_constr floc sh)) x2)
 424     | IFDEF STRICT THEN
 425         MtXtr loc x1 x2 ->
 426           let loc = floc loc in
 427           MtXtr loc x1 (option_map (vala_map self) x2)
 428       END ]
 429 and reloc_sig_item floc sh =
 430   self where rec self =
 431     fun
 432     [ SgCls loc x1 ->
 433         let loc = floc loc in
 434         SgCls loc
 435           (vala_map (List.map (class_infos_map floc (reloc_class_type floc sh))) x1)
 436     | SgClt loc x1 ->
 437         let loc = floc loc in
 438         SgClt loc
 439           (vala_map (List.map (class_infos_map floc (reloc_class_type floc sh))) x1)
 440     | SgDcl loc x1 ->
 441         let loc = floc loc in
 442         SgDcl loc (vala_map (List.map self) x1)
 443     | SgDir loc x1 x2 ->
 444         let loc = floc loc in
 445         SgDir loc x1 (vala_map (option_map (reloc_expr floc sh)) x2)
 446     | SgExc loc x1 x2 ->
 447         let loc = floc loc in
 448         SgExc loc x1 (vala_map (List.map (reloc_ctyp floc sh)) x2)
 449     | SgExt loc x1 x2 x3 ->
 450         let loc = floc loc in
 451         SgExt loc x1 (reloc_ctyp floc sh x2) x3
 452     | SgInc loc x1 ->
 453         let loc = floc loc in
 454         SgInc loc (reloc_module_type floc sh x1)
 455     | SgMod loc x1 x2 ->
 456         let loc = floc loc in
 457         SgMod loc x1
 458           (vala_map (List.map (fun (x1, x2) -> (x1, reloc_module_type floc sh x2)))
 459              x2)
 460     | SgMty loc x1 x2 ->
 461         let loc = floc loc in
 462         SgMty loc x1 (reloc_module_type floc sh x2)
 463     | SgOpn loc x1 ->
 464         let loc = floc loc in
 465         SgOpn loc x1
 466     | SgTyp loc x1 ->
 467         let loc = floc loc in
 468         SgTyp loc (vala_map (List.map (reloc_type_decl floc sh)) x1)
 469     | SgUse loc x1 x2 ->
 470         let loc = floc loc in
 471         SgUse loc x1
 472           (vala_map (List.map (fun (x1, loc) -> (self x1, floc loc))) x2)
 473     | SgVal loc x1 x2 ->
 474         let loc = floc loc in
 475         SgVal loc x1 (reloc_ctyp floc sh x2)
 476     | IFDEF STRICT THEN
 477         SgXtr loc x1 x2 ->
 478           let loc = floc loc in
 479           SgXtr loc x1 (option_map (vala_map self) x2)
 480       END ]
 481 and reloc_with_constr floc sh =
 482   fun
 483   [ WcMod loc x1 x2 ->
 484       let loc = floc loc in
 485       WcMod loc x1 (reloc_module_expr floc sh x2)
 486   | WcMos loc x1 x2 ->
 487       let loc = floc loc in
 488       WcMos loc x1 (reloc_module_expr floc sh x2)
 489   | WcTyp loc x1 x2 x3 x4 ->
 490       let loc = floc loc in
 491       WcTyp loc x1 x2 x3 (reloc_ctyp floc sh x4)
 492   | WcTys loc x1 x2 x3 ->
 493       let loc = floc loc in
 494       WcTys loc x1 x2 (reloc_ctyp floc sh x3) ]
 495 and reloc_module_expr floc sh =
 496   self where rec self =
 497     fun
 498     [ MeAcc loc x1 x2 ->
 499         let loc = floc loc in
 500         MeAcc loc (self x1) (self x2)
 501     | MeApp loc x1 x2 ->
 502         let loc = floc loc in
 503         MeApp loc (self x1) (self x2)
 504     | MeFun loc x1 x2 x3 ->
 505         let loc = floc loc in
 506         MeFun loc x1 (reloc_module_type floc sh x2) (self x3)
 507     | MeStr loc x1 ->
 508         let loc = floc loc in
 509         MeStr loc (vala_map (List.map (reloc_str_item floc sh)) x1)
 510     | MeTyc loc x1 x2 ->
 511         let loc = floc loc in
 512         MeTyc loc (self x1) (reloc_module_type floc sh x2)
 513     | MeUid loc x1 ->
 514         let loc = floc loc in
 515         MeUid loc x1
 516     | MeUnp loc x1 x2 ->
 517         let loc = floc loc in
 518         MeUnp loc (reloc_expr floc sh x1) (option_map (reloc_module_type floc sh) x2)
 519     | IFDEF STRICT THEN
 520         MeXtr loc x1 x2 ->
 521           let loc = floc loc in
 522           MeXtr loc x1 (option_map (vala_map self) x2)
 523       END ]
 524 and reloc_str_item floc sh =
 525   self where rec self =
 526     fun
 527     [ StCls loc x1 ->
 528         let loc = floc loc in
 529         StCls loc
 530           (vala_map (List.map (class_infos_map floc (reloc_class_expr floc sh))) x1)
 531     | StClt loc x1 ->
 532         let loc = floc loc in
 533         StClt loc
 534           (vala_map (List.map (class_infos_map floc (reloc_class_type floc sh))) x1)
 535     | StDcl loc x1 ->
 536         let loc = floc loc in
 537         StDcl loc (vala_map (List.map self) x1)
 538     | StDir loc x1 x2 ->
 539         let loc = floc loc in
 540         StDir loc x1 (vala_map (option_map (reloc_expr floc sh)) x2)
 541     | StExc loc x1 x2 x3 ->
 542         let loc = floc loc in
 543         StExc loc x1 (vala_map (List.map (reloc_ctyp floc sh)) x2) x3
 544     | StExp loc x1 ->
 545         let loc = floc loc in
 546         StExp loc (reloc_expr floc sh x1)
 547     | StExt loc x1 x2 x3 ->
 548         let loc = floc loc in
 549         StExt loc x1 (reloc_ctyp floc sh x2) x3
 550     | StInc loc x1 ->
 551         let loc = floc loc in
 552         StInc loc (reloc_module_expr floc sh x1)
 553     | StMod loc x1 x2 ->
 554         let loc = floc loc in
 555         StMod loc x1
 556           (vala_map (List.map (fun (x1, x2) -> (x1, reloc_module_expr floc sh x2)))
 557              x2)
 558     | StMty loc x1 x2 ->
 559         let loc = floc loc in
 560         StMty loc x1 (reloc_module_type floc sh x2)
 561     | StOpn loc x1 ->
 562         let loc = floc loc in
 563         StOpn loc x1
 564     | StTyp loc x1 ->
 565         let loc = floc loc in
 566         StTyp loc (vala_map (List.map (reloc_type_decl floc sh)) x1)
 567     | StUse loc x1 x2 ->
 568         let loc = floc loc in
 569         StUse loc x1
 570           (vala_map (List.map (fun (x1, loc) -> (self x1, floc loc))) x2)
 571     | StVal loc x1 x2 ->
 572         let loc = floc loc in
 573         StVal loc x1
 574           (vala_map
 575              (List.map (fun (x1, x2) -> (reloc_patt floc sh x1, reloc_expr floc sh x2)))
 576              x2)
 577     | IFDEF STRICT THEN
 578         StXtr loc x1 x2 ->
 579           let loc = floc loc in
 580           StXtr loc x1 (option_map (vala_map self) x2)
 581       END ]
 582 and reloc_type_decl floc sh x =
 583   {tdNam = vala_map (fun (loc, x1) -> (floc loc, x1)) x.tdNam;
 584    tdPrm = x.tdPrm; tdPrv = x.tdPrv; tdDef = reloc_ctyp floc sh x.tdDef;
 585    tdCon =
 586      vala_map (List.map (fun (x1, x2) -> (reloc_ctyp floc sh x1, reloc_ctyp floc sh x2)))
 587        x.tdCon}
 588 and reloc_class_type floc sh =
 589   self where rec self =
 590     fun
 591     [ CtAcc loc x1 x2 ->
 592         let loc = floc loc in
 593         CtAcc loc (self x1) (self x2)
 594     | CtApp loc x1 x2 ->
 595         let loc = floc loc in
 596         CtApp loc (self x1) (self x2)
 597     | CtCon loc x1 x2 ->
 598         let loc = floc loc in
 599         CtCon loc (self x1) (vala_map (List.map (reloc_ctyp floc sh)) x2)
 600     | CtFun loc x1 x2 ->
 601         let loc = floc loc in
 602         CtFun loc (reloc_ctyp floc sh x1) (self x2)
 603     | CtIde loc x1 ->
 604         let loc = floc loc in
 605         CtIde loc x1
 606     | CtSig loc x1 x2 ->
 607         let loc = floc loc in
 608         CtSig loc (vala_map (option_map (reloc_ctyp floc sh)) x1)
 609           (vala_map (List.map (reloc_class_sig_item floc sh)) x2)
 610     | IFDEF STRICT THEN
 611         CtXtr loc x1 x2 ->
 612           let loc = floc loc in
 613           CtXtr loc x1 (option_map (vala_map self) x2)
 614       END ]
 615 and reloc_class_sig_item floc sh =
 616   self where rec self =
 617     fun
 618     [ CgCtr loc x1 x2 ->
 619         let loc = floc loc in
 620         CgCtr loc (reloc_ctyp floc sh x1) (reloc_ctyp floc sh x2)
 621     | CgDcl loc x1 ->
 622         let loc = floc loc in
 623         CgDcl loc (vala_map (List.map self) x1)
 624     | CgInh loc x1 ->
 625         let loc = floc loc in
 626         CgInh loc (reloc_class_type floc sh x1)
 627     | CgMth loc x1 x2 x3 ->
 628         let loc = floc loc in
 629         CgMth loc x1 x2 (reloc_ctyp floc sh x3)
 630     | CgVal loc x1 x2 x3 ->
 631         let loc = floc loc in
 632         CgVal loc x1 x2 (reloc_ctyp floc sh x3)
 633     | CgVir loc x1 x2 x3 ->
 634         let loc = floc loc in
 635         CgVir loc x1 x2 (reloc_ctyp floc sh x3) ]
 636 and reloc_class_expr floc sh =
 637   self where rec self =
 638     fun
 639     [ CeApp loc x1 x2 ->
 640         let loc = floc loc in
 641         CeApp loc (self x1) (reloc_expr floc sh x2)
 642     | CeCon loc x1 x2 ->
 643         let loc = floc loc in
 644         CeCon loc x1 (vala_map (List.map (reloc_ctyp floc sh)) x2)
 645     | CeFun loc x1 x2 ->
 646         let loc = floc loc in
 647         CeFun loc (reloc_patt floc sh x1) (self x2)
 648     | CeLet loc x1 x2 x3 ->
 649         let loc = floc loc in
 650         CeLet loc x1
 651           (vala_map
 652              (List.map (fun (x1, x2) -> (reloc_patt floc sh x1, reloc_expr floc sh x2)))
 653              x2)
 654           (self x3)
 655     | CeStr loc x1 x2 ->
 656         let loc = floc loc in
 657         CeStr loc (vala_map (option_map (reloc_patt floc sh)) x1)
 658           (vala_map (List.map (reloc_class_str_item floc sh)) x2)
 659     | CeTyc loc x1 x2 ->
 660         let loc = floc loc in
 661         CeTyc loc (self x1) (reloc_class_type floc sh x2)
 662     | IFDEF STRICT THEN
 663         CeXtr loc x1 x2 ->
 664           let loc = floc loc in
 665           CeXtr loc x1 (option_map (vala_map self) x2)
 666       END ]
 667 and reloc_class_str_item floc sh =
 668   self where rec self =
 669     fun
 670     [ CrCtr loc x1 x2 ->
 671         let loc = floc loc in
 672         CrCtr loc (reloc_ctyp floc sh x1) (reloc_ctyp floc sh x2)
 673     | CrDcl loc x1 ->
 674         let loc = floc loc in
 675         CrDcl loc (vala_map (List.map self) x1)
 676     | CrInh loc x1 x2 ->
 677         let loc = floc loc in
 678         CrInh loc (reloc_class_expr floc sh x1) x2
 679     | CrIni loc x1 ->
 680         let loc = floc loc in
 681         CrIni loc (reloc_expr floc sh x1)
 682     | CrMth loc x1 x2 x3 x4 x5 ->
 683         let loc = floc loc in
 684         CrMth loc x1 x2 x3 (vala_map (option_map (reloc_ctyp floc sh)) x4)
 685           (reloc_expr floc sh x5)
 686     | CrVal loc x1 x2 x3 x4 ->
 687         let loc = floc loc in
 688         CrVal loc x1 x2 x3 (reloc_expr floc sh x4)
 689     | CrVav loc x1 x2 x3 ->
 690         let loc = floc loc in
 691         CrVav loc x1 x2 (reloc_ctyp floc sh x3)
 692     | CrVir loc x1 x2 x3 ->
 693         let loc = floc loc in
 694         CrVir loc x1 x2 (reloc_ctyp floc sh x3) ]
 695 ;
 696
 697 (* Equality over syntax trees *)
 698
 699 value eq_expr x y =
 700   reloc_expr (fun _ -> Ploc.dummy) 0 x =
 701   reloc_expr (fun _ -> Ploc.dummy) 0 y
 702 ;
 703 value eq_patt x y =
 704   reloc_patt (fun _ -> Ploc.dummy) 0 x =
 705   reloc_patt (fun _ -> Ploc.dummy) 0 y
 706 ;
 707 value eq_ctyp x y =
 708   reloc_ctyp (fun _ -> Ploc.dummy) 0 x =
 709   reloc_ctyp (fun _ -> Ploc.dummy) 0 y
 710 ;
 711 value eq_str_item x y =
 712   reloc_str_item (fun _ -> Ploc.dummy) 0 x =
 713   reloc_str_item (fun _ -> Ploc.dummy) 0 y
 714 ;
 715 value eq_sig_item x y =
 716   reloc_sig_item (fun _ -> Ploc.dummy) 0 x =
 717   reloc_sig_item (fun _ -> Ploc.dummy) 0 y
 718 ;
 719 value eq_module_expr x y =
 720   reloc_module_expr (fun _ -> Ploc.dummy) 0 x =
 721   reloc_module_expr (fun _ -> Ploc.dummy) 0 y
 722 ;
 723 value eq_module_type x y =
 724   reloc_module_type (fun _ -> Ploc.dummy) 0 x =
 725   reloc_module_type (fun _ -> Ploc.dummy) 0 y
 726 ;
 727 value eq_class_sig_item x y =
 728   reloc_class_sig_item (fun _ -> Ploc.dummy) 0 x =
 729   reloc_class_sig_item (fun _ -> Ploc.dummy) 0 y
 730 ;
 731 value eq_class_str_item x y =
 732   reloc_class_str_item (fun _ -> Ploc.dummy) 0 x =
 733   reloc_class_str_item (fun _ -> Ploc.dummy) 0 y
 734 ;
 735 value eq_class_type x y =
 736   reloc_class_type (fun _ -> Ploc.dummy) 0 x =
 737   reloc_class_type (fun _ -> Ploc.dummy) 0 y
 738 ;
 739 value eq_class_expr x y =
 740   reloc_class_expr (fun _ -> Ploc.dummy) 0 x =
 741   reloc_class_expr (fun _ -> Ploc.dummy) 0 y
 742 ;
 743
 744 (* ------------------------------------------------------------------------- *)
 745 (* Now the lexer.                                                            *)
 746 (* ------------------------------------------------------------------------- *)
 747
 748 (* camlp5r *)
 749 (* $Id: plexer.ml,v 6.11 2010-10-04 20:14:58 deraugla Exp $ *)
 750 (* Copyright (c) INRIA 2007-2010 *)
 751
 752 #load "pa_lexer.cmo";
 753
 754 (* ------------------------------------------------------------------------- *)
 755 (* Added by JRH as a backdoor to change lexical conventions.                 *)
 756 (* ------------------------------------------------------------------------- *)
 757
 758 value jrh_lexer = ref False;
 759
 760 open Versdep;
 761
 762 value no_quotations = ref False;
 763 value error_on_unknown_keywords = ref False;
 764
 765 value dollar_for_antiquotation = ref True;
 766 value specific_space_dot = ref False;
 767
 768 value force_antiquot_loc = ref False;
 769
 770 type context =
 771   { after_space : mutable bool;
 772     dollar_for_antiquotation : bool;
 773     specific_space_dot : bool;
 774     find_kwd : string -> string;
 775     line_cnt : int -> char -> unit;
 776     set_line_nb : unit -> unit;
 777     make_lined_loc : (int * int) -> string -> Ploc.t }
 778 ;
 779
 780 value err ctx loc msg =
 781   Ploc.raise (ctx.make_lined_loc loc "") (Plexing.Error msg)
 782 ;
 783
 784 (* ------------------------------------------------------------------------- *)
 785 (* JRH's hack to make the case distinction "unmixed" versus "mixed"          *)
 786 (* ------------------------------------------------------------------------- *)
 787
 788 value is_uppercase s = String.uppercase s = s;
 789 value is_only_lowercase s = String.lowercase s = s && not(is_uppercase s);
 790
 791 value jrh_identifier find_kwd id =
 792   let jflag = jrh_lexer.val in
 793   if id = "set_jrh_lexer" then
 794     (let _ = jrh_lexer.val := True in ("",find_kwd "true"))
 795   else if id = "unset_jrh_lexer" then
 796     (let _ = jrh_lexer.val := False in ("",find_kwd "false"))
 797   else
 798   try ("", find_kwd id) with
 799    [ Not_found ->
 800         if not(jflag) then
 801           if is_uppercase (String.sub id 0 1) then ("UIDENT", id)
 802           else ("LIDENT", id)
 803         else if is_uppercase (String.sub id 0 1) &&
 804         is_only_lowercase (String.sub id 1 (String.length id - 1))
 805 (***** JRH: Carl's alternative version
 806         then ("UIDENT", id)
 807         else if is_uppercase (String.sub id 0 1) then ("LIDENT", "__uc_"^id)
 808         else ("LIDENT", id)];
 809  *****)
 810         then ("UIDENT", id) else ("LIDENT", id)];
 811
 812 (* ------------------------------------------------------------------------- *)
 813 (* Back to original file with the mod of using the above.                    *)
 814 (* ------------------------------------------------------------------------- *)
 815
 816 value keyword_or_error ctx loc s =
 817   try ("", ctx.find_kwd s) with
 818   [ Not_found ->
 819       if error_on_unknown_keywords.val then
 820         err ctx loc ("illegal token: " ^ s)
 821       else ("", s) ]
 822 ;
 823
 824 value stream_peek_nth n strm =
 825   loop n (Stream.npeek n strm) where rec loop n =
 826     fun
 827     [ [] -> None
 828     | [x] -> if n == 1 then Some x else None
 829     | [_ :: l] -> loop (n - 1) l ]
 830 ;
 831
 832 value utf8_lexing = ref False;
 833
 834 value misc_letter buf strm =
 835   if utf8_lexing.val then
 836     match strm with lexer [ '\128'-'\225' | '\227'-'\255' ]
 837   else
 838     match strm with lexer [ '\128'-'\255' ]
 839 ;
 840
 841 value misc_punct buf strm =
 842   if utf8_lexing.val then
 843     match strm with lexer [ '\226' _ _ ]
 844   else
 845     match strm with parser []
 846 ;
 847
 848 value rec ident =
 849   lexer
 850   [ [ 'A'-'Z' | 'a'-'z' | '0'-'9' | '_' | ''' | misc_letter ] ident! | ]
 851 ;
 852
 853 value rec ident2 =
 854   lexer
 855   [ [ '!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
 856       '%' | '.' | ':' | '<' | '>' | '|' | '$' | misc_punct ]
 857       ident2!
 858   | ]
 859 ;
 860
 861 value rec ident3 =
 862   lexer
 863   [ [ '0'-'9' | 'A'-'Z' | 'a'-'z' | '_' | '!' | '%' | '&' | '*' | '+' | '-' |
 864       '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | ''' |
 865       '$' | '\128'-'\255' ] ident3!
 866   | ]
 867 ;
 868
 869 value binary = lexer [ '0' | '1' ];
 870 value octal = lexer [ '0'-'7' ];
 871 value decimal = lexer [ '0'-'9' ];
 872 value hexa = lexer [ '0'-'9' | 'a'-'f' | 'A'-'F' ];
 873
 874 value end_integer =
 875   lexer
 876   [ "l"/ -> ("INT_l", $buf)
 877   | "L"/ -> ("INT_L", $buf)
 878   | "n"/ -> ("INT_n", $buf)
 879   | -> ("INT", $buf) ]
 880 ;
 881
 882 value rec digits_under kind =
 883   lexer
 884   [ kind (digits_under kind)!
 885   | "_" (digits_under kind)!
 886   | end_integer ]
 887 ;
 888
 889 value digits kind =
 890   lexer
 891   [ kind (digits_under kind)!
 892   | -> raise (Stream.Error "ill-formed integer constant") ]
 893 ;
 894
 895 value rec decimal_digits_under =
 896   lexer [ [ '0'-'9' | '_' ] decimal_digits_under! | ]
 897 ;
 898
 899 value exponent_part =
 900   lexer
 901   [ [ 'e' | 'E' ] [ '+' | '-' | ]
 902     '0'-'9' ? "ill-formed floating-point constant"
 903     decimal_digits_under! ]
 904 ;
 905
 906 value number =
 907   lexer
 908   [ decimal_digits_under "." decimal_digits_under! exponent_part ->
 909       ("FLOAT", $buf)
 910   | decimal_digits_under "." decimal_digits_under! -> ("FLOAT", $buf)
 911   | decimal_digits_under exponent_part -> ("FLOAT", $buf)
 912   | decimal_digits_under end_integer! ]
 913 ;
 914
 915 value char_after_bslash =
 916   lexer
 917   [ "'"/
 918   | _ [ "'"/ | _ [ "'"/ | ] ] ]
 919 ;
 920
 921 value char ctx bp =
 922   lexer
 923   [ "\\" _ char_after_bslash!
 924   | "\\" -> err ctx (bp, $pos) "char not terminated"
 925   | ?= [ _ '''] _! "'"/ ]
 926 ;
 927
 928 value any ctx buf =
 929   parser bp [: `c :] -> do { ctx.line_cnt bp c; $add c }
 930 ;
 931
 932 value rec string ctx bp =
 933   lexer
 934   [ "\""/
 935   | "\\" (any ctx) (string ctx bp)!
 936   | (any ctx) (string ctx bp)!
 937   | -> err ctx (bp, $pos) "string not terminated" ]
 938 ;
 939
 940 value rec qstring ctx bp =
 941   lexer
 942   [ "`"/
 943   | (any ctx) (qstring ctx bp)!
 944   | -> err ctx (bp, $pos) "quotation not terminated" ]
 945 ;
 946
 947 value comment ctx bp =
 948   comment where rec comment =
 949     lexer
 950     [ "*)"
 951     | "*" comment!
 952     | "(*" comment! comment!
 953     | "(" comment!
 954     | "\"" (string ctx bp)! [ -> $add "\"" ] comment!
 955     | "'*)"
 956     | "'*" comment!
 957     | "'" (any ctx) comment!
 958     | (any ctx) comment!
 959     | -> err ctx (bp, $pos) "comment not terminated" ]
 960 ;
 961
 962 value rec quotation ctx bp =
 963   lexer
 964   [ ">>"/
 965   | ">" (quotation ctx bp)!
 966   | "<<" (quotation ctx bp)! [ -> $add ">>" ]! (quotation ctx bp)!
 967   | "<:" ident! "<" (quotation ctx bp)! [ -> $add ">>" ]! (quotation ctx bp)!
 968   | "<:" ident! (quotation ctx bp)!
 969   | "<" (quotation ctx bp)!
 970   | "\\"/ [ '>' | '<' | '\\' ] (quotation ctx bp)!
 971   | "\\" (quotation ctx bp)!
 972   | (any ctx) (quotation ctx bp)!
 973   | -> err ctx (bp, $pos) "quotation not terminated" ]
 974 ;
 975
 976 value less_expected = "character '<' expected";
 977
 978 value less ctx bp buf strm =
 979   if no_quotations.val then
 980     match strm with lexer
 981     [ [ -> $add "<" ] ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
 982   else
 983     match strm with lexer
 984     [ "<"/ (quotation ctx bp) -> ("QUOTATION", ":" ^ $buf)
 985     | ":"/ ident! "<"/ ? less_expected [ -> $add ":" ]! (quotation ctx bp) ->
 986         ("QUOTATION", $buf)
 987     | ":"/ ident! ":<"/ ? less_expected [ -> $add "@" ]! (quotation ctx bp) ->
 988         ("QUOTATION", $buf)
 989     | [ -> $add "<" ] ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
 990 ;
 991
 992 value rec antiquot_rest ctx bp =
 993   lexer
 994   [ "$"/
 995   | "\\"/ (any ctx) (antiquot_rest ctx bp)!
 996   | (any ctx) (antiquot_rest ctx bp)!
 997   | -> err ctx (bp, $pos) "antiquotation not terminated" ]
 998 ;
 999
1000 value rec antiquot ctx bp =
1001   lexer
1002   [ "$"/ -> ":" ^ $buf
1003   | [ 'a'-'z' | 'A'-'Z' | '0'-'9' | '!' | '_' ] (antiquot ctx bp)!
1004   | ":" (antiquot_rest ctx bp)! -> $buf
1005   | "\\"/ (any ctx) (antiquot_rest ctx bp)! -> ":" ^ $buf
1006   | (any ctx) (antiquot_rest ctx bp)! -> ":" ^ $buf
1007   | -> err ctx (bp, $pos) "antiquotation not terminated" ]
1008 ;
1009
1010 value antiloc bp ep s = Printf.sprintf "%d,%d:%s" bp ep s;
1011
1012 value rec antiquot_loc ctx bp =
1013   lexer
1014   [ "$"/ -> antiloc bp $pos (":" ^ $buf)
1015   | [ 'a'-'z' | 'A'-'Z' | '0'-'9' | '!' | '_' ] (antiquot_loc ctx bp)!
1016   | ":" (antiquot_rest ctx bp)! -> antiloc bp $pos $buf
1017   | "\\"/ (any ctx) (antiquot_rest ctx bp)! -> antiloc bp $pos (":" ^ $buf)
1018   | (any ctx) (antiquot_rest ctx bp)! -> antiloc bp $pos (":" ^ $buf)
1019   | -> err ctx (bp, $pos) "antiquotation not terminated" ]
1020 ;
1021
1022 value dollar ctx bp buf strm =
1023   if not no_quotations.val && ctx.dollar_for_antiquotation then
1024     ("ANTIQUOT", antiquot ctx bp buf strm)
1025   else if force_antiquot_loc.val then
1026     ("ANTIQUOT_LOC", antiquot_loc ctx bp buf strm)
1027   else
1028     match strm with lexer
1029     [ [ -> $add "$" ] ident2! -> ("", $buf) ]
1030 ;
1031
1032 (* ANTIQUOT - specific case for QUESTIONIDENT and QUESTIONIDENTCOLON
1033     input         expr        patt
1034     -----         ----        ----
1035     ?$abc:d$      ?abc:d      ?abc
1036     ?$abc:d$:     ?abc:d:     ?abc:
1037     ?$d$          ?:d         ?
1038     ?$d$:         ?:d:        ?:
1039 *)
1040
1041 (* ANTIQUOT_LOC - specific case for QUESTIONIDENT and QUESTIONIDENTCOLON
1042     input         expr             patt
1043     -----         ----             ----
1044     ?$abc:d$      ?8,13:abc:d      ?abc
1045     ?$abc:d$:     ?8,13:abc:d:     ?abc:
1046     ?$d$          ?8,9::d          ?
1047     ?$d$:         ?8,9::d:         ?:
1048 *)
1049
1050 value question ctx bp buf strm =
1051   if ctx.dollar_for_antiquotation then
1052     match strm with parser
1053     [ [: `'$'; s = antiquot ctx bp $empty; `':' :] ->
1054         ("ANTIQUOT", "?" ^ s ^ ":")
1055     | [: `'$'; s = antiquot ctx bp $empty :] ->
1056         ("ANTIQUOT", "?" ^ s)
1057     | [: :] ->
1058         match strm with lexer
1059         [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
1060   else if force_antiquot_loc.val then
1061     match strm with parser
1062     [ [: `'$'; s = antiquot_loc ctx bp $empty; `':' :] ->
1063         ("ANTIQUOT_LOC", "?" ^ s ^ ":")
1064     | [: `'$'; s = antiquot_loc ctx bp $empty :] ->
1065         ("ANTIQUOT_LOC", "?" ^ s)
1066     | [: :] ->
1067         match strm with lexer
1068         [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
1069   else
1070     match strm with lexer
1071     [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
1072 ;
1073
1074 value tilde ctx bp buf strm =
1075   if ctx.dollar_for_antiquotation then
1076     match strm with parser
1077     [ [: `'$'; s = antiquot ctx bp $empty; `':' :] ->
1078         ("ANTIQUOT", "~" ^ s ^ ":")
1079     | [: `'$'; s = antiquot ctx bp $empty :] ->
1080         ("ANTIQUOT", "~" ^ s)
1081     | [: :] ->
1082         match strm with lexer
1083         [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
1084   else if force_antiquot_loc.val then
1085     match strm with parser
1086     [ [: `'$'; s = antiquot_loc ctx bp $empty; `':' :] ->
1087         ("ANTIQUOT_LOC", "~" ^ s ^ ":")
1088     | [: `'$'; s = antiquot_loc ctx bp $empty :] ->
1089         ("ANTIQUOT_LOC", "~" ^ s)
1090     | [: :] ->
1091         match strm with lexer
1092         [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
1093   else
1094     match strm with lexer
1095     [ ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
1096 ;
1097
1098 value tildeident =
1099   lexer
1100   [ ":"/ -> ("TILDEIDENTCOLON", $buf)
1101   | -> ("TILDEIDENT", $buf) ]
1102 ;
1103
1104 value questionident =
1105   lexer
1106   [ ":"/ -> ("QUESTIONIDENTCOLON", $buf)
1107   | -> ("QUESTIONIDENT", $buf) ]
1108 ;
1109
1110 value rec linedir n s =
1111   match stream_peek_nth n s with
1112   [ Some (' ' | '\t') -> linedir (n + 1) s
1113   | Some ('0'..'9') -> linedir_digits (n + 1) s
1114   | _ -> False ]
1115 and linedir_digits n s =
1116   match stream_peek_nth n s with
1117   [ Some ('0'..'9') -> linedir_digits (n + 1) s
1118   | _ -> linedir_quote n s ]
1119 and linedir_quote n s =
1120   match stream_peek_nth n s with
1121   [ Some (' ' | '\t') -> linedir_quote (n + 1) s
1122   | Some '"' -> True
1123   | _ -> False ]
1124 ;
1125
1126 value rec any_to_nl =
1127   lexer
1128   [ "\r" | "\n"
1129   | _ any_to_nl!
1130   | ]
1131 ;
1132
1133 value next_token_after_spaces ctx bp =
1134   lexer
1135   [ 'A'-'Z' ident! ->
1136       let id = $buf in
1137      jrh_identifier ctx.find_kwd id
1138 (********** JRH: original was
1139       try ("", ctx.find_kwd id) with [ Not_found -> ("UIDENT", id) ]
1140  *********)
1141   | [ 'a'-'z' | '_' | misc_letter ] ident! ->
1142       let id = $buf in
1143       jrh_identifier ctx.find_kwd id
1144 (********** JRH: original was
1145       try ("", ctx.find_kwd id) with [ Not_found -> ("LIDENT", id) ]
1146  *********)
1147   | '1'-'9' number!
1148   | "0" [ 'o' | 'O' ] (digits octal)!
1149   | "0" [ 'x' | 'X' ] (digits hexa)!
1150   | "0" [ 'b' | 'B' ] (digits binary)!
1151   | "0" number!
1152   | "'"/ ?= [ '\\' 'a'-'z' 'a'-'z' ] -> keyword_or_error ctx (bp, $pos) "'"
1153   | "'"/ (char ctx bp) -> ("CHAR", $buf)
1154   | "'" -> keyword_or_error ctx (bp, $pos) "'"
1155   | "\""/ (string ctx bp)! -> ("STRING", $buf)
1156 (*** Line added by JRH ***)
1157   | "`"/ (qstring ctx bp)! -> ("QUOTATION", "tot:" ^ $buf)
1158   | "$"/ (dollar ctx bp)!
1159   | [ '!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' ] ident2! ->
1160       keyword_or_error ctx (bp, $pos) $buf
1161   | "~"/ 'a'-'z' ident! tildeident!
1162   | "~"/ '_' ident! tildeident!
1163   | "~" (tilde ctx bp)
1164   | "?"/ 'a'-'z' ident! questionident!
1165   | "?" (question ctx bp)!
1166   | "<"/ (less ctx bp)!
1167   | ":]" -> keyword_or_error ctx (bp, $pos) $buf
1168   | "::" -> keyword_or_error ctx (bp, $pos) $buf
1169   | ":=" -> keyword_or_error ctx (bp, $pos) $buf
1170   | ":>" -> keyword_or_error ctx (bp, $pos) $buf
1171   | ":" -> keyword_or_error ctx (bp, $pos) $buf
1172   | ">]" -> keyword_or_error ctx (bp, $pos) $buf
1173   | ">}" -> keyword_or_error ctx (bp, $pos) $buf
1174   | ">" ident2! -> keyword_or_error ctx (bp, $pos) $buf
1175   | "|]" -> keyword_or_error ctx (bp, $pos) $buf
1176   | "|}" -> keyword_or_error ctx (bp, $pos) $buf
1177   | "|" ident2! -> keyword_or_error ctx (bp, $pos) $buf
1178   | "[" ?= [ "<<" | "<:" ] -> keyword_or_error ctx (bp, $pos) $buf
1179   | "[|" -> keyword_or_error ctx (bp, $pos) $buf
1180   | "[<" -> keyword_or_error ctx (bp, $pos) $buf
1181   | "[:" -> keyword_or_error ctx (bp, $pos) $buf
1182   | "[" -> keyword_or_error ctx (bp, $pos) $buf
1183   | "{" ?= [ "<<" | "<:" ] -> keyword_or_error ctx (bp, $pos) $buf
1184   | "{|" -> keyword_or_error ctx (bp, $pos) $buf
1185   | "{<" -> keyword_or_error ctx (bp, $pos) $buf
1186   | "{:" -> keyword_or_error ctx (bp, $pos) $buf
1187   | "{" -> keyword_or_error ctx (bp, $pos) $buf
1188   | ".." -> keyword_or_error ctx (bp, $pos) ".."
1189   | "." ->
1190       let id =
1191         if ctx.specific_space_dot && ctx.after_space then " ." else "."
1192       in
1193       keyword_or_error ctx (bp, $pos) id
1194   | ";;" -> keyword_or_error ctx (bp, $pos) ";;"
1195   | ";" -> keyword_or_error ctx (bp, $pos) ";"
1196   | misc_punct ident2! -> keyword_or_error ctx (bp, $pos) $buf
1197   | "\\"/ ident3! -> ("LIDENT", $buf)
1198   | (any ctx) -> keyword_or_error ctx (bp, $pos) $buf ]
1199 ;
1200
1201 value get_comment buf strm = $buf;
1202
1203 value rec next_token ctx buf =
1204   parser bp
1205   [ [: `('\n' | '\r' as c); s :] ep -> do {
1206       if c = '\n' then incr Plexing.line_nb.val else ();
1207       Plexing.bol_pos.val.val := ep;
1208       ctx.set_line_nb ();
1209       ctx.after_space := True;
1210       next_token ctx ($add c) s
1211     }
1212   | [: `(' ' | '\t' | '\026' | '\012' as c); s :] -> do {
1213       ctx.after_space := True;
1214       next_token ctx ($add c) s
1215     }
1216   | [: `'#' when bp = Plexing.bol_pos.val.val; s :] ->
1217       let comm = get_comment buf () in
1218       if linedir 1 s then do {
1219         let buf = any_to_nl ($add '#') s in
1220         incr Plexing.line_nb.val;
1221         Plexing.bol_pos.val.val := Stream.count s;
1222         ctx.set_line_nb ();
1223         ctx.after_space := True;
1224         next_token ctx buf s
1225       }
1226       else
1227         let loc = ctx.make_lined_loc (bp, bp + 1) comm in
1228         (keyword_or_error ctx (bp, bp + 1) "#", loc)
1229   | [: `'(';
1230        a =
1231          parser
1232          [ [: `'*'; buf = comment ctx bp ($add "(*") !; s :] -> do {
1233              ctx.set_line_nb ();
1234              ctx.after_space := True;
1235              next_token ctx buf s
1236            }
1237          | [: :] ep ->
1238              let loc = ctx.make_lined_loc (bp, ep) $buf in
1239              (keyword_or_error ctx (bp, ep) "(", loc) ] ! :] -> a
1240   | [: comm = get_comment buf;
1241        tok = next_token_after_spaces ctx bp $empty :] ep ->
1242       let loc = ctx.make_lined_loc (bp, max (bp + 1) ep) comm in
1243       (tok, loc)
1244   | [: comm = get_comment buf; _ = Stream.empty :] ->
1245       let loc = ctx.make_lined_loc (bp, bp + 1) comm in
1246       (("EOI", ""), loc) ]
1247 ;
1248
1249 value next_token_fun ctx glexr (cstrm, s_line_nb, s_bol_pos) =
1250   try do {
1251     match Plexing.restore_lexing_info.val with
1252     [ Some (line_nb, bol_pos) -> do {
1253         s_line_nb.val := line_nb;
1254         s_bol_pos.val := bol_pos;
1255         Plexing.restore_lexing_info.val := None;
1256       }
1257     | None -> () ];
1258     Plexing.line_nb.val := s_line_nb;
1259     Plexing.bol_pos.val := s_bol_pos;
1260     let comm_bp = Stream.count cstrm in
1261     ctx.set_line_nb ();
1262     ctx.after_space := False;
1263     let (r, loc) = next_token ctx $empty cstrm in
1264     match glexr.val.Plexing.tok_comm with
1265     [ Some list ->
1266         if Ploc.first_pos loc > comm_bp then
1267           let comm_loc = Ploc.make_unlined (comm_bp, Ploc.last_pos loc) in
1268           glexr.val.Plexing.tok_comm := Some [comm_loc :: list]
1269         else ()
1270     | None -> () ];
1271     (r, loc)
1272   }
1273   with
1274   [ Stream.Error str ->
1275       err ctx (Stream.count cstrm, Stream.count cstrm + 1) str ]
1276 ;
1277
1278 value func kwd_table glexr =
1279   let ctx =
1280     let line_nb = ref 0 in
1281     let bol_pos = ref 0 in
1282     {after_space = False;
1283      dollar_for_antiquotation = dollar_for_antiquotation.val;
1284      specific_space_dot = specific_space_dot.val;
1285      find_kwd = Hashtbl.find kwd_table;
1286      line_cnt bp1 c =
1287        match c with
1288        [ '\n' | '\r' -> do {
1289            if c = '\n' then incr Plexing.line_nb.val else ();
1290            Plexing.bol_pos.val.val := bp1 + 1;
1291          }
1292        | c -> () ];
1293      set_line_nb () = do {
1294        line_nb.val := Plexing.line_nb.val.val;
1295        bol_pos.val := Plexing.bol_pos.val.val;
1296      };
1297      make_lined_loc loc comm =
1298        Ploc.make_loc Plexing.input_file.val line_nb.val bol_pos.val loc comm}
1299   in
1300   Plexing.lexer_func_of_parser (next_token_fun ctx glexr)
1301 ;
1302
1303 value rec check_keyword_stream =
1304   parser [: _ = check $empty; _ = Stream.empty :] -> True
1305 and check =
1306   lexer
1307   [ [ 'A'-'Z' | 'a'-'z' | misc_letter ] check_ident!
1308   | [ '!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
1309       '.' ]
1310       check_ident2!
1311   | "$" check_ident2!
1312   | "<" ?= [ ":" | "<" ]
1313   | "<" check_ident2!
1314   | ":]"
1315   | "::"
1316   | ":="
1317   | ":>"
1318   | ":"
1319   | ">]"
1320   | ">}"
1321   | ">" check_ident2!
1322   | "|]"
1323   | "|}"
1324   | "|" check_ident2!
1325   | "[" ?= [ "<<" | "<:" ]
1326   | "[|"
1327   | "[<"
1328   | "[:"
1329   | "["
1330   | "{" ?= [ "<<" | "<:" ]
1331   | "{|"
1332   | "{<"
1333   | "{:"
1334   | "{"
1335   | ";;"
1336   | ";"
1337   | misc_punct check_ident2!
1338   | _ ]
1339 and check_ident =
1340   lexer
1341   [ [ 'A'-'Z' | 'a'-'z' | '0'-'9' | '_' | ''' | misc_letter ]
1342     check_ident! | ]
1343 and check_ident2 =
1344   lexer
1345   [ [ '!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
1346       '.' | ':' | '<' | '>' | '|' | misc_punct ]
1347     check_ident2! | ]
1348 ;
1349
1350 value check_keyword s =
1351   try check_keyword_stream (Stream.of_string s) with _ -> False
1352 ;
1353
1354 value error_no_respect_rules p_con p_prm =
1355   raise
1356     (Plexing.Error
1357        ("the token " ^
1358           (if p_con = "" then "\"" ^ p_prm ^ "\""
1359            else if p_prm = "" then p_con
1360            else p_con ^ " \"" ^ p_prm ^ "\"") ^
1361           " does not respect Plexer rules"))
1362 ;
1363
1364 value error_ident_and_keyword p_con p_prm =
1365   raise
1366     (Plexing.Error
1367        ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^
1368           " and as keyword"))
1369 ;
1370
1371 value using_token kwd_table ident_table (p_con, p_prm) =
1372   match p_con with
1373   [ "" ->
1374       if not (hashtbl_mem kwd_table p_prm) then
1375         if check_keyword p_prm then
1376           if hashtbl_mem ident_table p_prm then
1377             error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm
1378           else Hashtbl.add kwd_table p_prm p_prm
1379         else error_no_respect_rules p_con p_prm
1380       else ()
1381   | "LIDENT" ->
1382       if p_prm = "" then ()
1383       else
1384         match p_prm.[0] with
1385         [ 'A'..'Z' -> error_no_respect_rules p_con p_prm
1386         | _ ->
1387             if hashtbl_mem kwd_table p_prm then
1388               error_ident_and_keyword p_con p_prm
1389             else Hashtbl.add ident_table p_prm p_con ]
1390   | "UIDENT" ->
1391       if p_prm = "" then ()
1392       else
1393         match p_prm.[0] with
1394         [ 'a'..'z' -> error_no_respect_rules p_con p_prm
1395         | _ ->
1396             if hashtbl_mem kwd_table p_prm then
1397               error_ident_and_keyword p_con p_prm
1398             else Hashtbl.add ident_table p_prm p_con ]
1399   | "TILDEIDENT" | "TILDEIDENTCOLON" | "QUESTIONIDENT" |
1400     "QUESTIONIDENTCOLON" | "INT" | "INT_l" | "INT_L" | "INT_n" | "FLOAT" |
1401     "CHAR" | "STRING" | "QUOTATION" |
1402     "ANTIQUOT" | "ANTIQUOT_LOC" | "EOI" ->
1403       ()
1404   | _ ->
1405       raise
1406         (Plexing.Error
1407            ("the constructor \"" ^ p_con ^
1408               "\" is not recognized by Plexer")) ]
1409 ;
1410
1411 value removing_token kwd_table ident_table (p_con, p_prm) =
1412   match p_con with
1413   [ "" -> Hashtbl.remove kwd_table p_prm
1414   | "LIDENT" | "UIDENT" ->
1415       if p_prm <> "" then Hashtbl.remove ident_table p_prm else ()
1416   | _ -> () ]
1417 ;
1418
1419 value text =
1420   fun
1421   [ ("", t) -> "'" ^ t ^ "'"
1422   | ("LIDENT", "") -> "lowercase identifier"
1423   | ("LIDENT", t) -> "'" ^ t ^ "'"
1424   | ("UIDENT", "") -> "uppercase identifier"
1425   | ("UIDENT", t) -> "'" ^ t ^ "'"
1426   | ("INT", "") -> "integer"
1427   | ("INT", s) -> "'" ^ s ^ "'"
1428   | ("FLOAT", "") -> "float"
1429   | ("STRING", "") -> "string"
1430   | ("CHAR", "") -> "char"
1431   | ("QUOTATION", "") -> "quotation"
1432   | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\""
1433   | ("EOI", "") -> "end of input"
1434   | (con, "") -> con
1435   | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
1436 ;
1437
1438 value eq_before_colon p e =
1439   loop 0 where rec loop i =
1440     if i == String.length e then
1441       failwith "Internal error in Plexer: incorrect ANTIQUOT"
1442     else if i == String.length p then e.[i] == ':'
1443     else if p.[i] == e.[i] then loop (i + 1)
1444     else False
1445 ;
1446
1447 value after_colon e =
1448   try
1449     let i = String.index e ':' in
1450     String.sub e (i + 1) (String.length e - i - 1)
1451   with
1452   [ Not_found -> "" ]
1453 ;
1454
1455 value after_colon_except_last e =
1456   try
1457     let i = String.index e ':' in
1458     String.sub e (i + 1) (String.length e - i - 2)
1459   with
1460   [ Not_found -> "" ]
1461 ;
1462
1463 value tok_match =
1464   fun
1465   [ ("ANTIQUOT", p_prm) ->
1466       if p_prm <> "" && (p_prm.[0] = '~' || p_prm.[0] = '?') then
1467         if p_prm.[String.length p_prm - 1] = ':' then
1468           let p_prm = String.sub p_prm 0 (String.length p_prm - 1) in
1469           fun
1470           [ ("ANTIQUOT", prm) ->
1471               if prm <> "" && prm.[String.length prm - 1] = ':' then
1472                 if eq_before_colon p_prm prm then after_colon_except_last prm
1473                 else raise Stream.Failure
1474               else raise Stream.Failure
1475           | _ -> raise Stream.Failure ]
1476         else
1477           fun
1478           [ ("ANTIQUOT", prm) ->
1479               if prm <> "" && prm.[String.length prm - 1] = ':' then
1480                 raise Stream.Failure
1481               else if eq_before_colon p_prm prm then after_colon prm
1482               else raise Stream.Failure
1483           | _ -> raise Stream.Failure ]
1484       else
1485         fun
1486         [ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm
1487         | _ -> raise Stream.Failure ]
1488   | tok -> Plexing.default_match tok ]
1489 ;
1490
1491 value gmake () =
1492   let kwd_table = Hashtbl.create 301 in
1493   let id_table = Hashtbl.create 301 in
1494   let glexr =
1495     ref
1496      {Plexing.tok_func = fun []; tok_using = fun []; tok_removing = fun [];
1497       tok_match = fun []; tok_text = fun []; tok_comm = None}
1498   in
1499   let glex =
1500     {Plexing.tok_func = func kwd_table glexr;
1501      tok_using = using_token kwd_table id_table;
1502      tok_removing = removing_token kwd_table id_table; tok_match = tok_match;
1503      tok_text = text; tok_comm = None}
1504   in
1505   do { glexr.val := glex; glex }
1506 ;
1507
1508 (* ------------------------------------------------------------------------- *)
1509 (* Back to etc/pa_o.ml                                                       *)
1510 (* ------------------------------------------------------------------------- *)
1511
1512 do {
1513   let odfa = dollar_for_antiquotation.val in
1514   dollar_for_antiquotation.val := False;
1515   Grammar.Unsafe.gram_reinit gram (gmake ());
1516   dollar_for_antiquotation.val := odfa;
1517   Grammar.Unsafe.clear_entry interf;
1518   Grammar.Unsafe.clear_entry implem;
1519   Grammar.Unsafe.clear_entry top_phrase;
1520   Grammar.Unsafe.clear_entry use_file;
1521   Grammar.Unsafe.clear_entry module_type;
1522   Grammar.Unsafe.clear_entry module_expr;
1523   Grammar.Unsafe.clear_entry sig_item;
1524   Grammar.Unsafe.clear_entry str_item;
1525   Grammar.Unsafe.clear_entry signature;
1526   Grammar.Unsafe.clear_entry structure;
1527   Grammar.Unsafe.clear_entry expr;
1528   Grammar.Unsafe.clear_entry patt;
1529   Grammar.Unsafe.clear_entry ctyp;
1530   Grammar.Unsafe.clear_entry let_binding;
1531   Grammar.Unsafe.clear_entry type_decl;
1532   Grammar.Unsafe.clear_entry constructor_declaration;
1533   Grammar.Unsafe.clear_entry label_declaration;
1534   Grammar.Unsafe.clear_entry match_case;
1535   Grammar.Unsafe.clear_entry with_constr;
1536   Grammar.Unsafe.clear_entry poly_variant;
1537   Grammar.Unsafe.clear_entry class_type;
1538   Grammar.Unsafe.clear_entry class_expr;
1539   Grammar.Unsafe.clear_entry class_sig_item;
1540   Grammar.Unsafe.clear_entry class_str_item
1541 };
1542
1543 Pcaml.parse_interf.val := Grammar.Entry.parse interf;
1544 Pcaml.parse_implem.val := Grammar.Entry.parse implem;
1545
1546 value mklistexp loc last =
1547   loop True where rec loop top =
1548     fun
1549     [ [] ->
1550         match last with
1551         [ Some e -> e
1552         | None -> <:expr< [] >> ]
1553     | [e1 :: el] ->
1554         let loc =
1555           if top then loc else Ploc.encl (MLast.loc_of_expr e1) loc
1556         in
1557         <:expr< [$e1$ :: $loop False el$] >> ]
1558 ;
1559
1560 value mklistpat loc last =
1561   loop True where rec loop top =
1562     fun
1563     [ [] ->
1564         match last with
1565         [ Some p -> p
1566         | None -> <:patt< [] >> ]
1567     | [p1 :: pl] ->
1568         let loc =
1569           if top then loc else Ploc.encl (MLast.loc_of_patt p1) loc
1570         in
1571         <:patt< [$p1$ :: $loop False pl$] >> ]
1572 ;
1573
1574 (*** JRH pulled this outside so user can add new infixes here too ***)
1575
1576 value ht = Hashtbl.create 73;
1577
1578 (*** And JRH added all the new HOL Light infixes here already ***)
1579
1580 value is_operator = do {
1581   let ct = Hashtbl.create 73 in
1582   List.iter (fun x -> Hashtbl.add ht x True)
1583     ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; "o"; "upto";
1584      "F_F"; "THENC"; "THEN"; "THENL"; "ORELSE"; "ORELSEC";
1585      "THEN_TCL"; "ORELSE_TCL"];
1586   List.iter (fun x -> Hashtbl.add ct x True)
1587     ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~';
1588      '?'; '%'; '.'; '$'];
1589   fun x ->
1590     try Hashtbl.find ht x with
1591     [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ]
1592 };
1593
1594 (*** JRH added this so parenthesised operators undergo same mapping ***)
1595
1596 value translate_operator =
1597   fun s ->
1598    match s with
1599     [ "THEN" -> "then_"
1600     | "THENC" -> "thenc_"
1601     | "THENL" -> "thenl_"
1602     | "ORELSE" -> "orelse_"
1603     | "ORELSEC" -> "orelsec_"
1604     | "THEN_TCL" -> "then_tcl_"
1605     | "ORELSE_TCL" -> "orelse_tcl_"
1606     | "F_F" -> "f_f_"
1607     | _ -> s];
1608
1609 value operator_rparen =
1610   Grammar.Entry.of_parser gram "operator_rparen"
1611     (fun strm ->
1612        match Stream.npeek 2 strm with
1613        [ [("", s); ("", ")")] when is_operator s -> do {
1614            Stream.junk strm;
1615            Stream.junk strm;
1616            translate_operator s
1617          }
1618        | _ -> raise Stream.Failure ])
1619 ;
1620
1621 value check_not_part_of_patt =
1622   Grammar.Entry.of_parser gram "check_not_part_of_patt"
1623     (fun strm ->
1624        let tok =
1625          match Stream.npeek 4 strm with
1626          [ [("LIDENT", _); tok :: _] -> tok
1627          | [("", "("); ("", s); ("", ")"); tok] when is_operator s -> tok
1628          | _ -> raise Stream.Failure ]
1629        in
1630        match tok with
1631        [ ("", "," | "as" | "|" | "::") -> raise Stream.Failure
1632        | _ -> () ])
1633 ;
1634
1635 value symbolchar =
1636   let list =
1637     ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?';
1638      '@'; '^'; '|'; '~']
1639   in
1640   loop where rec loop s i =
1641     if i == String.length s then True
1642     else if List.mem s.[i] list then loop s (i + 1)
1643     else False
1644 ;
1645
1646 value prefixop =
1647   let list = ['!'; '?'; '~'] in
1648   let excl = ["!="; "??"; "?!"] in
1649   Grammar.Entry.of_parser gram "prefixop"
1650     (parser
1651        [: `("", x)
1652            when
1653              not (List.mem x excl) && String.length x >= 2 &&
1654              List.mem x.[0] list && symbolchar x 1 :] ->
1655          x)
1656 ;
1657
1658 value infixop0 =
1659   let list = ['='; '<'; '>'; '|'; '&'; '$'] in
1660   let excl = ["<-"; "||"; "&&"] in
1661   Grammar.Entry.of_parser gram "infixop0"
1662     (parser
1663        [: `("", x)
1664            when
1665              not (List.mem x excl) && (x = "$" || String.length x >= 2) &&
1666              List.mem x.[0] list && symbolchar x 1 :] ->
1667          x)
1668 ;
1669
1670 value infixop1 =
1671   let list = ['@'; '^'] in
1672   Grammar.Entry.of_parser gram "infixop1"
1673     (parser
1674        [: `("", x)
1675            when
1676              String.length x >= 2 && List.mem x.[0] list &&
1677              symbolchar x 1 :] ->
1678          x)
1679 ;
1680
1681 value infixop2 =
1682   let list = ['+'; '-'] in
1683   Grammar.Entry.of_parser gram "infixop2"
1684     (parser
1685        [: `("", x)
1686            when
1687              x <> "->" && String.length x >= 2 && List.mem x.[0] list &&
1688              symbolchar x 1 :] ->
1689          x)
1690 ;
1691
1692 value infixop3 =
1693   let list = ['*'; '/'; '%'] in
1694   Grammar.Entry.of_parser gram "infixop3"
1695     (parser
1696        [: `("", x)
1697            when
1698              String.length x >= 2 && List.mem x.[0] list &&
1699              symbolchar x 1 :] ->
1700          x)
1701 ;
1702
1703 value infixop4 =
1704   Grammar.Entry.of_parser gram "infixop4"
1705     (parser
1706        [: `("", x)
1707            when
1708              String.length x >= 3 && x.[0] == '*' && x.[1] == '*' &&
1709              symbolchar x 2 :] ->
1710          x)
1711 ;
1712
1713 value test_constr_decl =
1714   Grammar.Entry.of_parser gram "test_constr_decl"
1715     (fun strm ->
1716        match Stream.npeek 1 strm with
1717        [ [("UIDENT", _)] ->
1718            match Stream.npeek 2 strm with
1719            [ [_; ("", ".")] -> raise Stream.Failure
1720            | [_; ("", "(")] -> raise Stream.Failure
1721            | [_ :: _] -> ()
1722            | _ -> raise Stream.Failure ]
1723        | [("", "|")] -> ()
1724        | _ -> raise Stream.Failure ])
1725 ;
1726
1727 value stream_peek_nth n strm =
1728   loop n (Stream.npeek n strm) where rec loop n =
1729     fun
1730     [ [] -> None
1731     | [x] -> if n == 1 then Some x else None
1732     | [_ :: l] -> loop (n - 1) l ]
1733 ;
1734
1735 (* horrible hack to be able to parse class_types *)
1736
1737 value test_ctyp_minusgreater =
1738   Grammar.Entry.of_parser gram "test_ctyp_minusgreater"
1739     (fun strm ->
1740        let rec skip_simple_ctyp n =
1741          match stream_peek_nth n strm with
1742          [ Some ("", "->") -> n
1743          | Some ("", "[" | "[<") ->
1744              skip_simple_ctyp (ignore_upto "]" (n + 1) + 1)
1745          | Some ("", "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1)
1746          | Some
1747              ("",
1748               "as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" |
1749               "_") ->
1750              skip_simple_ctyp (n + 1)
1751          | Some ("QUESTIONIDENT" | "LIDENT" | "UIDENT", _) ->
1752              skip_simple_ctyp (n + 1)
1753          | Some _ | None -> raise Stream.Failure ]
1754        and ignore_upto end_kwd n =
1755          match stream_peek_nth n strm with
1756          [ Some ("", prm) when prm = end_kwd -> n
1757          | Some ("", "[" | "[<") ->
1758              ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1)
1759          | Some ("", "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1)
1760          | Some _ -> ignore_upto end_kwd (n + 1)
1761          | None -> raise Stream.Failure ]
1762        in
1763        match Stream.peek strm with
1764        [ Some (("", "[") | ("LIDENT" | "UIDENT", _)) -> skip_simple_ctyp 1
1765        | Some ("", "object") -> raise Stream.Failure
1766        | _ -> 1 ])
1767 ;
1768
1769 value test_label_eq =
1770   Grammar.Entry.of_parser gram "test_label_eq"
1771     (test 1 where rec test lev strm =
1772        match stream_peek_nth lev strm with
1773        [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) ->
1774            test (lev + 1) strm
1775        | Some ("ANTIQUOT_LOC", _) -> ()
1776        | Some ("", "=") -> ()
1777        | _ -> raise Stream.Failure ])
1778 ;
1779
1780 value test_typevar_list_dot =
1781   Grammar.Entry.of_parser gram "test_typevar_list_dot"
1782     (let rec test lev strm =
1783        match stream_peek_nth lev strm with
1784        [ Some ("", "'") -> test2 (lev + 1) strm
1785        | Some ("", ".") -> ()
1786        | _ -> raise Stream.Failure ]
1787      and test2 lev strm =
1788        match stream_peek_nth lev strm with
1789        [ Some ("UIDENT" | "LIDENT", _) -> test (lev + 1) strm
1790        | _ -> raise Stream.Failure ]
1791      in
1792      test 1)
1793 ;
1794
1795 value e_phony =
1796   Grammar.Entry.of_parser gram "e_phony"
1797     (parser [])
1798 ;
1799 value p_phony =
1800   Grammar.Entry.of_parser gram "p_phony"
1801     (parser [])
1802 ;
1803
1804 value constr_arity = ref [("Some", 1); ("Match_Failure", 1)];
1805
1806 value rec is_expr_constr_call =
1807   fun
1808   [ <:expr< $uid:_$ >> -> True
1809   | <:expr< $uid:_$.$e$ >> -> is_expr_constr_call e
1810   | <:expr< $e$ $_$ >> -> is_expr_constr_call e
1811   | _ -> False ]
1812 ;
1813
1814 value rec constr_expr_arity loc =
1815   fun
1816   [ <:expr< $uid:c$ >> ->
1817       try List.assoc c constr_arity.val with [ Not_found -> 0 ]
1818   | <:expr< $uid:_$.$e$ >> -> constr_expr_arity loc e
1819   | _ -> 1 ]
1820 ;
1821
1822 value rec constr_patt_arity loc =
1823   fun
1824   [ <:patt< $uid:c$ >> ->
1825       try List.assoc c constr_arity.val with [ Not_found -> 0 ]
1826   | <:patt< $uid:_$.$p$ >> -> constr_patt_arity loc p
1827   | _ -> 1 ]
1828 ;
1829
1830 value get_seq =
1831   fun
1832   [ <:expr< do { $list:el$ } >> -> el
1833   | e -> [e] ]
1834 ;
1835
1836 value mem_tvar s tpl =
1837   List.exists (fun (t, _) -> Pcaml.unvala t = Some s) tpl
1838 ;
1839
1840 value choose_tvar tpl =
1841   let rec find_alpha v =
1842     let s = String.make 1 v in
1843     if mem_tvar s tpl then
1844       if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
1845     else Some (String.make 1 v)
1846   in
1847   let rec make_n n =
1848     let v = "a" ^ string_of_int n in
1849     if mem_tvar v tpl then make_n (succ n) else v
1850   in
1851   match find_alpha 'a' with
1852   [ Some x -> x
1853   | None -> make_n 1 ]
1854 ;
1855
1856 value quotation_content s = do {
1857   loop 0 where rec loop i =
1858     if i = String.length s then ("", s)
1859     else if s.[i] = ':' || s.[i] = '@' then
1860       let i = i + 1 in
1861       (String.sub s 0 i, String.sub s i (String.length s - i))
1862     else loop (i + 1)
1863 };
1864
1865 value concat_comm loc e =
1866   let loc =
1867     Ploc.with_comment loc
1868       (Ploc.comment loc ^ Ploc.comment (MLast.loc_of_expr e))
1869   in
1870   let floc =
1871     let first = ref True in
1872     fun loc1 ->
1873       if first.val then do {first.val := False; loc}
1874       else loc1
1875   in
1876   reloc_expr floc 0 e
1877 ;
1878
1879 EXTEND
1880   GLOBAL: sig_item str_item ctyp patt expr module_type module_expr
1881     signature structure class_type class_expr class_sig_item class_str_item
1882     let_binding type_decl constructor_declaration label_declaration
1883     match_case with_constr poly_variant;
1884   module_expr:
1885     [ [ "functor"; "("; i = V UIDENT "uid" ""; ":"; t = module_type; ")";
1886         "->"; me = SELF ->
1887           <:module_expr< functor ( $_uid:i$ : $t$ ) -> $me$ >>
1888       | "struct"; st = structure; "end" ->
1889           <:module_expr< struct $_list:st$ end >> ]
1890     | [ me1 = SELF; "."; me2 = SELF -> <:module_expr< $me1$ . $me2$ >> ]
1891     | [ me1 = SELF; "("; me2 = SELF; ")" -> <:module_expr< $me1$ $me2$ >> ]
1892     | [ i = mod_expr_ident -> i
1893       | "("; "val"; e = expr; ":"; mt = module_type; ")" ->
1894          <:module_expr< (value $e$ : $mt$) >>
1895       | "("; "val"; e = expr; ")" ->
1896          <:module_expr< (value $e$) >>
1897       | "("; me = SELF; ":"; mt = module_type; ")" ->
1898           <:module_expr< ( $me$ : $mt$ ) >>
1899       | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ]
1900   ;
1901   structure:
1902     [ [ st = V (LIST0 [ s = str_item; OPT ";;" -> s ]) -> st ] ]
1903   ;
1904   mod_expr_ident:
1905     [ LEFTA
1906       [ i = SELF; "."; j = SELF -> <:module_expr< $i$ . $j$ >> ]
1907     | [ i = V UIDENT -> <:module_expr< $_uid:i$ >> ] ]
1908   ;
1909   str_item:
1910     [ "top"
1911       [ "exception"; (_, c, tl, _) = constructor_declaration;
1912         b = rebind_exn ->
1913           <:str_item< exception $_uid:c$ of $_list:tl$ = $_list:b$ >>
1914       | "external"; i = V LIDENT "lid" ""; ":"; t = ctyp; "=";
1915         pd = V (LIST1 STRING) ->
1916           <:str_item< external $_lid:i$ : $t$ = $_list:pd$ >>
1917       | "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
1918         pd = V (LIST1 STRING) ->
1919           <:str_item< external $lid:i$ : $t$ = $_list:pd$ >>
1920       | "include"; me = module_expr -> <:str_item< include $me$ >>
1921       | "module"; r = V (FLAG "rec"); l = V (LIST1 mod_binding SEP "and") ->
1922           <:str_item< module $_flag:r$ $_list:l$ >>
1923       | "module"; "type"; i = V UIDENT "uid" ""; "="; mt = module_type ->
1924           <:str_item< module type $_uid:i$ = $mt$ >>
1925       | "open"; i = V mod_ident "list" "" ->
1926           <:str_item< open $_:i$ >>
1927       | "type"; tdl = V (LIST1 type_decl SEP "and") ->
1928           <:str_item< type $_list:tdl$ >>
1929       | "let"; r = V (FLAG "rec"); l = V (LIST1 let_binding SEP "and"); "in";
1930         x = expr ->
1931           let e = <:expr< let $_flag:r$ $_list:l$ in $x$ >> in
1932           <:str_item< $exp:e$ >>
1933       | "let"; r = V (FLAG "rec"); l = V (LIST1 let_binding SEP "and") ->
1934           match l with
1935           [ <:vala< [(p, e)] >> ->
1936               match p with
1937               [ <:patt< _ >> -> <:str_item< $exp:e$ >>
1938               | _ -> <:str_item< value $_flag:r$ $_list:l$ >> ]
1939           | _ -> <:str_item< value $_flag:r$ $_list:l$ >> ]
1940       | "let"; "module"; m = V UIDENT; mb = mod_fun_binding; "in"; e = expr ->
1941           <:str_item< let module $_uid:m$ = $mb$ in $e$ >>
1942       | e = expr -> <:str_item< $exp:e$ >> ] ]
1943   ;
1944   rebind_exn:
1945     [ [ "="; sl = V mod_ident "list" -> sl
1946       | -> <:vala< [] >> ] ]
1947   ;
1948   mod_binding:
1949     [ [ i = V UIDENT; me = mod_fun_binding -> (i, me) ] ]
1950   ;
1951   mod_fun_binding:
1952     [ RIGHTA
1953       [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
1954           <:module_expr< functor ( $uid:m$ : $mt$ ) -> $mb$ >>
1955       | ":"; mt = module_type; "="; me = module_expr ->
1956           <:module_expr< ( $me$ : $mt$ ) >>
1957       | "="; me = module_expr -> <:module_expr< $me$ >> ] ]
1958   ;
1959   (* Module types *)
1960   module_type:
1961     [ [ "functor"; "("; i = V UIDENT "uid" ""; ":"; t = SELF; ")"; "->";
1962         mt = SELF ->
1963           <:module_type< functor ( $_uid:i$ : $t$ ) -> $mt$ >> ]
1964     | [ mt = SELF; "with"; wcl = V (LIST1 with_constr SEP "and") ->
1965           <:module_type< $mt$ with $_list:wcl$ >> ]
1966     | [ "sig"; sg = signature; "end" ->
1967           <:module_type< sig $_list:sg$ end >>
1968       | "module"; "type"; "of"; me = module_expr ->
1969           <:module_type< module type of $me$ >>
1970       | i = mod_type_ident -> i
1971       | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ]
1972   ;
1973   signature:
1974     [ [ sg = V (LIST0 [ s = sig_item; OPT ";;" -> s ]) -> sg ] ]
1975   ;
1976   mod_type_ident:
1977     [ LEFTA
1978       [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >>
1979       | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ]
1980     | [ m = V UIDENT -> <:module_type< $_uid:m$ >>
1981       | m = V LIDENT -> <:module_type< $_lid:m$ >> ] ]
1982   ;
1983   sig_item:
1984     [ "top"
1985       [ "exception"; (_, c, tl, _) = constructor_declaration ->
1986           <:sig_item< exception $_uid:c$ of $_list:tl$ >>
1987       | "external"; i = V LIDENT "lid" ""; ":"; t = ctyp; "=";
1988         pd = V (LIST1 STRING) ->
1989           <:sig_item< external $_lid:i$ : $t$ = $_list:pd$ >>
1990       | "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
1991         pd = V (LIST1 STRING) ->
1992           <:sig_item< external $lid:i$ : $t$ = $_list:pd$ >>
1993       | "include"; mt = module_type ->
1994           <:sig_item< include $mt$ >>
1995       | "module"; rf = V (FLAG "rec");
1996         l = V (LIST1 mod_decl_binding SEP "and") ->
1997           <:sig_item< module $_flag:rf$ $_list:l$ >>
1998       | "module"; "type"; i = V UIDENT "uid" ""; "="; mt = module_type ->
1999           <:sig_item< module type $_uid:i$ = $mt$ >>
2000       | "module"; "type"; i = V UIDENT "uid" "" ->
2001           <:sig_item< module type $_uid:i$ = 'abstract >>
2002       | "open"; i = V mod_ident "list" "" ->
2003           <:sig_item< open $_:i$ >>
2004       | "type"; tdl = V (LIST1 type_decl SEP "and") ->
2005           <:sig_item< type $_list:tdl$ >>
2006       | "val"; i = V LIDENT "lid" ""; ":"; t = ctyp ->
2007           <:sig_item< value $_lid:i$ : $t$ >>
2008       | "val"; "("; i = operator_rparen; ":"; t = ctyp ->
2009           <:sig_item< value $lid:i$ : $t$ >> ] ]
2010   ;
2011   mod_decl_binding:
2012     [ [ i = V UIDENT; mt = module_declaration -> (i, mt) ] ]
2013   ;
2014   module_declaration:
2015     [ RIGHTA
2016       [ ":"; mt = module_type -> <:module_type< $mt$ >>
2017       | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF ->
2018           <:module_type< functor ( $uid:i$ : $t$ ) -> $mt$ >> ] ]
2019   ;
2020   (* "with" constraints (additional type equations over signature
2021      components) *)
2022   with_constr:
2023     [ [ "type"; tpl = V type_parameters "list"; i = V mod_ident ""; "=";
2024         pf = V (FLAG "private"); t = ctyp ->
2025           <:with_constr< type $_:i$ $_list:tpl$ = $_flag:pf$ $t$ >>
2026       | "type"; tpl = V type_parameters "list"; i = V mod_ident ""; ":=";
2027         t = ctyp ->
2028           <:with_constr< type $_:i$ $_list:tpl$ := $t$ >>
2029       | "module"; i = V mod_ident ""; "="; me = module_expr ->
2030           <:with_constr< module $_:i$ = $me$ >>
2031       | "module"; i = V mod_ident ""; ":="; me = module_expr ->
2032           <:with_constr< module $_:i$ := $me$ >> ] ]
2033   ;
2034   (* Core expressions *)
2035   expr:
2036     [ "top" RIGHTA
2037       [ e1 = SELF; ";"; e2 = SELF ->
2038           <:expr< do { $list:[e1 :: get_seq e2]$ } >>
2039       | e1 = SELF; ";" -> e1
2040       | el = V e_phony "list" -> <:expr< do { $_list:el$ } >> ]
2041     | "expr1"
2042       [ "let"; o = V (FLAG "rec"); l = V (LIST1 let_binding SEP "and"); "in";
2043         x = expr LEVEL "top" ->
2044           <:expr< let $_flag:o$ $_list:l$ in $x$ >>
2045       | "let"; "module"; m = V UIDENT; mb = mod_fun_binding; "in";
2046         e = expr LEVEL "top" ->
2047           <:expr< let module $_uid:m$ = $mb$ in $e$ >>
2048       | "function"; OPT "|"; l = V (LIST1 match_case SEP "|") ->
2049           <:expr< fun [ $_list:l$ ] >>
2050       | "fun"; p = patt LEVEL "simple"; (eo, e) = fun_def ->
2051           <:expr< fun [$p$ $opt:eo$ -> $e$] >>
2052       | "match"; e = SELF; "with"; OPT "|";
2053         l = V (LIST1 match_case SEP "|") ->
2054           <:expr< match $e$ with [ $_list:l$ ] >>
2055       | "try"; e = SELF; "with"; OPT "|"; l = V (LIST1 match_case SEP "|") ->
2056           <:expr< try $e$ with [ $_list:l$ ] >>
2057       | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1"; "else";
2058         e3 = expr LEVEL "expr1" ->
2059           <:expr< if $e1$ then $e2$ else $e3$ >>
2060       | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1" ->
2061           <:expr< if $e1$ then $e2$ else () >>
2062       | "for"; i = V LIDENT; "="; e1 = SELF; df = V direction_flag "to";
2063         e2 = SELF; "do"; e = V SELF "list"; "done" ->
2064           let el = Pcaml.vala_map get_seq e in
2065           <:expr< for $_lid:i$ = $e1$ $_to:df$ $e2$ do { $_list:el$ } >>
2066       | "while"; e1 = SELF; "do"; e2 = V SELF "list"; "done" ->
2067           let el = Pcaml.vala_map get_seq e2 in
2068           <:expr< while $e1$ do { $_list:el$ } >> ]
2069     | [ e = SELF; ","; el = LIST1 NEXT SEP "," ->
2070           <:expr< ( $list:[e :: el]$ ) >> ]
2071     | ":=" NONA
2072       [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" ->
2073           <:expr< $e1$.val := $e2$ >>
2074       | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> <:expr< $e1$ := $e2$ >> ]
2075     | "||" RIGHTA
2076       [ e1 = SELF; "or"; e2 = SELF -> <:expr< $lid:"or"$ $e1$ $e2$ >>
2077       | e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ]
2078     | "&&" RIGHTA
2079       [ e1 = SELF; "&"; e2 = SELF -> <:expr< $lid:"&"$ $e1$ $e2$ >>
2080       | e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ]
2081     | "<" LEFTA
2082       [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >>
2083       | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >>
2084       | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >>
2085       | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >>
2086       | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >>
2087       | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >>
2088       | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >>
2089       | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >>
2090       | e1 = SELF; op = infixop0; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
2091     | "^" RIGHTA
2092       [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >>
2093       | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >>
2094       | e1 = SELF; op = infixop1; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
2095     | RIGHTA
2096       [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ]
2097     | "+" LEFTA
2098       [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >>
2099       | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >>
2100       | e1 = SELF; op = infixop2; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
2101     | "*" LEFTA
2102       [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >>
2103       | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >>
2104       | e1 = SELF; "%"; e2 = SELF -> <:expr< $lid:"%"$ $e1$ $e2$ >>
2105       | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >>
2106       | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >>
2107       | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >>
2108       | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >>
2109       | e1 = SELF; op = infixop3; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
2110     | "**" RIGHTA
2111       [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >>
2112       | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >>
2113       | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >>
2114       | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >>
2115       | e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
2116     | "unary minus" NONA
2117       [ "-"; e = SELF -> <:expr< - $e$ >>
2118       | "-."; e = SELF -> <:expr< -. $e$ >> ]
2119     | "apply" LEFTA
2120       [ e1 = SELF; e2 = SELF ->
2121           let (e1, e2) =
2122             if is_expr_constr_call e1 then
2123               match e1 with
2124               [ <:expr< $e11$ $e12$ >> -> (e11, <:expr< $e12$ $e2$ >>)
2125               | _ -> (e1, e2) ]
2126             else (e1, e2)
2127           in
2128           match constr_expr_arity loc e1 with
2129           [ 1 -> <:expr< $e1$ $e2$ >>
2130           | _ ->
2131               match e2 with
2132               [ <:expr< ( $list:el$ ) >> ->
2133                   List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el
2134               | _ -> <:expr< $e1$ $e2$ >> ] ]
2135       | "assert"; e = SELF -> <:expr< assert $e$ >>
2136       | "lazy"; e = SELF -> <:expr< lazy ($e$) >> ]
2137     | "." LEFTA
2138       [ e1 = SELF; "."; "("; op = operator_rparen ->
2139           <:expr< $e1$ .( $lid:op$ ) >>
2140       | e1 = SELF; "."; "("; e2 = SELF; ")" ->
2141           <:expr< $e1$ .( $e2$ ) >>
2142       | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>
2143       | e = SELF; "."; "{"; el = V (LIST1 expr LEVEL "+" SEP ","); "}" ->
2144           <:expr< $e$ .{ $_list:el$ } >>
2145       | e1 = SELF; "."; e2 = SELF ->
2146           let rec loop m =
2147             fun
2148             [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
2149             | e -> <:expr< $m$ . $e$ >> ]
2150           in
2151           loop e1 e2 ]
2152     | "~-" NONA
2153       [ "!"; e = SELF -> <:expr< $e$ . val >>
2154       | "~-"; e = SELF -> <:expr< ~- $e$ >>
2155       | "~-."; e = SELF -> <:expr< ~-. $e$ >>
2156       | f = prefixop; e = SELF -> <:expr< $lid:f$ $e$ >> ]
2157     | "simple" LEFTA
2158       [ s = V INT -> <:expr< $_int:s$ >>
2159       | s = V INT_l -> <:expr< $_int32:s$ >>
2160       | s = V INT_L -> <:expr< $_int64:s$ >>
2161       | s = V INT_n -> <:expr< $_nativeint:s$ >>
2162       | s = V FLOAT -> <:expr< $_flo:s$ >>
2163       | s = V STRING -> <:expr< $_str:s$ >>
2164       | c = V CHAR -> <:expr< $_chr:c$ >>
2165       | UIDENT "True" -> <:expr< True_ >>
2166       | UIDENT "False" -> <:expr< False_ >>
2167       | i = expr_ident -> i
2168       | "false" -> <:expr< False >>
2169       | "true" -> <:expr< True >>
2170       | "["; "]" -> <:expr< [] >>
2171       | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >>
2172       | "[|"; "|]" -> <:expr< [| |] >>
2173       | "[|"; el = V expr1_semi_list "list"; "|]" ->
2174           <:expr< [| $_list:el$ |] >>
2175       | "{"; test_label_eq; lel = V lbl_expr_list "list"; "}" ->
2176           <:expr< { $_list:lel$ } >>
2177       | "{"; e = expr LEVEL "."; "with"; lel = V lbl_expr_list "list"; "}" ->
2178           <:expr< { ($e$) with $_list:lel$ } >>
2179       | "("; ")" -> <:expr< () >>
2180       | "("; "module"; me = module_expr; ":"; mt = module_type; ")" ->
2181           <:expr< (module $me$ : $mt$) >>
2182       | "("; "module"; me = module_expr; ")" ->
2183           <:expr< (module $me$) >>
2184       | "("; op = operator_rparen -> <:expr< $lid:op$ >>
2185       | "("; el = V e_phony "list"; ")" -> <:expr< ($_list:el$) >>
2186       | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
2187       | "("; e = SELF; ")" -> concat_comm loc <:expr< $e$ >>
2188       | "begin"; e = SELF; "end" -> concat_comm loc <:expr< $e$ >>
2189       | "begin"; "end" -> <:expr< () >>
2190       | x = QUOTATION ->
2191           let con = quotation_content x in
2192           Pcaml.handle_expr_quotation loc con ] ]
2193   ;
2194   let_binding:
2195     [ [ p = val_ident; e = fun_binding -> (p, e)
2196       | p = patt; "="; e = expr -> (p, e)
2197       | p = patt; ":"; t = poly_type; "="; e = expr ->
2198           (<:patt< ($p$ : $t$) >>, e) ] ]
2199   ;
2200 (*** JRH added the "translate_operator" here ***)
2201   val_ident:
2202     [ [ check_not_part_of_patt; s = LIDENT -> <:patt< $lid:s$ >>
2203       | check_not_part_of_patt; "("; s = ANY; ")" ->
2204            let s' = translate_operator s in <:patt< $lid:s'$ >> ] ]
2205   ;
2206   fun_binding:
2207     [ RIGHTA
2208       [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
2209       | "="; e = expr -> <:expr< $e$ >>
2210       | ":"; t = poly_type; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ]
2211   ;
2212   match_case:
2213     [ [ x1 = patt; w = V (OPT [ "when"; e = expr -> e ]); "->"; x2 = expr ->
2214           (x1, w, x2) ] ]
2215   ;
2216   lbl_expr_list:
2217     [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel]
2218       | le = lbl_expr; ";" -> [le]
2219       | le = lbl_expr -> [le] ] ]
2220   ;
2221   lbl_expr:
2222     [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ]
2223   ;
2224   expr1_semi_list:
2225     [ [ el = LIST1 (expr LEVEL "expr1") SEP ";" OPT_SEP -> el ] ]
2226   ;
2227   fun_def:
2228     [ RIGHTA
2229       [ p = patt LEVEL "simple"; (eo, e) = SELF ->
2230           (None, <:expr< fun [ $p$ $opt:eo$ -> $e$ ] >>)
2231       | eo = OPT [ "when"; e = expr -> e ]; "->"; e = expr ->
2232           (eo, <:expr< $e$ >>) ] ]
2233   ;
2234   expr_ident:
2235     [ RIGHTA
2236       [ i = V LIDENT -> <:expr< $_lid:i$ >>
2237       | i = V UIDENT -> <:expr< $_uid:i$ >>
2238       | i = V UIDENT; "."; j = SELF ->
2239           let rec loop m =
2240             fun
2241             [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
2242             | e -> <:expr< $m$ . $e$ >> ]
2243           in
2244           loop <:expr< $_uid:i$ >> j
2245       | i = V UIDENT; "."; "("; j = operator_rparen ->
2246           <:expr< $_uid:i$ . $lid:j$ >> ] ]
2247   ;
2248   (* Patterns *)
2249   patt:
2250     [ LEFTA
2251       [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ]
2252     | LEFTA
2253       [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
2254     | [ p = SELF; ","; pl = LIST1 NEXT SEP "," ->
2255           <:patt< ( $list:[p :: pl]$) >> ]
2256     | NONA
2257       [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
2258     | RIGHTA
2259       [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
2260     | LEFTA
2261       [ p1 = SELF; p2 = SELF ->
2262           let (p1, p2) =
2263             match p1 with
2264             [ <:patt< $p11$ $p12$ >> -> (p11, <:patt< $p12$ $p2$ >>)
2265             | _ -> (p1, p2) ]
2266           in
2267           match constr_patt_arity loc p1 with
2268           [ 1 -> <:patt< $p1$ $p2$ >>
2269           | n ->
2270               let p2 =
2271                 match p2 with
2272                 [ <:patt< _ >> when n > 1 ->
2273                     let pl =
2274                       loop n where rec loop n =
2275                         if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)]
2276                     in
2277                     <:patt< ( $list:pl$ ) >>
2278                 | _ -> p2 ]
2279               in
2280               match p2 with
2281               [ <:patt< ( $list:pl$ ) >> ->
2282                   List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl
2283               | _ -> <:patt< $p1$ $p2$ >> ] ]
2284       | "lazy"; p = SELF -> <:patt< lazy $p$ >> ]
2285     | LEFTA
2286       [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
2287     | "simple"
2288       [ s = V LIDENT -> <:patt< $_lid:s$ >>
2289       | s = V UIDENT -> <:patt< $_uid:s$ >>
2290       | s = V INT -> <:patt< $_int:s$ >>
2291       | s = V INT_l -> <:patt< $_int32:s$ >>
2292       | s = V INT_L -> <:patt< $_int64:s$ >>
2293       | s = V INT_n -> <:patt< $_nativeint:s$ >>
2294       | "-"; s = INT -> <:patt< $int:"-" ^ s$ >>
2295       | "-"; s = FLOAT -> <:patt< $flo:"-" ^ s$ >>
2296       | s = V FLOAT -> <:patt< $_flo:s$ >>
2297       | s = V STRING -> <:patt< $_str:s$ >>
2298       | s = V CHAR -> <:patt< $_chr:s$ >>
2299       | UIDENT "True" -> <:patt< True_ >>
2300       | UIDENT "False" -> <:patt< False_ >>
2301       | "false" -> <:patt< False >>
2302       | "true" -> <:patt< True >>
2303       | "["; "]" -> <:patt< [] >>
2304       | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >>
2305       | "[|"; "|]" -> <:patt< [| |] >>
2306       | "[|"; pl = V patt_semi_list "list"; "|]" ->
2307           <:patt< [| $_list:pl$ |] >>
2308       | "{"; lpl = V lbl_patt_list "list"; "}" ->
2309           <:patt< { $_list:lpl$ } >>
2310       | "("; ")" -> <:patt< () >>
2311       | "("; op = operator_rparen -> <:patt< $lid:op$ >>
2312       | "("; pl = V p_phony "list"; ")" -> <:patt< ($_list:pl$) >>
2313       | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
2314       | "("; p = SELF; ")" -> <:patt< $p$ >>
2315       | "("; "type"; s = V LIDENT; ")" -> <:patt< (type $_lid:s$) >>
2316       | "("; "module"; s = V UIDENT; ":"; mt = module_type; ")" ->
2317           <:patt< (module $_uid:s$ : $mt$) >>
2318       | "("; "module"; s = V UIDENT; ")" ->
2319           <:patt< (module $_uid:s$) >>
2320       | "_" -> <:patt< _ >>
2321       | x = QUOTATION ->
2322           let con = quotation_content x in
2323           Pcaml.handle_patt_quotation loc con ] ]
2324   ;
2325   patt_semi_list:
2326     [ [ p = patt; ";"; pl = SELF -> [p :: pl]
2327       | p = patt; ";" -> [p]
2328       | p = patt -> [p] ] ]
2329   ;
2330   lbl_patt_list:
2331     [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel]
2332       | le = lbl_patt; ";" -> [le]
2333       | le = lbl_patt -> [le] ] ]
2334   ;
2335   lbl_patt:
2336     [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ]
2337   ;
2338   patt_label_ident:
2339     [ LEFTA
2340       [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
2341     | RIGHTA
2342       [ i = UIDENT -> <:patt< $uid:i$ >>
2343       | i = LIDENT -> <:patt< $lid:i$ >> ] ]
2344   ;
2345   (* Type declaration *)
2346   type_decl:
2347     [ [ tpl = type_parameters; n = V type_patt; "="; pf = V (FLAG "private");
2348         tk = type_kind; cl = V (LIST0 constrain) ->
2349           <:type_decl< $_tp:n$ $list:tpl$ = $_priv:pf$ $tk$ $_list:cl$ >>
2350       | tpl = type_parameters; n = V type_patt; cl = V (LIST0 constrain) ->
2351           let tk = <:ctyp< '$choose_tvar tpl$ >> in
2352           <:type_decl< $_tp:n$ $list:tpl$ = $tk$ $_list:cl$ >> ] ]
2353   ;
2354   type_patt:
2355     [ [ n = V LIDENT -> (loc, n) ] ]
2356   ;
2357   constrain:
2358     [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
2359   ;
2360   type_kind:
2361     [ [ test_constr_decl; OPT "|";
2362         cdl = LIST1 constructor_declaration SEP "|" ->
2363           <:ctyp< [ $list:cdl$ ] >>
2364       | t = ctyp ->
2365           <:ctyp< $t$ >>
2366       | t = ctyp; "="; pf = FLAG "private"; "{";
2367         ldl = V label_declarations "list"; "}" ->
2368           <:ctyp< $t$ == $priv:pf$ { $_list:ldl$ } >>
2369       | t = ctyp; "="; pf = FLAG "private"; OPT "|";
2370         cdl = LIST1 constructor_declaration SEP "|" ->
2371           <:ctyp< $t$ == $priv:pf$ [ $list:cdl$ ] >>
2372       | "{"; ldl = V label_declarations "list"; "}" ->
2373           <:ctyp< { $_list:ldl$ } >> ] ]
2374   ;
2375   type_parameters:
2376     [ [ -> (* empty *) []
2377       | tp = type_parameter -> [tp]
2378       | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ]
2379   ;
2380   type_parameter:
2381     [ [ "+"; p = V simple_type_parameter -> (p, Some True)
2382       | "-"; p = V simple_type_parameter -> (p, Some False)
2383       | p = V simple_type_parameter -> (p, None) ] ]
2384   ;
2385   simple_type_parameter:
2386     [ [ "'"; i = ident -> Some i
2387       | "_" -> None ] ]
2388   ;
2389   constructor_declaration:
2390     [ [ ci = cons_ident; "of"; cal = V (LIST1 (ctyp LEVEL "apply") SEP "*") ->
2391           (loc, ci, cal, None)
2392       | ci = cons_ident; ":"; cal = V (LIST1 (ctyp LEVEL "apply") SEP "*");
2393         "->"; t = ctyp ->
2394           (loc, ci, cal, Some t)
2395       | ci = cons_ident; ":"; cal = V (LIST1 (ctyp LEVEL "apply") SEP "*") ->
2396           let t =
2397             match cal with
2398             [ <:vala< [t] >> -> t
2399             | <:vala< [t :: tl] >> -> <:ctyp< ($list:[t :: tl]$) >>
2400             | _ -> assert False ]
2401           in
2402           (loc, ci, <:vala< [] >>, Some t)
2403       | ci = cons_ident -> (loc, ci, <:vala< [] >>, None) ] ]
2404   ;
2405   cons_ident:
2406     [ [ i = V UIDENT "uid" "" -> i
2407       | UIDENT "True" -> <:vala< "True_" >>
2408       | UIDENT "False" -> <:vala< "False_" >> ] ]
2409   ;
2410   label_declarations:
2411     [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl]
2412       | ld = label_declaration; ";" -> [ld]
2413       | ld = label_declaration -> [ld] ] ]
2414   ;
2415   label_declaration:
2416     [ [ i = LIDENT; ":"; t = poly_type -> (loc, i, False, t)
2417       | "mutable"; i = LIDENT; ":"; t = poly_type -> (loc, i, True, t) ] ]
2418   ;
2419   (* Core types *)
2420   ctyp:
2421     [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ]
2422     | "arrow" RIGHTA
2423       [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
2424     | "star"
2425       [ t = SELF; "*"; tl = LIST1 (ctyp LEVEL "apply") SEP "*" ->
2426           <:ctyp< ( $list:[t :: tl]$ ) >> ]
2427     | "apply"
2428       [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ]
2429     | "ctyp2"
2430       [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >>
2431       | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ]
2432     | "simple"
2433       [ "'"; i = V ident "" -> <:ctyp< '$_:i$ >>
2434       | "_" -> <:ctyp< _ >>
2435       | i = V LIDENT -> <:ctyp< $_lid:i$ >>
2436       | i = V UIDENT -> <:ctyp< $_uid:i$ >>
2437       | "("; "module"; mt = module_type; ")" -> <:ctyp< module $mt$ >>
2438       | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")";
2439         i = ctyp LEVEL "ctyp2" ->
2440           List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl]
2441       | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ]
2442   ;
2443   (* Identifiers *)
2444   ident:
2445     [ [ i = LIDENT -> i
2446       | i = UIDENT -> i ] ]
2447   ;
2448   mod_ident:
2449     [ RIGHTA
2450       [ i = UIDENT -> [i]
2451       | i = LIDENT -> [i]
2452       | i = UIDENT; "."; j = SELF -> [i :: j] ] ]
2453   ;
2454   (* Miscellaneous *)
2455   direction_flag:
2456     [ [ "to" -> True
2457       | "downto" -> False ] ]
2458   ;
2459   (* Objects and Classes *)
2460   str_item:
2461     [ [ "class"; cd = V (LIST1 class_declaration SEP "and") ->
2462           <:str_item< class $_list:cd$ >>
2463       | "class"; "type"; ctd = V (LIST1 class_type_declaration SEP "and") ->
2464           <:str_item< class type $_list:ctd$ >> ] ]
2465   ;
2466   sig_item:
2467     [ [ "class"; cd = V (LIST1 class_description SEP "and") ->
2468           <:sig_item< class $_list:cd$ >>
2469       | "class"; "type"; ctd = V (LIST1 class_type_declaration SEP "and") ->
2470           <:sig_item< class type $_list:ctd$ >> ] ]
2471   ;
2472   (* Class expressions *)
2473   class_declaration:
2474     [ [ vf = V (FLAG "virtual"); ctp = class_type_parameters; i = V LIDENT;
2475         cfb = class_fun_binding ->
2476           {MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp;
2477            MLast.ciNam = i; MLast.ciExp = cfb} ] ]
2478   ;
2479   class_fun_binding:
2480     [ [ "="; ce = class_expr -> ce
2481       | ":"; ct = class_type; "="; ce = class_expr ->
2482           <:class_expr< ($ce$ : $ct$) >>
2483       | p = patt LEVEL "simple"; cfb = SELF ->
2484           <:class_expr< fun $p$ -> $cfb$ >> ] ]
2485   ;
2486   class_type_parameters:
2487     [ [ -> (loc, <:vala< [] >>)
2488       | "["; tpl = V (LIST1 type_parameter SEP ","); "]" -> (loc, tpl) ] ]
2489   ;
2490   class_fun_def:
2491     [ [ p = patt LEVEL "simple"; "->"; ce = class_expr ->
2492           <:class_expr< fun $p$ -> $ce$ >>
2493       | p = patt LEVEL "simple"; cfd = SELF ->
2494           <:class_expr< fun $p$ -> $cfd$ >> ] ]
2495   ;
2496   class_expr:
2497     [ "top"
2498       [ "fun"; cfd = class_fun_def -> cfd
2499       | "let"; rf = V (FLAG "rec"); lb = V (LIST1 let_binding SEP "and");
2500         "in"; ce = SELF ->
2501           <:class_expr< let $_flag:rf$ $_list:lb$ in $ce$ >> ]
2502     | "apply" LEFTA
2503       [ ce = SELF; e = expr LEVEL "label" ->
2504           <:class_expr< $ce$ $e$ >> ]
2505     | "simple"
2506       [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]";
2507         ci = class_longident ->
2508           <:class_expr< [ $list:[ct :: ctcl]$ ] $list:ci$ >>
2509       | "["; ct = ctyp; "]"; ci = class_longident ->
2510           <:class_expr< [ $ct$ ] $list:ci$ >>
2511       | ci = class_longident -> <:class_expr< $list:ci$ >>
2512       | "object"; cspo = V (OPT class_self_patt);
2513         cf = V class_structure "list"; "end" ->
2514           <:class_expr< object $_opt:cspo$ $_list:cf$ end >>
2515       | "("; ce = SELF; ":"; ct = class_type; ")" ->
2516           <:class_expr< ($ce$ : $ct$) >>
2517       | "("; ce = SELF; ")" -> ce ] ]
2518   ;
2519   class_structure:
2520     [ [ cf = LIST0 class_str_item -> cf ] ]
2521   ;
2522   class_self_patt:
2523     [ [ "("; p = patt; ")" -> p
2524       | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ]
2525   ;
2526   class_str_item:
2527     [ [ "inherit"; ce = class_expr; pb = V (OPT [ "as"; i = LIDENT -> i ]) ->
2528           <:class_str_item< inherit $ce$ $_opt:pb$ >>
2529       | "val"; ov = V (FLAG "!") "!"; mf = V (FLAG "mutable");
2530         lab = V LIDENT "lid" ""; e = cvalue_binding ->
2531           <:class_str_item< value $_!:ov$ $_flag:mf$ $_lid:lab$ = $e$ >>
2532       | "val"; ov = V (FLAG "!") "!"; mf = V (FLAG "mutable");
2533         "virtual"; lab = V LIDENT "lid" ""; ":"; t = ctyp ->
2534           if Pcaml.unvala ov then
2535             Ploc.raise loc (Stream.Error "virtual value cannot override")
2536           else
2537             <:class_str_item< value virtual $_flag:mf$ $_lid:lab$ : $t$ >>
2538       | "val"; "virtual"; mf = V (FLAG "mutable"); lab = V LIDENT "lid" "";
2539         ":"; t = ctyp ->
2540           <:class_str_item< value virtual $_flag:mf$ $_lid:lab$ : $t$ >>
2541       | "method"; "private"; "virtual"; l = V LIDENT "lid" ""; ":";
2542         t = poly_type ->
2543           <:class_str_item< method virtual private $_lid:l$ : $t$ >>
2544       | "method"; "virtual"; "private"; l = V LIDENT "lid" ""; ":";
2545         t = poly_type ->
2546           <:class_str_item< method virtual private $_lid:l$ : $t$ >>
2547       | "method"; "virtual"; l = V LIDENT "lid" ""; ":"; t = poly_type ->
2548           <:class_str_item< method virtual $_lid:l$ : $t$ >>
2549       | "method"; ov = V (FLAG "!") "!"; "private"; l = V LIDENT "lid" "";
2550         ":"; t = poly_type; "="; e = expr ->
2551           <:class_str_item< method $_!:ov$ private $_lid:l$ : $t$ = $e$ >>
2552       | "method"; ov = V (FLAG "!") "!"; "private"; l = V LIDENT "lid" "";
2553         sb = fun_binding ->
2554           <:class_str_item< method $_!:ov$ private $_lid:l$ = $sb$ >>
2555       | "method"; ov = V (FLAG "!") "!"; l = V LIDENT "lid" ""; ":";
2556         t = poly_type; "="; e = expr ->
2557           <:class_str_item< method $_!:ov$ $_lid:l$ : $t$ = $e$ >>
2558       | "method"; ov = V (FLAG "!") "!"; l = V LIDENT "lid" "";
2559         sb = fun_binding ->
2560           <:class_str_item< method $_!:ov$ $_lid:l$ = $sb$ >>
2561       | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
2562           <:class_str_item< type $t1$ = $t2$ >>
2563       | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ]
2564   ;
2565   cvalue_binding:
2566     [ [ "="; e = expr -> e
2567       | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >>
2568       | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr ->
2569           <:expr< ($e$ : $t$ :> $t2$) >>
2570       | ":>"; t = ctyp; "="; e = expr ->
2571           <:expr< ($e$ :> $t$) >> ] ]
2572   ;
2573   label:
2574     [ [ i = LIDENT -> i ] ]
2575   ;
2576   (* Class types *)
2577   class_type:
2578     [ [ test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2579           <:class_type< [ $t$ ] -> $ct$ >>
2580       | cs = class_signature -> cs ] ]
2581   ;
2582   class_signature:
2583     [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = SELF ->
2584           <:class_type< $id$ [ $list:tl$ ] >>
2585       | "object"; cst = V (OPT class_self_type);
2586         csf = V (LIST0 class_sig_item); "end" ->
2587           <:class_type< object $_opt:cst$ $_list:csf$ end >> ]
2588     | [ ct1 = SELF; "."; ct2 = SELF -> <:class_type< $ct1$ . $ct2$ >>
2589       | ct1 = SELF; "("; ct2 = SELF; ")" -> <:class_type< $ct1$ $ct2$ >> ]
2590     | [ i = V LIDENT -> <:class_type< $_id: i$ >>
2591       | i = V UIDENT -> <:class_type< $_id: i$ >> ] ]
2592   ;
2593   class_self_type:
2594     [ [ "("; t = ctyp; ")" -> t ] ]
2595   ;
2596   class_sig_item:
2597     [ [ "inherit"; cs = class_signature ->
2598           <:class_sig_item< inherit $cs$ >>
2599       | "val"; mf = V (FLAG "mutable"); l = V LIDENT "lid" ""; ":"; t = ctyp ->
2600           <:class_sig_item< value $_flag:mf$ $_lid:l$ : $t$ >>
2601       | "method"; "private"; "virtual"; l = V LIDENT "lid" ""; ":";
2602         t = poly_type ->
2603           <:class_sig_item< method virtual private $_lid:l$ : $t$ >>
2604       | "method"; "virtual"; "private"; l = V LIDENT "lid" ""; ":";
2605         t = poly_type ->
2606           <:class_sig_item< method virtual private $_lid:l$ : $t$ >>
2607       | "method"; "virtual"; l = V LIDENT "lid" ""; ":"; t = poly_type ->
2608           <:class_sig_item< method virtual $_lid:l$ : $t$ >>
2609       | "method"; "private"; l = V LIDENT "lid" ""; ":"; t = poly_type ->
2610           <:class_sig_item< method private $_lid:l$ : $t$ >>
2611       | "method"; l = V LIDENT "lid" ""; ":"; t = poly_type ->
2612           <:class_sig_item< method $_lid:l$ : $t$ >>
2613       | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
2614           <:class_sig_item< type $t1$ = $t2$ >> ] ]
2615   ;
2616   class_description:
2617     [ [ vf = V (FLAG "virtual"); ctp = class_type_parameters; n = V LIDENT;
2618         ":"; ct = class_type ->
2619           {MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp;
2620            MLast.ciNam = n; MLast.ciExp = ct} ] ]
2621   ;
2622   class_type_declaration:
2623     [ [ vf = V (FLAG "virtual"); ctp = class_type_parameters; n = V LIDENT;
2624         "="; cs = class_signature ->
2625           {MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp;
2626            MLast.ciNam = n; MLast.ciExp = cs} ] ]
2627   ;
2628   (* Expressions *)
2629   expr: LEVEL "simple"
2630     [ LEFTA
2631       [ "new"; i = V class_longident "list" -> <:expr< new $_list:i$ >>
2632       | "object"; cspo = V (OPT class_self_patt);
2633         cf = V class_structure "list"; "end" ->
2634           <:expr< object $_opt:cspo$ $_list:cf$ end >> ] ]
2635   ;
2636   expr: LEVEL "."
2637     [ [ e = SELF; "#"; lab = V LIDENT "lid" -> <:expr< $e$ # $_lid:lab$ >> ] ]
2638   ;
2639   expr: LEVEL "simple"
2640     [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" ->
2641           <:expr< ($e$ : $t$ :> $t2$) >>
2642       | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >>
2643       | "{<"; ">}" -> <:expr< {< >} >>
2644       | "{<"; fel = V field_expr_list "list"; ">}" ->
2645           <:expr< {< $_list:fel$ >} >> ] ]
2646   ;
2647   field_expr_list:
2648     [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF ->
2649           [(l, e) :: fel]
2650       | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)]
2651       | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ]
2652   ;
2653   (* Core types *)
2654   ctyp: LEVEL "simple"
2655     [ [ "#"; id = V class_longident "list" ->
2656          <:ctyp< # $_list:id$ >>
2657       | "<"; ml = V meth_list "list"; v = V (FLAG ".."); ">" ->
2658           <:ctyp< < $_list:ml$ $_flag:v$ > >>
2659       | "<"; ".."; ">" ->
2660          <:ctyp< < .. > >>
2661       | "<"; ">" ->
2662           <:ctyp< < > >> ] ]
2663   ;
2664   meth_list:
2665     [ [ f = field; ";"; ml = SELF -> [f :: ml]
2666       | f = field; ";" -> [f]
2667       | f = field -> [f] ] ]
2668   ;
2669   field:
2670     [ [ lab = LIDENT; ":"; t = poly_type -> (lab, t) ] ]
2671   ;
2672   (* Polymorphic types *)
2673   typevar:
2674     [ [ "'"; i = ident -> i ] ]
2675   ;
2676   poly_type:
2677     [ [ "type"; nt = LIST1 LIDENT; "."; ct = ctyp ->
2678           <:ctyp< type $list:nt$ . $ct$ >>
2679       | test_typevar_list_dot; tpl = LIST1 typevar; "."; t2 = ctyp ->
2680           <:ctyp< ! $list:tpl$ . $t2$ >>
2681       | t = ctyp -> t ] ]
2682   ;
2683   (* Identifiers *)
2684   class_longident:
2685     [ [ m = UIDENT; "."; l = SELF -> [m :: l]
2686       | i = LIDENT -> [i] ] ]
2687   ;
2688   (* Labels *)
2689   ctyp: AFTER "arrow"
2690     [ NONA
2691       [ i = V LIDENT; ":"; t = SELF -> <:ctyp< ~$_:i$: $t$ >>
2692       | i = V QUESTIONIDENTCOLON; t = SELF -> <:ctyp< ?$_:i$: $t$ >>
2693       | i = V QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ?$_:i$: $t$ >> ] ]
2694   ;
2695   ctyp: LEVEL "simple"
2696     [ [ "["; OPT "|"; rfl = V (LIST1 poly_variant SEP "|"); "]" ->
2697           <:ctyp< [ = $_list:rfl$ ] >>
2698       | "["; ">"; "]" -> <:ctyp< [ > $list:[]$ ] >>
2699       | "["; ">"; OPT "|"; rfl = V (LIST1 poly_variant SEP "|"); "]" ->
2700           <:ctyp< [ > $_list:rfl$ ] >>
2701       | "[<"; OPT "|"; rfl = V (LIST1 poly_variant SEP "|"); "]" ->
2702           <:ctyp< [ < $_list:rfl$ ] >>
2703       | "[<"; OPT "|"; rfl = V (LIST1 poly_variant SEP "|"); ">";
2704         ntl = V (LIST1 name_tag); "]" ->
2705           <:ctyp< [ < $_list:rfl$ > $_list:ntl$ ] >> ] ]
2706   ;
2707   poly_variant:
2708     [ [ "`"; i = V ident "" -> <:poly_variant< ` $_:i$ >>
2709       | "`"; i = V ident ""; "of"; ao = V (FLAG "&");
2710         l = V (LIST1 ctyp SEP "&") ->
2711           <:poly_variant< `$_:i$ of $_flag:ao$ $_list:l$ >>
2712       | t = ctyp -> <:poly_variant< $t$ >> ] ]
2713   ;
2714   name_tag:
2715     [ [ "`"; i = ident -> i ] ]
2716   ;
2717   expr: LEVEL "expr1"
2718     [ [ "fun"; p = labeled_patt; (eo, e) = fun_def ->
2719           <:expr< fun [ $p$ $opt:eo$ -> $e$ ] >> ] ]
2720   ;
2721   expr: AFTER "apply"
2722     [ "label"
2723       [ i = V TILDEIDENTCOLON; e = SELF -> <:expr< ~{$_:i$ = $e$} >>
2724       | i = V TILDEIDENT -> <:expr< ~{$_:i$} >>
2725       | i = V QUESTIONIDENTCOLON; e = SELF -> <:expr< ?{$_:i$ = $e$} >>
2726       | i = V QUESTIONIDENT -> <:expr< ?{$_:i$} >> ] ]
2727   ;
2728   expr: LEVEL "simple"
2729     [ [ "`"; s = V ident "" -> <:expr< ` $_:s$ >> ] ]
2730   ;
2731   fun_def:
2732     [ [ p = labeled_patt; (eo, e) = SELF ->
2733           (None, <:expr< fun [ $p$ $opt:eo$ -> $e$ ] >>) ] ]
2734   ;
2735   fun_binding:
2736     [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
2737   ;
2738   patt: LEVEL "simple"
2739     [ [ "`"; s = V ident "" -> <:patt< ` $_:s$ >>
2740       | "#"; t = V mod_ident "list" "" -> <:patt< # $_list:t$ >>
2741       | p = labeled_patt -> p ] ]
2742   ;
2743   labeled_patt:
2744     [ [ i = V TILDEIDENTCOLON; p = patt LEVEL "simple" ->
2745            <:patt< ~{$_:i$ = $p$} >>
2746       | i = V TILDEIDENT ->
2747            <:patt< ~{$_:i$} >>
2748       | "~"; "("; i = LIDENT; ")" ->
2749            <:patt< ~{$lid:i$} >>
2750       | "~"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
2751            <:patt< ~{$lid:i$ : $t$} >>
2752       | i = V QUESTIONIDENTCOLON; j = LIDENT ->
2753            <:patt< ?{$_:i$ = ?{$lid:j$}} >>
2754       | i = V QUESTIONIDENTCOLON; "_" ->
2755            <:patt< ?{$_:i$} >>
2756       | i = V QUESTIONIDENTCOLON; "("; p = patt; "="; e = expr; ")" ->
2757           <:patt< ?{$_:i$ = ?{$p$ = $e$}} >>
2758       | i = V QUESTIONIDENTCOLON; "("; p = patt; ":"; t = ctyp; ")" ->
2759           <:patt< ?{$_:i$ = ?{$p$ : $t$}} >>
2760       | i = V QUESTIONIDENTCOLON; "("; p = patt; ":"; t = ctyp; "=";
2761         e = expr; ")" ->
2762           <:patt< ?{$_:i$ = ?{$p$ : $t$ = $e$}} >>
2763       | i = V QUESTIONIDENTCOLON; "("; p = patt; ")" ->
2764           <:patt< ?{$_:i$ = ?{$p$}} >>
2765       | i = V QUESTIONIDENT -> <:patt< ?{$_:i$} >>
2766       | "?"; "("; i = LIDENT; "="; e = expr; ")" ->
2767           <:patt< ?{$lid:i$ = $e$} >>
2768       | "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" ->
2769           <:patt< ?{$lid:i$ : $t$ = $e$} >>
2770       | "?"; "("; i = LIDENT; ")" ->
2771           <:patt< ?{$lid:i$} >>
2772       | "?"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
2773           <:patt< ?{$lid:i$ : $t$} >> ] ]
2774   ;
2775   class_type:
2776     [ [ i = LIDENT; ":"; t = ctyp LEVEL "apply"; "->"; ct = SELF ->
2777           <:class_type< [ ~$i$: $t$ ] -> $ct$ >>
2778       | i = V QUESTIONIDENTCOLON; t = ctyp LEVEL "apply"; "->"; ct = SELF ->
2779           <:class_type< [ ?$_:i$: $t$ ] -> $ct$ >>
2780       | i = V QUESTIONIDENT; ":"; t = ctyp LEVEL "apply"; "->"; ct = SELF ->
2781           <:class_type< [ ?$_:i$: $t$ ] -> $ct$ >> ] ]
2782   ;
2783   class_fun_binding:
2784     [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
2785   ;
2786   class_fun_def:
2787     [ [ p = labeled_patt; "->"; ce = class_expr ->
2788           <:class_expr< fun $p$ -> $ce$ >>
2789       | p = labeled_patt; cfd = SELF ->
2790           <:class_expr< fun $p$ -> $cfd$ >> ] ]
2791   ;
2792 END;
2793
2794 (* Main entry points *)
2795
2796 EXTEND
2797   GLOBAL: interf implem use_file top_phrase expr patt;
2798   interf:
2799     [ [ si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
2800       | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2801           ([(<:sig_item< # $lid:n$ $opt:dp$ >>, loc)], None)
2802       | EOI -> ([], Some loc) ] ]
2803   ;
2804   sig_item_semi:
2805     [ [ si = sig_item; OPT ";;" -> (si, loc) ] ]
2806   ;
2807   implem:
2808     [ [ si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
2809       | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2810           ([(<:str_item< # $lid:n$ $opt:dp$ >>, loc)], None)
2811       | EOI -> ([], Some loc) ] ]
2812   ;
2813   str_item_semi:
2814     [ [ si = str_item; OPT ";;" -> (si, loc) ] ]
2815   ;
2816   top_phrase:
2817     [ [ ph = phrase; ";;" -> Some ph
2818       | EOI -> None ] ]
2819   ;
2820   use_file:
2821     [ [ si = str_item; OPT ";;"; (sil, stopped) = SELF ->
2822           ([si :: sil], stopped)
2823       | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2824           ([<:str_item< # $lid:n$ $opt:dp$ >>], True)
2825       | EOI -> ([], False) ] ]
2826   ;
2827   phrase:
2828     [ [ sti = str_item -> sti
2829       | "#"; n = LIDENT; dp = OPT expr ->
2830           <:str_item< # $lid:n$ $opt:dp$ >> ] ]
2831   ;
2832 END;
2833
2834 Pcaml.add_option "-no_quot" (Arg.Set no_quotations)
2835   "Don't parse quotations, allowing to use, e.g. \"<:>\" as token";
2836
2837 (* ------------------------------------------------------------------------- *)
2838 (* Added by JRH ***                                                          *)
2839 (* ------------------------------------------------------------------------- *)
2840
2841 EXTEND
2842   expr: AFTER "<"
2843    [[ f = expr; "o"; g = expr -> <:expr< ((o $f$) $g$) >>
2844     | f = expr; "upto"; g = expr -> <:expr< ((upto $f$) $g$) >>
2845     | f = expr; "F_F"; g = expr -> <:expr< ((f_f_ $f$) $g$) >>
2846     | f = expr; "THENC"; g = expr -> <:expr< ((thenc_ $f$) $g$) >>
2847     | f = expr; "THEN"; g = expr -> <:expr< ((then_ $f$) $g$) >>
2848     | f = expr; "THENL"; g = expr -> <:expr< ((thenl_ $f$) $g$) >>
2849     | f = expr; "ORELSE"; g = expr -> <:expr< ((orelse_ $f$) $g$) >>
2850     | f = expr; "ORELSEC"; g = expr -> <:expr< ((orelsec_ $f$) $g$) >>
2851     | f = expr; "THEN_TCL"; g = expr -> <:expr< ((then_tcl_ $f$) $g$) >>
2852     | f = expr; "ORELSE_TCL"; g = expr -> <:expr< ((orelse_tcl_ $f$) $g$) >>
2853 ]];
2854 END;
2855
2856 EXTEND
2857   top_phrase:
2858    [ [ sti = str_item; ";;" ->
2859          match sti with
2860          [ <:str_item< $exp:e$ >> -> Some <:str_item< value it = $e$ >>
2861          | x -> Some x ] ] ]
2862   ;
2863 END;