Skip to content

GitLab

Commit 9a271256 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-02-18 22:58:35 by jdemouth] Some bug fixes... (but still unstable) 

Original author: jdemouth
Date: 2004-02-18 22:58:35+00:00
parent 68d800dc
Hide whitespace changes
Inline Side-by-side
cdo2cmo/src/cduce.ml
View file @ 9a271256
......@@ -63,17 +63,18 @@ and from_decl left array = function
| ML_variant list ->
List.fold_left (
fun t ( name, list ) ->
let node = CD.Types.make () in
let atom = CD.Atoms.atom ( CD.Atoms.V.mk_ascii name ) in
let atom = CD.Types.cons ( CD.Types.atom atom ) in
CD.Types.define node ( CD.Types.atom atom );
let desc = match list with
| [] ->
CD.Types.descr atom
CD.Types.descr node
| hd :: [] ->
let desc = from_desc left array hd in
CD.Types.times atom desc
CD.Types.times node desc
| _ ->
let tuple = tuple_of_list left array list in
CD.Types.times atom tuple
CD.Types.times node tuple
in
CD.Types.cup t desc
) CD.Types.empty list
......@@ -81,51 +82,71 @@ and from_decl left array = function
and from_desc left array = function
| ML_arrow ( lbl, d1, d2 ) ->
let node = CD.Types.make () in
let l = from_desc true array d1
and r = from_desc false array d2 in
CD.Types.cons ( CD.Types.arrow l r )
CD.Types.define node ( CD.Types.arrow l r );
node
| ML_bool ->
CD.Types.cons ( CD.Builtin_defs.bool )
| ML_ident ( id, params, ocaml ) ->
let node = from_ocaml_type left params ocaml.ml_id ocaml.ml_decl in
let node = CD.Types.make () in
CD.Types.define node ( CD.Builtin_defs.bool );
node
| ML_char ->
let node = CD.Types.make () in
CD.Types.define node ( CD.Types.char ( CD.Chars.mk_classes [ ( 0, 255 ) ] ) );
node
| ML_ident ( id, params, ocaml ) ->
from_ocaml_type left params ocaml.ml_id ocaml.ml_decl
| ML_int ->
let node = CD.Types.make () in
let lB = CD.Intervals.V.mk ( string_of_int min_int )
and uB = CD.Intervals.V.mk ( string_of_int max_int ) in
CD.Types.cons ( CD.Types.interval ( CD.Intervals.bounded lB uB ) )
CD.Types.define node ( CD.Types.interval ( CD.Intervals.bounded lB uB ) );
node
| ML_list d ->
let desc = CD.Types.descr ( from_desc left array d ) in
CD.Types.cons ( CD.Sequence.star desc )
let desc = from_desc left array d in
CD.Sequence.star_node desc
| ML_option desc ->
let node = CD.Types.make () in
let trans = CD.Types.descr ( from_desc left array desc ) in
CD.Types.cons ( CD.Types.cup trans cd_type_nil )
CD.Types.define node ( CD.Types.cup trans cd_type_nil );
node
| ML_reference desc ->
let node = CD.Types.make () in
let get = ML_arrow ( None, ML_unit, desc )
and set = ML_arrow ( None, desc, ML_unit ) in
let ref = ML_record [ "get", get ; "set", set ] in
CD.Types.cons ( from_decl left array ref )
CD.Types.define node ( from_decl left array ref );
node
| ML_string ->
CD.Types.cons ( CD.Builtin_defs.string_latin1 )
let node = CD.Types.make () in
CD.Types.define node ( CD.Builtin_defs.string_latin1 );
node
| ML_tuple list ->
assert ( List.length list >= 2 );
tuple_of_list left array list
| ML_unit ->
CD.Types.cons ( CD.Sequence.nil_type )
let node = CD.Types.make () in
CD.Types.define node CD.Sequence.nil_type;
node
| ML_var id ->
from_desc left array array.( id )
and tuple_of_list left array list =
let rec internal tail = function
| hd :: [] ->
let node = CD.Types.make () in
let desc = from_desc left array hd in
CD.Types.times desc ( CD.Types.cons tail )
CD.Types.define node ( CD.Types.times tail desc );
node
| hd :: tl ->
let node = CD.Types.make () in
let desc = from_desc left array hd in
let tail = CD.Types.times desc ( CD.Types.cons tail ) in
internal tail tl
CD.Types.define node ( CD.Types.times tail desc );
internal node tl
| [] -> assert false in
let tail = CD.Types.descr ( from_desc left array ( List.hd list ) ) in
CD.Types.cons ( internal tail ( List.tl list ) )
let tail = from_desc left array ( List.hd list ) in
internal tail ( List.tl list )
(***********************************************************************************)
......
cdo2cmo/src/checker.ml
View file @ 9a271256
......@@ -10,10 +10,10 @@ let error e = raise ( Error e )
let report_error = function
| Undefined_value ( file, func ) ->
Format.eprintf "Error in file %s.cmi:@." file;
Format.eprintf "cdo2cmo : error in file %s.cmi:@." file;
Format.eprintf "Value %s has no counterpart in file %s.cdo@." func file
| Type_mismatch ( file, ml_t, cd_t ) ->
Format.eprintf "Error in file %s.cmi:@." file;
Format.eprintf "cdo2cmo : error in file %s.cmi:@." file;
Cduce.Type.print Format.err_formatter cd_t;
Format.eprintf "\nis not a subtype of@.";
Ocaml.Type.print Format.err_formatter ( true, [ ml_t ] )
......@@ -32,6 +32,6 @@ let run ml_cu cd_cu =
then error ( Type_mismatch ( file, ml_t, cd_base ) );
with Not_found ->
error ( Undefined_value ( file, ml_t.Types.ml_name ) ) )
| _ -> ()
| _ -> ()
) ml_cu
with Error e -> report_error e; exit 1
cdo2cmo/src/generator.ml
View file @ 9a271256
......@@ -37,6 +37,7 @@ end
type code_t =
| To_CDuce_bool
| To_CDuce_char
| To_CDuce_fun of string * string * code_t * code_t
| To_CDuce_int
| To_CDuce_list of code_t
......@@ -46,8 +47,9 @@ type code_t =
| To_CDuce_tuple of code_t list
| To_CDuce_type of string
| To_CDuce_unit
| To_CDuce_variant of ( string * code_t option ) list
| To_CDuce_variant of ( string * code_t list ) list
| To_OCaml_bool
| To_OCaml_char
| To_OCaml_fun of string * code_t * code_t
| To_OCaml_int
| To_OCaml_list of code_t
......@@ -57,7 +59,7 @@ type code_t =
| To_OCaml_tuple of code_t list
| To_OCaml_type of string
| To_OCaml_unit
| To_OCaml_variant of ( string * code_t option ) list
| To_OCaml_variant of ( string * code_t list ) list
type value_t =
| Type_to_cd of string * bool * bool * code_t
......@@ -74,7 +76,8 @@ let rec dump fmt = function
| false, _ -> Format.fprintf fmt "and "
in
Format.fprintf fmt "ocaml2cduce__%s cdo2cmo__val = @." name;
dump_code fmt "cdo2cmo__val" code
dump_code fmt "cdo2cmo__val" code;
Format.fprintf fmt "@."
| Type_to_ml ( name, first, is_rec, code ) ->
let () = match first, is_rec with
| true, true -> Format.fprintf fmt "let rec "
......@@ -82,60 +85,63 @@ let rec dump fmt = function
| false, _ -> Format.fprintf fmt "and "
in
Format.fprintf fmt "cduce2ocaml__%s cdo2cmo__val = @." name;
dump_code fmt "cdo2cmo__val" code
dump_code fmt "cdo2cmo__val" code;
Format.fprintf fmt "@."
| Value ( name, slot, code ) ->
Format.fprintf fmt "let %s =" name;
Format.fprintf fmt " let cdo2cmo__val = @.";
Format.fprintf fmt " !CDuce_all.Eval.from_comp_unit cdo2cmo__cu %d in@." slot;
Format.fprintf fmt "let cdo2cmo__val = @.";
Format.fprintf fmt "!CDuce_all.Eval.from_comp_unit cdo2cmo__cu %d in@." slot;
dump_code fmt "cdo2cmo__val" code
and dump_code fmt name = function
| To_CDuce_bool ->
Format.fprintf fmt " CDuce_all.Value.vbool %s@." name
Format.fprintf fmt "CDuce_all.Value.vbool %s@." name
| To_CDuce_char ->
assert false (* TODO *)
| To_CDuce_fun ( func, arg, code1, code2 ) ->
Format.fprintf fmt "let %s = fun %s -> @." func arg;
Format.fprintf fmt " let cdo2cmo__p = @.";
Format.fprintf fmt "let cdo2cmo__p = @.";
dump_code fmt arg code1;
Format.fprintf fmt " in @.";
Format.fprintf fmt " let cdo2cmo__val = %s cdo2cmo__p in@." func;
Format.fprintf fmt "in @.";
Format.fprintf fmt "let cdo2cmo__val = %s cdo2cmo__p in@." func;
dump_code fmt "cdo2cmo__val" code2;
Format.fprintf fmt " in@.";
Format.fprintf fmt " CDuce_all.Value.Abstraction( [], %s )@." func
Format.fprintf fmt "in@.";
Format.fprintf fmt "CDuce_all.Value.Abstraction( [], %s )@." func
| To_CDuce_int ->
Format.fprintf fmt " CDuce_all.Value.const (@.";
Format.fprintf fmt " CDuce_all.Types.Integer (@.";
Format.fprintf fmt " CDuce_all.Intervals.V.mk (@.";
Format.fprintf fmt " string_of_int %s ))) @." name
Format.fprintf fmt "CDuce_all.Value.const (@.";
Format.fprintf fmt "CDuce_all.Types.Integer (@.";
Format.fprintf fmt "CDuce_all.Intervals.V.mk (@.";
Format.fprintf fmt "string_of_int %s ))) @." name
| To_CDuce_list code ->
Format.fprintf fmt " CDuce_all.Value.sequence (@.";
Format.fprintf fmt " List.map (fun cdo2cmo__e -> @.";
Format.fprintf fmt "CDuce_all.Value.sequence (@.";
Format.fprintf fmt "List.map (fun cdo2cmo__e -> @.";
dump_code fmt "cdo2cmo__e" code;
Format.fprintf fmt " ) %s )@." name
Format.fprintf fmt ") %s )@." name
| To_CDuce_option code ->
Format.fprintf fmt " match %s with @." name;
Format.fprintf fmt " | None -> CDuce_all.Value.nil@.";
Format.fprintf fmt " | Some %s -> (@." name;
Format.fprintf fmt "match %s with @." name;
Format.fprintf fmt "| None -> CDuce_all.Value.nil@.";
Format.fprintf fmt "| Some %s -> (@." name;
dump_code fmt name code;
Format.fprintf fmt " )@."
Format.fprintf fmt ")@."
| To_CDuce_record list ->
Format.fprintf fmt " CDuce_all.Value.vrecord [@.";
Format.fprintf fmt "CDuce_all.Value.vrecord [@.";
let rec print_list = function
| [] -> ()
| [ ( field, desc ) ] ->
Format.fprintf fmt "( CDuce_all.Ns.mk_ascii \"\", @.";
Format.fprintf fmt " CDuce_all.Encodings.Utf8.mk \"%s\" ), @. " field;
Format.fprintf fmt "CDuce_all.Encodings.Utf8.mk \"%s\" ), @. " field;
dump_code fmt ( Format.sprintf "%s.%s" name field ) desc
| ( field, desc ) :: tl ->
Format.fprintf fmt "( CDuce_all.Ns.mk_ascii \"\", @.";
Format.fprintf fmt " CDuce_all.Encodings.Utf8.mk \"%s\" ), @. " field;
Format.fprintf fmt "CDuce_all.Encodings.Utf8.mk \"%s\" ), @. " field;
dump_code fmt ( Format.sprintf "%s.%s" name field ) desc;
print_list tl in
print_list list;
Format.fprintf fmt " ]@."
| To_CDuce_string ->
Format.fprintf fmt " CDuce_all.Value.string_latin1 %s@." name
Format.fprintf fmt "CDuce_all.Value.string_latin1 %s@." name
| To_CDuce_unit ->
Format.fprintf fmt " CDuce_all.Value.sequence [] @."
Format.fprintf fmt "CDuce_all.Value.sequence [] @."
| To_CDuce_tuple list ->
let rec print_proj n = function
| [] -> assert false
......@@ -164,24 +170,50 @@ and dump_code fmt name = function
| To_CDuce_type id ->
Format.fprintf fmt "ocaml2cduce__%s %s" id name
| To_CDuce_variant list ->
let print ( label, desc ) = match desc with
| None ->
Format.fprintf fmt " | %s -> @." label;
let rec print_proj n m =
if n < m then begin
Format.fprintf fmt "cdo2cmo__v%d" n;
if ( n + 1 ) < m then Format.fprintf fmt ", ";
print_proj ( n + 1 ) m
end; in
let rec print_list n = function
| [ cde ] ->
dump_code fmt "cdo2cmo__v0" cde
| d1 :: [ d2 ] ->
Format.fprintf fmt "CDuce_all.Value.Pair ( @.";
Format.fprintf fmt " CDuce_all.Value.Atom ( @.";
Format.fprintf fmt " CDuce_all.Atoms.V.mk_ascii \"%s\" ),@." label;
Format.fprintf fmt " CDuce_all.Value.nil )@."
| Some desc ->
Format.fprintf fmt " | %s cdo2cmo__x -> @." label;
dump_code fmt ( Format.sprintf "cdo2cmo__v%d" n ) d1;
Format.fprintf fmt ", ";
dump_code fmt ( Format.sprintf "cdo2cmo__v%d" ( n + 1 ) ) d2;
Format.fprintf fmt ")@."
| d1 :: tl ->
Format.fprintf fmt "CDuce_all.Value.Pair ( @.";
dump_code fmt ( Format.sprintf "cdo2cmo__v%d" n ) d1;
Format.fprintf fmt ", ";
print_list ( n + 1 ) tl;
Format.fprintf fmt ")@."
| _ -> assert false in
let print ( label, list ) = match list with
| [] ->
Format.fprintf fmt "| %s -> @." label;
Format.fprintf fmt "CDuce_all.Value.Pair ( @.";
Format.fprintf fmt " CDuce_all.Value.Atom ( @.";
Format.fprintf fmt " CDuce_all.Atoms.V.mk_ascii \"%s\" ),@." label;
dump_code fmt "cdo2cmo__x" desc;
Format.fprintf fmt "CDuce_all.Value.Atom ( @.";
Format.fprintf fmt "CDuce_all.Atoms.V.mk_ascii \"%s\" ),@." label;
Format.fprintf fmt "CDuce_all.Value.nil )@."
| list ->
Format.fprintf fmt "| %s ( " label;
print_proj 0 ( List.length list );
Format.fprintf fmt " ) -> @.";
Format.fprintf fmt "CDuce_all.Value.Pair ( @.";
Format.fprintf fmt "CDuce_all.Value.Atom ( @.";
Format.fprintf fmt "CDuce_all.Atoms.V.mk_ascii \"%s\" ),@." label;
print_list 0 list;
Format.fprintf fmt ")@." in
Format.fprintf fmt " match %s with @." name;
Format.fprintf fmt "match %s with @." name;
List.iter print list
| To_OCaml_bool ->
Format.fprintf fmt " CDuce_all.Value.equal %s CDuce_all.Value.vtrue@." name
| To_OCaml_char ->
assert false (* TODO *)
| To_OCaml_fun ( lbl, code1, code2 ) ->
Format.fprintf fmt "fun %s -> @." lbl;
Format.fprintf fmt " let cdo2cmo__p = @.";
......@@ -256,16 +288,31 @@ and dump_code fmt name = function
| To_OCaml_unit ->
Format.fprintf fmt " ()@."
| To_OCaml_variant list ->
let rec print_proj n m =
if n < m then begin
Format.fprintf fmt "cdo2cmo__v%d" n;
if n + 1 < m then Format.fprintf fmt ",@.";
print_proj ( n + 1 ) m
end; in
let rec print_list = function
| [] ->
Format.fprintf fmt " | _ -> assert false @."
| ( field, None ) :: tl ->
| ( field, [] ) :: tl ->
Format.fprintf fmt " | \"%s\" -> %s@." field field;
print_list tl
| ( field, Some desc ) :: tl ->
Format.fprintf fmt " | \"%s\" -> %s ( @." field field;
dump_code fmt "cdo2cmo__desc" desc;
Format.fprintf fmt " ) @.";
| ( field, list ) :: tl ->
Format.fprintf fmt " | \"%s\" -> ( @." field;
let cnt = ref 0 in
List.iter (
fun desc ->
Format.fprintf fmt "let cdo2cmo__v%d = @." !cnt;
dump_code fmt "cdo2cmo__desc" desc;
Format.fprintf fmt "in@.";
incr cnt
) list;
Format.fprintf fmt "%s ( " field;
print_proj 0 ( List.length list );
Format.fprintf fmt ") ) @.";
print_list tl in
Format.fprintf fmt " let cdo2cmo__atom, cdo2cmo__desc = match %s with @." name;
Format.fprintf fmt " | CDuce_all.Value.Pair ( @.";
......@@ -298,13 +345,14 @@ and generate_to_ml ctx name = function
| ML_variant list ->
let list = List.map (
fun ( field, desc ) -> match desc with
| [] -> field, None
| [] ->
field, []
| [ x ] ->
let d = generate_desc_to_ml_rec ctx x in
field, Some d
| _ ->
let d = generate_desc_to_ml_rec ctx ( ML_tuple desc ) in
field, Some d
let desc = generate_desc_to_ml_rec ctx x in
field, [ desc ]
| list ->
let list = List.map ( generate_desc_to_ml_rec ctx ) list in
field, list
) list in
To_OCaml_variant list
| ML_nil -> assert false
......@@ -314,6 +362,7 @@ and generate_desc_to_ml ctx name desc =
and generate_desc_to_ml_rec ctx (* name *) = function
| ML_bool -> To_OCaml_bool
| ML_char -> To_OCaml_char
| ML_int -> To_OCaml_int
| ML_string -> To_OCaml_string
| ML_unit -> To_OCaml_unit
......@@ -346,13 +395,14 @@ and generate_to_cd ctx name = function
| ML_variant list ->
let list = List.map (
fun ( field, desc ) -> match desc with
| [] -> field, None
| [] ->
field, []
| [ x ] ->
let d = generate_desc_to_cd_rec ctx name x in
field, Some d
let desc = generate_desc_to_cd_rec ctx name x in
field, [ desc ]
| _ ->
let d = generate_desc_to_cd_rec ctx name ( ML_tuple desc ) in
field, Some d
let list = List.map ( generate_desc_to_cd_rec ctx name ) desc in
field, list
) list in
To_CDuce_variant list
| ML_nil -> assert false
......@@ -361,7 +411,8 @@ and generate_desc_to_cd ctx name desc =
generate_desc_to_cd_rec ctx name desc
and generate_desc_to_cd_rec ctx name = function
| ML_bool -> To_CDuce_bool
| ML_bool -> To_CDuce_bool
| ML_char -> To_CDuce_char
| ML_int -> To_CDuce_int
| ML_string -> To_CDuce_string
| ML_unit -> To_CDuce_unit
......
cdo2cmo/src/ocaml.ml
View file @ 9a271256
......@@ -12,7 +12,7 @@ let error e = raise ( Error e )
let report_error err =
let msg = match err with
| Unsupported_feature s ->
"Unsupported " ^ s ^ " in interface file (.mli)"
"cdo2cmo : error unsupported " ^ s ^ " in interface file (.mli)"
in
Format.eprintf "%s@." msg
......@@ -68,9 +68,9 @@ and ml_print_decl fmt = function
| hd :: [] ->
Format.fprintf fmt "%s of " name;
ml_print_desc fmt hd
| hd :: tl ->
| list ->
Format.fprintf fmt "%s of " name;
ml_print_list fmt " * " ml_print_desc tl
ml_print_list fmt " * " ml_print_desc list
) list
| _ -> assert false
......@@ -86,6 +86,7 @@ and ml_print_desc fmt = function
Format.fprintf fmt " ) -> ";
ml_print_desc fmt d2
| ML_bool -> Format.fprintf fmt "bool"
| ML_char -> Format.fprintf fmt "char"
| ML_ident ( name, [||], _ ) ->
Format.fprintf fmt "%s" name
| ML_ident ( name, array, _ ) ->
......@@ -268,11 +269,8 @@ module Env = struct
node
(* Flush recursive type buffer. *)
let flush_types env = match env.env_queue with
| [] ->
Format.eprintf "Flush empty env.@.";
env
| [] -> env
| values ->
Format.eprintf "Flush env@.";
let len = Path.length env.env_path = 1 in
{ env with
env_list = env.env_list @ [ len, values ];
......@@ -313,6 +311,7 @@ let path_to_mlpath path =
let rec translate_ident env path spath = function
| [] when spath = "bool" -> env, ML_bool
| [] when spath = "char" -> env, ML_char
| [] when spath = "int" -> env, ML_int
| [] when spath = "string" -> env, ML_string
| [] when spath = "unit" -> env, ML_unit
......
cdo2cmo/src/types.ml
View file @ 9a271256
......@@ -19,6 +19,7 @@ and ocaml_decl =
and ocaml_desc =
| ML_arrow of string option * ocaml_desc * ocaml_desc
| ML_bool
| ML_char
| ML_ident of string * ocaml_desc array * ocaml_t
| ML_int
| ML_list of ocaml_desc
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment