2010-07-27 12:28:51 +02:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon *)
|
|
|
|
(* *)
|
|
|
|
(* Author : Marc Pouzet *)
|
|
|
|
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
|
|
|
|
|
|
|
open Names
|
|
|
|
open Misc
|
|
|
|
open Types
|
|
|
|
open Obc
|
|
|
|
open Obc_mapfold
|
|
|
|
open Global_mapfold
|
|
|
|
|
|
|
|
module Deps =
|
|
|
|
struct
|
2010-09-09 00:35:06 +02:00
|
|
|
|
|
|
|
let deps_longname deps { qual = modn; } = S.add modn deps
|
2010-07-27 12:28:51 +02:00
|
|
|
|
|
|
|
let deps_static_exp_desc funs deps sedesc =
|
|
|
|
let (sedesc, deps) = Global_mapfold.static_exp_desc funs deps sedesc in
|
|
|
|
match sedesc with
|
|
|
|
| Svar ln -> (sedesc, deps_longname deps ln)
|
|
|
|
| Sconstructor ln -> (sedesc, deps_longname deps ln)
|
|
|
|
| Srecord fnel ->
|
|
|
|
let add deps (ln, _) = deps_longname deps ln in
|
|
|
|
(sedesc, List.fold_left add deps fnel)
|
|
|
|
| Sop (ln, _) -> (sedesc, deps_longname deps ln)
|
2010-09-15 09:38:52 +02:00
|
|
|
| _ -> raise Errors.Fallback
|
2010-07-27 12:28:51 +02:00
|
|
|
|
|
|
|
let deps_lhsdesc funs deps ldesc =
|
|
|
|
let (ldesc, deps) = Obc_mapfold.lhsdesc funs deps ldesc in
|
|
|
|
match ldesc with
|
|
|
|
| Lfield (_, ln) -> (ldesc, deps_longname deps ln)
|
2010-09-15 09:38:52 +02:00
|
|
|
| _ -> raise Errors.Fallback
|
2010-07-27 12:28:51 +02:00
|
|
|
|
|
|
|
let deps_edesc funs deps edesc =
|
|
|
|
let (edesc, deps) = Obc_mapfold.edesc funs deps edesc in
|
|
|
|
match edesc with
|
|
|
|
| Eop (ln, _) -> (edesc, deps_longname deps ln)
|
|
|
|
| Estruct (ln, fnel) ->
|
|
|
|
let add deps (ln, _) = deps_longname deps ln in
|
|
|
|
(edesc, List.fold_left add (deps_longname deps ln) fnel)
|
2010-09-15 09:38:52 +02:00
|
|
|
| _ -> raise Errors.Fallback
|
2010-07-27 12:28:51 +02:00
|
|
|
|
|
|
|
let deps_act funs deps act =
|
|
|
|
let (act, deps) = Obc_mapfold.act funs deps act in
|
|
|
|
match act with
|
|
|
|
| Acase (_, cbl) ->
|
|
|
|
let add deps (ln, _) = deps_longname deps ln in
|
|
|
|
(act, List.fold_left add deps cbl)
|
2010-09-15 09:38:52 +02:00
|
|
|
| _ -> raise Errors.Fallback
|
2010-07-27 12:28:51 +02:00
|
|
|
|
|
|
|
let deps_obj_dec funs deps od =
|
|
|
|
let (od, deps) = Obc_mapfold.obj_dec funs deps od in
|
|
|
|
(od, deps_longname deps od.o_class)
|
|
|
|
|
|
|
|
let deps_program p =
|
|
|
|
let funs = { Obc_mapfold.defaults with
|
|
|
|
global_funs = { Global_mapfold.defaults with
|
|
|
|
static_exp_desc = deps_static_exp_desc; };
|
|
|
|
lhsdesc = deps_lhsdesc;
|
|
|
|
edesc = deps_edesc;
|
|
|
|
act = deps_act;
|
|
|
|
obj_dec = deps_obj_dec;
|
|
|
|
} in
|
|
|
|
let (_, deps) = Obc_mapfold.program funs S.empty p in
|
|
|
|
S.remove p.p_modname (S.remove "Pervasives" deps)
|
2010-09-15 09:38:52 +02:00
|
|
|
end
|