← Back to branch summary

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

« back to all changes in this revision

Viewing changes to camlp4/Camlp4/Printers/OCaml.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/Printers/OCaml.ml
27
27
  include Syntax;
28
28
 
29
29
  type sep = format unit formatter unit;
 
30
  type fun_binding = [= `patt of Ast.patt | `newtype of string ];
30
31
 
31
32
  value pp = fprintf;
32
33
  value cut f = fprintf f "@ ";
55
56
    fun
56
57
    [ Ast.LNil -> []
57
58
    | Ast.LCons x xs -> [x :: list_of_meta_list xs]
58
 
    | Ast.LAnt x -> assert False ];
 
59
    | Ast.LAnt _ -> assert False ];
59
60
 
60
61
  value meta_list elt sep f mxs =
61
62
    let xs = list_of_meta_list mxs in
132
133
    [ <:expr< fun $p$ -> $e$ >> as ge ->
133
134
        if is_irrefut_patt p then
134
135
          let (pl, e) = expr_fun_args e in
135
 
          ([p :: pl], e)
 
136
          ([`patt p :: pl], e)
136
137
        else ([], ge)
 
138
    | <:expr< fun (type $i$) -> $e$ >> ->
 
139
        let (pl, e) = expr_fun_args e in
 
140
        ([`newtype i :: pl], e)
137
141
    | ge -> ([], ge) ];
138
142
 
139
143
  value rec class_expr_fun_args =
165
169
    method reset =      {< pipe = False; semi = False >};
166
170
 
167
171
    value semisep : sep = ";;";
168
 
    value andsep : sep = "@]@ @[<2>and@ ";
169
 
    value value_val = "val";
170
 
    value value_let = "let";
171
172
    value mode = if comments then `comments else `no_comments;
172
173
    value curry_constr = init_curry_constr;
173
174
    value var_conversion = False;
174
175
 
 
176
    method andsep : sep = "@]@ @[<2>and@ ";
 
177
    method value_val = "val";
 
178
    method value_let = "let";
 
179
 
175
180
    method semisep = semisep;
176
181
    method set_semisep s = {< semisep = s >};
177
182
    method set_comments b = {< mode = if b then `comments else `no_comments >};
228
233
          pp f "@[<1>%a,@ %a@]" o#class_params t1 o#class_params t2
229
234
      | x -> o#ctyp f x ];
230
235
 
231
 
    method mutable_flag f b = o#flag f b "mutable";
232
 
    method rec_flag f b = o#flag f b "rec";
233
 
    method virtual_flag f b = o#flag f b "virtual";
234
 
    method private_flag f b = o#flag f b "private";
235
 
    method flag f b n =
236
 
      match b with
237
 
      [ Ast.BTrue -> do { pp_print_string f n; pp f "@ " }
238
 
      | Ast.BFalse -> ()
239
 
      | Ast.BAnt s -> o#anti f s ];
 
236
    method override_flag f =
 
237
      fun
 
238
      [ Ast.OvOverride -> pp f "!"
 
239
      | Ast.OvNil -> ()
 
240
      | Ast.OvAnt s -> o#anti f s ];
 
241
 
 
242
    method mutable_flag f = fun
 
243
      [ Ast.MuMutable -> pp f "mutable@ "
 
244
      | Ast.MuNil -> ()
 
245
      | Ast.MuAnt s -> o#anti f s ];
 
246
 
 
247
    method rec_flag f = fun
 
248
      [ Ast.ReRecursive -> pp f "rec@ "
 
249
      | Ast.ReNil -> ()
 
250
      | Ast.ReAnt s -> o#anti f s ];
 
251
 
 
252
    method virtual_flag f = fun
 
253
      [ Ast.ViVirtual -> pp f "virtual@ "
 
254
      | Ast.ViNil -> ()
 
255
      | Ast.ViAnt s -> o#anti f s ];
 
256
 
 
257
    method private_flag f = fun
 
258
      [ Ast.PrPrivate -> pp f "private@ "
 
259
      | Ast.PrNil -> ()
 
260
      | Ast.PrAnt s -> o#anti f s ];
240
261
 
241
262
    method anti f s = pp f "$%s$" s;
242
263
 
269
290
          pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]"
270
291
            o#patt p o#under_pipe#expr w o#under_pipe#expr e ];
271
292
 
 
293
    method fun_binding f =
 
294
      fun
 
295
      [ `patt p -> o#simple_patt f p
 
296
      | `newtype i -> pp f "(type %s)" i ];
 
297
 
272
298
    method binding f bi =
273
299
      let () = o#node f bi Ast.loc_of_binding in
274
300
      match bi with
275
301
      [ <:binding<>> -> ()
276
302
      | <:binding< $b1$ and $b2$ >> ->
277
 
          do { o#binding f b1; pp f andsep; o#binding f b2 }
 
303
          do { o#binding f b1; pp f o#andsep; o#binding f b2 }
278
304
      | <:binding< $p$ = $e$ >> ->
279
305
          let (pl, e) =
280
306
            match p with
283
309
          match (p, e) with
284
310
          [ (<:patt< $lid:_$ >>, <:expr< ($e$ : $t$) >>) ->
285
311
              pp f "%a :@ %a =@ %a"
286
 
                (list o#simple_patt "@ ") [p::pl] o#ctyp t o#expr e
 
312
                (list o#fun_binding "@ ") [`patt p::pl] o#ctyp t o#expr e
287
313
          | _ -> pp f "%a @[<0>%a=@]@ %a" o#simple_patt
288
 
                    p (list' o#simple_patt "" "@ ") pl o#expr e ]
 
314
                    p (list' o#fun_binding "" "@ ") pl o#expr e ]
289
315
      | <:binding< $anti:s$ >> -> o#anti f s ];
290
316
 
291
317
    method record_binding f bi =
331
357
 
332
358
    method patt_expr_fun_args f (p, e) =
333
359
      let (pl, e) = expr_fun_args e
334
 
      in pp f "%a@ ->@ %a" (list o#simple_patt "@ ") [p::pl] o#expr e;
 
360
      in pp f "%a@ ->@ %a" (list o#fun_binding "@ ") [p::pl] o#expr e;
335
361
 
336
362
    method patt_class_expr_fun_args f (p, ce) =
337
363
      let (pl, ce) = class_expr_fun_args ce
374
400
           pp f "@[<2>%a :@ %a@]" o#var s o#module_type mt
375
401
      | <:module_binding< $mb1$ and $mb2$ >> ->
376
402
          do { o#module_rec_binding f mb1;
377
 
               pp f andsep;
 
403
               pp f o#andsep;
378
404
               o#module_rec_binding f mb2 }
379
405
      | <:module_binding< $anti:s$ >> -> o#anti f s ];
380
406
 
432
458
          | [_] -> pp f "@[<2>%a@ %a@]" o#apply_expr x o#apply_expr y
433
459
          | al ->
434
460
              pp f "@[<2>%a@ (%a)@]" o#apply_expr a
435
 
                 (list o#under_pipe#expr ",@ ") al ]
 
461
                 (* The #apply_expr below may put too much parens.
 
462
                    However using #expr would be wrong: PR#5056. *)
 
463
                 (list o#under_pipe#apply_expr ",@ ") al ]
436
464
        else pp f "@[<2>%a@]" (list o#apply_expr "@ ") [a::al]
437
465
    | <:expr< $e1$.val := $e2$ >> ->
438
466
        pp f "@[<2>%a :=@ %a@]" o#dot_expr e1 o#expr e2
441
469
    | <:expr@loc< fun [] >> ->
442
470
        pp f "@[<2>fun@ _@ ->@ %a@]" o#raise_match_failure loc
443
471
    | <:expr< fun $p$ -> $e$ >> when is_irrefut_patt p ->
444
 
        pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (p, e)
 
472
        pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`patt p, e)
 
473
    | <:expr< fun (type $i$) -> $e$ >> ->
 
474
        pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`newtype i, e)
445
475
    | <:expr< fun [ $a$ ] >> ->
446
476
        pp f "@[<hv0>function%a@]" o#match_case a
447
477
    | <:expr< if $e1$ then $e2$ else $e3$ >> ->
456
486
        | _ ->
457
487
            pp f "@[<hv0>@[<2>let %a%a@]@ @[<hv2>in@ %a@]@]"
458
488
              o#rec_flag r o#binding bi o#reset_semi#expr e ]
 
489
    | <:expr< let open $i$ in $e$ >> ->
 
490
        pp f "@[<2>let open %a@]@ @[<2>in@ %a@]"
 
491
             o#ident i o#reset_semi#expr e
459
492
    | <:expr< match $e$ with [ $a$ ] >> ->
460
493
        pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]"
461
494
          o#expr e o#match_case a
541
574
        pp f "%a,@ %a" o#simple_expr e1 o#simple_expr e2
542
575
    | <:expr< $e1$; $e2$ >> ->
543
576
        pp f "%a;@ %a" o#under_semi#expr e1 o#expr e2
 
577
    | <:expr< (module $me$ : $mt$) >> ->
 
578
        pp f "@[<hv0>@[<hv2>(module %a : %a@])@]"
 
579
           o#module_expr me o#module_type mt
 
580
    | <:expr< (module $me$) >> ->
 
581
        pp f "@[<hv0>@[<hv2>(module %a@])@]" o#module_expr me
544
582
    | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> |
545
583
      <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> |
546
584
      <:expr< $_$ # $_$ >> |
547
 
      <:expr< fun [ $_$ ] >> | <:expr< match $_$ with [ $_$ ] >> |
 
585
      <:expr< fun [ $_$ ] >> | <:expr< fun (type $_$) -> $_$ >> | <:expr< match $_$ with [ $_$ ] >> |
548
586
      <:expr< try $_$ with [ $_$ ] >> |
549
587
      <:expr< if $_$ then $_$ else $_$ >> |
550
588
      <:expr< let $rec:_$ $_$ in $_$ >> |
551
589
      <:expr< let module $_$ = $_$ in $_$ >> |
 
590
      <:expr< let open $_$ in $_$ >> |
552
591
      <:expr< assert $_$ >> | <:expr< assert False >> |
553
592
      <:expr< lazy $_$ >> | <:expr< new $_$ >> |
554
593
      <:expr< object ($_$) $_$ end >> ->
556
595
 
557
596
    method direction_flag f b =
558
597
      match b with
559
 
      [ Ast.BTrue -> pp_print_string f "to"
560
 
      | Ast.BFalse -> pp_print_string f "downto"
561
 
      | Ast.BAnt s -> o#anti f s ];
 
598
      [ Ast.DiTo -> pp_print_string f "to"
 
599
      | Ast.DiDownto -> pp_print_string f "downto"
 
600
      | Ast.DiAnt s -> o#anti f s ];
562
601
 
563
602
    method patt f p =
564
603
    let () = o#node f p Ast.loc_of_patt in match p with
665
704
    | <:ctyp< { $t$ } >> -> pp f "@[<2>{@ %a@]@ }" o#ctyp t
666
705
    | <:ctyp< [ $t$ ] >> -> pp f "@[<0>%a@]" o#sum_type t
667
706
    | <:ctyp< ( $tup:t$ ) >> -> pp f "@[<1>(%a)@]" o#ctyp t
 
707
    | <:ctyp< (module $mt$) >> -> pp f "@[<2>(module@ %a@])" o#module_type mt
668
708
    | <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[@ %a@]@ ]" o#sum_type t
669
709
    | <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[<@ %a@]@,]" o#sum_type t
670
710
    | <:ctyp< [ < $t1$ > $t2$ ] >> ->
673
713
          (list o#simple_ctyp "@ ") [a::al]
674
714
    | <:ctyp< [ > $t$ ] >> -> pp f "@[<2>[>@ %a@]@,]" o#sum_type t
675
715
    | <:ctyp< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i
676
 
    | <:ctyp< $t1$ == $t2$ >> ->
677
 
        pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2
678
716
    | <:ctyp< `$s$ >> -> pp f "`%a" o#var s
679
717
    | <:ctyp< $t1$ * $t2$ >> -> pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2
680
718
    | <:ctyp<>> -> assert False
700
738
    | <:ctyp< $t1$ and $t2$ >> -> pp f "%a@ and %a" o#ctyp t1 o#ctyp t2
701
739
    | <:ctyp< mutable $t$ >> -> pp f "@[<2>mutable@ %a@]" o#ctyp t
702
740
    | <:ctyp< $t1$ & $t2$ >> -> pp f "%a@ &@ %a" o#ctyp t1 o#ctyp t2
 
741
    | <:ctyp< $t1$ == $t2$ >> ->
 
742
        pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 o#ctyp t2
703
743
    | Ast.TyDcl _ tn tp te cl -> do {
704
744
        pp f "@[<2>%a%a@]" o#type_params tp o#var tn;
705
745
        match te with
766
806
          pp f "@[<hv0>@[<hv2>type %a@]%(%)@]" o#ctyp t semisep
767
807
      | <:sig_item< value $s$ : $t$ >> ->
768
808
          pp f "@[<2>%s %a :@ %a%(%)@]"
769
 
            value_val o#var s o#ctyp t semisep
 
809
            o#value_val o#var s o#ctyp t semisep
770
810
      | <:sig_item< include $mt$ >> ->
771
811
          pp f "@[<2>include@ %a%(%)@]" o#module_type mt semisep
772
812
      | <:sig_item< class type $ct$ >> ->
818
858
      | <:str_item< type $t$ >> ->
819
859
            pp f "@[<hv0>@[<hv2>type %a@]%(%)@]" o#ctyp t semisep
820
860
      | <:str_item< value $rec:r$ $bi$ >> ->
821
 
            pp f "@[<2>%s %a%a%(%)@]" value_let o#rec_flag r o#binding bi semisep
 
861
            pp f "@[<2>%s %a%a%(%)@]" o#value_let o#rec_flag r o#binding bi semisep
822
862
      | <:str_item< $exp:e$ >> ->
823
863
            pp f "@[<2>let _ =@ %a%(%)@]" o#expr e semisep
824
864
      | <:str_item< include $me$ >> ->
856
896
          pp f "@[<2>type@ %a =@ %a@]" o#ctyp t1 o#ctyp t2
857
897
    | <:with_constr< module $i1$ = $i2$ >> ->
858
898
          pp f "@[<2>module@ %a =@ %a@]" o#ident i1 o#ident i2
 
899
    | <:with_constr< type $t1$ := $t2$ >> ->
 
900
          pp f "@[<2>type@ %a :=@ %a@]" o#ctyp t1 o#ctyp t2
 
901
    | <:with_constr< module $i1$ := $i2$ >> ->
 
902
          pp f "@[<2>module@ %a :=@ %a@]" o#ident i1 o#ident i2
859
903
    | <:with_constr< $wc1$ and $wc2$ >> ->
860
 
          do { o#with_constraint f wc1; pp f andsep; o#with_constraint f wc2 }
 
904
          do { o#with_constraint f wc1; pp f o#andsep; o#with_constraint f wc2 }
861
905
    | <:with_constr< $anti:s$ >> -> o#anti f s ];
862
906
 
863
907
    method module_expr f me =
882
926
    | <:module_expr< struct $st$ end >> ->
883
927
          pp f "@[<hv0>@[<hv2>struct@ %a@]@ end@]" o#str_item st
884
928
    | <:module_expr< ( $me$ : $mt$ ) >> ->
885
 
          pp f "@[<1>(%a :@ %a)@]" o#module_expr me o#module_type mt ];
 
929
          pp f "@[<1>(%a :@ %a)@]" o#module_expr me o#module_type mt
 
930
    | <:module_expr< (value $e$ : $mt$ ) >> ->
 
931
          pp f "@[<1>(%s %a :@ %a)@]" o#value_val o#expr e o#module_type mt
 
932
    | <:module_expr< (value $e$ ) >> ->
 
933
          pp f "@[<1>(%s %a)@]" o#value_val o#expr e
 
934
    ];
886
935
 
887
936
    method class_expr f ce =
888
937
    let () = o#node f ce Ast.loc_of_class_expr in
911
960
          pp f "@[<1>(%a :@ %a)@]" o#class_expr ce o#class_type ct
912
961
    | <:class_expr< $anti:s$ >> -> o#anti f s
913
962
    | <:class_expr< $ce1$ and $ce2$ >> ->
914
 
          do { o#class_expr f ce1; pp f andsep; o#class_expr f ce2 }
 
963
          do { o#class_expr f ce1; pp f o#andsep; o#class_expr f ce2 }
915
964
    | <:class_expr< $ce1$ = fun $p$ -> $ce2$ >> when is_irrefut_patt p ->
916
965
          pp f "@[<2>%a@ %a" o#class_expr ce1
917
966
            o#patt_class_expr_fun_args (p, ce2)
939
988
            o#ctyp t o#class_sig_item csg
940
989
    | <:class_type< $anti:s$ >> -> o#anti f s
941
990
    | <:class_type< $ct1$ and $ct2$ >> ->
942
 
          do { o#class_type f ct1; pp f andsep; o#class_type f ct2 }
 
991
          do { o#class_type f ct1; pp f o#andsep; o#class_type f ct2 }
943
992
    | <:class_type< $ct1$ : $ct2$ >> ->
944
993
          pp f "%a :@ %a" o#class_type ct1 o#class_type ct2
945
994
    | <:class_type< $ct1$ = $ct2$ >> ->
967
1016
              o#private_flag pr o#var s o#ctyp t semisep
968
1017
      | <:class_sig_item< value $mutable:mu$ $virtual:vi$ $s$ : $t$ >> ->
969
1018
            pp f "@[<2>%s %a%a%a :@ %a%(%)@]"
970
 
              value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t
 
1019
              o#value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t
971
1020
              semisep
972
1021
      | <:class_sig_item< $anti:s$ >> ->
973
1022
            pp f "%a%(%)" o#anti s semisep ];
983
1032
            do { o#class_str_item f cst1; cut f; o#class_str_item f cst2 }
984
1033
      | <:class_str_item< constraint $t1$ = $t2$ >> ->
985
1034
            pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 semisep
986
 
      | <:class_str_item< inherit $ce$ >> ->
987
 
            pp f "@[<2>inherit@ %a%(%)@]" o#class_expr ce semisep
988
 
      | <:class_str_item< inherit $ce$ as $lid:s$ >> ->
989
 
            pp f "@[<2>inherit@ %a as@ %a%(%)@]" o#class_expr ce o#var s semisep
 
1035
      | <:class_str_item< inherit $override:ov$ $ce$ >> ->
 
1036
            pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce semisep
 
1037
      | <:class_str_item< inherit $override:ov$ $ce$ as $lid:s$ >> ->
 
1038
            pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s semisep
990
1039
      | <:class_str_item< initializer $e$ >> ->
991
1040
            pp f "@[<2>initializer@ %a%(%)@]" o#expr e semisep
992
 
      | <:class_str_item< method $private:pr$ $s$ = $e$ >> ->
993
 
            pp f "@[<2>method %a%a =@ %a%(%)@]"
994
 
              o#private_flag pr o#var s o#expr e semisep
995
 
      | <:class_str_item< method $private:pr$ $s$ : $t$ = $e$ >> ->
996
 
            pp f "@[<2>method %a%a :@ %a =@ %a%(%)@]"
997
 
              o#private_flag pr o#var s o#ctyp t o#expr e semisep
 
1041
      | <:class_str_item< method $override:ov$ $private:pr$ $s$ = $e$ >> ->
 
1042
            pp f "@[<2>method%a %a%a =@ %a%(%)@]"
 
1043
              o#override_flag ov o#private_flag pr o#var s o#expr e semisep
 
1044
      | <:class_str_item< method $override:ov$ $private:pr$ $s$ : $t$ = $e$ >> ->
 
1045
            pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]"
 
1046
              o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e semisep
998
1047
      | <:class_str_item< method virtual $private:pr$ $s$ : $t$ >> ->
999
1048
            pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]"
1000
1049
              o#private_flag pr o#var s o#ctyp t semisep
1001
1050
      | <:class_str_item< value virtual $mutable:mu$ $s$ : $t$ >> ->
1002
1051
            pp f "@[<2>%s virtual %a%a :@ %a%(%)@]"
1003
 
              value_val o#mutable_flag mu o#var s o#ctyp t semisep
1004
 
      | <:class_str_item< value $mutable:mu$ $s$ = $e$ >> ->
1005
 
            pp f "@[<2>%s %a%a =@ %a%(%)@]"
1006
 
              value_val o#mutable_flag mu o#var s o#expr e semisep
 
1052
              o#value_val o#mutable_flag mu o#var s o#ctyp t semisep
 
1053
      | <:class_str_item< value $override:ov$ $mutable:mu$ $s$ = $e$ >> ->
 
1054
            pp f "@[<2>%s%a %a%a =@ %a%(%)@]"
 
1055
              o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e semisep
1007
1056
      | <:class_str_item< $anti:s$ >> ->
1008
1057
            pp f "%a%(%)" o#anti s semisep ];
1009
1058