diff --git a/generator/Makefile b/generator/Makefile
index 8e532659eea388324e9898509786b30a8c699a08..db83ef9530edf097d8c076b6ba7d0ca42fcee828 100644
--- a/generator/Makefile
+++ b/generator/Makefile
@@ -6,8 +6,14 @@
# OCAMLBIN=~/shared/ocamleasy/bin/
# OCAMLLIB=~/shared/ocamleasy/lib
-ML_DIRS := lex parsing tools typing utils
-OCAMLBUILD := ocamlbuild -r -j 4 -classic-display \
+ML_DIRS := lex parsing tools typing utils stdlib_ml
+STD_DIR := stdlib_ml
+TEST_DIR := tests
+TEST_DIR_JS := tests/js
+ML_TESTS := $(wildcard $(TEST_DIR)/*.ml)
+
+CC := ocamlc -c
+OCAMLBUILD := ocamlbuild -r -j 4 -classic-display \
$(addprefix -I ,$(ML_DIRS)) \
all: main.byte
@@ -18,14 +24,22 @@ main.byte:
native:
$(OCAMLBUILD) main.native
-test: main.byte
- ./main.byte _test.ml
+stdlib:
+ $(CC) stdlib_ml/stdlib.mli
-interp: main.byte
- ./main.byte _interp.ml
+tests: main.byte stdlib
+ $(foreach mlfile, $(ML_TESTS), ./main.byte $(mlfile);)
+ mv $(TEST_DIR)/*.js $(TEST_DIR_JS)
+
+clean_stdlib:
+ rm -f $(STD_DIR)/*.cmi
+
+clean_tests:
+ rm -f $(TEST_DIR)/*.cmi
+ rm -f $(TEST_DIR_JS)/*.js
clean:
rm -rf _build
rm -f *.native *.byte
-# rm -f *~
+cleanall: clean clean_tests clean_stdlib
diff --git a/generator/README b/generator/README
deleted file mode 100644
index e263542d23cc94170cc76e65e6eda761d670c8b7..0000000000000000000000000000000000000000
--- a/generator/README
+++ /dev/null
@@ -1,2 +0,0 @@
-All-in-one command:
-$ touch a.cmi && rm *.cm* && make && ocamlc -c stdlib.mli
diff --git a/generator/README.org b/generator/README.org
new file mode 100644
index 0000000000000000000000000000000000000000..a8a68c5e9ccce0c4bec91de58495825ed02a54eb
--- /dev/null
+++ b/generator/README.org
@@ -0,0 +1,62 @@
+* Js_of_ocaml bis
+
+** Why bis? & Purpose
+
+ Because, there is already a tool named `js_of_ocaml` whose job is
+ to produce efficient Javascript from OCaml bytecode.
+
+ Here, we try to translate OCaml syntax to ECMAScript5 syntax, the
+ purpose of it is to generate readable ECMAScript code, so that it
+ could later be use in a step-by-step ECMAScript interpreter.
+
+** Dependencies
+
+ - `node.js` and the `esprima` package. In order to get the esprima
+ package the more convenient way is to get `npm` (/node package
+ manager/) and run `npm install esprima`.
+ - ocaml 4.02.1
+
+** How to run it
+
+#+BEGIN_src
+make
+make tests
+./run tests/js/the_file_you_want_to_run.js
+#+END_src
+
+** How does it work?
+
+ In order to get the statically typed abstract syntax tree (STAST) of
+ OCaml we usethe same files that are used in the compiler of OCaml
+ 4.02.1 (hence the dependency).
+
+ On top, of this STAST, there is a custom back-end that
+ transliterate OCaml to ECMAScript. The code written in OCaml cannot
+ rely on code from the typical standard library. Therefore a
+ file named `stdlib.mli` (found in the directory `stdlib_ml`) contains
+ all the required definitions for the exemples to work. This file as
+ a twin which is `stdlib.js` found in `stdlib_js`, in this file the
+ functions whose prototype is in `stdlib.mli` are defined here.
+
+** About the subset of OCaml supported
+
+ * ==Let (rec) == declarations, except `let () = ` and `let _ =`.
+ * ==If then else== statements, as excepted `if then else`
+ statements return a value.
+ * ==Pattern matching==, only one level of pattern matching over
+ arbitrary types.
+ * ==Types declarations==, if a constructor take arguments (one or
+ more), you should add an annotations to provide default names for
+ the parameters. See example below.
+
+#+BEGIN_src
+
+type 'a tree =
+ | Leaf [@f value] of `a
+ | Node [@f left, value, right] of `a tree * `a * `a tree
+
+#+END_src
+
+Special note: from OCaml 4.02.2 annotations do not have the same
+syntax, but for now we work with OCaml 4.02.1 so the code above
+works and is recommended.
diff --git a/generator/_test.ml b/generator/_test.ml
deleted file mode 100644
index 824e243286732adfcd85fad99c8b878e115e355b..0000000000000000000000000000000000000000
--- a/generator/_test.ml
+++ /dev/null
@@ -1,4 +0,0 @@
-
-let x = 3 in
-let _y = 4 in
-x
\ No newline at end of file
diff --git a/generator/go.sh b/generator/go.sh
deleted file mode 100755
index 8f58e6df93d2fce6854d17b4f850420e967ece40..0000000000000000000000000000000000000000
--- a/generator/go.sh
+++ /dev/null
@@ -1 +0,0 @@
-make
diff --git a/generator/js_of_ast.ml b/generator/js_of_ast.ml
index 1353b7281e751c59454bbe866481204179955088..d9be0fee0333301d0df86f930bf83f3a30a16600 100644
--- a/generator/js_of_ast.ml
+++ b/generator/js_of_ast.ml
@@ -2,7 +2,6 @@ open Misc
open Asttypes
open Types
open Typedtree
-open Mytools
open Longident
open Format
open Print_type
@@ -13,15 +12,8 @@ let hashtlb_size = 256
let default_value = ["", [""]]
let type_tbl = Hashtbl.create hashtlb_size;;
-let print_tbl () =
- let rec print_str_list = function
- | [] -> ""
- | x :: [] -> (Format.sprintf {|"%s"|} x)
- | x :: xs -> (Format.sprintf {|"%s", |} x) ^ print_str_list xs
- in Hashtbl.iter (fun cstr elems -> Printf.printf ({|"%s" : %s -> [%s]|} ^^ "\n") cstr (snd elems) (print_str_list (fst elems))) type_tbl; ()
-
let unsupported s =
- failwith ("unsupported language construction: " ^ s ^ ".")
+ failwith ("unsupported language construction: " ^ s ^ ".")
and out_of_scope s =
failwith (s ^ " are and will not be supported.")
@@ -32,11 +24,11 @@ and error s =
let rec range i j acc = if i <= j then range i (j - 1) (j :: acc) else acc
let show_list_f f sep l = l
- |> List.map f
- |> List.fold_left (fun acc x -> acc ^ (if acc = "" then "" else sep) ^ x) ""
+ |> List.map f
+ |> List.fold_left (fun acc x -> acc ^ (if acc = "" then "" else sep) ^ x) ""
let show_list sep l =
- List.fold_left (fun acc x -> acc ^ (if acc = "" then "" else sep) ^ x) "" l
+ List.fold_left (fun acc x -> acc ^ (if acc = "" then "" else sep) ^ x) "" l
let js_of_constant = function
| Const_int n -> string_of_int n
@@ -51,39 +43,35 @@ let js_of_longident loc =
let res = String.concat "." @@ Longident.flatten loc.txt in
if res = "()" then "" else res
-
-
let ident_of_pat pat = match pat.pat_desc with
| Tpat_var (id, _) -> Ident.name id
| _ -> error "functions can't deconstruct values"
-
let rec js_of_let_pattern pat expr =
let expr_type pat expr = match expr.exp_desc with
| Texp_construct (loc, cd, el) ->
- let value = js_of_longident loc in
- if el = [] then
- if value = "true" || value = "false" then value else Format.sprintf {|{tag: "%s"}|} value
- else let rec expand_constructor_list fields exprs = match fields, exprs with
- | [], [] -> []
- | [], x :: xs | x :: xs , [] -> failwith "argument lists should have the same length."
- | x :: xs, y :: ys -> Format.sprintf {|%s: %s|} x y :: expand_constructor_list xs ys
- in let names, typ = Hashtbl.find type_tbl value
- in Format.sprintf {|{tag: "%s", %s}|} value (show_list ", " (expand_constructor_list names (List.map js_of_expression el)))
+ let value = js_of_longident loc in
+ if el = [] then
+ if value = "true" || value = "false" then value else Format.sprintf "{type: \"%s}\"" value
+ else let rec expand_constructor_list fields exprs = match fields, exprs with
+ | [], [] -> []
+ | [], x :: xs | x :: xs , [] -> failwith "argument lists should have the same length."
+ | x :: xs, y :: ys -> Format.sprintf "@[%s:@,%s@]" x y :: expand_constructor_list xs ys
+ in let names, typ = Hashtbl.find type_tbl value
+ in Format.sprintf "{type: \"%s\",@, %s}" value (show_list ", " (expand_constructor_list names (List.map js_of_expression el)))
| _ -> string_of_type_exp pat.pat_type in
let sexpr = js_of_expression expr in
match pat.pat_desc with
- | Tpat_var (id, _) -> Format.sprintf "var %s = %s;\n"
- (Ident.name id) sexpr
- | Tpat_tuple (pat_l) | Tpat_array (pat_l) ->
- let l = List.map (function pat -> match pat.pat_desc with
- | Tpat_var (id, _) -> (Ident.name id, string_of_type_exp pat.pat_type)
- | _ -> out_of_scope "pattern-matching in arrays") pat_l in
- Format.sprintf "var __%s = %s;\n " "array" sexpr ^
- List.fold_left2 (fun acc (name, exp_type) y ->
- acc ^ Format.sprintf "var %s = __%s[%d];\n"
- name "array" y)
- "" l @@ range 0 (List.length l - 1) []
+ | Tpat_var (id, _) ->
+ Format.sprintf "@[<v 0>var %s = %s;@,@]" (Ident.name id) sexpr
+ | Tpat_tuple (pat_l)
+ | Tpat_array (pat_l) ->
+ let l = List.map (function pat -> match pat.pat_desc with
+ | Tpat_var (id, _) -> (Ident.name id, string_of_type_exp pat.pat_type)
+ | _ -> out_of_scope "pattern-matching in arrays") pat_l in
+ Format.sprintf "@[<v 0>var __%s = %s;@,@]" "array" sexpr ^
+ List.fold_left2 (fun acc (name, exp_type) y -> acc ^ Format.sprintf "@[<v 0>var %s = __%s[%d];@,@]" name "array" y)
+ "" l @@ range 0 (List.length l - 1) []
| _ -> error "let can't deconstruct values"
and js_of_pattern pat obj = match pat.pat_desc with
@@ -93,13 +81,13 @@ and js_of_pattern pat obj = match pat.pat_desc with
| Tpat_alias (_,_,_) -> out_of_scope "alias-pattern"
| Tpat_tuple (_) -> out_of_scope "tuple matching"
| Tpat_construct (loc, cd, el) ->
- let c = js_of_longident loc in
- let spat = {|case "|} ^ c ^ {|"|} in
- let params = fst (Hashtbl.find type_tbl c) in
- let binders =
- if List.length el = 0 then ""
- else "var " ^ show_list ", " (List.map2 (fun x y -> x ^ " = " ^ obj ^ "." ^ y) (List.map (fun x -> fst (js_of_pattern x obj)) el) params) ^ ";" in
- spat, binders
+ let c = js_of_longident loc in
+ let spat = Format.sprintf "%s" ("case \"" ^ c ^ "\"") in
+ let params = fst (Hashtbl.find type_tbl c) in
+ let binders =
+ if List.length el = 0 then Format.sprintf ""
+ else Format.sprintf "%s@," ("var " ^ show_list ", " (List.map2 (fun x y -> x ^ " = " ^ obj ^ "." ^ y) (List.map (fun x -> fst (js_of_pattern x obj)) el) params) ^ ";") in
+ spat, binders
| Tpat_variant (_,_,_) -> out_of_scope "polymorphic variants in pattern matching"
| Tpat_array (_) -> out_of_scope "array-match"
| Tpat_record (_,_) -> out_of_scope "record"
@@ -110,20 +98,16 @@ and js_of_expression (e:expression) =
let js_of_branch b obj =
let spat, binders = js_of_pattern b.c_lhs obj in
let se = js_of_expression b.c_rhs in
- Format.sprintf "%s: @ %s @ return %s" spat binders se in
+ Format.sprintf "@[<v 2>%s: @[<v 4>%s@,return %s;@]@,@]" spat binders se in
match e.exp_desc with
| Texp_ident (_, loc, _) -> js_of_longident loc
| Texp_constant c -> js_of_constant c
| Texp_let (_, vb_l, e) ->
- let show_val vb = js_of_let_pattern vb.vb_pat vb.vb_expr in
- let sd = String.concat "\n" @@ List.map show_val @@ vb_l in
- let se = js_of_expression e in
- Format.sprintf
- "(function () {
- %s
-
- return %s;
- })()" sd se
+ let show_val vb = js_of_let_pattern vb.vb_pat vb.vb_expr in
+ let sd = String.concat "\n" @@ List.map show_val @@ vb_l in
+ let se = js_of_expression e in
+ Format.sprintf
+ "@[<v 0>(function () {@,@[<v 4>@,%s@,@,return %s;@,@]@,})()@]" sd se
| Texp_function (_, c :: [], Total) ->
let rec explore pats e = match e.exp_desc with
| Texp_function (_, c :: [], Total) ->
@@ -134,24 +118,18 @@ and js_of_expression (e:expression) =
js_of_expression e in
let names, body = explore [c.c_lhs] c.c_rhs in
Format.sprintf
- "function (%s) {
- return %s;
- }" names body
+ "@[function (%s) {@,@[<v 4>@,return %s;@,@]@,}@]" names body
| Texp_function (_, _, _) -> out_of_scope "powered-up functions"
| Texp_apply (f, exp_l) ->
let sl = exp_l
|> List.map (fun (_, eo, _) -> match eo with None -> out_of_scope "optional apply arguments" | Some ei -> js_of_expression ei)
|> String.concat ", " in
let se = js_of_expression f in
- Format.sprintf "%s(%s)" se sl
+ Format.sprintf "@[<v 0>%s(%s)@]" se sl
| Texp_match (exp, l, [], Total) ->
let se = js_of_expression exp in
- let sb = List.fold_left (fun acc x -> acc ^ js_of_branch x se ^ ";") "" l in
- Format.sprintf "(function () {
- switch (%s.tag) {
- %s
- }
- })()" se sb
+ let sb = List.fold_left (fun acc x -> acc ^ js_of_branch x se) "" l in
+ Format.sprintf "@[<v 0>(function () {@,@[<v 4>@,switch (%s.type) {@,@[<v 4>@,%s@,@]@,}@]@,})()@]" se sb
| Texp_match (_, _, _, Partial) -> out_of_scope "partial matching"
| Texp_match (_,_,_,_) -> out_of_scope "matching with exception branches"
| Texp_try (_, _) -> out_of_scope "exceptions"
@@ -160,13 +138,13 @@ and js_of_expression (e:expression) =
| Texp_construct (loc, cd, el) -> (*TODO: Modifs*)
let value = js_of_longident loc in
if el = [] then
- if value = "true" || value = "false" then value else Format.sprintf {|{tag: "%s"}|} value
+ if value = "true" || value = "false" then value else Format.sprintf "{type: \"%s\"}" value
else let rec expand_constructor_list fields exprs = match fields, exprs with
| [], [] -> []
| [], x :: xs | x :: xs , [] -> failwith "argument lists should have the same length."
- | x :: xs, y :: ys -> (if y = "" then Format.sprintf {|%s|} x else Format.sprintf {|%s: %s|} x y) :: expand_constructor_list xs ys
+ | x :: xs, y :: ys -> (if y = "" then Format.sprintf "%s" x else Format.sprintf "%s: %s" x y) :: expand_constructor_list xs ys
in let names, typ = Hashtbl.find type_tbl value
- in Format.sprintf {|{tag: "%s", %s}|} value (show_list ", " (expand_constructor_list names (List.map js_of_expression el)))
+ in Format.sprintf "{type: \"%s\", %s}" value (show_list ", " (expand_constructor_list names (List.map js_of_expression el)))
| Texp_variant (_,_) -> out_of_scope "polymorphic variant"
| Texp_record (_, _) -> failwith "not implemented yet"
| Texp_field (_,_,_) -> failwith "not implemented yet"
@@ -174,19 +152,10 @@ and js_of_expression (e:expression) =
| Texp_array (exp_l) ->
"[" ^ show_list_f js_of_expression ", " exp_l ^ "]"
| Texp_ifthenelse (e1, e2, None) -> Format.sprintf
- "(function () {
- if (%s) {
- return %s;
- }
- })()" (js_of_expression e1) (js_of_expression e2)
+ "@[<v 0>(function () {@,@[<v 4>@,if (%s) {@,@[<v 4>@,return %s;@]@,}@]@,})()@]" (js_of_expression e1) (js_of_expression e2)
| Texp_ifthenelse (e1, e2, Some e3) -> Format.sprintf
- "(function () {
- if (%s) {
- return %s;
- } else {
- return %s;
- }
- })()" (js_of_expression e1) (js_of_expression e2) (js_of_expression e3)
+ "@[<v 0>(function () {@,@[<v 4>@,if (%s) {@,@[<v 4>@,return %s;@]@,} else {@,@[<v 4>@,return %s;@]@,}@]@]@,})()@]"
+ (js_of_expression e1) (js_of_expression e2) (js_of_expression e3)
| Texp_sequence (_, _) -> unsupported "sequences"
| Texp_while (_, _) -> unsupported "while loops"
| Texp_for (_,_,_,_,_,_) -> unsupported "for loops"
@@ -237,7 +206,7 @@ and js_of_structure_item s = match s.str_desc with
Hashtbl.add type_tbl (Ident.name y.cd_id) ((extract_attrs y.cd_attributes), Ident.name x.typ_id); explore_cstrs ys;
in explore_cstrs cdl
| _ -> unsupported "records") in
- explore_type tl; print_tbl (); ""
+ explore_type tl; ""
| Tstr_primitive _ -> out_of_scope "primitive functions"
| Tstr_typext _ -> out_of_scope "type extensions"
| Tstr_exception _ -> out_of_scope "exceptions"
diff --git a/generator/main.ml b/generator/main.ml
index ce83923f7a04e18bf662478b800f2d58ea8c3c7f..42a528278760ee0460525c0cdda7aa4f79c75ced 100644
--- a/generator/main.ml
+++ b/generator/main.ml
@@ -5,11 +5,7 @@ open Parse_type
(*#########################################################################*)
let debug = ref false
-
-let myflag = ref false
-
let ppf = Format.std_formatter
-
let outputfile = ref None
(* err_formatter *)
@@ -18,21 +14,21 @@ let outputfile = ref None
(*#########################################################################*)
let _ =
-
+
(* disable loading of stdlib *)
- Clflags.nopervasives := true;
+ Clflags.nopervasives := false;
(*---------------------------------------------------*)
(* parsing of command line *)
let files = ref [] in
Arg.parse
- [ ("-I", Arg.String (fun i -> Clflags.include_dirs := i::!Clflags.include_dirs),
+ [ ("-I", Arg.String (fun i -> Clflags.include_dirs := i :: !Clflags.include_dirs),
"includes a directory where to look for interface files");
- ("-myflag", Arg.Set myflag, "example of a flag");
("-o", Arg.String (fun s -> outputfile := Some s), "set the output file name");
- ("-debug", Arg.Set debug, "trace the various steps") ]
- (fun f -> files := f::!files)
+ ("-debug", Arg.Set debug, "trace the various steps")
+ ]
+ (fun f -> files := f :: !files)
("usage: [-I dir] [..other options..] file.ml");
if List.length !files <> 1 then
@@ -44,13 +40,13 @@ let _ =
let dirname = Filename.dirname sourcefile in
let outputfile : string =
match !outputfile with
- | None -> Filename.concat dirname ((String.capitalize basename) ^ ".js")
+ | None -> Filename.concat dirname (basename ^ ".js")
| Some f -> f
in
(*---------------------------------------------------*)
(* "reading and typing source file" *)
- let (opt,inputfile) = process_implementation_file ppf sourcefile in
+ let (opt, inputfile) = process_implementation_file ppf sourcefile in
let ((parsetree1 : Parsetree.structure), typedtree1) =
match opt with
| None -> failwith "Could not read and typecheck input file"
@@ -58,16 +54,3 @@ let _ =
in
file_put_contents outputfile (Js_of_ast.js_of_structure typedtree1)
-
- (* file_put_contents ("_parsed_file.ml") (Print_past.string_of_structure parsetree1); *)
-
- (*---------------------------------------------------*)
- (* typing normalized code
- let (typedtree2, _ : Typedtree.structure * Typedtree.module_coercion) =
- match typecheck_implementation_file ppf sourcefile parsetree2 with
- | None -> failwith "Could not typecheck the normalized source code\nCheck out the file output/_normalized.ml."
- | Some typedtree2 -> typedtree2
- in
- file_put_contents (debugdirBase ^ "_normalized_typed.ml") (Print_tast.string_of_structure typedtree2);
- ignore (typedtree2);
- *)
diff --git a/generator/parse_type.ml b/generator/parse_type.ml
index f4491fed172bbcd784366219388fd83b08f89310..b00a50c3bfe48b13def67e6f232d7799013156fb 100644
--- a/generator/parse_type.ml
+++ b/generator/parse_type.ml
@@ -18,7 +18,7 @@ open Typedtree
let init_path () =
load_path :=
- "" :: List.rev (Config.standard_library :: !Clflags.include_dirs);
+ "stdlib_ml" :: List.rev (Config.standard_library :: !Clflags.include_dirs);
Env.reset_cache ()
(** Return the initial environment in which compilation proceeds. *)
@@ -27,7 +27,7 @@ let initial_env () =
try
if !Clflags.nopervasives
then Env.open_pers_signature "Stdlib" Env.initial_unsafe_string
- else Env.open_pers_signature "Pervasives" Env.initial_unsafe_string
+ else Env.open_pers_signature "Stdlib" Env.initial_unsafe_string
with Not_found ->
fatal_error "cannot open pervasives"
diff --git a/generator/print_tast.ml b/generator/print_tast.ml
deleted file mode 100644
index 5b3f3925573c01d07ac4fe65df95a2387eddca43..0000000000000000000000000000000000000000
--- a/generator/print_tast.ml
+++ /dev/null
@@ -1,318 +0,0 @@
-open Misc
-open Asttypes
-open Types
-open Typedtree
-open Mytools
-open Longident
-open Format
-open Print_type
-
-(** Printing facility for typed abstract syntax trees produced by the
- type-checker*)
-
-(*#########################################################################*)
-(* ** Printing of base values *)
-
-let string_of_ident s =
- Ident.name s
-
-let string_of_lident idt =
- let names = Longident.flatten idt in
- String.concat "." names
-
-let string_of_constant = function
- | Const_int n -> string_of_int n
- | Const_char c -> String.make 1 c
- | Const_string (s, _) -> s
- | Const_float f -> f
- | Const_int32 _ -> unsupported "int32 type"
- | Const_int64 _ -> unsupported "int64 type"
- | Const_nativeint _ -> unsupported "native int type"
-
-let string_of_recflag = function
- | Nonrecursive -> ""
- | Recursive -> " rec"
-
-
-
-(*#########################################################################*)
-(* ** Printing of items *)
-
-let string_of_typed_var s t =
- sprintf "(%s : %s)" s (string_of_type_exp t)
-
-let string_of_path p =
- Path.name p
-
-let show_string s =
- s
-
-(*#########################################################################*)
-(* ** Printing of patterns *)
-
-let string_of_pattern par p =
- let rec aux par p =
- match p.pat_desc with
- | Tpat_any -> "_"
- | Tpat_var (id,_) -> string_of_typed_var (string_of_ident id) p.pat_type
- | Tpat_alias (p, ak, _) -> unsupported "alias patterns"
- (* let sp = aux false p in
- begin match ak with
- | TPat_alias id -> show_par par (sprintf "%s as %s" (string_of_typed_var (string_of_ident id) p.pat_type) sp)
- | TPat_constraint _ -> sp
- | TPat_type pp -> sp (* ignore type *)
- end *)
- | Tpat_constant c ->
- sprintf "%s" (string_of_constant c)
- | Tpat_tuple l ->
- show_par true (sprintf "%s" (show_list (aux false) "," l))
- | Tpat_construct (p,cd,ps) -> unsupported "construct patterns"
- (*
- let c = string_of_path p in
- if ps = []
- then c
- else if List.length ps = 1
- then show_par par (c ^ " " ^ aux true (List.hd ps))
- else
- show_par par (sprintf "%s (%s)" c (show_list (aux false) "," ps)) *)
- | Tpat_or (p1,p2,_) ->
- show_par par (sprintf "%s | %s" (aux false p1) (aux false p2))
- | Tpat_lazy p1 ->
- show_par par (sprintf "lazy %s" (aux true p1))
- | Tpat_variant (_,_,_) -> unsupported "variant patterns"
- | Tpat_record _ -> unsupported "record patterns"
- | Tpat_array pats -> unsupported "array patterns"
- in
- aux false p
-
-let string_of_let_pattern par fvs p =
- let typ = p.pat_type in
- let styp = string_of_type_sch fvs typ in
- sprintf "%s : %s" (string_of_pattern par p) styp
- (*
- match p.pat_desc with
- | Tpat_var id ->
- let typ = p.pat_type in
- sprintf "%s : %s" (string_of_ident id) (string_of_type_sch fvs typ)
- | _ -> unsupported "let-pattern not reduced to a variable"
- *)
-
-(*#########################################################################*)
-(* ** Printing of expression *)
-
-let rec string_of_expression par e =
- let aux ?par e =
- string_of_expression (bool_of_option par) e in
- let aux_pat ?par e =
- string_of_pattern (bool_of_option par) e in
- let string_of_branch (p,e) =
- Format.sprintf "@[@[%s@] ->@ @[%s@]@]" (aux_pat p) (aux e) in
- (*let typ = e.exp_type in*)
- match e.exp_desc with
- | Texp_ident (p,loc,vd) -> string_of_path p (* string_of_typed_var (string_of_path p) vd.val_type*)
- | Texp_constant c -> string_of_constant c
- | Texp_let (rf, l, e) ->
- let show_pe (p,e) =
- let sp = (string_of_let_pattern false fvs p) in
- let se = aux e in
- Format.sprintf "%s =@ @[%s@]" sp se in
- let sl = show_list show_pe " and " l in
- let se = aux e in
- Format.sprintf "@[let%s %s in@ @[%s@]@]" (string_of_recflag rf) sl se
- | Texp_function (_,c1::[], pa) ->
- let p1 = c1.c_lhs in
- let e1 = c1.c_rhs in
- let rec explore pats e =
- match e.exp_desc with
- | Texp_function (_,(p1,e1)::[], pa) ->
- explore (p1::pats) e1
- | _ -> List.rev pats, e
- in
- let pats,body = explore [] e in
- let sp = show_list aux_pat " " pats in
- let sb = aux ~par:false body in
- let s = Format.sprintf "@[fun @[%s@] ->@ @[%s@]@]" sp sb in
- show_par par s
- | Texp_function (_,l, pa) ->
- Format.sprintf "@[function %s@]" (show_listp string_of_branch "\n | " l)
- | Texp_apply (e, l) -> (* todo: afficher les infixes correctement *)
- let l = List.map (fun (lab,eo,opt) -> match eo with None -> unsupported "optional apply arguments" | Some ei -> ei) l in
- let se = aux ~par:true e in
- let show_arg ei =
- let s_ei = aux ~par:false ei in
- let t_ei = string_of_type_exp ei.exp_type in
- sprintf "(%s : %s)" s_ei t_ei in
- let sl = show_list show_arg " " l in
- let s = sprintf "%s %s" se sl in
- show_par par s
- | Texp_match (e, l, pa) ->
- let se = aux e in
- let s = Format.sprintf "@[match@ @[%s@] with@ @[%s@]@]"
- se (show_list string_of_branch " | " l) in
- show_par par s
- | Texp_try (e,l) -> unsupported "exceptions"
- | Texp_tuple l ->
- show_par true (show_list aux ", " l)
- | Texp_construct (p, cd, es) ->
- let c = string_of_path p in
- if es = []
- then c
- else if List.length es = 1
- then show_par par (c ^ " " ^ aux ~par:true (List.hd es))
- else
- show_par par (sprintf "%s (%s)" c (show_list aux "," es))
- | Texp_variant (l,eo) -> unsupported "variants"
- | Texp_record (l,Some eo) -> unsupported "record-with"
- | Texp_record (l,None) ->
- let print_item (p,li,ei) =
- Format.sprintf "%s = %s" (string_of_path p) (aux ei) in
- let s = Format.sprintf "@[{%s}@]" (show_list print_item "; " l) in
- show_par par s
- | Texp_field (e,p,i) ->
- let s = Format.sprintf "@[%s.%s@]" (aux e) (string_of_path p) in
- show_par par s
- | Texp_setfield (e,p,i,e2) ->
- let s = Format.sprintf "@[%s.%s <- %s@]" (aux e) (string_of_path p) (aux e2) in
- show_par par s
- | Texp_array l -> unsupported "array expression" (* Texp_array (List.map aux l)*)
- | Texp_ifthenelse (e1, e2, None) ->
- let s = Format.sprintf "@[if %s@ then %s@]" (aux e1) (aux e2) in
- show_par par s
- | Texp_ifthenelse (e1, e2, Some e3) ->
- let s = Format.sprintf "@[if %s@ then %s@ else %s@]" (aux e1) (aux e2) (aux e3) in
- show_par par s
- | Texp_when (e1,e2) -> (*todo:better printing so that compiles *)
- Format.sprintf "<< when %s >> %s" (aux e1) (aux e2)
- | Texp_sequence (e1,e2) ->
- let s = Format.sprintf "@[%s@ ; %s@]" (aux e1) (aux e2) in
- show_par par s
- | Texp_while (e1,e2) ->
- let s = Format.sprintf "@[while %s@ do %s@ done@]" (aux e1) (aux e2) in
- show_par par s
- | Texp_for (i,e1,e2,d,e3) ->
- let s = Format.sprintf "@[for %s = %s to %s do@ %s@ done@]" (Ident.name i) (aux e1) (aux e2) (aux e3) in
- show_par par s
- | Texp_send (_,_,_) -> unsupported "send expression"
- | Texp_new _ -> unsupported "new expression"
- | Texp_instvar (_,_) -> unsupported "inst-var expression"
- | Texp_setinstvar (_,_,_) -> unsupported "set-inst-var expression"
- | Texp_override _ -> unsupported "Pexp_override expression"
- | Texp_letmodule (_,_,_) -> unsupported "let-module expression"
- | Texp_assert e ->
- let s = Format.sprintf "@[assert %s@]" (aux e) in
- show_par par s
- | Texp_assertfalse ->
- show_par par "assert false"
- | Texp_lazy e ->
- let s = Format.sprintf "@[lazy %s@]" (aux e) in
- show_par par s
- | Texp_object _ -> unsupported "objects"
- | Texp_poly (_,_) -> unsupported "poly"
- | Texp_newtype (_,_) -> unsupported "newtype"
- | Texp_pack _ -> unsupported "pack"
- | Texp_open (_,_) -> unsupported "open"
- | Texp_constraint (e,_,_) -> aux e
-
-
-(*#########################################################################*)
-(* ** Printing of type declarations *)
-
-(* TODO
-
-let show_core_type par t =
- let rec aux par t =
- match t.ctyp_desc with
- | Ttyp_any -> "_"
- | Ttyp_var x -> "'"^x
- | Ttyp_arrow (_,t1,t2) -> show_par par (sprintf "%s -> %s" (aux false t1) (aux false t2))
- | Ttyp_tuple ts -> show_par true (show_list (aux true) " * " ts)
- | Ttyp_constr (p,ts) ->
- let args = match ts with
- | [] -> ""
- | [x] -> sprintf "%s" (aux true x)
- | l -> show_par true (show_list (aux false) ", " l)
- in
- sprintf "%s %s" args (string_of_path p)
- | Ttyp_object _ -> unsupported "object types"
- | Ttyp_class _ -> unsupported "class types"
- | Ttyp_alias _ -> unsupported "alias types"
- | Ttyp_variant _ -> unsupported "variant types"
- | Ttyp_poly _ -> unsupported "poly types"
- | Ttyp_package _ -> unsupported "package types"
- in
- aux par t
-
-
-let show_type_decl (name,decl) =
- let show_type t =
- show_core_type false t in
- let params =
- match decl.typ_params with
- | [] -> ""
- | [a] -> sprintf "'%s " a
- | l -> show_par true (show_list show_string ", " l) ^ " "
- in
- let header = sprintf " %s%s" params (string_of_ident name) in
- match decl.typ_kind with
- | Ttype_abstract ->
- begin match decl.typ_manifest with
- | None -> header
- | Some def -> sprintf "%s = %s" header (show_type def)
- end
- | Ttype_record _ (* (string * mutable_flag * core_type * Location.t) list *) ->
- unsupported "records type def (todo)"
- | Ttype_variant branches ->
- let show_branch (constr, args, _) =
- match args with
- | [] -> constr
- | [a] -> sprintf "%s of %s" constr (show_type a)
- | l -> sprintf "%s of %s" constr (show_par true (show_list show_type "* " l))
- in
- header ^ " = " ^ show_list show_branch " | " branches
-
-let is_simple_type_decl (name,decl) =
- match decl.typ_kind with
- Ttype_record _ -> true
- | Ttype_abstract -> true
- | _ -> false
-
-*)
-
-(*#########################################################################*)
-(* ** Printing of modules and top-level phrases *)
-
-let rec string_of_module m =
- match m.mod_desc with
- | Tmod_ident p -> string_of_path p
- | Tmod_structure s -> sprintf "struct\n%s\nend\n" (string_of_structure s)
- | Tmod_functor (id,mt,me) -> sprintf "%s : _ ==>%s\n" (string_of_ident id) (string_of_module me)
- | Tmod_apply (me1,me2,mc) -> sprintf "%s %s" (string_of_module me1) (string_of_module me2)
- | Tmod_constraint (me,_,mt,mc) -> sprintf "(%s : _)" (string_of_module me)
- | Tmod_unpack (_,_) -> unsupported "unpack"
-
-and string_of_structure (s:structure) =
- show_list string_of_structure_item lin2 s.str_items
-
-and string_of_structure_item (si:structure_item) =
- Printtyp.reset();
- match si.str_desc with
- | Tstr_eval e -> sprintf "let _ = %s" (string_of_expression false e)
- | Tstr_value (r,fvs,l) ->
- let show_pe (p,e) =
- let sp = string_of_let_pattern false fvs p in
- let se = string_of_expression false e in
- Format.sprintf "%s =@ @[%s@]" sp se in
- let sl = show_list show_pe " and " l in
- Format.sprintf "@[let%s %s@]" (string_of_recflag r) sl
- (* Format.sprintf "@[let%s %s =@ @[<2>%s@]@]" *)
- | Tstr_primitive (id,v) -> sprintf "val %s : _" (string_of_ident id)
- | Tstr_type l -> sprintf "type _ = _"
- | Tstr_exception (id,e) -> sprintf "exception %s = _" (string_of_ident id)
- | Tstr_exn_rebind (id,p) -> unsupported "exception-rebind"
- | Tstr_module (id,m) -> Format.sprintf "@[module %s =@ @[<2>%s] @]" (string_of_ident id) (string_of_module m)
- | Tstr_recmodule _ -> unsupported "recursive modules"
- | Tstr_modtype (id,mt) -> sprintf "module type %s = _" (string_of_ident id)
- | Tstr_open p -> sprintf "open %s = _" (string_of_path p)
- | Tstr_class _ -> unsupported "objects"
- | Tstr_class_type _ -> unsupported "objects"
- | Tstr_include (m,ids) -> sprintf "include %s" (string_of_module m)
diff --git a/generator/run.debug.sh b/generator/run.debug.sh
new file mode 100755
index 0000000000000000000000000000000000000000..51dec5deca95b3c5ead2715f57e3d755c5af53a4
--- /dev/null
+++ b/generator/run.debug.sh
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+cat stdlib_js/stdlib.debug.js >> _____tmp.js
+cat $1 >> _____tmp.js
+
+node _____tmp.js
+
+rm _____tmp.js
diff --git a/generator/run.sh b/generator/run.sh
new file mode 100755
index 0000000000000000000000000000000000000000..620e6fd10296863355f837efb6150b6fb7e2699e
--- /dev/null
+++ b/generator/run.sh
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+cat stdlib_js/stdlib.js >> _____tmp.js
+cat $1 >> _____tmp.js
+
+node _____tmp.js
+
+rm _____tmp.js
diff --git a/generator/stdlib.mli b/generator/stdlib.mli
deleted file mode 100644
index 23a4eebf3fc051b3426d084a9fad83f673e17005..0000000000000000000000000000000000000000
--- a/generator/stdlib.mli
+++ /dev/null
@@ -1,14 +0,0 @@
-val ( + ) : int -> int -> int
-val ( - ) : int -> int -> int
-val ( * ) : int -> int -> int
-val ( / ) : int -> int -> int
-
-val ( +. ) : float -> float -> float
-val ( -. ) : float -> float -> float
-val ( *. ) : float -> float -> float
-val ( /. ) : float -> float -> float
-
-val ( < ) : 'a -> 'a -> bool
-val ( > ) : 'a -> 'a -> bool
-
-val ( = ) : 'a -> 'a -> unit
diff --git a/generator/stdlib_js/stdlib.debug.js b/generator/stdlib_js/stdlib.debug.js
new file mode 100644
index 0000000000000000000000000000000000000000..aef5f2f8cab6e98b9b8a30a1d7f488492c3b6119
--- /dev/null
+++ b/generator/stdlib_js/stdlib.debug.js
@@ -0,0 +1,49 @@
+
+var add = function (a, b) { return "(" + a + " + " + b + ")" }
+var sub = function (a, b) { return "(" + a + " - " + b + ")" }
+var mul = function (a, b) { return "(" + a + " * " + b + ")" }
+var div = function (a, b) { return "(" + a + " / " + b + ")" }
+
+var eq = function (a, b) { return a === b }
+var le = function (a, b) { return a < b }
+var ge = function (a, b) { return a > b }
+
+var leq = function (a, b) { return a <= b }
+var geq = function (a, b) { return a >= b }
+
+var print = function (x) { console.log(x) }
+
+var to_string = function (x) { return String(x) }
+
+var parse = function (source) {
+ var ast = require('esprima').parse(source).body[0].expression;
+
+ function transform (tree) {
+ if (tree === undefined) {
+ } else {
+ switch (tree.operator) {
+ case '+':
+ tree.type = "Add"; tree.operator = undefined; break;
+ case '-':
+ tree.type = "Sub"; tree.operator = undefined; break;
+ case "*":
+ tree.type = "Mul"; tree.operator = undefined; break;
+ case "/":
+ tree.type = "Div"; tree.operator = undefined; break;
+ default: break;
+ }
+
+ switch (tree.type) {
+ case "Literal":
+ tree.type = "Const"; break;
+ default: break;
+ }
+
+ if (tree.left !== undefined) tree.left = transform(tree.left);
+ if (tree.right !== undefined) tree.right = transform(tree.right);
+ return tree;
+ }
+ }
+
+ return transform(ast);
+}
diff --git a/generator/stdlib_js/stdlib.js b/generator/stdlib_js/stdlib.js
new file mode 100644
index 0000000000000000000000000000000000000000..adbab39e9e5756d37808a9ee3e1325c1ce954c54
--- /dev/null
+++ b/generator/stdlib_js/stdlib.js
@@ -0,0 +1,48 @@
+var add = function (a, b) { return a + b }
+var sub = function (a, b) { return a - b }
+var mul = function (a, b) { return a * b }
+var div = function (a, b) { return a / b }
+
+var eq = function (a, b) { return a === b }
+var le = function (a, b) { return a < b }
+var ge = function (a, b) { return a > b }
+
+var leq = function (a, b) { return a <= b }
+var geq = function (a, b) { return a >= b }
+
+var print = function (x) { console.log(x) }
+
+var to_string = function (x) { return String(x) }
+
+var parse = function (source) {
+ var ast = require('esprima').parse(source).body[0].expression;
+
+ function transform (tree) {
+ if (tree === undefined) {
+ } else {
+ switch (tree.operator) {
+ case '+':
+ tree.type = "Add"; tree.operator = undefined; break;
+ case '-':
+ tree.type = "Sub"; tree.operator = undefined; break;
+ case "*":
+ tree.type = "Mul"; tree.operator = undefined; break;
+ case "/":
+ tree.type = "Div"; tree.operator = undefined; break;
+ default: break;
+ }
+
+ switch (tree.type) {
+ case "Literal":
+ tree.type = "Const"; break;
+ default: break;
+ }
+
+ if (tree.left !== undefined) tree.left = transform(tree.left);
+ if (tree.right !== undefined) tree.right = transform(tree.right);
+ return tree;
+ }
+ }
+
+ return transform(ast);
+}
diff --git a/generator/stdlib_ml/stdlib.cmi b/generator/stdlib_ml/stdlib.cmi
new file mode 100644
index 0000000000000000000000000000000000000000..2fea646fdf08c348060814fae85299c395212916
Binary files /dev/null and b/generator/stdlib_ml/stdlib.cmi differ
diff --git a/generator/stdlib_ml/stdlib.mli b/generator/stdlib_ml/stdlib.mli
new file mode 100644
index 0000000000000000000000000000000000000000..ab7efeca1340bb672ec00206ec1fa8f2242d8a63
--- /dev/null
+++ b/generator/stdlib_ml/stdlib.mli
@@ -0,0 +1,16 @@
+val add : 'a -> 'a -> 'a
+val sub : 'a -> 'a -> 'a
+val mul : 'a -> 'a -> 'a
+val div : 'a -> 'a -> 'a
+
+val eq : 'a -> 'a -> bool
+val le : 'a -> 'a -> bool
+val ge : 'a -> 'a -> bool
+
+val leq : 'a -> 'a -> bool
+val geq : 'a -> 'a -> bool
+
+val print : 'a -> unit
+
+val to_string : 'a -> string
+val parse : 'a -> 'b
diff --git a/generator/tests/calc.cmi b/generator/tests/calc.cmi
new file mode 100644
index 0000000000000000000000000000000000000000..b5d163858a1c5a56e6c5d588b28221617988266b
Binary files /dev/null and b/generator/tests/calc.cmi differ
diff --git a/generator/tests/calc.ml b/generator/tests/calc.ml
new file mode 100644
index 0000000000000000000000000000000000000000..be11a5da53938c9e1f0982ebf4021f572e101ab4
--- /dev/null
+++ b/generator/tests/calc.ml
@@ -0,0 +1,24 @@
+type expr =
+ | Const [@f value] of int
+ | Add [@f left, right] of expr * expr
+ | Sub [@f left, right] of expr * expr
+ | Mul [@f left, right] of expr * expr
+ | Div [@f left, right] of expr * expr
+
+let rec eval_ expr = match expr with
+ | Const n -> n
+ | Add (ls, rs) -> add (eval_ ls) (eval_ rs)
+ | Sub (ls, rs) -> sub (eval_ ls) (eval_ rs)
+ | Mul (ls, rs) -> mul (eval_ ls) (eval_ rs)
+ | Div (ls, rs) -> div (eval_ ls) (eval_ rs)
+
+let rec print_expr expr = match expr with
+ | Const n -> to_string n
+ | Add (ls, rs) -> (add (add (add (add "(" (print_expr ls)) ")") " + ") (print_expr rs))
+ | Sub (ls, rs) -> (add (add (add (add "(" (print_expr ls)) ")") " - ") (print_expr rs))
+ | Mul (ls, rs) -> (add (add (add (add "(" (print_expr ls)) ")") " * ") (print_expr rs))
+ | Div (ls, rs) -> (add (add (add (add "(" (print_expr ls)) ")") " / ") (print_expr rs))
+
+let f =
+ let source = parse "((1972 / 29) / 2) + 8" in
+ print (add (add (print_expr source) " = ") (to_string (eval_ source)))
diff --git a/generator/tests/js/calc.js b/generator/tests/js/calc.js
new file mode 100644
index 0000000000000000000000000000000000000000..f525709f0ac683055543b5b8072c85362d67d900
--- /dev/null
+++ b/generator/tests/js/calc.js
@@ -0,0 +1,64 @@
+var eval_ = function (expr) {
+
+ return (function () {
+
+ switch (expr.type) {
+
+ case "Const": var n = expr.value;
+
+ return n;
+ case "Add": var ls = expr.left, rs = expr.right;
+
+ return add(eval_(ls), eval_(rs));
+ case "Sub": var ls = expr.left, rs = expr.right;
+
+ return sub(eval_(ls), eval_(rs));
+ case "Mul": var ls = expr.left, rs = expr.right;
+
+ return mul(eval_(ls), eval_(rs));
+ case "Div": var ls = expr.left, rs = expr.right;
+
+ return div(eval_(ls), eval_(rs));
+
+
+ }
+})();
+ };
+
+
+var print_expr = function (expr) {
+
+ return (function () {
+
+ switch (expr.type) {
+
+ case "Const": var n = expr.value;
+
+ return to_string(n);
+ case "Add": var ls = expr.left, rs = expr.right;
+
+ return add(add(add(add("(", print_expr(ls)), ")"), " + "), print_expr(rs));
+ case "Sub": var ls = expr.left, rs = expr.right;
+
+ return add(add(add(add("(", print_expr(ls)), ")"), " - "), print_expr(rs));
+ case "Mul": var ls = expr.left, rs = expr.right;
+
+ return add(add(add(add("(", print_expr(ls)), ")"), " * "), print_expr(rs));
+ case "Div": var ls = expr.left, rs = expr.right;
+
+ return add(add(add(add("(", print_expr(ls)), ")"), " / "), print_expr(rs));
+
+
+ }
+})();
+ };
+
+
+var f = (function () {
+
+ var source = parse("((1972 / 29) / 2) + 8");
+
+
+ return print(add(add(print_expr(source), " = "), to_string(eval_(source))));
+
+})();
diff --git a/generator/tests/js/let.js b/generator/tests/js/let.js
new file mode 100644
index 0000000000000000000000000000000000000000..89342f1ab3abd42cabbbed7affa0080889b753ff
--- /dev/null
+++ b/generator/tests/js/let.js
@@ -0,0 +1,54 @@
+(function () {
+
+ var abr = 1;
+
+var bli = 4;
+
+
+ return (function () {
+
+ if (true) {
+
+ return abr;
+ } else {
+
+ return bli;
+ }
+})();
+
+})()
+
+var app = function (x) {
+ return x;
+ };
+
+
+var app2 = function (x) {
+ return x;
+ };
+
+
+
+
+var affiche = function (x) {
+
+ return (function () {
+
+ switch (x.type) {
+
+ case "As":
+ return "As";
+ case "Petite": var n = x.petite;
+
+ return "Petite";
+
+
+ }
+})();
+ };
+
+
+var pet = {type: "Petite", petite: 5};
+
+
+var cinq = 5;
diff --git a/generator/tests/js/mylist.js b/generator/tests/js/mylist.js
new file mode 100644
index 0000000000000000000000000000000000000000..1feb8a096a69d5ee6c3fe492c27ea12de244c4d6
--- /dev/null
+++ b/generator/tests/js/mylist.js
@@ -0,0 +1,190 @@
+var incr = function (i) {
+ return add(i, 1);
+ };
+
+
+
+
+var head = function (d, l) {
+
+ return (function () {
+
+ switch (l.type) {
+
+ case "Nil":
+ return d;
+ case "Cons": var x = l.hd, xs = l.tl;
+
+ return x;
+
+
+ }
+})();
+ };
+
+
+var tail = function (d, l) {
+
+ return (function () {
+
+ switch (l.type) {
+
+ case "Nil":
+ return d;
+ case "Cons": var x = l.hd, xs = l.tl;
+
+ return xs;
+
+
+ }
+})();
+ };
+
+
+var init = function (l) {
+
+ return (function () {
+
+ switch (l.type) {
+
+ case "Nil":
+ return {type: "Nil"};
+ case "Cons": var x = l.hd, xs = l.tl;
+
+ return xs;
+
+
+ }
+})();
+ };
+
+
+var last = function (l) {
+
+ return (function () {
+
+ switch (l.type) {
+
+ case "Nil":
+ return {type: "Nil"};
+ case "Cons": var x = l.hd, xs = l.tl;
+
+ return (function () {
+
+ switch (xs.type) {
+
+ case "Nil":
+ return x;
+ default:
+ return last(xs);
+
+
+ }
+})();
+
+
+ }
+})();
+ };
+
+
+var fold_left = function (f, acc, l) {
+
+ return (function () {
+
+ switch (l.type) {
+
+ case "Nil":
+ return acc;
+ case "Cons": var x = l.hd, xs = l.tl;
+
+ return fold_left(f, f(acc, x), xs);
+
+
+ }
+})();
+ };
+
+
+var fold_right = function (f, l, acc) {
+
+ return (function () {
+
+ switch (l.type) {
+
+ case "Nil":
+ return acc;
+ case "Cons": var x = l.hd, xs = l.tl;
+
+ return f(fold_right(f, xs, acc), x);
+
+
+ }
+})();
+ };
+
+
+var rev_map = function (f, l) {
+
+ return fold_left(function (acc, x) {
+ return {type: "Cons", hd: f(x), tl: acc};
+ }, {type: "Nil"}, l);
+ };
+
+
+var map = function (f, l) {
+
+ return fold_right(function (acc, x) {
+ return {type: "Cons", hd: f(x), tl: acc};
+ }, l, {type: "Nil"});
+ };
+
+
+var length = function (l) {
+
+ return fold_left(function (acc, x) {
+ return incr(acc);
+ }, 0, l);
+ };
+
+
+var range = function (i, j, acc) {
+
+ return (function () {
+
+ if (le(i, j)) {
+
+ return range(incr(i), j, {type: "Cons", hd: i, tl: acc});
+ } else {
+
+ return acc;
+ }
+})();
+ };
+
+
+var list0 = {type: "Nil"};
+
+
+var list1 = range(0, 1, {type: "Nil"});
+
+
+var list2 = range(1, 5, {type: "Nil"});
+
+
+var sqr = function (x) {
+ return mul(x, x);
+ };
+
+
+length(list0)
+
+length(list1)
+
+length(list2)
+
+map(sqr, list0)
+
+map(sqr, list1)
+
+map(sqr, list2)
\ No newline at end of file
diff --git a/generator/tests/let.cmi b/generator/tests/let.cmi
new file mode 100644
index 0000000000000000000000000000000000000000..2528ba236604509d869848c4d2dcce14a17179f0
Binary files /dev/null and b/generator/tests/let.cmi differ
diff --git a/generator/tests/let.ml b/generator/tests/let.ml
new file mode 100644
index 0000000000000000000000000000000000000000..a27ee5d2d7f85eadf71b4b6b7d9700e530bcee32
--- /dev/null
+++ b/generator/tests/let.ml
@@ -0,0 +1,19 @@
+let abr = 1
+and bli = 4 in
+if true then abr else bli
+
+let app x = x
+
+let app2 = fun x -> x
+
+type carte =
+ | As
+ | Petite [@f petite] of int
+
+
+let affiche x = match x with
+ | As -> "As"
+ | Petite n -> "Petite"
+
+let pet = Petite 5
+let cinq = 5
diff --git a/generator/tests/mylist.cmi b/generator/tests/mylist.cmi
new file mode 100644
index 0000000000000000000000000000000000000000..824d5453d1f41e9ad999413e8f5205b93ae00c04
Binary files /dev/null and b/generator/tests/mylist.cmi differ
diff --git a/generator/tests/mylist.ml b/generator/tests/mylist.ml
new file mode 100644
index 0000000000000000000000000000000000000000..7f1277b551ec72d76cd53aa65de7ad842e668ea6
--- /dev/null
+++ b/generator/tests/mylist.ml
@@ -0,0 +1,53 @@
+let incr i = add i 1
+
+type 'a liste =
+ | Nil
+ | Cons [@f hd, tl] of 'a * 'a liste
+
+let head d l = match l with
+ | Nil -> d
+ | Cons (x, xs) -> x
+
+let tail d l = match l with
+ | Nil -> d
+ | Cons (x, xs) -> xs
+
+let init l = match l with
+ | Nil -> Nil
+ | Cons (x, xs) -> xs
+
+let rec last l = match l with
+ | Nil -> Nil
+ | Cons (x, xs) -> (match xs with
+ | Nil -> x
+ | _ -> last xs)
+
+let rec fold_left f acc l = match l with
+ | Nil -> acc
+ | Cons (x, xs) -> fold_left f (f acc x) xs
+
+let rec fold_right f l acc = match l with
+ | Nil -> acc
+ | Cons (x, xs) -> f (fold_right f xs acc) x
+
+let rev_map f l = fold_left (fun acc x -> Cons(f x, acc)) Nil l
+let map f l = fold_right (fun acc x -> Cons(f x, acc)) l Nil
+
+let length l = fold_left (fun acc x -> incr acc) 0 l
+
+let rec range i j acc = if le i j then range (incr i) j (Cons (i, acc)) else acc
+
+(* Test *)
+
+let list0 = Nil
+let list1 = range 0 1 Nil
+let list2 = range 1 5 Nil
+
+let sqr x = mul x x;;
+
+length list0;;
+length list1;;
+length list2;;
+map sqr list0;;
+map sqr list1;;
+map sqr list2;;
diff --git a/generator/transformations.org b/generator/transformations.org
index 4d5a7e4e2105110b5f109011b690a5fcea9bc522..c4ef84bab4624b2cfdecc899f0f0c995212c3604 100644
--- a/generator/transformations.org
+++ b/generator/transformations.org
@@ -1,37 +1,4 @@
-* env_record_create_set_mutable_binding
-
-** Coq
-
-Definition env_record_set_mutable_binding runs S C L x v str : result_void :=
- if_some (pick_option (env_record_binds S L)) (fun E =>
- match E with
- | env_record_decl Ed =>
- if_some (Heap.read_option Ed x) (fun rm =>
- let '(mu, v_old) := rm in
- ifb mutability_is_mutable mu then
- res_void (env_record_write_decl_env S L x mu v)
- else out_error_or_void S str native_error_type)
- | env_record_object l pt =>
- object_put runs S C l x v str
- end).
-
-** ML
-
-let env_record_set_mutable_binding C L x v str =
- if_some (pick_option (env_record_binds L)) (fun E ->
- match E with
- | env_record_decl Ed ->
- if_some (Heap.read_option Ed x) (fun rm ->
- let '(mu, v_old) := rm in
- ifb mutability_is_mutable mu then
- res_void (env_record_write_decl_env S L x mu v)
- else out_error_or_void S str native_error_type)
- | env_record_object l pt =>
- object_put runs S C l x v str
- end).
-
-
* build_error
** Coq
@@ -44,49 +11,53 @@ Definition build_error S vproto vmsg : result :=
** ML
-let build_error vproto vmsg =
+let build_error S vproto vmsg =
let O = object_new vproto "Error" in
- let l = object_alloc O in
- if value_compare vmsg undef then val_loc l
+ let (l, S') := object_alloc S O in
+ if value_compare vmsg undef then out_ter S' l
else result_not_yet_implemented
** JS
-function build_error(vproto, vmsg) {
+function build_error(S, vproto, vmsg) {
var O = object_new(vproto, "Error");
- var l = object_alloc(O);
+ var l = object_alloc(S, O).first;
+ var S2 = object_alloc(S, O).second;
if (value_compare(vmsg, undef) {
- return val_loc(l);
+ return out_ter(S2, l);
} else {
- return result_not_yet_implemented();
+ return result_not_yet_implemented;
}
}
** JS, with log
-function build_error(vproto, vmsg) {
+function build_error(S, vproto, vmsg) {
log_custom({line: line, type: "enter"});
- var res = build_error__body(vproto, vmsg);
+ var res = build_error__body(S, vproto, vmsg);
var ctx = ctx_empty();
ctx = ctx_push(ctx, "res", res, "result");
log_custom({line: line, type: "exit", ctx: ctx});
return res;
}
-function build_error__body(vproto, vmsg) {
+function build_error__body(S, vproto, vmsg) {
var ctx = ctx_empty();
+ ctx = ctx_push(ctx, "S", S, "state");
ctx = ctx_push(ctx, "vproto", vproto, "value");
ctx = ctx_push(ctx, "vmsg", vmsg, "value");
log(1, ctx, "build_error");
var O = object_new(vproto, "Error");
ctx = ctx_push(ctx, "O", O, "object");
log(2, ctx, "var");
- var l = object_alloc(O);
+ var l = object_alloc(S, O).first;
+ var S2 = object_alloc(S, O).second;
ctx = ctx_push(ctx, "l", l, "location");
+ ctx = ctx_push(ctx, "S2", S2, "state");
log(3, ctx, "var");
- if (value_compare(vmsg, undef)) {
+ if (value_compare(vmsg, undef) {
log(4, ctx, "case");
- return val_loc(l);
+ return out_ter(S2, l);
} else {
log(5, ctx, "case");
return result_not_yet_implemented;
@@ -104,37 +75,39 @@ Definition run_error T S ne : specres T :=
** ML
-let run_error ne =
- if_object (build_error (prealloc_native_error_proto ne) undef) (fun l ->
- res_throw l)
+let run_error (*T*) S ne =
+ if_object (build_error S (prealloc_native_error_proto ne) undef) (fun S' l ->
+ result_some (specret_out (out_ter S' (res_throw l))))
** JS
-function run_error(ne) {
- return if_object(build_error(prealloc_native_error_proto(ne), undef), function (l) {
- return res_throw(l)});
+function run_error(S, ne) {
+ return if_object(build_error(S, prealloc_native_error_proto(ne), undef), function (S2, l) {
+ return result_some(specret_out(out_ter(S2, (res_throw(l)))))});
}
** JS, with log
-function run_error(ne) {
+function run_error(S, ne) {
log_custom({line: line, type: "enter"});
- var res = run_error__body(ne);
+ var res = run_error__body(S, ne);
var ctx = ctx_empty();
ctx = ctx_push(ctx, "res", res, "result");
log_custom({line: line, type: "exit", ctx: ctx});
return res;
}
-function run_error__body(ne) {
+function run_error__body(S, ne) {
var ctx = ctx_empty();
+ ctx = ctx_push(ctx, "S", S, "state");
ctx = ctx_push(ctx, "ne", ne, "error");
log(1, ctx, "run_error");
- return if_object(build_error(prealloc_native_error_proto(ne), undef), function (l) {
+ return if_object(build_error(S, prealloc_native_error_proto(ne), undef), function (S2, l) {
+ ctx = ctx_push(ctx, "S2", S2, "state");
ctx = ctx_push(ctx, "l", l, "location");
log(2, ctx, "fun");
- return res_throw(l)});
+ return result_some(specret_out(out_ter(S2, (res_throw(l)))))});
}
* object_proto_is_prototype_of
@@ -149,82 +122,82 @@ Definition object_proto_is_prototype_of runs S l0 l : result :=
ifb l' = l0
then out_ter S true
else runs_type_object_proto_is_prototype_of runs S l0 l'
- | _ =>
+ | value_prim _ =>
impossible_with_heap_because S "[run_object_method] returned a primitive in [object_proto_is_prototype_of_body]."
end).
** ML
-let object_proto_is_prototype_of l0 l =
- if_some (run_object_method object_proto_ l) (fun B ->
+let object_proto_is_prototype_of S l0 l =
+ if_some (run_object_method object_proto_ S l) (fun B ->
match B with
- | value_prim prim_null -> val_bool false
+ | null -> out_ter S false
| value_object l' ->
if loc_compare l' l0
- then val_bool true
- else object_proto_is_prototype_of l0 l'
- | _ ->
- impossible_with_heap_because "[run_object_method] returned a primitive in [object_proto_is_prototype_of_body]."
+ then out_ter S true
+ else runs_type_object_proto_is_prototype_of S l0 l'
+ | value_prim _ ->
+ impossible_with_heap_because S "[run_object_method] returned a primitive in [object_proto_is_prototype_of_body]."
end)
** JS
-function object_proto_is_prototype_of(l0, l) {
- return if_some (run_object_method(object_proto_, l), function (B) {
- if (B.tag === "value_prim" && B.prim.tag === "prim_null") {
- return val_bool(false);
- } else if (B.tag === "value_object") {
- if (loc_compare (B.l, l0)) {
- return out_val(true);
+function object_proto_is_prototype_of(S, l0, l) {
+ return if_some (run_object_method(object_proto_, S, l), function (B) {
+ switch (B.tag) {
+ case "null": // "prim"?
+ return out_ter(S, false);
+ case "value_object":
+ var l2 = B.l;
+ if (loc_compare (l2, l0)) {
+ return out_ter(S, true);
} else {
- return runs_type_object_proto_is_prototype_of(l0, B.l);
+ return runs_type_object_proto_is_prototype_of(S, l0, l2);
}
- } else {
- return impossible_with_heap_because("[run_object_method] returned a primitive in [object_proto_is_prototype_of_body].");
- }
+ case "value_prim":
+ return impossible_with_heap_because(S, "[run_object_method] returned a primitive in [object_proto_is_prototype_of_body].");
}
});
}
** JS, with log
-function object_proto_is_prototype_of(l0, l) {
+function object_proto_is_prototype_of(S, l0, l) {
+ log_custom({line: line, type: "enter"});
+ var res = object_proto_is_prototype_of__body(S, l0, l);
var ctx = ctx_empty();
- ctx = ctx_push(ctx, "l0", l0, "location");
- ctx = ctx_push(ctx, "l", l, "location");
- log_custom({line: line, type: "enter", ctx: ctx});
- var res = object_proto_is_prototype_of__body(l0, l);
- ctx = ctx_push(ctx, "__res", res, "result");
+ ctx = ctx_push(ctx, "res", res, "result");
log_custom({line: line, type: "exit", ctx: ctx});
return res;
}
-function object_proto_is_prototype_of__body(l0, l) {
+function object_proto_is_prototype_of__body(S, l0, l) {
var ctx = ctx_empty();
+ ctx = ctx_push(ctx, "S", S, "state");
ctx = ctx_push(ctx, "l0", l0, "location");
ctx = ctx_push(ctx, "l", l, "location");
log(1, ctx, "object_proto_is_prototype_of");
- return if_some (run_object_method(object_proto_, l), function (B) {
+ return if_some (run_object_method(object_proto_, S, l), function (B) {
ctx = ctx_push(ctx, "B", B);
log(2, ctx, "fun");
switch (B.tag) {
case "null": // "prim"?
log(3, ctx, "case");
- return out_val(false);
+ return out_ter(S, false);
case "value_object":
var l2 = B.l;
ctx = ctx_push(ctx, "l2", l2);
log(3, ctx, "case");
if (loc_compare (l2, l0)) {
log(4, ctx, "case");
- return out_val(true);
+ return out_ter(S, true);
} else {
log(5, ctx, "case");
- return runs_type_object_proto_is_prototype_of(l0, l2);
+ return runs_type_object_proto_is_prototype_of(S, l0, l2);
}
case "value_prim":
log(6, ctx, "case");
- return impossible_with_heap_because("[run_object_method] returned a primitive in [object_proto_is_prototype_of_body].");
+ return impossible_with_heap_because(S, "[run_object_method] returned a primitive in [object_proto_is_prototype_of_body].");
}
});
}