From 4c2a5121e48a05f3534951752d492f0655d58293 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Thu, 12 May 2011 17:37:24 +0200 Subject: [PATCH] remove useless ml folder. --- compiler/obc/ml/caml.ml | 98 --- compiler/obc/ml/caml_aux.ml | 131 ---- compiler/obc/ml/caml_printer.ml | 404 ------------ compiler/obc/ml/cenvironment.ml | 46 -- compiler/obc/ml/coiteration.ml | 848 ------------------------- compiler/obc/ml/declarative.ml | 295 --------- compiler/obc/ml/declarative_printer.ml | 699 -------------------- compiler/obc/ml/default_value.ml | 63 -- compiler/obc/ml/misc.ml | 295 --------- compiler/obc/ml/ml.ml | 2 - 10 files changed, 2881 deletions(-) delete mode 100644 compiler/obc/ml/caml.ml delete mode 100644 compiler/obc/ml/caml_aux.ml delete mode 100644 compiler/obc/ml/caml_printer.ml delete mode 100644 compiler/obc/ml/cenvironment.ml delete mode 100644 compiler/obc/ml/coiteration.ml delete mode 100644 compiler/obc/ml/declarative.ml delete mode 100644 compiler/obc/ml/declarative_printer.ml delete mode 100644 compiler/obc/ml/default_value.ml delete mode 100644 compiler/obc/ml/misc.ml delete mode 100644 compiler/obc/ml/ml.ml diff --git a/compiler/obc/ml/caml.ml b/compiler/obc/ml/caml.ml deleted file mode 100644 index 99b7420..0000000 --- a/compiler/obc/ml/caml.ml +++ /dev/null @@ -1,98 +0,0 @@ -(**************************************************************************) -(* *) -(* Heptagon *) -(* *) -(* Author : Marc Pouzet *) -(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) -(* *) -(**************************************************************************) - - -(** Sequential caml code. *) - -open Misc -open Names -open Idents -open Location - -type caml_code = - { c_types: (string, type_definition) Hashtbl.t; - c_defs: (string * cexp) list; - } - -and immediate = - Cbool of bool - | Cint of int - | Cfloat of float - | Cchar of char - | Cstring of string - | Cvoid - -and cexp = - Cconstant of immediate - | Cglobal of qualified_ident - | Cvar of string - | Cconstruct of qualified_ident * cexp list - | Capply of cexp * cexp list - | Cfun of pattern list * cexp - | Cletin of is_rec * (pattern * cexp) list * cexp - | Cifthenelse of cexp * cexp * cexp - | Cifthen of cexp * cexp - | Cmatch of cexp * (pattern * cexp) list - | Ctuple of cexp list - | Crecord of (qualified_ident * cexp) list - | Crecord_access of cexp * qualified_ident - | Cseq of cexp list - | Cderef of cexp - | Cref of cexp - | Cset of string * cexp - | Clabelset of string * string * cexp - | Cmagic of cexp - -and is_rec = bool - -and pattern = - Cconstantpat of immediate - | Cvarpat of string - | Cconstructpat of qualified_ident * pattern list - | Ctuplepat of pattern list - | Crecordpat of (qualified_ident * pattern) list - | Corpat of pattern * pattern - | Caliaspat of pattern * string - | Cwildpat - -let cvoidpat = Cconstantpat(Cvoid) -let cvoid = Cconstant(Cvoid) -let crefvoid = Cref(cvoid) -let cfalse = Cconstant(Cbool(false)) -let ctrue = Cconstant(Cbool(true)) -let creftrue = Cref(ctrue) -let cdummy = Cmagic (Cconstant (Cvoid)) -let cand_op = {qual = pervasives_module;id = "&&"} -let cor_op = {qual = pervasives_module;id = "or"} -let cnot_op = {qual = pervasives_module;id = "not"} -let cand c1 c2 = Capply (Cglobal (cand_op), [c1;c2]) -let cor c1 c2 = Capply (Cglobal (cor_op), [c1;c2]) -let cnot c = Capply(Cglobal (cnot_op),[c]) -let cvoidfun e = Cfun([cvoidpat], e) -let cvoidapply e = Capply(e, [cvoid]) -let cfun params e = - match params, e with - | params, Cfun(others, e) -> Cfun(params @ others, e) - | [], _ -> cvoidfun e - | _ -> Cfun(params, e) -let capply e l = match l with [] -> cvoidapply e | _ -> Capply(e, l) -let cifthen c e = match c with Cconstant(Cbool(true)) -> e | _ -> Cifthen(c, e) -let cifthenelse c e1 e2 = - match c with - | Cconstant(Cbool(true)) -> e1 - | Cconstant(Cbool(false)) -> e2 - | _ -> Cifthenelse(c, e1, e2) -let cseq e1 e2 = - match e1, e2 with - | Cconstant(Cvoid), _ -> e2 - | _, Cconstant(Cvoid) -> e1 - | e1, Cseq l2 -> Cseq(e1 :: l2) - | Cseq(l1), e2 -> Cseq (l1 @ [e2]) - | _ -> Cseq[e1;e2] - diff --git a/compiler/obc/ml/caml_aux.ml b/compiler/obc/ml/caml_aux.ml deleted file mode 100644 index 48da556..0000000 --- a/compiler/obc/ml/caml_aux.ml +++ /dev/null @@ -1,131 +0,0 @@ -(**************************************************************************) -(* *) -(* Lucid Synchrone *) -(* *) -(* Author : Marc Pouzet *) -(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) -(* *) -(**************************************************************************) - -(* $Id: caml_aux.ml,v 1.1.1.1 2005-11-03 15:45:23 pouzet Exp $ *) - -(* file caml-aux.ml *) -(* auxiliary functions for caml expressions *) -(* free variables *) - -open Misc;; -open Caml;; -open Declarative;; - -(* convertions from declarative structures to caml ones *) -(* immediates *) -let caml_of_declarative_immediate = function - | Dbool b -> if b then Ftrue else Ffalse - | Dint i -> Fint i - | Dfloat f -> Ffloat f - | Dchar c -> Fchar c - | Dstring s -> Fstring s - -(* globals *) -let string_of_global g = - let pref = g.dqualid.dqual in - (if (pref <> "") && (pref <> "Lucy_pervasives") then - g.dqualid.dqual^"." - else "") ^ g.dqualid.did - -(* pat_desc *) -let rec caml_pattern_of_pat_desc = function - | Dvarpat i -> Fvarpat ("x__"^(string_of_int i)) - | Dconstantpat i -> Fimpat (caml_of_declarative_immediate i) - | Dtuplepat pl -> Ftuplepat (List.map caml_of_declarative_pattern pl) - | Dconstruct0pat g -> Fconstruct0pat (string_of_global g) - | Dconstruct1pat (g,p) -> Fconstruct1pat (string_of_global g, - caml_of_declarative_pattern p) - | Drecordpat gpl -> Frecordpat (List.map - (fun (x,y) -> - (string_of_global x, - caml_of_declarative_pattern y)) - gpl) -(* patterns *) -and caml_of_declarative_pattern p = caml_pattern_of_pat_desc p.dp_desc -(* ---- end of convertions *) - -let rec flat_exp_of_pattern = function - | Fpunit -> Fim Funit - | Fimpat i -> Fim i - | Fvarpat v -> Fvar { cvar_name=v; cvar_imported=false } - | Fconstruct0pat c -> Fconstruct0 c - | Fconstruct1pat (c,p) -> Fconstruct1 (c, flat_exp_of_pattern p) - | Ftuplepat pl -> Ftuple (List.map flat_exp_of_pattern pl) - | Frecordpat cpl -> - Frecord (List.map (fun (x,y) -> (x,flat_exp_of_pattern y)) cpl) - -(* small functions manipulating lists *) -let union x1 x2 = - let rec rec_union l = function - [] -> l - | h::t -> if List.mem h l then (rec_union l t) else (rec_union (h::l) t) - in - rec_union x1 x2 - -let subtract x1 x2 = - let rec sub l = function - [] -> l - | h::t -> if List.mem h x2 then (sub l t) else (sub (h::l) t) - in - sub [] x1 - -let flat l = - let rec f ac = function - [] -> ac - | t::q -> f (ac@t) q - in - f [] l - -let intersect x1 x2 = - let rec inter l = function - [] -> l - | h::t -> if List.mem h x1 then (inter (h::l) t) else (inter l t) - in - inter [] x2 - -(* make a variable *) -let make_var n = Fvar {cvar_name = n;cvar_imported = false} -and make_imported_var n b = Fvar {cvar_name = n;cvar_imported = b} - -let nil_ident = "Lucy__nil" -let state_ident = "Lucy__state" - -(* makes a conditional *) -let ifthenelse(c,e1,e2) = - match c with - Fim(Ftrue) -> e1 - | Fim(Ffalse) -> e2 - | _ -> Fifthenelse(c,e1,e2) - -(* makes a list of conditionnals *) -let ifseq l = - let rec ifs l = - let (c,e)::t = l in - if t = [] then - e - else - ifthenelse (c, e, ifs t) - in - ifs l - - - - - - - - - - - - - - - - diff --git a/compiler/obc/ml/caml_printer.ml b/compiler/obc/ml/caml_printer.ml deleted file mode 100644 index 536a407..0000000 --- a/compiler/obc/ml/caml_printer.ml +++ /dev/null @@ -1,404 +0,0 @@ -(**************************************************************************) -(* *) -(* Lucid Synchrone *) -(* *) -(* Author : Marc Pouzet *) -(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) -(* *) -(**************************************************************************) - -(* $Id: caml_printer.ml,v 1.20 2008-06-17 13:21:12 pouzet Exp $ *) - -(** Printing [Caml] code *) - -open Misc -open Names -open Format -open Declarative -open Declarative_printer -open Caml - -(** Generic printing of a list. - This function seems to appear in several places... *) -let print_list print print_sep l = - let rec printrec l = - match l with - [] -> () - | [x] -> - print x - | x::l -> - open_box 0; - print x; - print_sep (); - print_space (); - printrec l; - close_box () in - printrec l - -(** Prints an immediate. A patch is needed on float number for - [ocaml] < 3.05. *) -let print_immediate i = - match i with - Cbool(b) -> print_string (if b then "true" else "false") - | Cint(i) -> print_int i - | Cfloat(f) -> print_float f - | Cchar(c) -> print_char '\''; print_char c; print_char '\'' - | Cstring(s) -> print_string "\""; - print_string (String.escaped s); - print_string "\"" - | Cvoid -> print_string "()" - -(** Prints a name. Infix chars are surrounded by parenthesis *) -let is_infix = - let module StrSet = Set.Make(String) in - let set_infix = - List.fold_right - StrSet.add - ["or"; "quo"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] - StrSet.empty in - fun s -> StrSet.mem s set_infix - -let print_name s = - let c = String.get s 0 in - let s = if is_infix s then "(" ^ s ^ ")" - else match c with - | 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> s - | '*' -> "( " ^ s ^ " )" - | _ -> if s = "()" then s else "(" ^ s ^ ")" in - print_string s - -(** Prints a global name *) -let print_qualified_ident {qual=q;id=n} = - (* special case for values imported from the standard library *) - if (q = pervasives_module) or (q = Modules.compiled_module_name ()) - or (q = "") - then print_name n - else - begin - print_string q; - print_string "."; - print_name n - end - -let priority exp = - match exp with - Crecord _ | Crecord_access _ | Cvar _ | Ctuple _ - | Cglobal _ | Cconstant _ | Cconstruct(_, []) | Cderef _ -> 3 - | Clet _ | Cfun _ | Cseq _ -> 1 - | Cset _ | Clabelset _ - | Cref _ | Capply _ | Cmagic _ | Cconstruct _ -> 2 - | Cifthen _ | Cifthenelse _ | Cmatch _ -> 0 - -let priority_pattern p = - match p with - Cconstructpat _ | Cconstantpat _ | Cvarpat _ - | Ctuplepat _ | Crecordpat _ -> 2 - | _ -> 1 - -(** Emission of code *) -let rec print pri e = - open_box 2; - (* if the priority of the context is higher than the *) - (* priority of e, we ass a parenthesis *) - let pri_e = priority e in - if pri > pri_e then print_string "("; - begin match e with - Cconstant(e) -> print_immediate e - | Cglobal(gl) -> print_qualified_ident gl - | Cvar(s) -> print_name s - | Cconstruct(gl, e_list) -> - print_qualified_ident gl; - if e_list <> [] then print_tuple e_list - | Capply(f,l) -> - print pri_e f; - print_space (); - print_list (print (pri_e + 1)) (fun () -> ()) l - | Cfun(pat_list,e) -> - print_string "fun"; - print_space (); - print_list (print_pattern 0) (fun () -> ()) pat_list; - print_space (); - print_string "->"; - print_space (); - print 0 e - (* local definition *) - | Clet(is_rec, l, e) -> print_let is_rec l e - | Cifthenelse(e1,e2,e3) -> - print_string "if"; - print_space (); - print (pri_e - 1) e1; - print_space (); - print_string "then"; - print_space (); - print 2 e2; - print_space (); - print_string "else"; - print_space (); - print 2 e3 - | Cifthen(e1,e2) -> - print_string "if"; - print_space (); - print (pri_e - 1) e1; - print_space (); - print_string "then"; - print_space (); - print 2 e2 - | Ctuple(l) -> print_tuple l - | Crecord(l) -> - print_string "{"; - print_list - (fun (gl, e) -> print_qualified_ident gl; - print_string " = "; - print 1 e) - (fun () -> print_string ";") l; - print_string "}" - | Crecord_access(e, gl) -> - print pri_e e; - print_string "."; - print_qualified_ident gl - | Cmatch(e,l) -> - print_string "match "; - print 0 e; - print_string " with"; - print_space (); - List.iter - (fun pat_expr -> - print_string "| "; - print_match_pat_expr 2 pat_expr) l - | Cseq l -> print_list (print 2) (fun () -> print_string ";") l - | Cderef(e) -> - print_string "!"; - print pri_e e - | Cref(e) -> - print_string "ref"; - print_space (); - print (pri_e + 1) e - | Cset(s, e) -> - print_string s; - print_string " :="; - print_space (); - print pri_e e - | Clabelset(s, l, e) -> - print_string s; - print_string "."; - print_string l; - print_space (); - print_string "<-"; - print_space (); - print pri_e e - | Cmagic(e) -> - print_string "Obj.magic"; - print_space (); - print (pri_e+1) e - end; - if pri > pri_e then print_string ")"; - close_box() - -and print_tuple e_list = - print_string "("; - print_list (print 2) (fun () -> print_string ",") e_list; - print_string ")" - -and print_let_pat_expr (pat, expr) = - match pat, expr with - pat, Cfun(pat_list, expr) -> - open_box 2; - print_list (print_pattern 0) (fun () -> ()) (pat :: pat_list); - print_string " ="; - print_space (); - print 0 expr; - close_box () - | _ -> - print_pattern 0 pat; - print_string " = "; - print 0 expr - -and print_let is_rec l e = - open_box 0; - if is_rec then print_string "let rec " else print_string "let "; - print_list print_let_pat_expr - (fun () -> print_string "\n"; print_string "and ") l; - print_string " in"; - print_break 1 0; - print 0 e; - close_box () - -and print_pattern pri pat = - open_box 2; - let pri_e = priority_pattern pat in - if pri > pri_e then print_string "("; - begin match pat with - Cconstantpat(i) -> print_immediate i - | Cvarpat(v) -> print_string v - | Cconstructpat(gl, pat_list) -> - print_qualified_ident gl; - if pat_list <> [] then print_tuple_pat pat_list - | Ctuplepat(pat_list) -> - print_tuple_pat pat_list - | Crecordpat(l) -> - print_string "{"; - print_list (fun (gl, pat) -> print_qualified_ident gl; - print_string "="; - print_pattern (pri_e - 1) pat) - (fun () -> print_string ";") l; - print_string "}" - | Corpat(pat1, pat2) -> - print_pattern pri_e pat1; - print_string "|"; - print_pattern pri_e pat2 - | Caliaspat(pat, s) -> - print_pattern pri_e pat; - print_space (); - print_string "as"; - print_space (); - print_string s - | Cwildpat -> print_string "_" - end; - if pri > pri_e then print_string ")"; - close_box () - -and print_tuple_pat pat_list = - print_string "("; - print_list (print_pattern 0) (fun () -> print_string ",") pat_list; - print_string ")" - -and print_match_pat_expr prio (pat, expr) = - open_box 2; - print_pattern 0 pat; - print_space (); print_string "->"; print_space (); - print prio expr; - close_box (); - print_space ();; - -(* print a definition *) -let print_definition (name, e) = - print_string "let "; - print_let_pat_expr (Cvarpat(name), e) - -(* print code *) -let print_code e = print 0 e - -(* print types *) -let rec print_type typ = - open_box 1; - begin match typ with - Darrow(is_node, typ1, typ2) -> - print_type typ1; - if is_node then print_string " => " else print_string " -> "; - print_type typ2 - | Dproduct(ty_list) -> - print_list print_type (fun _ -> print_string " *") ty_list - | Dconstr(qual_ident, ty_list) -> - if ty_list <> [] then - begin - print_string "("; - print_list print_type (fun _ -> print_string ",") ty_list; - print_string ")"; - print_space () - end; - print_qualified_ident qual_ident - | Dtypvar(i) -> print_type_name i - | Dbase(b) -> print_base_type b - | Dsignal(ty) -> print_type ty; print_space (); print_string "sig" - end; - close_box () - -and print_type_name n = - print_string "'a"; - print_int n - -and print_base_type b = - match b with - Dtyp_bool -> print_string "bool" - | Dtyp_int -> print_string "int" - | Dtyp_float -> print_string "float" - | Dtyp_unit -> print_string "unit" - | Dtyp_string -> print_string "string" - | Dtyp_char -> print_string "char" - -(* print variant *) -let print_variant (qualid, { arg = typ_list; res = typ }) = - print_string " | "; - print_qualified_ident qualid; - match typ_list with - [] -> (* arity = 0 *) - () - | _ -> print_string " of "; - print_list print_type (fun () -> print_string "*") typ_list - -let print_record (qualid, is_mutable, { res = typ1 }) = - if is_mutable then print_string "mutable "; - print_qualified_ident qualid; - print_string ":"; - print_type typ1; - print_string ";" - -let print_type_declaration s { d_type_desc = td; d_type_arity = l } = - open_box 2; - if l <> [] then - begin - print_string "("; - print_list print_type_name (fun _ -> print_string ",") l; - print_string ")"; - print_space () - end; - print_string s; - print_string " = "; - begin match td with - Dabstract_type -> () - | Dabbrev(ty) -> - print_type ty - | Dvariant_type variant_list -> - List.iter print_variant variant_list - | Drecord_type record_list -> - print_string "{"; - print_list print_record (fun _ -> ()) record_list; - print_string "}" - end; - print_newline (); - close_box () - -let print_type_declarations l = - let rec printrec l = - match l with - [] -> () - | [s, d] -> print_type_declaration s d - | (s, d) :: l -> - print_type_declaration s d; - print_string "and "; - printrec l in - open_box 0; - print_string "type "; - printrec l; - print_newline (); - close_box ();; - -(* the main function *) -set_max_boxes max_int ;; - -let output_expr oc e = - (* emit on channel oc *) - set_formatter_out_channel oc; - print 0 e; - print_flush () - -let output_code oc c = - (* emit on channel oc *) - set_formatter_out_channel oc; - print_code c - -let output_definitions oc d_list = - (* emit on channel oc *) - set_formatter_out_channel oc; - print_list print_definition print_newline d_list; - print_flush () - -let output oc caml_code = - set_formatter_out_channel oc; - (* print type declarations *) - let l = Misc.listoftable caml_code.c_types in - if l <> [] then print_type_declarations l; - (* print value definitions *) - print_list print_definition print_newline caml_code.c_code; - print_flush () - diff --git a/compiler/obc/ml/cenvironment.ml b/compiler/obc/ml/cenvironment.ml deleted file mode 100644 index d410adb..0000000 --- a/compiler/obc/ml/cenvironment.ml +++ /dev/null @@ -1,46 +0,0 @@ -(**************************************************************************) -(* *) -(* Lucid Synchrone *) -(* *) -(* Author : Marc Pouzet *) -(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) -(* *) -(**************************************************************************) - -(* $Id: cenvironment.ml,v 1.1 2006-03-18 08:04:25 pouzet Exp $ *) - -open Misc -open Declarative - -(** Environment with static link **) -type cblock = - { c_block: block; (* table of free names *) - c_state: name; (* the name of the internal state *) - c_write: name; (* temporary values *) - } -type env = cblock list -let empty_env = [] -let current env = List.hd env -let cblock env = (current env).c_block -let statename env = (current env).c_state - -let push_block block env = - { c_block = block; - c_state = symbol#name; - c_write = symbol#name } :: env -let push block env = - if env = empty_env - then push_block block env - else let cblock = current env in - { cblock with c_block = block } :: env -let rec findall env i = - match env with - [] -> raise Not_found - | { c_block = b; c_state = st; c_write = wt } :: env -> - try - Hashtbl.find b.b_env i, st, wt - with - Not_found -> findall env i -let find env i = - let id, _, _ = findall env i in - id diff --git a/compiler/obc/ml/coiteration.ml b/compiler/obc/ml/coiteration.ml deleted file mode 100644 index 712d1cb..0000000 --- a/compiler/obc/ml/coiteration.ml +++ /dev/null @@ -1,848 +0,0 @@ -(**************************************************************************) -(* *) -(* Lucid Synchrone *) -(* *) -(* Author : Marc Pouzet *) -(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) -(* *) -(**************************************************************************) - -(* $Id: coiteration.ml,v 1.27 2008-06-10 06:54:36 delaval Exp $ *) - - -(** Translating [declarative] code into sequential [caml] code. *) - -open Misc -open Names -open Declarative -open Rw -open Dmisc -open Caml -open Cenvironment - -let prefix_for_names = "_" -let prefix_for_inits = "_init" -let prefix_for_memos = "_pre" -let prefix_for_statics = "_static" -let prefix_for_clocks = "_cl" -let prefix_for_lasts = "__last" - -let prefix_state_type = "_state_" -let prefix_state_constr = "`St_" -let prefix_state_label = "_mem_" -let prefix_state_constr_nil = "`Snil_" -let prefix_for_self_state = "_self_" -let prefix_for_temp = "_temp_" - -(** the type of unknown states *) -(* type 'a state = Snil | St of 'a *) -let state_nil = Cconstruct(qualid prefix_state_constr_nil, []) -let state_nil_pat = Cconstructpat(qualid prefix_state_constr_nil, []) -let state_pat pat_list = Cconstructpat(qualid prefix_state_constr, pat_list) -let state e_list = Cconstruct(qualid prefix_state_constr, e_list) -let state_record name_e_list = - Crecord(List.map (fun (name, e) -> (qualid name), e) name_e_list) - -let intro_state_type () = - let tname = prefix_state_type in - let result_type = - Dconstr(qualid prefix_state_type, [Dtypvar(0)]) in - let variants = - [(qualid prefix_state_constr_nil, { arg = []; res = result_type }); - (qualid prefix_state_constr, {arg = [Dtypvar(0)]; res = result_type})] - in - let type_def = - { d_type_desc = Dvariant_type(variants); - d_type_arity = [0] } in - add_type (tname, type_def) - -(** introduce a new type for enumerated states *) -(* type ('a1,...,'an) state_k = St1 of 'a1 | ... Stm of 'an *) -let intro_enum_type n = - let l = Misc.from n in - (* name of the result type *) - let tname = prefix_state_type ^ (string_of_int(symbol#name)) in - let result_type = - Dconstr(qualid tname, List.map (fun name -> Dtypvar(name)) l) in - let variants = - List.map - (fun name -> - (qualid (tname ^ prefix_state_constr ^ (string_of_int name)), - { arg = [Dtypvar(name)]; res = result_type })) l in - let type_def = - { d_type_desc = Dvariant_type(variants); - d_type_arity = l } in - add_type (tname, type_def); - tname ^ prefix_state_constr - -(** introduce a new type for record states *) -(* type ('a1,...,'an) state_k = {mutable name1:a1;...;mutable namen:an} *) -let intro_record_type name_value_list = - let l = Misc.from (List.length name_value_list) in - let tname = prefix_state_type ^ (string_of_int(symbol#name)) in - let result_type = - Dconstr(qualid tname, List.map (fun name -> Dtypvar(name)) l) in - let labels = - List.map2 - (fun (name,_) ai -> - (qualid name, - true, - { res = Dtypvar(ai); arg = result_type })) name_value_list l in - let type_def = - { d_type_desc = Drecord_type(labels); - d_type_arity = l } in - add_type (tname, type_def) - -(** the intermediate code generated during the compilation process *) -type tcode = - Tlet of pattern * cexp - | Tset of string * cexp - | Tlabelset of string * string * cexp - | Tletrec of (pattern * cexp) list - | Texp of cexp - -(* and its translation into caml code *) -let rec clet tcode ce = - let code2c tcode ce = - match tcode with - Tlet(p, c) -> Clet(false, [p,c], ce) - | Tset(s, e) -> cseq (Cset(s,e)) ce - | Tlabelset(s, n, e) -> cseq (Clabelset(s, n, e)) ce - | Tletrec(l) -> Clet(true, l, ce) - | Texp(c) when ce = cvoid -> c - | Texp(c) -> cseq c ce in - match tcode with - [] -> ce - | tc :: tcode -> code2c tc (clet tcode ce) - -let cseq tcode = clet tcode cvoid -let ifthen c ce = - match c with - Cconstant(Cbool(true)) -> ce - | _ -> Cifthen(c, ce) - -let merge code ce l = - (* we make special treatments for conditionals *) - match l with - [] -> code - | [Cconstantpat(Cbool(b1)), c1; - Cconstantpat(Cbool(b2)), c2] -> - if b1 then - Texp(Cifthenelse(ce, c1, c2)) :: code - else - Texp(Cifthenelse(ce, c2, c1)) :: code - (* general case *) - | _ -> Texp(Cmatch(ce, l)) :: code - - -(** extract the set of static computations from an expression *) -let rec static acc e = - let acc, desc = match e.d_desc with - | Dconstant _ | Dvar _ | Dfun _ -> acc, e.d_desc - | Dtuple l -> - let acc, l = static_list acc l in - acc, Dtuple(l) - | Dprim(g, e_list) -> - (* pointwise application *) - let acc, e_list = static_list acc e_list in - acc, Dprim(g, e_list) - | Dconstruct(g, e_list) -> - let acc, e_list = static_list acc e_list in - acc, Dconstruct(g, e_list) - | Drecord(gl_expr_list) -> - let static_record (gl, expr) (acc, gl_expr_list) = - let acc, e = static acc expr in - acc, (gl, e) :: gl_expr_list in - let acc, l = - List.fold_right static_record gl_expr_list (acc, []) in - acc, Drecord(l) - | Drecord_access(expr, gl) -> - let acc, e = static acc expr in - acc, Drecord_access(e, gl) - | Difthenelse(e0, e1, e2) -> - let acc, e0 = static acc e0 in - let acc, e1 = static acc e1 in - let acc, e2 = static acc e2 in - acc, Difthenelse(e0, e1, e2) - | Dlet(block, e_let) -> - let acc, block = static_block acc block in - let acc, e = static acc e_let in - acc, Dlet(block, e_let) - | Dapply(is_state, f, l) -> - let acc, f = static acc f in - let acc, l = static_list acc l in - acc, Dapply(is_state, f, l) - | Deseq(e1, e2) -> - let acc, e1 = static acc e1 in - let acc, e2 = static acc e2 in - acc, Deseq(e1, e2) - | Dwhen(e1) -> - let acc, e1 = static acc e1 in - acc, Dwhen(e1) - | Dclock(ck) -> - acc, Dclock(ck) - | Dlast _ | Dinit _ | Dpre _ | Dtest _ -> - (* this case should not arrive *) - fatal_error "static" in - acc, { e with d_desc = desc } - -and static_list acc l = - match l with - [] -> acc, [] - | e :: l -> - let acc, e = static acc e in - let acc, l = static_list acc l in - acc, e :: l - -and static_block acc b = - let acc, eq = static_eq acc b.b_equations in - acc, { b with b_equations = eq } - -(* extract the set of static computations from an equation *) -and static_eqs acc eq_list = - match eq_list with - [] -> acc, [] - | eq :: eq_list -> - let acc, eq = static_eq acc eq in - let acc, eq_list = static_eqs acc eq_list in - acc, dcons eq eq_list - -and static_eq acc eq = - match eq with - Dget _ -> acc, eq - | Dequation(pat, e) -> - let acc, e = static acc e in - acc, Dequation(pat, e) - | Dwheneq(eq, ck) -> - let acc, eq = static_eq acc eq in - acc, Dwheneq(eq, ck) - | Dmerge(is_static, e, p_block_list) -> - let acc, e = static acc e in - let acc, p_block_list = static_pat_block_list acc p_block_list in - acc, Dmerge(is_static, e, p_block_list) - | Dnext(n, e) -> - let acc, e = static acc e in - acc, Dnext(n, e) - | Dseq(eq_list) -> - let acc, eq_list = static_eqs acc eq_list in - acc, Dseq(eq_list) - | Dpar(eq_list) -> - let acc, eq_list = static_eqs acc eq_list in - acc, Dpar(eq_list) - | Dblock(block) -> - let acc, block = static_block acc block in - acc, Dblock(block) - | Dstatic(pat, e) -> - (pat, e) :: acc, no_equation - | Demit _ | Dlasteq _ | Dautomaton _ | Dreset _ | Dpresent _ -> - (* these cases should not arrive since control structures have *) - (* been translated into the basic kernel *) - fatal_error "static_eq" - -and static_pat_block_list acc p_block_list = - (* treat one handler *) - let static_pat_block acc (pat, block) = - let acc, block = static_block acc block in - acc, (pat, block) in - match p_block_list with - [] -> acc, [] - | pat_block :: pat_block_list -> - let acc, pat_block = static_pat_block acc pat_block in - let acc, pat_block_list = static_pat_block_list acc pat_block_list in - acc, pat_block :: pat_block_list - -(** Auxiliary definitions **) -let string_of_ident ident = - let prefix = - match ident.id_kind with - Kinit -> prefix_for_inits - | Kstatic -> prefix_for_statics - | Kmemo -> prefix_for_memos - | Kclock -> prefix_for_clocks - | Klast -> prefix_for_lasts - | _ -> prefix_for_names in - let suffix = - match ident.id_original with - None -> "" - | Some(n) when (is_an_infix_or_prefix_operator n) -> "__infix" - | Some(n) -> "__" ^ n in - prefix ^ (string_of_int ident.id_name) ^ suffix - -let string_of_name env i = - (* find the original name when it exists *) - let ident = find env i in - string_of_ident ident - -let name i = prefix_for_names ^ (string_of_int i) -let memo i = prefix_for_memos ^ (string_of_int i) -let initial i = prefix_for_inits ^ (string_of_int i) -let clock i = prefix_for_clocks ^ (string_of_int i) -let stat i = prefix_for_statics ^ (string_of_int i) - -(* the name of the current state *) -let selfstate env = prefix_for_self_state ^ (string_of_int (statename env)) - -(* access to a write variable *) -let access_write wt s = Cderef (Cvar s) - -(* makes an access to a name *) -let access env i = - let ident, st, wt = findall env i in - let s = string_of_ident ident in - match ident.id_kind with - Kinit | Kmemo | Kstatic -> - Crecord_access(Cvar(prefix_for_self_state ^ (string_of_int st)), - qualid s) - | _ -> - if is_a_write ident - then access_write wt s - else Cvar(s) - -let set name c = Tset(name, c) -let next self name c = Tlabelset(self, name, c) - -(** Compilation of functions *) -(* x1...xn. is translated into - - (1) combinatorial function - - \x1...xn.code;res - - (2) \x1...xn.self. - let self = match !self with - Nil -> let v = { ... init ... } in - self := St(v);v - | St(self) -> self in - code; - res - - r = f [...] x1...xn is translated into: - - (1) combinatorial function - - f = f [...] x1...xn - - (2) state function - - st = ref Nil initialisation part - - r = f x1...xn st step part - -Rmk: we can also write: "if reset then self := { ... }" -*) - -let co_apply env is_state (init_write, init_mem) f subst e_list = - if is_state then - (* state function *) - let st = prefix_for_names ^ (string_of_int symbol#name) in - let prefix = selfstate env in - (init_write, (st, Cref(state_nil)) :: init_mem), - Capply(f, - (subst @ e_list @ [Crecord_access(Cvar(prefix), qualid st)])) - else - (init_write, init_mem), Capply(f, subst @ e_list) - -(* prepare the initialization of memory variables *) -let cmatchstate self states = - let v = prefix_for_names ^ (string_of_int (symbol#name)) in - let st = prefix_state_constr ^ (string_of_int (symbol#name)) in - Cmatch(Cderef(Cvar(self)), - [Cconstructpat(qualid st,[Cvarpat(self)]), Cvar(self); - Cwildpat, Clet(false, [Cvarpat(v), states], - Cseq[Cset(self, - Cconstruct(qualid st, [Cvar(v)])); - Cvar(v)])]) - -(* prepare the initialization of write variables *) -let define_init_writes env init_write code = - List.fold_right - (fun (name, e) code -> Clet(false, [Cvarpat(name), Cref e], code)) - init_write code - -let co_fun env - is_state params p_list static (init_write, init_mem) code result = - if init_mem <> [] then intro_record_type init_mem; - - let code = clet code result in - let code = - if init_write <> [] - then define_init_writes env init_write code - else code in - let self = selfstate env in - if is_state - then - if init_mem = [] then Cfun(params @ p_list @ [Cvarpat(self)], code) - else Cfun(params @ p_list @ [Cvarpat(self)], - Clet(false, [Cvarpat(self), - cmatchstate self - (clet static (state_record init_mem))], - code)) - else Cfun(params @ p_list, code) - -(** Compilation of pattern matching *) -(* - match e with - P1 -> e1 - | ... - | Pn -> en - -(1) e is a static computation - -- initialisation code - let memory = match e with - P1 -> St1 { ... } - | ... - | Pn -> Stn { ... } - -- step code - match memory with - St1{...} -> step1 -| ... -| Stn{...} -> stepn - -(2) e may evolve at every instant - -- init code - ...i1... - ...in... - -- match e with - P1 -> step1 - | ... - | Pn -> stepn - -for the moment, we treat case (1) as case (2) *) - -(* -let co_static_merge e (pat, init_code_fvars_list) = - (* introduces the type definitions for the representation of states *) - let n = List.length init_code_fvars_list in - let prefix_constructor = intro_enum_type n in - - (* builds a constructor value *) - let constructor prefix number f_vars = - Cconstruct(qualid (prefix ^ (string_of_int number)), - List.map (fun name -> Cvar(name)) fvars) in - let constructor_pat prefix number f_vars = - Cconstructpat(qualid (prefix ^ (string_of_int number)), - List.map (fun name -> Cvarpat(name)) fvars) in - - (* computes the initialisation part *) - let rec states number init_code_fvars_list = - match init_code_fvars_list with - [] -> [] - | (pat, init, _, fvars) :: init_code_fvars_list -> - let pat_code = (pat, clet init (constructor prefix number fvars)) in - let pat_code_list = states (number + 1) init_code_fvars_list in - pat_code :: code_list in - - (* computes the transition part *) - let rec steps number init_code_fvars_list = - match init_code_fvars_list with - [] -> [] - | (_, _, code, fvars) :: init_code_fvars_list -> - let pat_code = (constructor_pat prefix number fvars, code) in - let pat_code_list = steps (number + 1) init_code_fvars_list in - pat_code :: pat_code_list in - - (* make the final code *) - let memory = symbol#name in - let init_code = Cmatch(e, states 0 init_code_fvars_list) in - let step_code = Cmatch(Cvar memory, steps 0 init_code_fvars_list) in - Tlet(memory, init_code), step_code - -*) - -(** Compilation of clocks *) -let rec translate_clock env init ck = - match ck with - Dfalse -> init, cfalse - | Dtrue -> init, ctrue - | Dclockvar(n) -> init, access env n - | Don(is_on, ck, car) -> - let init, ck = translate_clock env init ck in - let init, car = translate_carrier env init car in - init, if is_on then cand car ck - else cand (cnot car) ck - -and translate_carrier env init car = - match car with - Dcfalse -> init, cfalse - | Dctrue -> init, ctrue - | Dcvar(n) -> init, access env n - | Dcglobal(g, res, ck) -> - (* a global clock allocates memory *) - (* and is compiled as a function call *) - let res = match res with None -> cfalse | Some(n) -> access env n in - let init, c = translate_clock env init ck in - let init, new_ce = - co_apply env true init (Cglobal g) [c] [res] in - init, new_ce - -(** Compiling immediate. *) -let translate_immediate i = - match i with - | Dbool(b) -> Cbool(b) - | Dint(i) -> Cint(i) - | Dfloat(f) -> Cfloat(f) - | Dchar(c) -> Cchar(c) - | Dstring(s) -> Cstring(s) - | Dvoid -> Cvoid - -(** Compiling variables. *) -let translate_var env v = - match v with - Dglobal(g) -> Cglobal(g) - | Dlocal(n) -> access env n - -(** Compiling a pattern. *) -let rec translate_pat env pat = - match pat with - | Dconstantpat(i) -> Cconstantpat(translate_immediate(i)) - | Dvarpat(s) -> Cvarpat(string_of_name env s) - | Dtuplepat(l) -> Ctuplepat(List.map (translate_pat env) l) - | Dconstructpat(gl, pat_list) -> - Cconstructpat(gl, List.map (translate_pat env) pat_list) - | Dorpat(pat1, pat2) -> Corpat(translate_pat env pat1, - translate_pat env pat2) - | Drecordpat(gl_pat_list) -> - Crecordpat - (List.map (fun (gl, pat) -> (gl, translate_pat env pat)) - gl_pat_list) - | Daliaspat(pat, i) -> Caliaspat(translate_pat env pat, - string_of_name env i) - | Dwildpat -> Cwildpat - -(* -(* add accesses to write variables defined in patterns *) -let rec add_write_access env code pat = - match pat with - Dconstantpat(i) -> code - | Dvarpat(s) when is_a_write (find env s) -> - Tset(string_of_name env s, access env s) :: code - | Dvarpat _ -> code - | Dtuplepat(l) | Dconstructpat(_, l) -> - List.fold_left (add_write_access env) code l - | Dorpat(pat1, pat2) -> - add_write_access env (add_write_access env code pat1) pat2 - | Drecordpat(gl_pat_list) -> - List.fold_left (fun code (_, pat) -> add_write_access env code pat) - code gl_pat_list - | Daliaspat(pat, i) -> - add_write_access env (add_write_access env code pat) (Dvarpat(i)) - | Dwildpat -> code -*) - -(** Compiling an expression *) -(* takes an environment giving information about variables *) -(* and an expression and returns the new code *) -let rec translate env init e = - match e.d_desc with - | Dconstant(i) -> - let i = translate_immediate i in - init, Cconstant(i) - | Dvar(v, subst) -> - let v = translate_var env v in - let init, s = translate_subst env init subst in - let v = match s with [] -> v | l -> Capply(v, l) in - init, v - | Dtuple l -> - let init, lc = translate_list env init l in - init, Ctuple(lc) - | Dfun(is_state, params, p_list, body, result) -> - (* state function *) - let env = push_block body env in - (* compiles types and clock abstractions *) - let params = translate_forall env params in - (* compiles parameters *) - let p_list = List.map (translate_pat env) p_list in - (* remove static computation from the body *) - (* and put it in the allocation place for stateful functions *) - let (static_code, init_code, body, result) = - if is_state - then - let static_code, body = static_block [] body in - let static_code, result = static static_code result in - let static_code = List.rev static_code in - (* translate the static code *) - let static_code, init_code = - translate_static_code env static_code in - (static_code, init_code, body, result) - else - ([], ([], []), body, result) in - (* then translate the body *) - let init_code, body = translate_block env init_code body in - let init_code, result = translate env init_code result in - init, - co_fun env is_state params p_list static_code init_code body result - | Dprim(g, e_list) -> - (* pointwise application *) - let init, ce_list = translate_list env init e_list in - init, Capply(Cglobal(g), ce_list) - | Dconstruct(g, e_list) -> - let init, ce_list = translate_list env init e_list in - init, Cconstruct(g, ce_list) - | Drecord(gl_expr_list) -> - let translate_record (gl, expr) (init, gl_expr_list) = - let init, ce = translate env init expr in - init, (gl, ce) :: gl_expr_list in - let init, l = - List.fold_right translate_record gl_expr_list (init, []) in - init, Crecord(l) - | Drecord_access(expr, gl) -> - let init, ce = translate env init expr in - init, Crecord_access(ce, gl) - | Difthenelse(e0, e1, e2) -> - let init, c0 = translate env init e0 in - let init, c1 = translate env init e1 in - let init, c2 = translate env init e2 in - init, Cifthenelse(c0, c1, c2) - | Dlet(block, e_let) -> - let env = push block env in - let init, code = translate_block env init block in - let init, ce = translate env init e_let in - init, clet code ce - | Dapply(is_state, { d_desc = Dvar(f, subst) }, l) -> - let f = translate_var env f in - let init, l = translate_list env init l in - let init, subst = translate_subst env init subst in - co_apply env is_state init f subst l - | Dapply(is_state, f, l) -> - let init, f = translate env init f in - let init, l = translate_list env init l in - co_apply env is_state init f [] l - | Deseq(e1, e2) -> - let init, e1 = translate env init e1 in - let init, e2 = translate env init e2 in - init, Cseq [e1; e2] - | Dwhen(e1) -> - translate env init e1 - | Dclock(ck) -> - translate_clock env init ck - | Dlast _ | Dinit _ | Dpre _ | Dtest _ -> - (* this case should not arrive *) - fatal_error "translate" - -and translate_list env init l = - match l with - [] -> init, [] - | ce :: l -> - let init, ce = translate env init ce in - let init, l = translate_list env init l in - init, ce :: l - -and translate_block env init b = - (* allocate the memory in the initialisation part *) - let init = allocate_memory env init in - (* compiles the body *) - let init, code = translate_equation env init [] b.b_equations in - (* sets code in the correct order *) - let code = List.rev code in - (* returns the components of the block *) - init, code - -(* the input equations must be already scheduled *) -and translate_equations env init code eq_list = - match eq_list with - [] -> init, code - | eq :: eq_list -> - let init, code = translate_equation env init code eq in - translate_equations env init code eq_list - -and translate_equation_into_exp env init eq = - let init, code = translate_equation env init [] eq in - (* sets code in the correct order *) - let code = List.rev code in - init, cseq code - -and translate_block_into_exp env init block = - let init, code = translate_block env init block in - init, cseq code - -and translate_equation env init code eq = - match eq with - Dget(pat, v) -> - let cpat = translate_pat env pat in - let n = translate_var env v in - init, Tlet(cpat, n) :: code - | Dequation(Dvarpat(n), e) when is_a_write (find env n) -> - let name = string_of_name env n in - let init, ce = translate env init e in - init, (set name ce) :: code - | Dequation(pat, e) | Dstatic(pat, e) -> - let is_rec = is_recursive pat e in - let pat = translate_pat env pat in - let init, ce = translate env init e in - init, if is_rec then Tletrec([pat, ce]) :: code - else Tlet(pat, ce) :: code - | Dwheneq(eq, ck) -> - let init, ce = translate_equation_into_exp env init eq in - let init, ck_ce = translate_clock env init ck in - init, Texp(ifthen ck_ce ce) :: code - | Dmerge(is_static, e, p_block_list) -> - let init, ce = translate env init e in - let init, l = translate_pat_block_list env init p_block_list in - init, merge code ce l - | Dnext(n, e) -> - (* n is either a memo or an initialisation variable *) - let init, ce = translate env init e in - init, (next (selfstate env) (string_of_name env n) ce) :: code - | Dseq(eq_list) | Dpar(eq_list) -> - translate_equations env init code eq_list - | Dblock(block) -> - translate_block env init block - | Demit _ | Dlasteq _ | Dautomaton _ | Dreset _ | Dpresent _ -> - (* these cases should not arrive since control structures have *) - (* been translated into the basic kernel *) - fatal_error "translate_equation" - -(* compilation of pattern matching *) -and translate_pat_block_list env init p_block_list = - (* compile one handler *) - let translate_pat_block init (pat, block) = - let env = push block env in - let cpat = translate_pat env pat in - let init, ce = translate_block_into_exp env init block in - init, (cpat, ce) in - match p_block_list with - [] -> init, [] - | pat_block :: pat_block_list -> - let init, pat_ce = translate_pat_block init pat_block in - let init, pat_ce_list = - translate_pat_block_list env init pat_block_list in - init, pat_ce :: pat_ce_list - -(* translate a pure (stateless) expression *) -and translate_pure env e = - let init, ce = translate env ([], []) e in - assert (init = ([], [])); - ce - -(* computes extra parameters for clock abstraction *) -and translate_forall env params = - let p_clocks = - List.map (fun n -> Cvarpat(string_of_name env n)) params.s_clock in - let p_carriers = - List.map (fun n -> Cvarpat(string_of_name env n)) params.s_carrier in - p_clocks @ p_carriers - -(* generates an application for clock instanciation *) -and translate_subst env init subst = - let rec translate_clock_list init cl_list = - match cl_list with - [] -> init, [] - | cl :: cl_list -> - let init, cl = translate_clock env init cl in - let init, cl_list = translate_clock_list init cl_list in - init, cl :: cl_list in - let rec translate_carrier_list init car_list = - match car_list with - [] -> init, [] - | car :: car_list -> - let init, car = translate_carrier env init car in - let init, car_list = translate_carrier_list init car_list in - init, car :: car_list in - let init, cl_list = translate_clock_list init subst.s_clock in - let init, car_list = translate_carrier_list init subst.s_carrier in - init, cl_list @ car_list - -(* Initialisation code *) -and allocate_memory env init = - let allocate _ ident (acc_write, acc_mem) = - match ident.id_kind with - Kmemo -> - (* we allocate only one cell *) - let default = default_value env ident in - acc_write, (memo ident.id_name, default) :: acc_mem - | Kinit -> - (* init variables are considered to be state variables *) - acc_write, (initial ident.id_name, Cconstant(Cbool(true))) :: acc_mem - | _ when is_a_write ident -> - (* local write variables are allocated too *) - (* but they will be stored in a stack allocated structure *) - let name = string_of_name env ident.id_name in - let default = default_value env ident in - (name, default) :: acc_write, acc_mem - | _ -> acc_write, acc_mem in - Hashtbl.fold allocate (cblock env).b_env init - -(* add static code into the initialisation part *) -and translate_static_code env static_code = - (* add one equation *) - (* we compute the list of introduced names and compile the equation *) - let translate_eq acc (pat, e) = - let acc = fv_pat acc pat in - let pat = translate_pat env pat in - let ce = translate_pure env e in - acc, Tlet(pat, ce) in - let rec translate_static_code acc static_code = - match static_code with - [] -> acc, [] - | pat_e :: static_code -> - let acc, cpat_ce = translate_eq acc pat_e in - let acc, static_code = translate_static_code acc static_code in - acc, cpat_ce :: static_code in - (* introduced names must be added to the memory *) - let intro acc_mem n = - let v = string_of_name env n in - (* modify the kind of [n] *) - set_static (find env n); - (string_of_name env n, Cvar(v)) :: acc_mem in - - (* first compile the static code *) - let acc, static_code = translate_static_code [] static_code in - (* introduced names must be added to the memory initialisation *) - let acc_mem = List.fold_left intro [] acc in - static_code, ([], acc_mem) - -(* default value *) -and default_value env ident = - (* find a value from a type *) - let rec value ty = - match ty with - Dproduct(ty_l) -> Ctuple(List.map value ty_l) - | Dbase(b) -> - let v = match b with - Dtyp_bool -> Cbool(false) - | Dtyp_int -> Cint(0) - | Dtyp_float -> Cfloat(0.0) - | Dtyp_unit -> Cvoid - | Dtyp_char -> Cchar(' ') - | Dtyp_string -> Cstring("") in - Cconstant(v) - | Dsignal(ty) -> Ctuple[value ty; cfalse] - | Dtypvar _ | Darrow _ -> cdummy - | Dconstr(qualid, _) -> - try - let desc = find_type qualid in - match desc.d_type_desc with - Dabstract_type -> cdummy - | Dabbrev(ty) -> - value ty - | Dvariant_type l -> - let case = List.hd l in - begin match case with - (qual, { arg = ty_l }) -> - Cconstruct(qual, List.map value ty_l) - end - | Drecord_type l -> - let field_of_type (qual, _, ty_ty) = (qual, value ty_ty.res) in - Crecord (List.map field_of_type l) - with - Not_found -> cdummy in - let value (Dtypforall(_, ty)) = value ty in - match ident.id_value with - None -> value ident.id_typ - | Some(e) -> translate_pure env e - -(** Compilation of a table of declarative code *) -let translate table = - let translate (s, e) = (s, translate_pure empty_env e) in - (* introduce the type of states *) -(* intro_state_type (); *) - (* then translate *) - (* translate the code *) - { c_types = table.d_types; - c_code = List.map translate table.d_code; - c_vars = table.d_vars; - } diff --git a/compiler/obc/ml/declarative.ml b/compiler/obc/ml/declarative.ml deleted file mode 100644 index ae6db9e..0000000 --- a/compiler/obc/ml/declarative.ml +++ /dev/null @@ -1,295 +0,0 @@ -(**************************************************************************) -(* *) -(* Lucid Synchrone *) -(* *) -(* Author : Marc Pouzet *) -(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) -(* *) -(**************************************************************************) - -(* $Id: declarative.ml,v 1.18 2007-01-11 07:35:53 pouzet Exp $ *) -(* the intermediate format *) - -open Misc -open Names - -(* one set of (unique) names *) -type name = int - -type global = - Gname of string * name - | Gmodname of qualified_ident - -(* type definitions *) -type type_definition = - { d_type_desc: type_components; - d_type_arity: int list - } - -and ('a, 'b) ptyp = { arg: 'a; res: 'b } - -and type_components = - Dabstract_type - | Dabbrev of typ - | Dvariant_type of (qualified_ident * (typ list, typ) ptyp) list - | Drecord_type of (qualified_ident * is_mutable * (typ, typ) ptyp) list - -and is_mutable = bool - -(* types *) -and typs = Dtypforall of name list * typ -and typ = - | Darrow of is_node * typ * typ - | Dproduct of typ list - | Dconstr of qualified_ident * typ list - | Dtypvar of name - | Dbase of base_typ - | Dsignal of typ - -and is_node = bool - -and base_typ = - Dtyp_bool | Dtyp_int | Dtyp_float | Dtyp_unit | - Dtyp_char | Dtyp_string - -type guard = clock - -and clock = - | Dfalse (* the false clock *) - | Dtrue (* the base clock *) - | Don of bool * clock * carrier (* "cl on c" or "cl on not c" *) - | Dclockvar of name (* 'a *) - -and carrier = - Dcfalse - | Dctrue - | Dcvar of name - | Dcglobal of qualified_ident * name option * clock - (* identifier, reset name and clock *) - -(* immediate values *) -type immediate = - | Dbool of bool - | Dint of int - | Dfloat of float - | Dchar of char - | Dstring of string - | Dvoid - -type 'a desc = - { d_desc: 'a; - d_ty: typ; - d_guard: guard - } - -(* patterns *) -type pattern = - | Dwildpat - | Dvarpat of name - | Dconstantpat of immediate - | Dtuplepat of pattern list - | Dconstructpat of qualified_ident * pattern list - | Drecordpat of (qualified_ident * pattern) list - | Daliaspat of pattern * name - | Dorpat of pattern * pattern - -(* signal expressions *) -type spattern = - | Dandpat of spattern * spattern - | Dexppat of expr - | Dcondpat of expr * pattern - -(* expressions *) -and expr = expr_desc desc - -and expr_desc = - | Dconstant of immediate - | Dvar of var * subst - | Dlast of name - | Dpre of expr option * expr - | Difthenelse of expr * expr * expr - | Dinit of clock * name option - | Dtuple of expr list - | Dconstruct of qualified_ident * expr list - | Drecord of (qualified_ident * expr) list - | Drecord_access of expr * qualified_ident - | Dprim of qualified_ident * expr list - | Dfun of is_state * params * pattern list * block * expr - | Dapply of is_state * expr * expr list - | Dlet of block * expr - | Deseq of expr * expr - | Dtest of expr (* testing the presence "?" *) - | Dwhen of expr (* instruction "when" *) - | Dclock of clock - -and is_state = bool - -and var = - | Dlocal of name - | Dglobal of qualified_ident - -and is_external = bool (* true for imported ML values *) - -(* type and clock instance *) -and ('a, 'b, 'c) substitution = - { s_typ: 'a list; - s_clock: 'b list; - s_carrier: 'c list } - -and subst = (typ, clock, carrier) substitution -and params = (name, name, name) substitution - -(* block *) -and block = - { b_env: (name, ident) Hashtbl.t; (* environment *) - mutable b_write: name list; (* write variables *) - b_equations: equation; (* equations *) - } - -(* equation *) -and equation = - Dequation of pattern * expr (* equation p = e *) - | Dnext of name * expr (* next x = e *) - | Dlasteq of name * expr (* last x = e *) - | Demit of pattern * expr (* emit pat = e *) - | Dstatic of pattern * expr (* static pat = e *) - | Dget of pattern * var (* pat = x *) - | Dwheneq of equation * guard (* eq when clk *) - | Dmerge of is_static * expr (* control structure *) - * (pattern * block) list - | Dreset of equation * expr (* reset *) - | Dautomaton of clock * (state_pat * block * block * escape * escape) list - (* automaton weak and strong *) - | Dpar of equation list (* parallel equations *) - | Dseq of equation list (* sequential equations *) - | Dblock of block (* block structure *) - | Dpresent of clock * (spattern * block) list * block - (* presence testing *) - -and escape = (spattern * block * is_continue * state) list - -and is_static = bool -and is_strong = bool -and is_continue = bool - -and state_pat = string * pattern list -and state = string * expr list - -(* ident definition *) -and ident = - { id_name: name; (* its name (unique identifier) *) - id_original: string option; (* its original name when possible *) - id_typ: typs; (* its type *) - id_value: expr option; (* its initial value when possible *) - mutable id_kind: id_kind; (* kind of identifier *) - mutable id_write: bool; (* physically assigned or not *) - mutable id_last: bool; (* do we need its last value also? *) - mutable id_signal: bool; (* is-it a signal? *) - } - -(* a local variable in a block may be of four different kinds *) -and id_kind = - Kinit (* initialisation state variable *) - | Kclock (* clock variable *) - | Kreset (* reset variable *) - | Kmemo (* state variable *) - | Kstatic (* static variable *) - | Klast (* last variable *) - | Kvalue (* defined variable *) - | Kshared (* shared variable with several definitions *) - | Kinput (* input variable, i.e, argument *) - -(* global definition *) -(* Invariant: expr must be bounded and static *) - -(* the declarative code associated to a file *) -type declarative_code = - { mutable d_modname: string; (* module name *) - mutable d_types: (string, type_definition) Hashtbl.t; - (* type definitions *) - mutable d_code: (string * expr) list; (* value definitions *) - mutable d_vars: string list; (* defined names *) - } - - -(* the generated code of a module *) -let dc = { d_modname = ""; - d_types = Hashtbl.create 7; - d_code = []; - d_vars = [] - } - -let code () = dc - -(* thing to do when starting the production of declarative code *) -(* for a file *) -let start modname = - dc.d_modname <- modname; - dc.d_types <- Hashtbl.create 7; - dc.d_code <- []; - dc.d_vars <- [] - -(* things to do at the end of the front-end*) -let finish () = - dc.d_code <- List.rev dc.d_code - -(* apply a function to every value *) -let replace translate = - let rec replace (s, e) = - let e = translate e in - dc.d_code <- (s, e) :: dc.d_code in - let code = dc.d_code in - dc.d_code <- []; - List.iter replace code; - dc.d_code <- List.rev dc.d_code - - -(* add an input to the declarative code *) -let add_dec (name, code) = - dc.d_code <- (name, code) :: dc.d_code; - dc.d_vars <- name :: dc.d_vars - -(* add a type definition to the declarative code *) -let add_type (name, type_def) = - Hashtbl.add dc.d_types name type_def - -(* read code from and write code into a file *) -let read_declarative_code ic = input_value ic - -let write_declarative_code oc = - output_value oc (code ()) - -(* the list of opened modules *) -let dc_modules = (Hashtbl.create 7 : (string, declarative_code) Hashtbl.t) - -(* add a module to the list of opened modules *) -let add_module m = - let name = String.uncapitalize m in - try - let fullname = find_in_path (name ^ ".dcc") in - let ic = open_in fullname in - let dc = input_value ic in - Hashtbl.add dc_modules m dc; - close_in ic; - dc - with - Cannot_find_file _ -> - Printf.eprintf - "Cannot find the compiled declarative file %s.dcc.\n" - name; - raise Error - -let find_value qualid = - let dc = - if qualid.qual = dc.d_modname then dc - else raise Not_found -(* - try - Hashtbl.find dc_modules qualid.qual - with - Not_found -> add_module qualid.qual *) in - List.assoc qualid.id dc.d_code - -let find_type qualid = - if qualid.qual = dc.d_modname then Hashtbl.find dc.d_types qualid.qual - else raise Not_found diff --git a/compiler/obc/ml/declarative_printer.ml b/compiler/obc/ml/declarative_printer.ml deleted file mode 100644 index 6c93d2c..0000000 --- a/compiler/obc/ml/declarative_printer.ml +++ /dev/null @@ -1,699 +0,0 @@ -(**************************************************************************) -(* *) -(* Lucid Synchrone *) -(* *) -(* Author : Marc Pouzet *) -(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) -(* *) -(**************************************************************************) - -(* $Id: declarative_printer.ml,v 1.13 2007-01-11 07:35:53 pouzet Exp $ *) - -open Misc -open Names -open Declarative -open Modules -open Format - -(* generic printing of a list *) -let print_list print l = - let rec printrec l = - match l with - [] -> () - | [x] -> - print x - | x::l -> - print x; - print_space (); - printrec l in - printrec l - -(* local name *) -let print_name i = - print_string "/";print_int i - -(* global names *) -let print_qualified_ident { qual = q; id = id } = - if (q = pervasives_module) or (q = compiled_module_name ()) - or (q = "") - then print_string id - else - begin - print_string q; - print_string "."; - print_string id - end - -(* print types *) -let rec print_type typ = - open_box 1; - begin match typ with - Darrow(is_node, typ1, typ2) -> - print_string "("; - if is_node then print_string "=>" else print_string "->"; - print_space (); - print_list print_type [typ1;typ2]; - print_string ")" - | Dproduct(ty_list) -> - print_string "("; - print_string "*"; - print_space (); - print_list print_type ty_list; - print_string ")" - | Dconstr(qual_ident, ty_list) -> - if ty_list <> [] then print_string "("; - print_qualified_ident qual_ident; - if ty_list <> [] then - begin print_space (); - print_list print_type ty_list; - print_string ")" - end - | Dsignal(ty) -> print_type ty; print_space (); print_string "sig" - | Dtypvar(i) -> print_int i - | Dbase(b) -> print_base_type b - end; - close_box () - -and print_base_type b = - match b with - Dtyp_bool -> print_string "bool" - | Dtyp_int -> print_string "int" - | Dtyp_float -> print_string "float" - | Dtyp_unit -> print_string "unit" - | Dtyp_string -> print_string "string" - | Dtyp_char -> print_string "char" - -let print_typs (Dtypforall(l, typ)) = - match l with - [] -> (* we do not print the quantifier when there is no type variable *) - print_type typ - | l -> - open_box 1; - print_string "(forall"; - print_space (); - print_list print_name l; - print_space (); - print_type typ; - print_string ")"; - close_box () - -(* print clocks *) -let rec print_clock clk = - match clk with - | Dfalse -> print_string "false" - | Dtrue -> print_string "true" - | Dclockvar(i) -> print_name i - | Don(b, clk, c) -> - print_string "("; - if b then print_string "on" else print_string "onot"; - print_space (); - print_clock clk; - print_space (); - print_carrier c; - print_string ")" -and print_carrier c = - match c with - Dcfalse -> print_string "false" - | Dctrue -> print_string "true" - | Dcvar(i) -> print_name i - | Dcglobal(qual_ident, res, clk) -> - print_qualified_ident qual_ident; - print_string "("; - (match res with - None -> () - | Some(n) -> print_space ();print_name n;print_space ()); - print_clock clk; - print_string ")" - -(* immediate values *) -let print_immediate i = - match i with - Dbool(b) -> print_string (if b then "true" else "false") - | Dint(i) -> print_int i - | Dfloat(f) -> print_float f - | Dchar(c) -> print_char c - | Dstring(s) -> print_string s - | Dvoid -> print_string "()" - -(* print patterns *) -let atom_pat pat = - match pat with - Dconstantpat _ | Dvarpat _ | Dwildpat -> true - | _ -> false - -let rec print_pat pat = - open_box 1; - if not (atom_pat pat) then print_string "("; - begin match pat with - Dwildpat -> print_string "_" - | Dconstantpat(i) -> print_immediate i - | Dvarpat(i) -> print_name i - | Dconstructpat(qual_ident, pat_list) -> - print_string "constr"; - print_space (); - print_qualified_ident qual_ident; - if pat_list <> [] then print_space (); - print_list print_pat pat_list - | Dtuplepat(pat_list) -> - print_string ","; - print_space (); - print_list print_pat pat_list - | Drecordpat(l) -> - print_string "record"; - print_list - (fun (qual_ident, pat) -> - open_box 1; - print_string "("; - print_qualified_ident qual_ident; - print_space (); - print_pat pat; - print_string ")"; - close_box ()) l - | Dorpat(pat1, pat2) -> - print_string "orpat"; - print_space (); - print_list print_pat [pat1;pat2] - | Daliaspat(pat, i) -> - print_string "as"; - print_space (); - print_pat pat; - print_space (); - print_int i - end; - if not (atom_pat pat) then print_string ")"; - close_box () - -(* print statepat *) -let print_statepat (s, l) = - match l with - [] -> print_string s - | l -> print_string "("; - print_string s; - print_space (); - print_list print_pat l; - print_string ")" - -(* print expressions *) -let atom e = - match e.d_desc with - Dconstant _ -> true - | _ -> false - -(* print variables *) -let print_var v = - match v with - Dlocal(n) -> - print_string "local"; - print_space (); - print_name n - | Dglobal(qual_ident) -> - print_string "global"; - print_space (); - print_qualified_ident qual_ident - -let rec print e = - open_box 1; - if not (atom e) then print_string "("; - begin match e.d_desc with - Dconstant(i) -> print_immediate i - | Dvar(v, subst) -> - print_var v; - print_subst subst - | Dlast(i) -> - print_string "last"; - print_space (); - print_name i - | Dpre(opt_default, e) -> - print_string "pre"; - print_space (); - begin match opt_default with - None -> print e - | Some(default) -> - print default; print_space (); print e - end - | Dinit(ck, None) -> - print_string "init"; - print_space (); - print_clock ck - | Dinit(ck, Some(n)) -> - print_string "init"; - print_space (); - print_clock ck; - print_space (); - print_name n - | Difthenelse(e0,e1,e2) -> - print_string "if"; - print_space (); - print e0; - print_space (); - print e1; - print_space (); - print e2 - | Dtuple(l) -> - print_string ","; - print_space (); - print_list print l - | Dconstruct(qual_ident,l) -> - print_string "constr"; - print_space (); - print_qualified_ident qual_ident; - if l <> [] then print_space (); - print_list print l - | Dprim(qual_ident, l) -> - print_string "("; - print_qualified_ident qual_ident; - print_space (); - print_list print l; - print_string ")" - | Drecord(l) -> - print_string "record"; - print_space (); - print_list (fun (qual_ident, e) -> - open_box 1; - print_string "("; - print_qualified_ident qual_ident; - print_space (); - print e; - print_string ")"; - close_box ()) l - | Drecord_access(e,qual_ident) -> - print_string "access"; - print_space (); - print e; - print_space (); - print_qualified_ident qual_ident - | Dfun(is_state, params, args, block, e) -> - print_string ("fun" ^ (if is_state then "(s)" else "(c)")); - print_space (); - print_params params; - print_space (); - print_list print_pat args; - print_space (); - print_block block; - print_space (); - print_string "return "; - print e - | Dapply(is_state, f, e_list) -> - print_string ("apply" ^ (if is_state then "(s)" else "(c)")); - print_space (); - print f; - print_space (); - print_list print e_list - | Dlet(block, e) -> - print_string "let"; - print_space (); - print_block block; - print_space (); - print e - | Deseq(e1, e2) -> - print_string "seq"; - print_space (); - print e1; - print_space (); - print e2 - | Dtest(e1) -> - print_string "test"; - print_space (); - print e1 - | Dwhen(e1) -> - print_string "when"; - print_space (); - print e1 - | Dclock(ck) -> - print_string "clock"; - print_space (); - print_clock ck - end; - if not (atom e) then print_string ")"; - close_box() - -and print_block b = - (* print variable definitions *) - let print_env env = - open_box 1; - print_string "(env"; - print_space (); - Hashtbl.iter (fun i ident -> print_ident ident;print_space ()) env; - print_string ")"; - close_box () in - (* main function *) - open_box 1; - print_string "("; - (* environment *) - print_env b.b_env; - print_space (); - (* equations *) - print_equation b.b_equations; - print_space (); - (* write variables *) - print_string "(write"; - print_space (); - print_list print_name b.b_write; - print_string ")"; - print_string ")"; - close_box () - -(* print ident declarations *) -(* e.g, "(kind x/412 (int) (cl) (write) (last) (signal) (= 412))" *) -and print_ident id = - let print_kind () = - match id.id_kind with - Kinit -> print_string "init" - | Kclock -> print_string "clock" - | Kmemo -> print_string "memo" - | Kstatic -> print_string "static" - | Klast -> print_string "last" - | Kreset -> print_string "reset" - | Kvalue -> print_string "value" - | Kinput -> print_string "input" - | Kshared -> print_string "shared" in - let print_name () = - begin match id.id_original with - None -> () - | Some(s) -> print_string s - end; - print_name id.id_name in - let print_typs () = - print_string "("; - print_typs id.id_typ; - print_string ")" in - let print_write () = - if id.id_write then - begin print_space (); print_string "(write)" end in - let print_last () = - if id.id_last then - begin print_space (); print_string "(last)" end in - let print_signal () = - if id.id_signal then - begin print_space (); print_string "(signal)" end in - let print_expr () = - match id.id_value with - None -> () - | Some(e) -> - print_space ();print_string "(= "; print e; print_string ")" in - (* main function *) - open_box 1; - print_string "("; - print_kind (); - print_space (); - print_name (); - print_space (); - print_typs (); - print_space (); - print_write (); - print_last (); - print_signal (); - print_expr (); - print_string ")"; - close_box () - -(* prints a sequence of sets of parallel equations *) -and print_equation eq = - open_box 1; - print_string "("; - begin match eq with - Dequation(pat, e) -> - print_string "let"; - print_space (); - print_pat pat; - print_space (); - print e; - print_space (); - print_clock e.d_guard - | Dlasteq(n, e) -> - print_string "last"; - print_space (); - print_name n; - print_space (); - print e; - print_space (); - print_clock e.d_guard - | Demit(pat, e) -> - print_string "emit"; - print_space (); - print_pat pat; - print_space (); - print e; - print_space (); - print_clock e.d_guard - | Dstatic(pat, e) -> - print_string "static"; - print_space (); - print_pat pat; - print_space (); - print e; - print_space (); - print_clock e.d_guard - | Dnext(n, e) -> - print_string "next"; - print_space (); - print_name n; - print_space (); - print e; - print_space (); - print_clock e.d_guard - | Dget(pat, v) -> - print_string "get"; - print_space (); - print_pat pat; - print_space (); - print_var v - | Dwheneq(eq, clk) -> - print_string "when"; - print_space (); - print_clock clk; - print_space (); - print_equation eq - | Dmerge(is_static, e, pat_block_list) -> - print_string "merge"; - print_space (); - if is_static then print_string "static" - else print_clock e.d_guard; - print_space (); - print e; - print_space (); - print_list (fun (pat, block) -> - open_box 1; - print_string "("; - print_pat pat; - print_space (); - print_block block; - print_string ")"; - close_box ()) pat_block_list - | Dpresent(ck, scondpat_block_list, block) -> - print_string "present"; - print_space (); - print_clock ck; - print_space (); - print_list (fun (scondpat, block) -> - open_box 1; - print_string "("; - print_spat scondpat; - print_space (); - print_block block; - print_string ")"; - close_box ()) scondpat_block_list; - print_space (); - print_block block - | Dreset(eq, e) -> - print_string "reset"; - print_space (); - print_equation eq; - print_space (); - print e - | Dautomaton(ck, handlers) -> - print_string "automaton"; - print_space (); - print_clock ck; - print_space (); - print_list print_handler handlers - | Dpar(eq_list) -> - print_string "par"; - print_space (); - print_list print_equation eq_list - | Dseq(eq_list) -> - print_string "seq"; - print_space (); - print_list print_equation eq_list - | Dblock(b) -> - print_string "block"; - print_space (); - print_block b - end; - print_string ")"; - close_box () - -(* print the handlers of an automaton *) -and print_handler (statepat, b_weak, b_strong, weak_escape, strong_escape) = - open_box 1; - print_string "(state"; - print_space (); - print_statepat statepat; - print_space (); - print_block b_weak; - print_space (); - print_block b_strong; - print_space (); - print_string "(weak "; - print_escape weak_escape; - print_string ")"; - print_space (); - print_string "(strong "; - print_escape weak_escape; - print_string ")"; - print_string ")"; - close_box () - -and print_escape escape_list = - print_list - (fun (spat, b, is_continue, state) -> - print_string "("; - if is_continue then print_string "continue " else print_string "then "; - print_spat spat; - print_space (); - print_block b; - print_space (); - print_state state; - print_string ")") - escape_list; - close_box () - - -(* print type and clock instance *) -and print_subst { s_typ = st; s_clock = scl; s_carrier = sc } = - match st, scl, sc with - [],[],[] -> () - | l1,l2,l3 -> - print_string "["; - print_list print_type l1; - print_string "]"; - print_space (); - print_string "["; - print_list print_clock l2; - print_string "]"; - print_space (); - print_string "["; - print_list print_carrier l3; - print_string "]"; - -and print_params { s_typ = pt; s_clock = pcl; s_carrier = pc } = - match pt, pcl, pc with - [],[],[] -> () - | l1,l2,l3 -> - print_string "["; - print_list print_name l1; - print_string "]"; - print_space (); - print_string "["; - print_list print_name l2; - print_string "]"; - print_space (); - print_string "["; - print_list print_name l3; - print_string "]" - -and print_state (s, l) = - match l with - [] -> print_string s - | l -> print_string "("; - print_string s; - print_space (); - print_list print l; - print_string ")" - -and atom_spat spat = - match spat with - Dexppat _ | Dcondpat _ -> true - | _ -> false - -and print_spat spat = - open_box 1; - if not (atom_spat spat) then print_string "("; - begin match spat with - Dandpat(spat1, spat2) -> - print_string "& "; - print_spat spat1; - print_space (); - print_spat spat2 - | Dexppat(e) -> - print e - | Dcondpat(e, pat) -> - print_string "is "; - print e; - print_space (); - print_pat pat - end; - if not (atom_spat spat) then print_string ")"; - close_box () - -(* the main entry for printing definitions *) -let print_definition (name, e) = - open_box 2; - print_string "(def "; - if is_an_infix_or_prefix_operator name - then begin print_string "( "; print_string name; print_string " )" end - else print_string name; - print_space (); - print e; - print_string ")"; - print_newline (); - close_box () - -(* print types *) -let print_variant (qualid, { arg = typ_list; res = typ }) = - print_string "("; - print_qualified_ident qualid; - print_string "("; - print_list print_type typ_list; - print_string ")"; - print_space (); - print_type typ; - print_string ")" - -let print_record (qualid, is_mutable, { arg = typ1; res = typ2 }) = - print_string "("; - if is_mutable then print_string "true" else print_string "false"; - print_space (); - print_qualified_ident qualid; - print_space (); - print_type typ1; - print_space (); - print_type typ2; - print_string ")" - -let print_type_declaration s { d_type_desc = td; d_type_arity = arity } = - open_box 2; - print_string "(type["; - print_list print_name arity; - print_string "]"; - print_space (); - print_string s; - print_space (); - begin match td with - Dabstract_type -> () - | Dabbrev(ty) -> - print_type ty - | Dvariant_type variant_list -> - List.iter print_variant variant_list - | Drecord_type record_list -> - List.iter print_record record_list - end; - print_string ")"; - print_newline (); - close_box ();; - -(* the main functions *) -set_max_boxes max_int ;; - -let output_equations oc eqs = - set_formatter_out_channel oc; - List.iter print_equation eqs - -let output oc declarative_code = - set_formatter_out_channel oc; - (* print type declarations *) - Hashtbl.iter print_type_declaration declarative_code.d_types; - (* print value definitions *) - List.iter print_definition declarative_code.d_code; - print_flush () - diff --git a/compiler/obc/ml/default_value.ml b/compiler/obc/ml/default_value.ml deleted file mode 100644 index ff2800a..0000000 --- a/compiler/obc/ml/default_value.ml +++ /dev/null @@ -1,63 +0,0 @@ -(**************************************************************************) -(* *) -(* Lucid Synchrone *) -(* *) -(* Author : Gregoire Hamon, Marc Pouzet *) -(* Organization : SPI team, LIP6 laboratory, University Paris 6 *) -(* *) -(**************************************************************************) - -(* $Id: default_value.ml,v 1.1.1.1 2005-11-03 15:45:23 pouzet Exp $ *) - -(** Computes a default value from a type *) - -open Misc -open Names -open Def_types -open Types -open Initialization -open Caml - -let default x ty = - let rec def ty = - match ty with - TypeVar{contents = Typindex _} -> Cdummy "" - | TypeVar{contents = Typlink ty} -> def ty - | Tarrow _ -> x - | Tproduct(t_list) -> - if t_list = [] - then Cdummy "" - else Ctuple (List.map def t_list) - | Tconstr (info, tlist) -> - if info.qualid.qual = pervasives_module then - match info.qualid.id with - | "int" -> Cim (Cint 0) - | "bool" | "clock" -> Cim (Cbool false) - | "float" -> Cim (Cfloat 0.0) - | "char" -> Cim (Cchar 'a') - | "string" -> Cim (Cstring "") - | "unit" -> Cim (Cvoid) - | _ -> Cdummy "" - else - match info.info_in_table.type_desc with - Abstract_type -> Cdummy "" - | Variant_type l -> - begin - let case = List.hd l in - match case.info_in_table.typ_desc with - Tarrow (ty1, ty2) -> - Cconstruct1 ({ cqual = case.qualid.qual; - cid = case.qualid.id }, def ty1) - | _ -> - Cconstruct0 { cqual = case.qualid.qual; - cid = case.qualid.id } - end - | Record_type l -> - let field_of_type x = - let ty1,_ = filter_arrow x.info_in_table.typ_desc in - ({ cqual = x.qualid.qual; cid = x.qualid.id }, def ty1) in - Crecord (List.map field_of_type l) - in - def ty - - diff --git a/compiler/obc/ml/misc.ml b/compiler/obc/ml/misc.ml deleted file mode 100644 index 3b0b07d..0000000 --- a/compiler/obc/ml/misc.ml +++ /dev/null @@ -1,295 +0,0 @@ -(**************************************************************************) -(* *) -(* Lucid Synchrone *) -(* *) -(* Author : Marc Pouzet *) -(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) -(* *) -(**************************************************************************) - -(* $Id: misc.ml,v 1.11 2006-09-30 12:27:27 pouzet Exp $ *) - -(* version of the compiler *) -let version = "3.0b" - -let date = DATE - -(* standard module *) -let pervasives_module = Pervasives -let standard_lib = STDLIB - -(* variable creation *) -(* generating names *) -class name_generator = - object - val mutable counter = 0 - method name = - counter <- counter + 1; - counter - method reset = - counter <- 0 - method init i = - counter <- i - end - -(* association table with memoization *) -class name_assoc_table f = - object - val mutable counter = 0 - val mutable assoc_table: (int * string) list = [] - method name var = - try - List.assq var assoc_table - with - not_found -> - let n = f counter in - counter <- counter + 1; - assoc_table <- (var,n) :: assoc_table; - n - method reset = - counter <- 0; - assoc_table <- [] - end - -(* error during the whole process *) -exception Error - -(* internal error : for example, an abnormal pattern matching failure *) -(* gives the name of the function *) -exception Internal_error of string - -let fatal_error s = raise (Internal_error s) - -let not_yet_implemented s = - Printf.eprintf "The construction %s is not implemented yet.\n" s; - raise Error - -(* creating a name generator for type and clock calculus *) -(* ensure unicity for the whole process *) -let symbol = new name_generator - -(* generic and non generic variables in the various type systems *) -let generic = -1 -let notgeneric = 0 -let maxlevel = max_int - -let binding_level = ref 0 -let top_binding_level () = !binding_level = 0 - -let push_binding_level () = binding_level := !binding_level + 1 -let pop_binding_level () = - binding_level := !binding_level - 1; - assert (!binding_level > generic) -let reset_binding_level () = binding_level := 0 - -(* realtime mode *) -let realtime = ref false - -(* assertions *) -let no_assert = ref false - -(* converting integers into variable names *) -(* variables are printed 'a, 'b *) -let int_to_letter bound i = - if i < 26 - then String.make 1 (Char.chr (i+bound)) - else String.make 1 (Char.chr ((i mod 26) + bound)) ^ string_of_int (i/26) - -let int_to_alpha i = int_to_letter 97 i - -(* printing information *) -class on_off = - object - val mutable status = false - method set = status <- true - method get = status - end - -let print_type = new on_off -let print_clock = new on_off -let print_init = new on_off -let print_causality = new on_off -let no_causality = ref false -let no_initialisation = ref false - -let no_deadcode = ref false - -(* control what is done in the compiler *) -exception Stop - -let only = ref "" -let set_only_info o = only := o -let parse_only () = - if !only = "parse" then raise Stop -let type_only () = - if !only = "type" then raise Stop -let clock_only () = - if !only = "clock" then raise Stop -let caus_only () = - if !only = "caus" then raise Stop -let init_only () = - if !only = "init" then raise Stop -let dec_only () = - if !only = "parse" or !only = "type" - or !only = "clock" or !only = "init" - or !only = "dec" then raise Stop - -(* load paths *) -let load_path = ref ([] : string list) - -(* no link *) -let no_link = ref false - -(* simulation node *) -let simulation_node = ref "" - -(* sampling rate *) -let sampling_rate : int option ref = ref None - -(* level of inlining *) -let inlining_level = ref 10 - -(* emiting declarative code *) -let print_declarative_code = ref false -let print_auto_declarative_code = ref false -let print_total_declarative_code = ref false -let print_last_declarative_code = ref false -let print_signals_declarative_code = ref false -let print_reset_declarative_code = ref false -let print_linearise_declarative_code = ref false -let print_initialize_declarative_code = ref false -let print_split_declarative_code = ref false -let print_inline_declarative_code = ref false -let print_constant_declarative_code = ref false -let print_deadcode_declarative_code = ref false -let print_copt_declarative_code = ref false - -(* total emission of signals *) -let set_total_emit = ref false - -(* generating C *) -let make_c_code = ref false - -(* profiling information about the compilation *) -let print_exec_time = ref false - -exception Cannot_find_file of string - -let find_in_path filename = - if Sys.file_exists filename then - filename - else if not(Filename.is_implicit filename) then - raise(Cannot_find_file filename) - else - let rec find = function - [] -> - raise(Cannot_find_file filename) - | a::rest -> - let b = Filename.concat a filename in - if Sys.file_exists b then b else find rest - in find !load_path - - -(* Prompts: [error_prompt] is printed before compiler error *) -(* and warning messages *) -let error_prompt = ">" - -(* list intersection *) -let intersect l1 l2 = - List.exists (fun el -> List.mem el l1) l2 - -(* remove an entry from an association list *) -let rec remove n l = - match l with - [] -> raise Not_found - | (m, v) :: l -> - if n = m then l else (m, v) :: remove n l - -(* list substraction. l1 - l2 *) -let sub_list l1 l2 = - let rec sl l l1 = - match l1 with - [] -> l - | h :: t -> sl (if List.mem h l2 then l else (h :: l)) t in - sl [] l1 - -(* union *) -let rec union l1 l2 = - match l1, l2 with - [], l2 -> l2 - | l1, [] -> l1 - | x :: l1, l2 -> - if List.mem x l2 then union l1 l2 else x :: union l1 l2 - -let addq x l = if List.memq x l then l else x :: l - -let rec unionq l1 l2 = - match l1, l2 with - [], l2 -> l2 - | l1, [] -> l1 - | x :: l1, l2 -> - if List.memq x l2 then unionq l1 l2 else x :: unionq l1 l2 - -(* intersection *) -let rec intersection l1 l2 = - match l1, l2 with - ([], _) | (_, []) -> [] - | x :: l1, l2 -> if List.mem x l2 then x :: intersection l1 l2 - else intersection l1 l2 - -(* the last element of a list *) -let rec last l = - match l with - [] -> raise (Failure "last") - | [x] -> x - | _ :: l -> last l - -(* iterator *) -let rec map_fold f acc l = - match l with - [] -> acc, [] - | x :: l -> - let acc, v = f acc x in - let acc, l = map_fold f acc l in - acc, v :: l - -(* flat *) -let rec flat l = - match l with - [] -> [] - | x :: l -> x @ flat l - -(* reverse *) -let reverse l = - let rec reverse acc l = - match l with - [] -> acc - | x :: l -> reverse (x :: acc) l in - reverse [] l - -(* generic printing of a list *) -let print_list print print_sep l = - let rec printrec l = - match l with - [] -> () - | [x] -> - print x - | x::l -> - print x; - print_sep (); - printrec l in - printrec l - -(* generates the sequence of integers *) -let rec from n = if n = 0 then [] else n :: from (n-1) - -(* for infix operators, print parenthesis around *) -let is_an_infix_or_prefix_operator op = - if op = "" then false - else - let c = String.get op 0 in - not (((c >= 'a') & (c <= 'z')) or ((c >= 'A') & (c <= 'Z'))) - -(* making a list from a hash-table *) -let listoftable t = - Hashtbl.fold (fun key value l -> (key, value) :: l) t [] diff --git a/compiler/obc/ml/ml.ml b/compiler/obc/ml/ml.ml deleted file mode 100644 index 139597f..0000000 --- a/compiler/obc/ml/ml.ml +++ /dev/null @@ -1,2 +0,0 @@ - -