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