printer.ml 17.2 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
(* A pretty-printer for [IL]. *)

open IL
open Printf

module Make (X : sig

  (* This is the channel that is being written to. *)

  val f: out_channel

  (* If [raw_stretch_action] is set, then we print the semantic actions
     as they are found into the original source code. *)
  val raw_stretch_action: bool

  (* This controls the way we print Objective Caml stretches (types and
     semantic actions). We either surround them with #line directives
     (for better error reports if the generated code is ill - typed) or
     don't (for better readability). The value is either [None] -- do
     not provide #line directives -- or [Some filename] -- do provide
     them. [filename] is the name of the file that is being written
     to. *)

  val locate_stretches: string option

end) = struct

(* ------------------------------------------------------------------------- *)
(* Dealing with newlines and indentation. *)

let maxindent =
  120

let whitespace =
  String.make maxindent ' '

let indentation =
  ref 0

let line =
  ref 1

(* [rawnl] is, in principle, the only place where writing a newline
   character to the output channel is permitted. This ensures that the
   line counter remains correct. But see also [stretch] and [typ0]. *)

let rawnl f =
  incr line;
  output_char f '\n'

let nl f =
  rawnl f;
POTTIER Francois's avatar
POTTIER Francois committed
53
  output_substring f whitespace 0 !indentation
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71

let indent ofs producer f x =
  let old_indentation = !indentation in
  let new_indentation = old_indentation + ofs in
  if new_indentation <= maxindent then
    indentation := new_indentation;
  nl f;
  producer f x;
  indentation := old_indentation

(* This produces a #line directive. *)

let sharp f line file =
  fprintf f "%t# %d \"%s\"%t" rawnl line file rawnl

(* ------------------------------------------------------------------------- *)
(* Printers of atomic elements. *)

72
let nothing _ =
73
74
75
76
77
78
79
80
  ()

let space f =
  output_char f ' '

let comma f =
  output_string f ", "

POTTIER Francois's avatar
POTTIER Francois committed
81
82
83
let semi f =
  output_char f ';'

84
let seminl f =
POTTIER Francois's avatar
POTTIER Francois committed
85
  semi f;
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
  nl f

let times f =
  output_string f " * "

let letrec f =
  output_string f "let rec "

let letnonrec f =
  output_string f "let "

let keytyp f =
  output_string f "type "

let exc f =
  output_string f "exception "

let et f =
  output_string f "and "

let var f x =
  output_string f x

let bar f =
  output_string f " | "

(* ------------------------------------------------------------------------- *)
(* List printers. *)

115
116
(* A list with a separator in front of every element. *)

117
118
119
120
121
122
let rec list elem sep f = function
  | [] ->
      ()
  | e :: es ->
      fprintf f "%t%a%a" sep elem e (list elem sep) es

123
124
125
126
127
128
129
130
131
132
(* A list with a separator between elements. *)

let seplist elem sep f = function
  | [] ->
      ()
  | e :: es ->
      fprintf f "%a%a" elem e (list elem sep) es

(* OCaml type parameters. *)

133
let typeparams p0 p1 f = function
134
135
136
137
  | [] ->
      ()
  | [ param ] ->
      fprintf f "%a " p0 param
138
139
  | _ :: _ as params ->
      fprintf f "(%a) " (seplist p1 comma) params
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320

(* ------------------------------------------------------------------------- *)
(* Expression printer. *)

(* We use symbolic constants that stand for subsets of the
   expression constructors. We do not use numeric levels
   to stand for subsets, because our subsets do not form
   a linear inclusion chain. *)

type subset =
  | All
  | AllButSeq
  | AllButFunTryMatch
  | AllButFunTryMatchSeq
  | AllButLetFunTryMatch
  | AllButLetFunTryMatchSeq
  | AllButIfThenSeq
  | OnlyAppOrAtom
  | OnlyAtom

(* This computes the intersection of a subset with the
   constraint "should not be a sequence". *)

let andNotSeq = function
  | All
  | AllButSeq ->
      AllButSeq
  | AllButFunTryMatch
  | AllButFunTryMatchSeq ->
      AllButFunTryMatchSeq
  | AllButLetFunTryMatch
  | AllButLetFunTryMatchSeq ->
      AllButLetFunTryMatchSeq
  | AllButIfThenSeq ->
      AllButIfThenSeq
  | OnlyAppOrAtom ->
      OnlyAppOrAtom
  | OnlyAtom ->
      OnlyAtom

(* This defines the semantics of subsets by relating
   expressions with subsets. *)

let rec member e k =
  match e with
  | EComment _
  | EPatComment _ ->
      true
  | EFun _
  | ETry _
  | EMatch _ ->
      begin
	match k with
	| AllButFunTryMatch
	| AllButFunTryMatchSeq
	| AllButLetFunTryMatch
	| AllButLetFunTryMatchSeq
	| OnlyAppOrAtom
	| OnlyAtom ->
	    false
	| _ ->
	    true
      end
  | ELet ([], e) ->
      member e k
  | ELet ((PUnit, _) :: _, _) ->
      begin
	match k with
	| AllButSeq
	| AllButFunTryMatchSeq
	| AllButLetFunTryMatchSeq
	| AllButIfThenSeq
	| OnlyAppOrAtom
	| OnlyAtom ->
	    false
	| _ ->
	    true
      end
  | ELet (_ :: _, _) ->
      begin
	match k with
	| AllButLetFunTryMatch
	| AllButLetFunTryMatchSeq
	| OnlyAppOrAtom
	| OnlyAtom ->
	    false
	| _ ->
	    true
      end
  | EIfThen _ ->
      begin
	match k with
	| AllButIfThenSeq
	| OnlyAppOrAtom
	| OnlyAtom ->
	    false
	| _ ->
	    true
      end
  | EApp (_, _ :: _)
  | EData (_, _ :: _)
  | EMagic _
  | ERepr _
  | ERaise _ ->
      begin
	match k with
	| OnlyAtom ->
	    false
	| _ ->
	    true
      end
  | ERecordWrite _
  | EIfThenElse _ ->
      begin
	match k with
	| OnlyAppOrAtom
	| OnlyAtom ->
	    false
	| _ ->
	    true
      end
  | EVar _
  | ETextual _
  | EApp (_, [])
  | EData (_, [])
  | ETuple _
  | EAnnot _
  | ERecord _
  | ERecordAccess (_, _)
  | EIntConst _
  | EMaxInt
  | EStringConst _
  | EUnit
  | EArray _
  | EArrayAccess (_, _) ->
      true


let rec exprlet k pes f e2 =
  match pes with
  | [] ->
      exprk k f e2
  | (PUnit, e1) :: pes ->
      fprintf f "%a%t%a" (exprk AllButLetFunTryMatch) e1 seminl (exprlet k pes) e2
  | (PVar id1, EAnnot (e1, ts1)) :: pes ->
      (* TEMPORARY current ocaml does not support type schemes here; drop quantifiers, if any *)
      fprintf f "let %s : %a = %a in%t%a" id1 typ ts1.body (* scheme ts1 *) expr e1 nl (exprlet k pes) e2
  | (PVar id1, EFun (ps1, e1)) :: pes ->
      fprintf f "let %s%a = %a in%t%t%a"
	id1 (list pat0 space) ps1 (indent 2 expr) e1 nl nl (exprlet k pes) e2
  | (p1, (ELet _ as e1)) :: pes ->
      fprintf f "let %a =%a%tin%t%a" pat p1 (indent 2 expr) e1 nl nl (exprlet k pes) e2
  | (p1, e1) :: pes ->
      fprintf f "let %a = %a in%t%a" pat p1 expr e1 nl (exprlet k pes) e2

and atom f e =
  exprk OnlyAtom f e

and app f e =
  exprk OnlyAppOrAtom f e

and expr f e =
  exprk All f e

and exprk k f e =
  if member e k then
    match e with
    | EComment (c, e) ->
	if Settings.comment then
	  fprintf f "(* %s *)%t%a" c nl (exprk k) e
	else
	  exprk k f e
    | EPatComment (s, p, e) ->
	if Settings.comment then
	  fprintf f "(* %s%a *)%t%a" s pat p nl (exprk k) e
	else
	  exprk k f e
    | ELet (pes, e2) ->
	exprlet k pes f e2
    | ERecordWrite (e1, field, e2) ->
	fprintf f "%a.%s <- %a" atom e1 field (exprk (andNotSeq k)) e2
321
    | EMatch (_, []) ->
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
	assert false
    | EMatch (e, brs) ->
	fprintf f "match %a with%a" expr e (branches k) brs
    | ETry (_, []) ->
	assert false
    | ETry (e, brs) ->
	fprintf f "try%a%twith%a" (indent 2 expr) e nl (branches k) brs
    | EIfThen (e1, e2) ->
	fprintf f "if %a then%a" expr e1 (indent 2 (exprk (andNotSeq k))) e2
    | EIfThenElse (e0, e1, e2) ->
	fprintf f "if %a then%a%telse%a"
          expr e0 (indent 2 (exprk AllButIfThenSeq)) e1 nl (indent 2 (exprk (andNotSeq k))) e2
    | EFun (ps, e) ->
	fprintf f "fun%a ->%a" (list pat0 space) ps (indent 2 (exprk k)) e
    | EApp (EVar op, [ e1; e2 ])
      when op.[0] = '(' && op.[String.length op - 1] = ')' ->
	let op = String.sub op 1 (String.length op - 2) in
	fprintf f "%a %s %a" app e1 op app e2
    | EApp (e, args) ->
	fprintf f "%a%a" app e (list atom space) args
    | ERaise e ->
	fprintf f "raise %a" atom e
    | EMagic e ->
	fprintf f "Obj.magic %a" atom e
    | ERepr e ->
	fprintf f "Obj.repr %a" atom e
    | EData (d, []) ->
	var f d
    | EData (d, [ arg ]) ->
	fprintf f "%s %a" d atom arg
352
353
354
    | EData ("::", [ arg1; arg2 ]) ->
        (* Special case for infix cons. *)
        fprintf f "%a :: %a" atom arg1 atom arg2
355
356
    | EData (d, (_ :: _ :: _ as args)) ->
	fprintf f "%s (%a)" d (seplist app comma) args
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
    | EVar v ->
	var f v
    | ETextual action ->
	stretch (X.raw_stretch_action) f action
    | EUnit ->
	fprintf f "()"
    | EIntConst k ->
	if k >= 0 then
	  fprintf f "%d" k
	else
	  fprintf f "(%d)" k
    | EMaxInt ->
        fprintf f "max_int"
    | EStringConst s ->
	fprintf f "\"%s\"" (String.escaped s)
    | ETuple [] ->
	assert false
    | ETuple [ e ] ->
	atom f e
376
377
    | ETuple (_ :: _ :: _ as es) ->
	fprintf f "(%a)" (seplist app comma) es
378
379
380
381
382
383
    | EAnnot (e, s) ->
	(* TEMPORARY current ocaml does not support type schemes here; drop quantifiers, if any *)
	fprintf f "(%a : %a)" app e typ s.body (* should be scheme s *)
    | ERecordAccess (e, field) ->
	fprintf f "%a.%s" atom e field
    | ERecord fs ->
POTTIER Francois's avatar
POTTIER Francois committed
384
	fprintf f "{%a%t}" (indent 2 (seplist field nl)) fs nl
385
    | EArray fs ->
POTTIER Francois's avatar
POTTIER Francois committed
386
	fprintf f "[|%a%t|]" (indent 2 (seplist array_field nl)) fs nl
387
388
389
390
391
392
393
394
395
396
397
398
399
400
    | EArrayAccess (e, i) ->
	fprintf f "%a.(%a)" atom e expr i
  else
    fprintf f "(%a)" expr e

and stretch raw f stretch =
  let content = stretch.Stretch.stretch_content
  and raw_content = stretch.Stretch.stretch_raw_content in
  match X.locate_stretches with
  | Some basename ->
      sharp f stretch.Stretch.stretch_linenum stretch.Stretch.stretch_filename;
      output_string f content;
      line := !line + stretch.Stretch.stretch_linecount;
      sharp f (!line + 2) basename;
POTTIER Francois's avatar
POTTIER Francois committed
401
      output_substring f whitespace 0 !indentation
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
  | None ->
      output_string f (if raw then raw_content else content)

and branches k f = function
  | [] ->
      ()
  | [ br ] ->
      fprintf f "%t| %a" nl (branch k) br
  | br :: brs ->
      fprintf f "%t| %a%a" nl (branch AllButFunTryMatch) br (branches k) brs

and branch k f br =
  fprintf f "%a ->%a" pat br.branchpat (indent 4 (exprk k)) br.branchbody

and field f (label, e) =
POTTIER Francois's avatar
POTTIER Francois committed
417
  fprintf f "%s = %a%t" label app e semi
418

POTTIER Francois's avatar
POTTIER Francois committed
419
420
and fpat f (label, p) =
  fprintf f "%s = %a%t" label pat p semi
421
422

and array_field f e =
POTTIER Francois's avatar
POTTIER Francois committed
423
  fprintf f "%a%t" app e semi
424
425
426
427
428
429
430
431
432
433
434
435
436
437

and pat0 f = function
  | PUnit ->
      fprintf f "()"
  | PWildcard ->
      fprintf f "_"
  | PVar x ->
      var f x
  | PData (d, []) ->
      var f d
  | PTuple [] ->
      assert false
  | PTuple [ p ] ->
      pat0 f p
438
439
  | PTuple (_ :: _ :: _ as ps) ->
      fprintf f "(%a)" (seplist pat1 comma) ps
440
441
442
  | PAnnot (p, t) ->
      fprintf f "(%a : %a)" pat p typ t
  | PRecord fps ->
POTTIER Francois's avatar
POTTIER Francois committed
443
444
445
      (* In a record pattern, fields can be omitted. *)
      let fps = List.filter (function (_, PWildcard) -> false | _ -> true) fps in
      fprintf f "{%a%t}" (indent 2 (seplist fpat nl)) fps nl
446
447
448
449
450
451
  | p ->
      fprintf f "(%a)" pat p

and pat1 f = function
  | PData (d, [ arg ]) ->
      fprintf f "%s %a" d pat0 arg
452
453
  | PData (d, (_ :: _ :: _ as args)) ->
      fprintf f "%s (%a)" d (seplist pat1 comma) args
454
455
456
457
458
459
460
461
  | PTuple [ p ] ->
      pat1 f p
  | p ->
      pat0 f p

and pat2 f = function
  | POr [] ->
      assert false
462
  | POr (_ :: _ as ps) ->
POTTIER Francois's avatar
POTTIER Francois committed
463
      seplist pat2 bar f ps
464
465
466
467
468
469
470
471
  | PTuple [ p ] ->
      pat2 f p
  | p ->
      pat1 f p

and pat f p =
  pat2 f p

472
473
474
475
476
and typevar f = function
  | "_" ->
      fprintf f "_"
  | v ->
      fprintf f "'%s" v
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495

and typ0 f = function
  | TypTextual (Stretch.Declared ocamltype) ->
      (* Parentheses are necessary to avoid confusion between 1 - ary
	 data constructor with n arguments and n - ary data constructor. *)
      fprintf f "(%a)" (stretch true) ocamltype
  | TypTextual (Stretch.Inferred t) ->
      line := !line + LineCount.count 0 (Lexing.from_string t);
      fprintf f "(%s)" t
  | TypVar v ->
      typevar f v
  | TypApp (t, params) ->
      fprintf f "%a%s" (typeparams typ0 typ) params t
  | t ->
      fprintf f "(%a)" typ t

and typ1 f = function
  | TypTuple [] ->
      assert false
496
497
  | TypTuple (_ :: _ as ts) ->
      seplist typ0 times f ts
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
  | t ->
      typ0 f t

and typ2 f = function
  | TypArrow (t1, t2) ->
      fprintf f "%a -> %a" typ1 t1 typ2 t2
  | t ->
      typ1 f t

and typ f =
  typ2 f

and scheme f scheme =
  match scheme.quantifiers with
  | [] ->
      typ f scheme.body
  | qs ->
      fprintf f "%a. %a" (list typevar space) qs typ scheme.body

(* ------------------------------------------------------------------------- *)
(* Toplevel definition printer. *)

POTTIER Francois's avatar
POTTIER Francois committed
520
(* The tuple of the arguments of a data constructor. *)
521

POTTIER Francois's avatar
POTTIER Francois committed
522
523
524
525
526
527
let datavalparams f params =
  (* [typ1] because [type t = A of  int -> int ] is not allowed by OCaml *)
  (*                [type t = A of (int -> int)] is allowed *)
  seplist typ1 times f params

(* A data constructor definition. *)
528

POTTIER Francois's avatar
POTTIER Francois committed
529
530
531
532
533
534
535
536
537
538
539
540
let datadef typename f def =
  fprintf f "  | %s" def.dataname;
  match def.datavalparams, def.datatypeparams with
  | [], None ->
      (* | A *)
      ()
  | _ :: _, None ->
      (* | A of t * u *)
      fprintf f " of %a"
        datavalparams def.datavalparams
  | [], Some indices ->
      (* | A : (v, w) ty *)
POTTIER Francois's avatar
POTTIER Francois committed
541
      fprintf f " : %a%s"
POTTIER Francois's avatar
POTTIER Francois committed
542
543
544
        (typeparams typ0 typ) indices typename
  | _ :: _, Some indices ->
      (* | A : t * u -> (v, w) ty *)
POTTIER Francois's avatar
POTTIER Francois committed
545
      fprintf f " : %a -> %a%s"
POTTIER Francois's avatar
POTTIER Francois committed
546
547
        datavalparams def.datavalparams
        (typeparams typ0 typ) indices typename
548
549
550
551
552
553
554

let fielddef f def =
  fprintf f "  %s%s: %a"
    (if def.modifiable then "mutable " else "")
    def.fieldname
    scheme def.fieldtype

POTTIER Francois's avatar
POTTIER Francois committed
555
let typerhs typename f = function
556
557
  | TDefRecord [] ->
      assert false
POTTIER Francois's avatar
POTTIER Francois committed
558
559
  | TDefRecord (_ :: _ as fields) ->
      fprintf f " = {%t%a%t}" nl (seplist fielddef seminl) fields nl
560
561
562
  | TDefSum [] ->
      ()
  | TDefSum defs ->
POTTIER Francois's avatar
POTTIER Francois committed
563
      fprintf f " = %a" (list (datadef typename) nl) defs
564
565
566
567
568
569
570
571
572
573
  | TAbbrev t ->
      fprintf f " = %a" typ t

let typeconstraint f = function
  | None ->
      ()
  | Some (t1, t2) ->
      fprintf f "%tconstraint %a = %a" nl typ t1 typ t2

let typedef f def =
574
  fprintf f "%a%s%a%a"
575
576
    (typeparams typevar typevar) def.typeparams
    def.typename
POTTIER Francois's avatar
POTTIER Francois committed
577
    (typerhs def.typename) def.typerhs
578
579
580
581
582
    typeconstraint def.typeconstraint

let rec pdefs pdef sep1 sep2 f = function
  | [] ->
      ()
583
584
  | [ def ] ->
      fprintf f "%t%a" sep1 pdef def
585
  | def :: defs ->
586
587
588
589
590
      fprintf f "%t%a%t%t%a"
        sep1 pdef def
        (* Separate two successive items with two newlines. *)
        nl nl
        (pdefs pdef sep2 sep2) defs
591
592
593
594

let valdef f = function
  | { valpat = PVar id; valval = EAnnot (e, ts) } ->
      (* TEMPORARY current ocaml does not support type schemes here; drop quantifiers, if any *)
595
      fprintf f "%s : %a =%a" id typ ts.body (* scheme ts *) (indent 2 expr) e
596
  | { valpat = p; valval = e } ->
597
      fprintf f "%a =%a" pat p (indent 2 expr) e
598

599
600
let valdefs recursive =
  pdefs valdef (if recursive then letrec else letnonrec) et
601
602
603
604

let typedefs =
  pdefs typedef keytyp et

605
606
607
608
let excdef in_intf f def =
  match in_intf, def.exceq with
  | _, None
  | true, Some _ ->
609
      fprintf f "%s" def.excname
610
  | false, Some s ->
611
      fprintf f "%s = %s" def.excname s
612

613
614
let excdefs in_intf =
  pdefs (excdef in_intf) exc exc
615

POTTIER Francois's avatar
POTTIER Francois committed
616
let block format body f b =
617
618
619
  fprintf f format (fun f b ->
    indent 2 body f b;
    nl f
POTTIER Francois's avatar
POTTIER Francois committed
620
621
  ) b

622
623
624
625
626
(* Convention: each structure (or interface) item prints a newline before and
   after itself. *)

let rec structure_item f item =
  match item with
627
628
  | SIFunctor ([], s) ->
      structure f s
629
630
  | SIStretch stretches ->
      List.iter (stretch false f) stretches
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
  | _ ->
    nl f;
    begin match item with
    | SIFunctor (params, s) ->
        fprintf f "module Make%a%t= %a"
          (list (stretch false) nl) params
          nl
          structend s
    | SIExcDefs defs ->
        excdefs false f defs
    | SITypeDefs defs ->
        typedefs f defs
    | SIValDefs (recursive, defs) ->
        valdefs recursive f defs
    | SIStretch _ ->
        assert false (* already handled above *)
    | SIModuleDef (name, rhs) ->
        fprintf f "module %s = %a" name modexpr rhs
    end;
    nl f
651

652
653
654
and structend f s =
  block "struct%aend" structure f s

655
and structure f s =
656
  list structure_item nothing f s
657

658
and modexpr f = function
659
660
661
  | MVar x ->
      fprintf f "%s" x
  | MStruct s ->
662
      structend f s
663
664
665
666
  | MApp (e1, e2) ->
      fprintf f "%a (%a)" modexpr e1 modexpr e2

let valdecl f (x, ts) =
667
  fprintf f "val %s: %a" x typ ts.body
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682

let with_kind f = function
  | WKNonDestructive ->
      output_string f "="
  | WKDestructive ->
      output_string f ":="

let rec module_type f = function
  | MTNamedModuleType s ->
      output_string f s
  | MTWithType (mt, name, wk, t) ->
      fprintf f "%a%a"
        module_type mt
        (indent 2 with_type) (name, wk, t)
  | MTSigEnd i ->
683
      sigend f i
684
685
686
687
688
689
690

and with_type f (name, wk, t) =
  fprintf f "with type %s %a %a"
    name
    with_kind wk
    typ t

691
692
and interface_item f item =
  match item with
693
694
  | IIFunctor ([], i) ->
      interface f i
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
  | _ ->
    nl f;
    begin match item with
    | IIFunctor (params, i) ->
        fprintf f "module Make%a%t: %a"
          (list (stretch false) nl) params nl
          sigend i
    | IIExcDecls defs ->
        excdefs true f defs
    | IITypeDecls defs ->
        typedefs f defs
    | IIValDecls decls ->
        pdefs valdecl nothing nothing f decls
    | IIInclude mt ->
        fprintf f "include %a" module_type mt
    | IIModule (name, mt) ->
        fprintf f "module %s : %a" name module_type mt
    | IIComment comment ->
        fprintf f "(* %s *)" comment
    end;
    nl f
716

717
718
719
and sigend f i =
  block "sig%aend" interface f i

720
721
and interface f i =
  list interface_item nothing f i
722

723
724
let program s =
  structure X.f s;
POTTIER Francois's avatar
POTTIER Francois committed
725
  flush X.f
726
727

let interface i =
POTTIER Francois's avatar
POTTIER Francois committed
728
729
  interface X.f i;
  flush X.f
730
731

let expr e =
POTTIER Francois's avatar
POTTIER Francois committed
732
733
  expr X.f e;
  flush X.f
734
735

end