1
(**************************************************************************)
5
(* Fran�ois Pottier, INRIA Rocquencourt *)
6
(* Yann R�gis-Gianas, PPS, Universit� Paris Diderot *)
8
(* Copyright 2005-2008 Institut National de Recherche en Informatique *)
9
(* et en Automatique. All rights reserved. This file is distributed *)
10
(* under the terms of the Q Public License version 1.0, with the change *)
11
(* described in file LICENSE. *)
13
(**************************************************************************)
15
(* Code for traversing or transforming [IL] terms. *)
20
(* This turns a list of value definitions into a hash table. It also
21
counts and numbers the definitions. We assume that the left-hand
22
side of every definition is a variable. *)
24
let tabulate_defs (defs : valdef list) : int * (string, int * valdef) Hashtbl.t =
26
let table = Hashtbl.create 1023 in
30
Hashtbl.add table (pat2var def.valpat) (k, def)
34
(* This mixin class, used by [map] and [fold] below, helps maintain
35
environments, which can be used to keep track of local variable
38
class virtual ['env] env = object(self)
40
(* The virtual method [pvar] records a local variable binding in
43
method virtual pvar: 'env -> string -> 'env
45
method pat env = function
61
List.fold_left self#pat env ps
63
method fpats env fps =
64
List.fold_left self#fpat env fps
66
method fpat env (_, p) =
71
(* A class that helps transform expressions. The environment [env] can be
72
used to keep track of local variable bindings. *)
76
class virtual ['env] map = object (self)
80
method expr (env : 'env) e =
95
| EIfThenElse (e, e1, e2) ->
96
self#eifthenelse env e e1 e2
106
self#estringconst env s
119
| ERecordAccess (e, f) ->
120
self#erecordaccess env e f
121
| ERecordWrite (e, f, e1) ->
122
self#erecordwrite env e f e1
124
self#etextual env action
126
self#ecomment env s e
127
| EPatComment (s, p, e) ->
128
self#epatcomment env s p e
131
| EArrayAccess (e, i) ->
132
self#earrayaccess env e i
139
method efun env ps e =
140
let e' = self#expr (self#pats env ps) e in
146
method eapp env e es =
147
let e' = self#expr env e
148
and es' = self#exprs env es in
149
if e == e' && es == es' then
154
method elet env bs e =
155
let env, bs' = self#bindings env bs in
156
let e' = self#expr env e in
157
if bs == bs' && e == e' then
162
method ematch env e bs =
163
let e' = self#expr env e
164
and bs' = self#branches env bs in
165
if e == e' && bs == bs' then
170
method eifthen env e e1 =
171
let e' = self#expr env e
172
and e1' = self#expr env e1 in
173
if e == e' && e1 == e1' then
178
method eifthenelse env e e1 e2 =
179
let e' = self#expr env e
180
and e1' = self#expr env e1
181
and e2' = self#expr env e2 in
182
if e == e' && e1 == e1' && e2 == e2' then
185
EIfThenElse (e', e1', e2')
187
method eraise env e =
188
let e' = self#expr env e in
194
method etry env e bs =
195
let e' = self#expr env e
196
and bs' = self#branches env bs in
197
if e == e' && bs == bs' then
205
method eintconst env k =
208
method estringconst env s =
211
method edata env d es =
212
let es' = self#exprs env es in
218
method etuple env es =
219
let es' = self#exprs env es in
225
method eannot env e t =
226
let e' = self#expr env e in
232
method emagic env e =
233
let e' = self#expr env e in
240
let e' = self#expr env e in
246
method erecord env fs =
247
let fs' = self#fields env fs in
253
method erecordaccess env e f =
254
let e' = self#expr env e in
258
ERecordAccess (e', f)
260
method erecordwrite env e f e1 =
261
let e' = self#expr env e
262
and e1' = self#expr env e1 in
263
if e == e' && e1 == e1' then
266
ERecordWrite (e', f, e1')
268
method earray env es =
269
let es' = self#exprs env es in
275
method earrayaccess env e i =
276
let e' = self#expr env e in
282
method etextual env action =
285
method ecomment env s e =
286
let e' = self#expr env e in
292
method epatcomment env s p e =
293
let e' = self#expr env e in
297
EPatComment (s, p, e')
299
method exprs env es =
300
Misc.smap (self#expr env) es
302
method fields env fs =
303
Misc.smap (self#field env) fs
305
method field env ((f, e) as field) =
306
let e' = self#expr env e in
312
method branches env bs =
313
Misc.smap (self#branch env) bs
315
method branch env b =
316
let e = b.branchbody in
317
let e' = self#expr (self#pat env b.branchpat) e in
321
{ b with branchbody = e' }
323
(* The method [binding] produces a pair of an updated environment
324
and a transformed binding. *)
326
method binding env ((p, e) as b) =
327
let e' = self#expr env e in
334
(* For nested non-recursive bindings, the environment produced by
335
each binding is used to traverse the following bindings. The
336
method [binding] produces a pair of an updated environment
337
and a transformed list of bindings. *)
339
method bindings env bs =
340
Misc.smapa self#binding env bs
342
method valdef env def =
343
let e = def.valval in
344
let e' = self#expr env e in
348
{ def with valval = e' }
350
method valdefs env defs =
351
Misc.smap (self#valdef env) defs
355
(* A class that helps iterate, or fold, over expressions. *)
357
class virtual ['env, 'a] fold = object (self)
361
method expr (env : 'env) (accu : 'a) e =
366
self#efun env accu ps e
368
self#eapp env accu e es
370
self#elet env accu bs e
372
self#ematch env accu e bs
374
self#eifthen env accu e e1
375
| EIfThenElse (e, e1, e2) ->
376
self#eifthenelse env accu e e1 e2
378
self#eraise env accu e
380
self#etry env accu e bs
384
self#eintconst env accu k
386
self#estringconst env accu s
388
self#edata env accu d es
390
self#etuple env accu es
392
self#eannot env accu e t
394
self#emagic env accu e
396
self#erepr env accu e
398
self#erecord env accu fs
399
| ERecordAccess (e, f) ->
400
self#erecordaccess env accu e f
401
| ERecordWrite (e, f, e1) ->
402
self#erecordwrite env accu e f e1
404
self#etextual env accu action
406
self#ecomment env accu s e
407
| EPatComment (s, p, e) ->
408
self#epatcomment env accu s p e
410
self#earray env accu es
411
| EArrayAccess (e, i) ->
412
self#earrayaccess env accu e i
414
method evar (env : 'env) (accu : 'a) x =
417
method efun (env : 'env) (accu : 'a) ps e =
418
let accu = self#expr (self#pats env ps) accu e in
421
method eapp (env : 'env) (accu : 'a) e es =
422
let accu = self#expr env accu e in
423
let accu = self#exprs env accu es in
426
method elet (env : 'env) (accu : 'a) bs e =
427
let env, accu = self#bindings env accu bs in
428
let accu = self#expr env accu e in
431
method ematch (env : 'env) (accu : 'a) e bs =
432
let accu = self#expr env accu e in
433
let accu = self#branches env accu bs in
436
method eifthen (env : 'env) (accu : 'a) e e1 =
437
let accu = self#expr env accu e in
438
let accu = self#expr env accu e1 in
441
method eifthenelse (env : 'env) (accu : 'a) e e1 e2 =
442
let accu = self#expr env accu e in
443
let accu = self#expr env accu e1 in
444
let accu = self#expr env accu e2 in
447
method eraise (env : 'env) (accu : 'a) e =
448
let accu = self#expr env accu e in
451
method etry (env : 'env) (accu : 'a) e bs =
452
let accu = self#expr env accu e in
453
let accu = self#branches env accu bs in
456
method eunit (env : 'env) (accu : 'a) =
459
method eintconst (env : 'env) (accu : 'a) k =
462
method estringconst (env : 'env) (accu : 'a) s =
465
method edata (env : 'env) (accu : 'a) d es =
466
let accu = self#exprs env accu es in
469
method etuple (env : 'env) (accu : 'a) es =
470
let accu = self#exprs env accu es in
473
method eannot (env : 'env) (accu : 'a) e t =
474
let accu = self#expr env accu e in
477
method emagic (env : 'env) (accu : 'a) e =
478
let accu = self#expr env accu e in
481
method erepr (env : 'env) (accu : 'a) e =
482
let accu = self#expr env accu e in
485
method erecord (env : 'env) (accu : 'a) fs =
486
let accu = self#fields env accu fs in
489
method erecordaccess (env : 'env) (accu : 'a) e f =
490
let accu = self#expr env accu e in
493
method erecordwrite (env : 'env) (accu : 'a) e f e1 =
494
let accu = self#expr env accu e in
495
let accu = self#expr env accu e1 in
498
method earray (env : 'env) (accu : 'a) es =
499
let accu = self#exprs env accu es in
502
method earrayaccess (env : 'env) (accu : 'a) e i =
503
let accu = self#expr env accu e in
506
method etextual (env : 'env) (accu : 'a) action =
509
method ecomment (env : 'env) (accu : 'a) s e =
510
let accu = self#expr env accu e in
513
method epatcomment (env : 'env) (accu : 'a) s p e =
514
let accu = self#expr env accu e in
517
method exprs (env : 'env) (accu : 'a) es =
518
List.fold_left (self#expr env) accu es
520
method fields (env : 'env) (accu : 'a) fs =
521
List.fold_left (self#field env) accu fs
523
method field (env : 'env) (accu : 'a) (f, e) =
524
let accu = self#expr env accu e in
527
method branches (env : 'env) (accu : 'a) bs =
528
List.fold_left (self#branch env) accu bs
530
method branch (env : 'env) (accu : 'a) b =
531
let accu = self#expr (self#pat env b.branchpat) accu b.branchbody in
534
method binding ((env, accu) : 'env * 'a) (p, e) =
535
let accu = self#expr env accu e in
539
method bindings (env : 'env) (accu : 'a) bs =
540
List.fold_left self#binding (env, accu) bs
542
method valdef (env : 'env) (accu : 'a) def =
543
let accu = self#expr env accu def.valval in
546
method valdefs (env : 'env) (accu : 'a) defs =
547
List.fold_left (self#valdef env) accu defs
added
removed
src/traverse.ml
