module_generation

generator/Makefile

@@ -28,6 +28,7 @@ debug: main.d.byte
 native: _tags
 	$(OCAMLBUILD) main.native
 
+
 stdlib:
 	$(CC) stdlib_ml/stdlib.mli
 
@@ -118,6 +119,16 @@ arthur: $(ML_JSREF:.ml=.log.js) $(ML_JSREF:.ml=.unlog.js) $(ML_JSREF:.ml=.token.
 # tests/jsref/JsInterpreter.log.js
 
 
+######### lineof target #########
+
+tests/jsref/lineof.js: lineof.byte $(ML_JSREF:.ml=.token.js)
+	lineof.byte -o $@ $(ML_JSREF:.ml=.token.js)
+
+lineof: tests/jsref/lineof.js
+
+##################
+
+
 clean_stdlib:
 	rm -f $(STD_DIR)/*.cmi
 
@@ -141,22 +152,12 @@ cleanall: clean clean_cmi
 
 ifeq ($(filter clean%,$(MAKECMDGOALS)),)
 -include $(ML_TESTS:.ml=.ml.d)
-endif
-
-#ifeq ($(MAKECMDGOALS),tests/lambda)
-ifneq ($(findstring tests/lambda,$(MAKECMDGOALS)),)
--include $(ML_LAMBDA:.ml=.ml.d)
-endif
-
-#tests/
-ifneq ($(findstring jsref,$(MAKECMDGOALS)),)
-#$(error $(ML_JSREF:.ml=.ml.d))
 -include $(ML_JSREF:.ml=.ml.d)
 -include $(MLI_JSREF:.mli=.mli.d)
 endif
 
-ifneq ($(findstring a,$(MAKECMDGOALS)),)
-#$(error $(ML_JSREF:.ml=.ml.d))
--include $(ML_JSREF:.ml=.ml.d)
--include $(MLI_JSREF:.mli=.mli.d)
-endif
+
+#ifeq ($(findstring clean,$(MAKECMDGOALS)),)
+#-include $(ML_JSREF:.ml=.ml.d)
+#-include $(MLI_JSREF:.mli=.mli.d)
+#endif

generator/TODO

@@ -43,4 +43,22 @@ LATER
 
 - => binder qq part vers une comparaison --- dans un fichier js
   _compare_JsSyntax_native_error
-  _compare_JsSyntax_prealloc
\ No newline at end of file
+  _compare_JsSyntax_prealloc
+
+
+
+==========
+
+TODO: demo of double clicking goes to the right page in ecma in english
+
+TODO: interpretation of comparison function in the search by "predicate"
+   might want to automatically "lift" basic values to their encoding
+	(unless some box is checked to prevent this behavior)
+
+	example:  "x == 3"  means:
+	"similar(x, { type: "value", tag: "value_prim", value: { type: "prim", tag: "float", value: 3.0 } })".
+
+	where similar is a recursive structural comparison function (not going through the heap)
+
+
+==========

generator/js_of_ast.ml

@@ -248,10 +248,9 @@ let ppf_path =
 let ppf_module content =
   Printf.sprintf "{@,%s@,}" content
 
-let ppf_module_wrap name content =
-  let modu = ppf_module content in
-  Printf.sprintf "var %s = %s;" name modu
-
+let ppf_module_wrap name content names_bound =
+  let bindings = show_list ", " (List.map (fun id -> Printf.sprintf "@\n  %s: %s" id id) names_bound) in
+  Printf.sprintf "var %s = (function() {@,@, %s @,@,@\nreturn {@\n %s };@,@\n})();@," name content bindings
 
 
 
@@ -472,13 +471,22 @@ let reject_inline dest =
 (****************************************************************)
 (* TRANSLATION *)
 
+(* takes a list of pairs made of: list of strings, and list of strings, 
+   and return a pair of a string (the string concat with newlines of the fst strings),
+   and a list of strings (the list flatten of the snd strings) *)
+
+let combine_list_output args = 
+   let (strs,bss) = List.split args in
+   (show_list "@,@," strs), (List.flatten bss)
+
 let rec js_of_structure s =
-  show_list_f (fun strct -> js_of_structure_item strct) "@,@," s.str_items
+   combine_list_output (List.map (fun strct -> js_of_structure_item strct) s.str_items)
 
 and js_of_submodule m =
+  Printf.printf "warning: code generation is incorrect for local modules\n"; 
   let loc = m.mod_loc in
   match m.mod_desc with
-  | Tmod_structure  s -> ppf_module (js_of_structure s)
+  | Tmod_structure  s -> ppf_module (fst (*TODO*) (js_of_structure s))
   | Tmod_functor (id, _, mtyp, mexp) -> ppf_function (ppf_ident id) (js_of_submodule mexp)
   | Tmod_apply (m1, m2, _) -> ppf_apply (js_of_submodule m1) (js_of_submodule m2)
   | Tmod_ident (p,_) -> ppf_path p
@@ -491,31 +499,38 @@ and show_value_binding ctx vb = (* dest is Ignore *)
 and js_of_structure_item s =
   let loc = s.str_loc in
   match s.str_desc with
-  | Tstr_eval (e, _)     -> Printf.sprintf "%s" @@ js_of_expression ctx_initial Dest_ignore e
-  | Tstr_value (_, vb_l) -> String.concat "@,@," @@ List.map (fun vb -> 
-     (* let (id, sdecl) = show_value_binding ctx_initial vb in *)
-     Printf.sprintf "@\n@\n%s: %s," (ident_of_pat vb.vb_pat) (js_of_expression_inline_or_wrap ctx_initial vb.vb_expr))
-     @@ vb_l
+  | Tstr_eval (e, _)     -> 
+     let str = Printf.sprintf "%s" @@ js_of_expression ctx_initial Dest_ignore e in
+     (str, [])
+  | Tstr_value (_, vb_l) -> 
+     combine_list_output (~~ List.map vb_l (fun vb -> 
+        let id = ident_of_pat vb.vb_pat in
+        let sbody = js_of_expression_inline_or_wrap ctx_initial vb.vb_expr in
+        let s = Printf.sprintf "@\n@\n var %s = %s;" id sbody in
+        (s, [id])))
   | Tstr_type decls -> 
-     (* function id( f1, f2) { return { typ: t, tag: x, "f1": f1, "f2": f2 } } *)
-     String.concat "@,@," @@ (List.map (fun decl -> 
+     combine_list_output (~~ List.map decls (fun decl -> 
         match decl.typ_type.type_kind with
         | Type_variant cstr_decls ->
            let styp = decl.typ_name.txt in
-           String.concat "@,@," @@ (List.map (fun (cd:Types.constructor_declaration) -> 
+           combine_list_output (~~ List.map cstr_decls (fun (cd:Types.constructor_declaration) -> 
               let cstr_name = cd.Types.cd_id.Ident.name in
               let fields = extract_cstr_attrs_basic cstr_name cd.cd_attributes in
               let sargs = show_list ", " fields in
               let sbindings = map_filter_fields_elements ppf_cstr fields fields in
               let rest = show_list ", " sbindings in
               let sobj = ppf_cstrs styp cstr_name rest in 
-              Printf.sprintf "function %s(%s) { return %s; }" cstr_name sargs sobj))
-          @@ cstr_decls
-        | _ -> ""))
-     @@ decls
-  | Tstr_open       _  -> "" (* Handle modules by use of multiple compilation/linking *)
-  | Tstr_modtype    _  -> ""
-  | Tstr_module     b  -> ppf_decl (ppf_ident b.mb_id) (js_of_submodule b.mb_expr)
+              let sbody = Printf.sprintf "function %s(%s) { return %s; }" cstr_name sargs sobj in
+              (sbody, [cstr_name])
+              ))
+        | _ -> ("", [])
+        ))
+  | Tstr_open       _  -> ("",[]) (* Handle modules by use of multiple compilation/linking *)
+  | Tstr_modtype    _  -> ("",[])
+  | Tstr_module     b  -> 
+     let id = ppf_ident b.mb_id in
+     let sbody = ppf_decl id (js_of_submodule b.mb_expr) in
+     (sbody, [id])
   | Tstr_primitive  _  -> out_of_scope loc "primitive functions"
   | Tstr_typext     _  -> out_of_scope loc "type extensions"
   | Tstr_exception  _  -> out_of_scope loc "exceptions"
@@ -832,8 +847,8 @@ and js_of_pattern pat obj =
 
 let to_javascript basename module_name typedtree =
   token_register_basename basename;
-  let content = js_of_structure typedtree in
-  let pre_res = ppf_module_wrap module_name content in
+  let (content,names_bound) = js_of_structure typedtree in
+  let pre_res = ppf_module_wrap module_name content names_bound in
   let str_ppf = Format.str_formatter in
   Format.fprintf str_ppf (Scanf.format_from_string pre_res "");
   Format.flush_str_formatter ()

generator/main.ml

@@ -34,6 +34,7 @@ let _ =
      failwith "The file name must be of the form *.ml";
    let basename = Filename.chop_suffix (Filename.basename sourcefile) ".ml" in
    let dirname = Filename.dirname sourcefile in
+   let pathname = if dirname = "" then basename else (dirname ^ "/" ^ basename) in
    let log_output, unlog_output, token_output =
      match !outputfile with
      | None -> Filename.concat dirname (basename ^ ".log.js"),
@@ -56,7 +57,7 @@ let _ =
       in
 
       match !current_mode with
-        | Mode_cmi -> Printf.printf "wrote cmi file\n"
+        | Mode_cmi -> Printf.printf "Wrote %s.cmi\n" pathname
         | _ ->
           let out = Js_of_ast.to_javascript basename module_name typedtree1 in
           let output_filename = match !current_mode with
@@ -66,4 +67,4 @@ let _ =
             | _ -> assert false
           in
           file_put_contents output_filename out;
-          Printf.printf "wrote %s\n" output_filename
+          Printf.printf "Wrote %s\n" output_filename

generator/params.ml

 let debug = ref false
 
+let (~~) f x y = f y x
+
+
 (****************************************************************)
 (* MODES *)