405 lines
11 KiB
OCaml
405 lines
11 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* 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 ()
|
|
|