← Back to branch summary

~ubuntu-branches/debian/sid/ocaml/sid

« back to all changes in this revision

Viewing changes to camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu
  • Date: 2011-04-21 21:35:08 UTC
  • mfrom: (1.1.11 upstream) (12.1.14 sid)
  • Revision ID: james.westby@ubuntu.com-20110421213508-kg34453aqmb0moha
* Fixes related to -output-obj with g++ (in debian/patches):
  - add Declare-primitive-name-table-as-const-char
  - add Avoid-multiple-declarations-in-generated-.c-files-in
  - fix Embed-bytecode-in-C-object-when-using-custom: the closing
    brace for extern "C" { ... } was missing in some cases

Show diffs side-by-side

added added

removed removed

Lines of Context:
camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
74
74
    | _ -> { (t) with ptyp_desc = Ptyp_poly [] t } ]
75
75
  ;
76
76
 
77
 
  value mb2b =
78
 
    fun
79
 
    [ Ast.BTrue -> True
80
 
    | Ast.BFalse -> False
81
 
    | Ast.BAnt _ -> assert False ];
 
77
  value mkvirtual = fun
 
78
    [ <:virtual_flag< virtual >> -> Virtual
 
79
    | <:virtual_flag<>> -> Concrete
 
80
    | _ -> assert False ];
82
81
 
83
 
  value mkvirtual m = if mb2b m then Virtual else Concrete;
 
82
  value mkdirection = fun
 
83
    [ <:direction_flag< to >> -> Upto
 
84
    | <:direction_flag< downto >> -> Downto
 
85
    | _ -> assert False ];
84
86
 
85
87
  value lident s = Lident s;
86
88
  value ldot l s = Ldot l s;
110
112
 
111
113
  value mkrf =
112
114
    fun
113
 
    [ Ast.BTrue -> Recursive
114
 
    | Ast.BFalse -> Nonrecursive
115
 
    | Ast.BAnt _ -> assert False ];
 
115
    [ <:rec_flag< rec >> -> Recursive
 
116
    | <:rec_flag<>> -> Nonrecursive
 
117
    | _ -> assert False ];
116
118
 
117
119
  value mkli s = loop lident
118
120
    where rec loop f =
232
234
        mktyp loc (Ptyp_object (meth_list fl [mkfield loc Pfield_var]))
233
235
    | TyCls loc id ->
234
236
        mktyp loc (Ptyp_class (ident id) [] [])
 
237
    | <:ctyp@loc< (module $pt$) >> ->
 
238
        let (i, cs) = package_type pt in
 
239
        mktyp loc (Ptyp_package i cs)
235
240
    | TyLab loc _ _ -> error loc "labelled type not allowed here"
236
241
    | TyMan loc _ _ -> error loc "manifest type not allowed here"
237
242
    | TyOlb loc _ _ -> error loc "labelled type not allowed here"
256
261
    | TyAnt loc _ -> error loc "antiquotation not allowed here"
257
262
    | TyOfAmp _ _ _ |TyAmp _ _ _ |TySta _ _ _ |
258
263
      TyCom _ _ _ |TyVrn _ _ |TyQuM _ _ |TyQuP _ _ |TyDcl _ _ _ _ _ |
259
 
      TyObj _ _ (BAnt _) | TyNil _ | TyTup _ _ ->
 
264
      TyObj _ _ (RvAnt _) | TyNil _ | TyTup _ _ ->
260
265
        assert False ]
261
266
  and row_field = fun
262
267
    [ <:ctyp<>> -> []
276
281
    | <:ctyp@loc< $lid:lab$ : $t$ >> ->
277
282
        [mkfield loc (Pfield lab (mkpolytype (ctyp t))) :: acc]
278
283
    | _ -> assert False ]
 
284
 
 
285
  and package_type_constraints wc acc =
 
286
    match wc with
 
287
    [ <:with_constr<>> -> acc
 
288
    | <:with_constr< type $lid:id$ = $ct$ >> ->
 
289
        [(id, ctyp ct) :: acc]
 
290
    | <:with_constr< $wc1$ and $wc2$ >> ->
 
291
        package_type_constraints wc1 (package_type_constraints wc2 acc)
 
292
    | _ -> error (loc_of_with_constr wc) "unexpected `with constraint' for a package type" ]
 
293
 
 
294
  and package_type : module_type -> package_type =
 
295
    fun
 
296
    [ <:module_type< $id:i$ with $wc$ >> ->
 
297
      (long_uident i, package_type_constraints wc [])
 
298
    | <:module_type< $id:i$ >> -> (long_uident i, [])
 
299
    | mt -> error (loc_of_module_type mt) "unexpected package type" ]
279
300
  ;
280
301
 
281
302
  value mktype loc tl cl tk tp tm =
285
306
     ptype_variance = variance}
286
307
  ;
287
308
  value mkprivate' m = if m then Private else Public;
288
 
  value mkprivate m = mkprivate' (mb2b m);
 
309
  value mkprivate = fun
 
310
    [ <:private_flag< private >> -> Private
 
311
    | <:private_flag<>> -> Public
 
312
    | _ -> assert False ];
289
313
  value mktrecord =
290
314
    fun
291
315
    [ <:ctyp@loc< $lid:s$ : mutable $t$ >> ->
332
356
    | Ast.LCons x xs -> [x :: list_of_meta_list xs]
333
357
    | Ast.LAnt _ -> assert False ];
334
358
 
335
 
  value mkmutable m = if mb2b m then Mutable else Immutable;
 
359
  value mkmutable = fun
 
360
    [ <:mutable_flag< mutable >> -> Mutable
 
361
    | <:mutable_flag<>> -> Immutable
 
362
    | _ -> assert False ];
336
363
 
337
364
  value paolab lab p =
338
365
    match (lab, p) with
370
397
    | <:ctyp< $id:i$ >> -> (ident i, acc)
371
398
    | _ -> assert False ];
372
399
 
 
400
  value mkwithtyp pwith_type loc id_tpl ct =
 
401
    let (id, tpl) = type_parameters_and_type_name id_tpl [] in
 
402
    let (params, variance) = List.split tpl in
 
403
    let (kind, priv, ct) = opt_private_ctyp ct in
 
404
    (id, pwith_type
 
405
      {ptype_params = params; ptype_cstrs = [];
 
406
        ptype_kind = kind;
 
407
        ptype_private = priv;
 
408
        ptype_manifest = Some ct;
 
409
        ptype_loc = mkloc loc; ptype_variance = variance});
 
410
 
373
411
  value rec mkwithc wc acc =
374
412
    match wc with
375
 
    [ WcNil _ -> acc
376
 
    | WcTyp loc id_tpl ct ->
377
 
        let (id, tpl) = type_parameters_and_type_name id_tpl [] in
378
 
        let (params, variance) = List.split tpl in
379
 
        let (kind, priv, ct) = opt_private_ctyp ct in
380
 
        [(id,
381
 
        Pwith_type
382
 
          {ptype_params = params; ptype_cstrs = [];
383
 
            ptype_kind = kind;
384
 
            ptype_private = priv;
385
 
            ptype_manifest = Some ct;
386
 
            ptype_loc = mkloc loc; ptype_variance = variance}) :: acc]
387
 
    | WcMod _ i1 i2 ->
 
413
    [ <:with_constr<>> -> acc
 
414
    | <:with_constr@loc< type $id_tpl$ = $ct$ >> ->
 
415
        [mkwithtyp (fun x -> Pwith_type x) loc id_tpl ct :: acc]
 
416
    | <:with_constr< module $i1$ = $i2$ >> ->
388
417
        [(long_uident i1, Pwith_module (long_uident i2)) :: acc]
 
418
    | <:with_constr@loc< type $id_tpl$ := $ct$ >> ->
 
419
        [mkwithtyp (fun x -> Pwith_typesubst x) loc id_tpl ct :: acc]
 
420
    | <:with_constr< module $i1$ := $i2$ >> (*WcMoS _ i1 i2*) ->
 
421
        [(long_uident i1, Pwith_modsubst (long_uident i2)) :: acc]
389
422
    | <:with_constr< $wc1$ and $wc2$ >> -> mkwithc wc1 (mkwithc wc2 acc)
390
423
    | <:with_constr@loc< $anti:_$ >> ->
391
424
         error loc "bad with constraint (antiquotation)" ];
490
523
            mkrangepat loc c1 c2
491
524
        | _ -> error loc "range pattern allowed only for characters" ]
492
525
    | PaRec loc p ->
493
 
        mkpat loc (Ppat_record (List.map mklabpat (list_of_patt p [])))
 
526
        let ps = list_of_patt p [] in
 
527
        let is_wildcard = fun [ <:patt< _ >> -> True | _ -> False ] in
 
528
        let (wildcards,ps) = List.partition is_wildcard ps in
 
529
        let is_closed = if wildcards = [] then Closed else Open in
 
530
        mkpat loc (Ppat_record (List.map mklabpat ps, is_closed))
494
531
    | PaStr loc s ->
495
532
        mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s)))
496
533
    | <:patt@loc< ($p1$, $p2$) >> ->
541
578
    | e -> [(loc_of_expr e, [], e) :: l] ]
542
579
  ;
543
580
 
 
581
  value override_flag loc =
 
582
    fun [ <:override_flag< ! >> -> Override
 
583
        | <:override_flag<>> -> Fresh
 
584
        |  _ -> error loc "antiquotation not allowed here"
 
585
        ];
 
586
 
544
587
  value list_of_opt_ctyp ot acc =
545
588
    match ot with
546
589
    [ <:ctyp<>> -> acc
639
682
    | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float (remove_underscores s)))
640
683
    | ExFor loc i e1 e2 df el ->
641
684
        let e3 = ExSeq loc el in
642
 
        let df = if mb2b df then Upto else Downto in
643
 
        mkexp loc (Pexp_for i (expr e1) (expr e2) df (expr e3))
 
685
        mkexp loc (Pexp_for i (expr e1) (expr e2) (mkdirection df) (expr e3))
644
686
    | <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> ->
645
687
        mkexp loc
646
688
          (Pexp_function lab None
731
773
    | ExWhi loc e1 el ->
732
774
        let e2 = ExSeq loc el in
733
775
        mkexp loc (Pexp_while (expr e1) (expr e2))
 
776
    | <:expr@loc< let open $i$ in $e$ >> ->
 
777
        mkexp loc (Pexp_open (long_uident i) (expr e))
 
778
    | <:expr@loc< (module $me$ : $pt$) >> ->
 
779
        mkexp loc (Pexp_pack (module_expr me) (package_type pt))
 
780
    | <:expr@loc< (module $_$) >> ->
 
781
        error loc "(module_expr : package_type) expected here"
 
782
    | ExFUN loc i e ->
 
783
        mkexp loc (Pexp_newtype i (expr e))
734
784
    | <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here"
735
785
    | <:expr@loc< $_$;$_$ >> ->
736
786
        error loc "expr; expr: not allowed here, use do {...} or [|...|] to surround them"
752
802
    match x with
753
803
    [ <:binding< $x$ and $y$ >> ->
754
804
         binding x (binding y acc)
 
805
    | <:binding@_loc< $p$ = ($e$ : ! $vs$ . $ty$) >> ->
 
806
        [(patt <:patt< ($p$ : ! $vs$ . $ty$ ) >>, expr e) :: acc]
755
807
    | <:binding< $p$ = $e$ >> -> [(patt p, expr e) :: acc]
756
808
    | <:binding<>> -> acc
757
809
    | _ -> assert False ]
865
917
        mkmod loc (Pmod_structure (str_item sl []))
866
918
    | <:module_expr@loc< ($me$ : $mt$) >> ->
867
919
        mkmod loc (Pmod_constraint (module_expr me) (module_type mt))
 
920
    | <:module_expr@loc< (value $e$ : $pt$) >> ->
 
921
        mkmod loc (Pmod_unpack (expr e) (package_type pt))
 
922
    | <:module_expr@loc< (value $_$) >> ->
 
923
        error loc "(value expr) not supported yet"
868
924
    | <:module_expr@loc< $anti:_$ >> -> error loc "antiquotation in module_expr" ]
869
925
  and str_item s l =
870
926
    match s with
900
956
    | <:str_item@loc< $anti:_$ >> -> error loc "antiquotation in str_item" ]
901
957
  and class_type =
902
958
    fun
903
 
    [ CtCon loc Ast.BFalse id tl ->
 
959
    [ CtCon loc ViNil id tl ->
904
960
        mkcty loc
905
961
          (Pcty_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl [])))
906
962
    | CtFun loc (TyLab _ lab t) ct ->
930
986
        [ <:ctyp<>> -> (loc, ([], []))
931
987
        | t -> (loc_of_ctyp t, List.split (class_parameters t [])) ]
932
988
      in
933
 
      {pci_virt = if mb2b vir then Virtual else Concrete;
 
989
      {pci_virt = mkvirtual vir;
934
990
       pci_params = (params, mkloc loc_params);
935
991
       pci_name = name;
936
992
       pci_expr = class_expr ce;
946
1002
        [ <:ctyp<>> -> (loc, ([], []))
947
1003
        | t -> (loc_of_ctyp t, List.split (class_parameters t [])) ]
948
1004
      in
949
 
      {pci_virt = if mb2b vir then Virtual else Concrete;
 
1005
      {pci_virt = mkvirtual vir;
950
1006
       pci_params = (params, mkloc loc_params);
951
1007
       pci_name = name;
952
1008
       pci_expr = class_type ct;
974
1030
        let (ce, el) = class_expr_fa [] c in
975
1031
        let el = List.map label_expr el in
976
1032
        mkpcl loc (Pcl_apply (class_expr ce) el)
977
 
    | CeCon loc Ast.BFalse id tl ->
 
1033
    | CeCon loc ViNil id tl ->
978
1034
        mkpcl loc
979
1035
          (Pcl_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl [])))
980
1036
    | CeFun loc (PaLab _ lab po) ce ->
1009
1065
    | CrCtr loc t1 t2 -> [Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l]
1010
1066
    | <:class_str_item< $cst1$; $cst2$ >> ->
1011
1067
        class_str_item cst1 (class_str_item cst2 l)
1012
 
    | CrInh _ ce "" -> [Pcf_inher (class_expr ce) None :: l]
1013
 
    | CrInh _ ce pb -> [Pcf_inher (class_expr ce) (Some pb) :: l]
 
1068
    | CrInh loc ov ce pb ->
 
1069
        let opb = if pb = "" then None else Some pb in
 
1070
        [Pcf_inher (override_flag loc ov) (class_expr ce) opb :: l]
1014
1071
    | CrIni _ e -> [Pcf_init (expr e) :: l]
1015
 
    | CrMth loc s b e t ->
 
1072
    | CrMth loc s ov pf e t ->
1016
1073
        let t =
1017
1074
          match t with
1018
1075
          [ <:ctyp<>> -> None
1019
1076
          | t -> Some (mkpolytype (ctyp t)) ] in
1020
1077
        let e = mkexp loc (Pexp_poly (expr e) t) in
1021
 
        [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l]
1022
 
    | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l]
1023
 
    | CrVir loc s b t ->
1024
 
        [Pcf_virt (s, mkprivate b, mkpolytype (ctyp t), mkloc loc) :: l]
1025
 
    | CrVvr loc s b t ->
1026
 
        [Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l]
 
1078
        [Pcf_meth (s, mkprivate pf, override_flag loc ov, e, mkloc loc) :: l]
 
1079
    | CrVal loc s ov mf e ->
 
1080
        [Pcf_val (s, mkmutable mf, override_flag loc ov, expr e, mkloc loc) :: l]
 
1081
    | CrVir loc s pf t ->
 
1082
        [Pcf_virt (s, mkprivate pf, mkpolytype (ctyp t), mkloc loc) :: l]
 
1083
    | CrVvr loc s mf t ->
 
1084
        [Pcf_valvirt (s, mkmutable mf, ctyp t, mkloc loc) :: l]
1027
1085
    | CrAnt _ _ -> assert False ];
1028
1086
 
1029
1087
  value sig_item ast = sig_item ast [];