Skip to content
Browse files

Merge branch 'master' of github.com:cago/tryocaml

Conflicts:
	toplevellib/patch.js_of_ocaml_syntax_extension
	toplevellib/patch.print_hashtbl
	toplevellib/patch.print_hashtbl_and_exn
	try-ocaml/index.html
	tryocaml/.depend
	tryocaml/Makefile
  • Loading branch information...
2 parents 79efe01 + 8ec817e commit 87188286e41f82fccbe76520476591085bf9983c @lefessan lefessan committed May 10, 2012
View
2 Makefile
@@ -1,6 +1,8 @@
all:
$(MAKE) -C js_of_ocaml
$(MAKE) -C js_of_ocaml/compiler compiler.cma
+ $(MAKE) -C cmicomp
+ $(MAKE) -C ocp-jslib
$(MAKE) -C toplevel
$(MAKE) -C ocaml-num
$(MAKE) -C tutorial
View
3 Makefile.config
@@ -2,8 +2,9 @@ OCAMLC=ocamlc
OCAMLDEP=ocamldep.opt
JS_DIR=$(ROOT)/js_of_ocaml
-JS_DIR=$(ROOT)/js_of_ocaml
TOPLEVEL_DIR=$(ROOT)/toplevel
OCAMLNUM_DIR=$(ROOT)/ocaml-num
TUTORIAL_DIR=$(ROOT)/tutorial
TOPLEVELLIB_DIR=$(ROOT)/toplevellib
+CMICOMP_DIR=$(ROOT)/cmicomp
+OCPJSLIB_DIR=$(ROOT)/ocp-jslib
View
2 Makefile.rules
@@ -1,6 +1,6 @@
depend: $(SOURCES)
- $(OCAMLDEP) $(PP) $(SOURCES) *.ml *.mli > .depend
+ $(OCAMLDEP) $(INCLUDES) $(PP) $(SOURCES) *.ml *.mli > .depend
clean:
rm -f *.cm[aiox] *.o *.annot *~ $(TARGETS)
View
14 Makefile.tryocaml
@@ -1,5 +1,7 @@
all: byte $(TRYOCAML_NAME).js
+include $(ROOT)/Makefile.jsconfig
+
SOURCES= lessons.ml lessons.mli
TARGETS=$(TRYOCAML_NAME).byte $(TRYOCAML_NAME).js
@@ -23,9 +25,6 @@ TOPLEVELLIB=$(TOPLEVELLIB_DIR)/
COMP=$(JS_DIR)/compiler/js_of_ocaml
JSFILES=$(JS_DIR)/runtime/runtime.js $(JS_DIR)/runtime/weak.js $(TOPLEVEL_DIR)/toplevel_runtime.js
#OCAMLC=ocamlfind ocamlc -annot -pp "camlp4o $(JS_DIR)/lib/syntax/pa_js.cmo"
-PP= -pp "camlp4o $(JS_DIR)/lib/syntax/pa_js.cmo"
-OCAMLFIND=ocamlfind
-OCAMLFIND_OPTIONS= -package lwt,str
EXPUNGE=$(shell ocamlc -where)/expunge
# Removed gc and sys
STDLIB_MODULES=\
@@ -77,14 +76,16 @@ TOPLEVEL_MODULES=$(STDLIB_MODULES) n regexp tutorial outcometree topdirs toploop
TOPLEVEL_CMIS=$(TOPLEVEL_DIR)/toplevel.cmi
TOPLEVEL_CMOS=$(TOPLEVEL_DIR)/toplevel.cmo $(TOPLEVEL_DIR)/topmain.cmo
TOPLEVEL_CMAS= \
- $(JS_DIR)/lib/js_of_ocaml.cma $(JS_DIR)/compiler/compiler.cma \
+ $(CMICOMP_DIR)/js_of_ocaml.cma $(JS_DIR)/compiler/compiler.cma \
$(TOPLEVELLIB)toplevellib.cma \
$(OCAMLNUM_DIR)/ocaml-num.cma \
lessons.cmo \
- $(TUTORIAL_DIR)/tutorial.cma
+ $(TUTORIAL_DIR)/tutorial.cma \
+ $(OCPJSLIB_DIR)/ocp-jslib.cma
INCLUDES= \
- -I $(JS_DIR)/lib -I $(JS_DIR)/compiler \
+ -I $(CMICOMP_DIR) \
+ -I $(JS_DIR)/compiler \
-I $(TUTORIAL_DIR)/ \
$(INCLUDE_TOPLEVELLIB) \
-I $(OCAMLNUM_DIR) \
@@ -104,3 +105,4 @@ $(TRYOCAML_NAME).byte: $(TOPLEVEL_CMIS) $(TOPLEVEL_CMOS) $(TOPLEVEL_CMAS) \
rm -f $@.tmp
byte: lessons.cmo try-ocaml.byte
+
View
BIN cmicomp/cmicomp
Binary file not shown.
View
7 js_of_ocaml/runtime/stdlib.js
@@ -563,3 +563,10 @@ function caml_ml_output () { return 0; }
function caml_final_register () { return 0; }
//Provides: caml_final_release const
function caml_final_release () { return 0; }
+//Provides: caml_backtrace_status const
+function caml_backtrace_status () { return 0; }
+//Provides: caml_get_exception_backtrace const
+function caml_get_exception_backtrace () {
+ caml_invalid_argument
+ ("Primitive 'caml_get_exception_backtrace' not implemented");
+}
View
12 ocp-jslib/.depend
@@ -0,0 +1,12 @@
+button.cmo: utils.cmi button.cmi
+button.cmx: utils.cmx button.cmi
+cookie.cmo: cookie.cmi
+cookie.cmx: cookie.cmi
+dragnDrop.cmo: utils.cmi dragnDrop.cmi
+dragnDrop.cmx: utils.cmx dragnDrop.cmi
+utils.cmo: utils.cmi
+utils.cmx: utils.cmi
+button.cmi:
+cookie.cmi:
+dragnDrop.cmi:
+utils.cmi:
View
18 ocp-jslib/Makefile
@@ -0,0 +1,18 @@
+ROOT=..
+
+include $(ROOT)/Makefile.config
+include $(ROOT)/Makefile.jsconfig
+
+MLOBJS= utils.cmo button.cmo cookie.cmo dragnDrop.cmo
+MLINTFS= $(MLOBJS:.cmo=.cmi)
+
+INCLUDES= -I $(JS_DIR)/lib
+LIBNAME=ocp-jslib
+
+
+all : $(LIBNAME).cma
+
+$(LIBNAME).cma: $(MLINTFS) $(MLOBJS)
+ $(OCAMLC) -a -o $(LIBNAME).cma $(MLOBJS)
+
+include $(ROOT)/Makefile.rules
View
26 ocp-jslib/button.ml
@@ -0,0 +1,26 @@
+open Utils
+
+let registered_buttons = ref []
+
+let button_type = _s "button"
+
+let create txt action =
+ let b = Dom_html.createButton ~_type:button_type doc in
+ let id = "button" ^ txt in
+ b##innerHTML <- _s txt;
+ b##id <- _s id;
+ registered_buttons := (id, txt) :: !registered_buttons;
+ b##className <- _s "btn";
+ b##onclick <- Dom_html.handler (fun _ -> action (); Js._true);
+ b
+
+let create_with_image src width txt action =
+ let b = Dom_html.createButton ~_type:button_type doc in
+ let id = "button" ^ txt in
+ b##innerHTML <-
+ Js.string (Printf.sprintf
+ "<img src=\"%s\" width=\"%d\" text=\"%s\"/>" src width txt);
+ b##id <- Js.string id;
+ b##className <- _s "btn";
+ b##onclick <- Dom_html.handler (fun _ -> action (); Js._true);
+ b
View
5 ocp-jslib/button.mli
@@ -0,0 +1,5 @@
+val create : string -> (unit -> 'a) -> Dom_html.buttonElement Js.t
+
+val create_with_image : string -> int -> string -> (unit -> 'a) -> Dom_html.buttonElement Js.t
+
+val registered_buttons : (string * string) list ref
View
24 ocp-jslib/cookie.ml
@@ -0,0 +1,24 @@
+let get_cookie () =
+ let reg1 = Regexp.regexp "; " in
+ let list = Regexp.split reg1 (Js.to_string Dom_html.document##cookie) in
+ let reg2 = Regexp.regexp "=" in
+ List.map (fun s ->
+ match Regexp.split reg2 s with
+ x :: y -> (x, String.concat "=" y)
+ | [] -> ("", "")
+ ) list
+
+let set_cookie key value =
+ let today = jsnew Js.date_now () in
+ let expire_date = jsnew Js.date_ms
+ (today##getFullYear () + 1, today##getMonth (), today##getDay (),
+ today##getHours (), today##getMinutes (), today##getSeconds (),
+ today##getMilliseconds ()) in
+ let expire_time = Js.to_string expire_date##toUTCString () in
+ Dom_html.document##cookie <-
+ Js.string (Printf.sprintf "%s=%s;expires=%s" key value expire_time)
+
+let set_cookie_with_timeout key value date =
+ let expire_time = Js.to_string date##toUTCString () in
+ Dom_html.document##cookie <-
+ Js.string (Printf.sprintf "%s=%s;expires=%s" key value expire_time)
View
16 ocp-jslib/cookie.mli
@@ -0,0 +1,16 @@
+
+(** Gets browser cookies and returns a [(key, value) list]. *)
+val get_cookie : unit -> (string * string) list
+
+(** Sets browser cookies. Expiration time is one year by default. *)
+val set_cookie : string -> string -> unit
+
+(** Sets browser cookies with expiration time. *)
+val set_cookie_with_timeout : string -> string -> Js.date Js.t -> unit
+
+
+
+
+
+
+
View
44 ocp-jslib/dragnDrop.ml
@@ -0,0 +1,44 @@
+
+open Utils
+
+type drag_events = {
+ mutable ondragstart : Dom_html.dragEvent Js.t -> bool Js.t;
+ mutable ondragover : Dom_html.dragEvent Js.t -> bool Js.t;
+ mutable ondragend : Dom_html.dragEvent Js.t -> bool Js.t;
+ mutable ondrop : Dom_html.dragEvent Js.t -> bool Js.t;
+ mutable ondragleave : Dom_html.dragEvent Js.t -> bool Js.t;
+ mutable ondrag : Dom_html.dragEvent Js.t -> bool Js.t;
+}
+
+let default_func = (fun e -> Js._false)
+
+let default_event = {
+ ondragover = default_func;
+ ondragend = default_func;
+ ondrop = default_func;
+ ondragstart = default_func;
+ ondrag = default_func;
+ ondragleave = default_func;
+}
+
+let init () = {
+ ondragover = default_func;
+ ondragend = default_func;
+ ondrop = default_func;
+ ondragstart = default_func;
+ ondrag = default_func;
+ ondragleave = default_func;
+}
+
+let make ?events:(ev=default_event) container =
+ container##ondragover <- Dom.handler ev.ondragover;
+ container##ondragend <- Dom.handler ev.ondragend;
+ container##ondrop <- Dom_html.handler ev.ondrop
+
+
+
+
+
+
+
+
View
17 ocp-jslib/dragnDrop.mli
@@ -0,0 +1,17 @@
+
+(** By default, all events return false. *)
+type drag_events = {
+ mutable ondragstart : Dom_html.dragEvent Js.t -> bool Js.t;
+ mutable ondragover : Dom_html.dragEvent Js.t -> bool Js.t;
+ mutable ondragend : Dom_html.dragEvent Js.t -> bool Js.t;
+ mutable ondrop : Dom_html.dragEvent Js.t -> bool Js.t;
+ mutable ondragleave : Dom_html.dragEvent Js.t -> bool Js.t;
+ mutable ondrag : Dom_html.dragEvent Js.t -> bool Js.t;
+}
+
+(** Initializes a [drag_events] type with default behavior for all events. *)
+val init : unit -> drag_events
+
+(** Makes an element 'drag and drop'able. *)
+val make : ?events:drag_events -> Dom_html.element Js.t -> unit
+
View
51 ocp-jslib/utils.ml
@@ -0,0 +1,51 @@
+let doc = Dom_html.document
+
+let window = Dom_html.window
+
+let loc = Js.Unsafe.variable "location"
+
+let _s s = Js.string s
+
+let _f f = Js.wrap_callback f
+
+let get_element_by_id id =
+ Js.Opt.get (doc##getElementById (Js.string id)) (fun () -> assert false)
+
+let set_by_id id s =
+ let div = get_element_by_id id in
+ div##innerHTML <- Js.string s
+
+let set_div_by_id id s =
+ try
+ set_by_id id s
+ with _ -> ()
+
+let get_by_id id =
+ let div = get_element_by_id id in
+ Js.to_string div##innerHTML
+
+let get_by_name id =
+ let div =
+ List.hd (Dom.list_of_nodeList (doc##getElementsByTagName (Js.string id))) in
+ Js.to_string div##innerHTML
+
+let jsnew0 (constr : 'a Js.t Js.constr) () =
+ (Js.Unsafe.new_obj constr [| |] : 'a Js.t)
+
+let jsnew1 (constr : ('a -> 'z Js.t) Js.constr) (a) =
+ (Js.Unsafe.new_obj constr [|
+ Js.Unsafe.inject (a : 'a)
+ |] : 'z Js.t)
+
+let jsnew2 (constr : ('a -> 'b -> 'z Js.t) Js.constr) (a,b) =
+ (Js.Unsafe.new_obj constr [|
+ Js.Unsafe.inject (a : 'a);
+ Js.Unsafe.inject (b : 'b);
+ |] : 'z Js.t)
+
+let jsnew3 (constr : ('a -> 'b -> 'c -> 'z Js.t) Js.constr) (a,b,c) =
+ (Js.Unsafe.new_obj constr [|
+ Js.Unsafe.inject (a : 'a);
+ Js.Unsafe.inject (b : 'b);
+ Js.Unsafe.inject (c : 'c);
+ |] : 'z Js.t)
View
39 ocp-jslib/utils.mli
@@ -0,0 +1,39 @@
+(** {1 Useful functions and alias} *)
+val doc : Dom_html.document Js.t
+
+val window : Dom_html.window Js.t
+
+val loc : Dom_html.location Js.t
+
+val _s : string -> Js.js_string Js.t
+
+val _f : ('a -> 'b) -> ('c, 'a -> 'b) Js.meth_callback
+
+val set_div_by_id : string -> string -> unit
+
+val set_by_id : string -> string -> unit
+
+val get_element_by_id : string -> Dom_html.element Js.t
+
+val get_by_id : string -> string
+
+val get_by_name : string -> string
+
+(** {2 Constructors} *)
+
+(** [jsnew0] is a syntax extension to build an object using contructor [constr]
+ without arguments. *)
+val jsnew0 : 'a Js.t Js.constr -> unit -> 'a Js.t
+
+(** [jsnew1] is a syntax extension to build an object using contructor [constr]
+ and argument [a].*)
+val jsnew1 : ('a -> 'b Js.t) Js.constr -> 'a -> 'b Js.t
+
+(** [jsnew2] is a syntax extension to build an object using contructor [constr]
+ and arguments [a] and [b].*)
+val jsnew2 : ('a -> 'b -> 'c Js.t) Js.constr -> 'a * 'b -> 'c Js.t
+
+(** [jsnew3] is a syntax extension to build an object using contructor [constr]
+ and arguments [a], [b] and [c].*)
+val jsnew3 : ('a -> 'b -> 'c -> 'd Js.t) Js.constr -> 'a * 'b * 'c -> 'd Js.t
+
View
12 toplevel/.depend
@@ -1,7 +1,11 @@
-test.cmo:
-test.cmx:
-toplevel.cmo: errors.cmi toplevel.cmi
-toplevel.cmx: errors.cmi toplevel.cmi
+toplevel.cmo: ../ocp-jslib/utils.cmi ../tutorial/tutorial.cmi \
+ ../ocaml-num/topnum.cmo ../js_of_ocaml/compiler/pretty_print.cmi \
+ errors.cmi ../js_of_ocaml/compiler/driver.cmi ../ocp-jslib/dragnDrop.cmi \
+ ../ocp-jslib/cookie.cmi ../ocp-jslib/button.cmi toplevel.cmi
+toplevel.cmx: ../ocp-jslib/utils.cmx ../tutorial/tutorial.cmx \
+ ../ocaml-num/topnum.cmx ../js_of_ocaml/compiler/pretty_print.cmx \
+ errors.cmi ../js_of_ocaml/compiler/driver.cmx ../ocp-jslib/dragnDrop.cmx \
+ ../ocp-jslib/cookie.cmx ../ocp-jslib/button.cmx toplevel.cmi
topmain.cmo: toplevel.cmi
topmain.cmx: toplevel.cmx
errors.cmi:
View
8 toplevel/Makefile
@@ -2,6 +2,8 @@ byte: toplevel.cma
ROOT=..
include ../Makefile.config
+include ../Makefile.jsconfig
+
# remove this variable to use the default ocaml toplevel
INCLUDE_TOPLEVELLIB= -I $(TOPLEVELLIB_DIR)/
TOPLEVELLIB=$(TOPLEVELLIB_DIR)/
@@ -13,13 +15,13 @@ toplevel.cma: $(TOPLEVEL_CMOS) $(TOPLEVEL_CMIS)
$(OCAMLC) -a -o toplevel.cma $(TOPLEVEL_CMOS)
INCLUDES= \
- -I $(JS_DIR)/lib -I $(JS_DIR)/compiler \
+ -I $(CMICOMP_DIR) \
+ -I $(JS_DIR)/compiler \
-I $(TUTORIAL_DIR)/ \
$(INCLUDE_TOPLEVELLIB) \
-I $(OCAMLNUM_DIR) \
+ -I $(OCPJSLIB_DIR) \
-I $(TOPLEVEL_DIR) \
-I .
-PP=-pp "camlp4o $(JS_DIR)/lib/syntax/pa_js.cmo"
-
include ../Makefile.rules
View
58 toplevel/examples/cookies.ml
@@ -1,59 +1,13 @@
-let document = Dom_html.document
-let window = Dom_html.window
-
-let _s s = Js.string s
-let _f f = Js.wrap_callback f
-
-let getElementById id =
- Js.Opt.get (document##getElementById (_s id)) (fun () -> assert false)
-
-let get_cookies () =
- let reg1 = Regexp.regexp "; " in
- let list = Regexp.split reg1 (Js.to_string document##cookie) in
- let reg2 = Regexp.regexp "=" in
- List.map (fun s ->
- match Regexp.split reg2 s with
- x :: y -> (x, String.concat "=" y)
- | [] -> ("", "")
- ) list
-
-let jsnew0 (constr : 'a Js.t Js.constr) () =
- (Js.Unsafe.new_obj constr [| |] : 'a Js.t)
-
-let jsnew1 (constr : ('a -> 'z Js.t) Js.constr) (a) =
- (Js.Unsafe.new_obj constr [|
- Js.Unsafe.inject (a : 'a)
- |] : 'z Js.t)
-
-let jsnew2 (constr : ('a -> 'b -> 'z Js.t) Js.constr) (a,b) =
- (Js.Unsafe.new_obj constr [|
- Js.Unsafe.inject (a : 'a);
- Js.Unsafe.inject (b : 'b);
- |] : 'z Js.t)
-
-let jsnew3 (constr : ('a -> 'b -> 'c -> 'z Js.t) Js.constr) (a,b,c) =
- (Js.Unsafe.new_obj constr [|
- Js.Unsafe.inject (a : 'a);
- Js.Unsafe.inject (b : 'b);
- Js.Unsafe.inject (c : 'c);
- |] : 'z Js.t)
-
-let set_cookie key value =
- let today = jsnew0 Js.date_now () in
- let expire_time = today##setTime
- ((Js.to_float today##getTime()) *. 60. *. 60. *. 24. *. 365.) in
- document##cookie <- Js.string (Printf.sprintf "%s=%s;expires=%f" key value
- (Js.to_float expire_time))
+open Utils
let _ =
- let title = getElementById "main-title" in
+ let title = get_element_by_id "main-title" in
let v = try
- int_of_string (List.assoc "counter" (get_cookies() ))
- with Not_found ->
- 0
- in
+ int_of_string (List.assoc "counter" (Cookie.get_cookie () ))
+ with Not_found -> 0 in
+
let v = v + 1 in
- set_cookie "counter" (string_of_int v);
+ Cookie.set_cookie "counter" (string_of_int v);
title##innerHTML <- _s (
Printf.sprintf "This is your %s time in TryOCaml"
(match v with
View
19 toplevel/examples/moving_box.ml
@@ -1,16 +1,7 @@
-let document = Dom_html.document
-let window = Dom_html.window
+open Utils
-let _s s = Js.string s
-let _f f = Js.wrap_callback f
-
-let getElementById id =
- Js.Opt.get (document##getElementById (_s id)) (fun () -> assert false)
-
-(***************************************)
-
-let canvas = Dom_html.createCanvas document
-let body = getElementById "main-title"
+let canvas = Dom_html.createCanvas doc
+let body = get_element_by_id "main-title"
let context = canvas##getContext (Dom_html._2d_)
let x = ref 10.
@@ -22,10 +13,10 @@ let redraw _ =
y := if !y > 150. then 0. else !y +. 1.;
context##fillStyle <- Js.string "red";
context##fillRect (!x,!y, 20., 20.)
-
+
let _ =
Dom.appendChild body canvas;
- let interval_id = window##setInterval (_f redraw, 2.5) in
+ let _ = window##setInterval (_f redraw, 2.5) in
()
View
23 toplevel/examples/moving_box2.ml
@@ -1,19 +1,4 @@
-let document = Dom_html.document
-let window = Dom_html.window
-
-let _s s = Js.string s
-let _f f = Js.wrap_callback f
-
-let getElementById id =
- Js.Opt.get (document##getElementById (_s id)) (fun () -> assert false)
-
-let createTextButton id txt action =
- let b = Dom_html.createButton ~_type:(_s "button") document in
- b##innerHTML <- _s txt;
- b##id <- _s id;
- b##className <- _s "btn";
- b##onclick <- Dom_html.handler (fun _ -> action (); Js._true);
- b
+open Utils
let setIntervalUntilFalse f time =
let interval_id = ref None in
@@ -37,8 +22,8 @@ let setTimeout f time =
(***************************************)
-let canvas = Dom_html.createCanvas document
-let body = getElementById "main-title"
+let canvas = Dom_html.createCanvas doc
+let body = get_element_by_id "main-title"
let context = canvas##getContext (Dom_html._2d_)
let x = ref 10.
@@ -54,7 +39,7 @@ let redraw _ =
let _ =
Dom.appendChild body canvas;
let stop = setInterval redraw 2.5 in
- Dom.appendChild body (createTextButton "stop" "Stop" stop);
+ Dom.appendChild body (Button.create "Stop" stop);
setTimeout stop 50000.
View
7 toplevel/toplevel-with-js.js
6 additions, 1 deletion not shown because the diff is too large. Please use a local Git client to view these changes.
View
7 toplevel/toplevel.js
6 additions, 1 deletion not shown because the diff is too large. Please use a local Git client to view these changes.
View
342 toplevel/toplevel.ml
@@ -18,6 +18,10 @@
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
+open Utils
+
+module Html = Dom_html
+
let init_in_lesson = ref (fun _ -> ())
let split_primitives p =
@@ -30,8 +34,6 @@ let split_primitives p =
split beg (cur + 1) in
Array.of_list(split 0 0)
-(****)
-
class type global_data = object
method toc : (string * string) list Js.readonly_prop
method compile : (string -> string) Js.writeonly_prop
@@ -51,39 +53,7 @@ let _ =
output_program (Pretty_print.to_buffer b);
Buffer.contents b
in
- g##compile <- compile; (*XXX HACK!*)
-
-module Html = Dom_html
-
-let s = ""
-
-let doc = Html.document
-let window = Html.window
-let loc = Js.Unsafe.variable "location"
-let default_lang = "en"
-
-let registered_buttons = ref []
-
-let button_type = Js.string "button"
-let text_button txt action =
- let b = Dom_html.createButton ~_type:button_type doc in
- let id = "button"^txt in
- b##innerHTML <- Js.string (Tutorial.translate txt);
- b##id <- Js.string id;
- registered_buttons := (id, txt) :: !registered_buttons;
- b##className <- Js.string "btn";
- b##onclick <- Dom_html.handler (fun _ -> action (); Js._true);
- b
-
-let image_button src width txt action =
- let b = Dom_html.createButton ~_type:button_type doc in
- let id = "button"^txt in
- b##innerHTML <- Js.string (
- Printf.sprintf "<img src=\"%s\" width=\"%d\" text=\"%s\"/>" src width (Tutorial.translate txt));
- b##id <- Js.string id;
- b##className <- Js.string "btn";
- b##onclick <- Dom_html.handler (fun _ -> action (); Js._true);
- b
+ g##compile <- compile (*XXX HACK!*)
let exec ppf s =
let lb = Lexing.from_string s in
@@ -108,6 +78,7 @@ let _ =
(Js.Unsafe.meth_call (Obj.magic exn) "toString" [||]))
)
)
+
let start ppf =
Format.fprintf ppf " Welcome to TryOCaml (v. %s)@.@." Sys.ocaml_version;
Toploop.initialize_toplevel_env ();
@@ -131,7 +102,6 @@ let start ppf =
"#install_printer Topnum.print_num";
"#install_printer Toploop.print_exn";
"open Topnum";
-
];
()
@@ -183,41 +153,28 @@ let ensure_at_bol ppf =
consume_nl := true; at_bol := true
end
-let get_element_by_id id =
- Js.Opt.get (doc##getElementById (Js.string id))
- (fun () -> assert false)
-
-let set_by_id id s =
- let container = get_element_by_id id in
- container##innerHTML <- Js.string s
-
-let set_container_by_id id s =
- try
- set_by_id id s
- with _ -> ()
-
let update_lesson_text () =
- if !Tutorial.this_lesson <> 0 then begin
+ if !Tutorial.this_lesson <> 0 then begin
!init_in_lesson ();
- set_container_by_id "lesson-text" !Tutorial.this_step_html
+ set_div_by_id "lesson-text" !Tutorial.this_step_html
end
-
+
let update_lesson_number () =
if !Tutorial.this_lesson <> 0 then
- set_container_by_id "lesson-number"
+ set_div_by_id "lesson-number"
(Printf.sprintf "<span class=\"lesson\">%s %d</span>"
(Tutorial.translate "Lesson")
!Tutorial.this_lesson)
-
+
let update_lesson_step_number () =
- if !Tutorial.this_lesson <> 0 then
- set_container_by_id "lesson-step"
+ if !Tutorial.this_lesson <> 0 then
+ set_div_by_id "lesson-step"
(Printf.sprintf "<span class=\"step\">%s %d</span>"
(Tutorial.translate "Step")
!Tutorial.this_step)
let update_prompt prompt =
- set_container_by_id "sharp" prompt
+ set_div_by_id "sharp" prompt
let extract_escaped_and_kill html i =
let len = String.length html in
@@ -251,81 +208,6 @@ let text_of_html html =
done;
Buffer.contents b
-(* Some useful functions to handle cookies *)
-let find_in good_input input =
- try
- let len = String.length good_input in
- for i = 0 to String.length input - len do
- if String.sub input i len = good_input then
- raise Exit
- done;
- false
- with Exit -> true
-
-let get_cookie () =
- let reg = Regexp.regexp ";" in
- Regexp.split reg (Js.to_string doc##cookie)
-
-let get_lang_from_cookie () =
- let s = doc##cookie in
- let reg = Regexp.regexp ".*lang=([a-z][a-z]).*" in
- match Regexp.string_match reg (Js.to_string s) 0 with
- | None -> default_lang
- | Some r ->
- match (Regexp.matched_group r 1) with
- None -> default_lang
- | Some s -> s
-
-let get_lesson_from_cookie () =
- let s = doc##cookie in
- let reg = Regexp.regexp ".*lesson=([0-9]+).*" in
- match Regexp.string_match reg (Js.to_string s) 0 with
- | None -> 0
- | Some r ->
- match (Regexp.matched_group r 1) with
- None -> 0
- | Some s -> int_of_string s
-
-let get_step_from_cookie () =
- let s = doc##cookie in
- let reg = Regexp.regexp ".*step=([0-9]+).*" in
- match Regexp.string_match reg (Js.to_string s) 0 with
- | None -> 0
- | Some r ->
- match (Regexp.matched_group r 1) with
- None -> 0
- | Some s -> int_of_string s
-
-let set_cookie key value =
- let today = jsnew Js.date_now () in
- let expire_time = today##setTime
- ((Js.to_float today##getTime()) *. 60. *. 60. *. 24. *. 365.) in
- doc##cookie <- Js.string (Printf.sprintf "%s=%s;expires=%f" key value
- (Js.to_float expire_time))
-
-let get_by_id id =
- let container = get_element_by_id id in
- Js.to_string container##innerHTML
-
-let get_by_name id =
- let container =
- List.hd (Dom.list_of_nodeList (doc##getElementsByTagName (Js.string id)))
- in
- Js.to_string container##innerHTML
-
-let update_debug_message =
- let b = Buffer.create 100 in
- Tutorial.debug_fun := (fun s ->
- Firebug.console##log (Js.string s);
- Buffer.add_string b s; Buffer.add_string b "<br/>");
- function () ->
- let s = Buffer.contents b in
- Buffer.clear b;
- set_container_by_id "lesson-debug"
- (if s = "" then ""
- else Printf.sprintf
- "<div class=\"alert-message block-message warning\">%s</div>" s)
-
exception End_of_input
let string_of_char_list list =
@@ -417,7 +299,7 @@ let loop s ppf buffer =
let _ =
Tutorial.message_fun := (fun s ->
if !Tutorial.this_lesson <> 0 then
- set_container_by_id "lesson-message"
+ set_div_by_id "lesson-message"
(Printf.sprintf
"<div class=\"alert-message block-message success\">%s</div>" s)
)
@@ -448,9 +330,9 @@ let _ =
Tutorial.update_lang_fun := (fun _ ->
List.iter (fun list ->
List.iter (fun (id, s) ->
- set_container_by_id id (Tutorial.translate s))
+ set_div_by_id id (Tutorial.translate s))
list)
- [ to_update; !registered_buttons ]
+ [ to_update; !Button.registered_buttons ]
)
let get_storage () =
@@ -497,8 +379,7 @@ let add_history s =
with
| _ -> Firebug.console##warn(Js.string "can't set history")
-
-let run _ =
+let run () =
let top = get_element_by_id "toplevel" in
let output_area = get_element_by_id "output" in
let buffer = Buffer.create 1000 in
@@ -511,18 +392,20 @@ let run _ =
(fun _ ->
Dom.appendChild output_area
(doc##createTextNode(Js.string (Buffer.contents b)));
- Buffer.clear b)
- in
+ Buffer.clear b) in
+
let textbox = Html.createTextarea doc in
textbox##value <- Js.string "";
textbox##id <- Js.string "console";
Dom.appendChild top textbox;
textbox##focus();
textbox##select();
+
let container = get_element_by_id "toplevel-container" in
let history = ref (get_history ()) in
let history_bckwrd = ref !history in
let history_frwrd = ref [] in
+
let rec make_code_clickable () =
let textbox = get_element_by_id "console" in
let textbox = match Js.Opt.to_option (Html.CoerceTo.textarea textbox) with
@@ -550,7 +433,7 @@ let run _ =
history_frwrd := [];
textbox##value <- Js.string "";
(try loop s ppf buffer with _ -> ());
- update_debug_message ();
+ Tutorial.debug_fun := (fun s -> Firebug.console##log (Js.string s));
make_code_clickable ();
textbox##focus();
container##scrollTop <- container##scrollHeight
@@ -559,42 +442,39 @@ let run _ =
(fun _ ->
textbox##focus(); textbox##select(); Js._true);
-
- (* Make the toplevel drop-able *)
- container##ondragover <- Dom.handler (fun _ -> Js._false);
- container##ondragend <- Dom.handler (fun _ -> Js._false);
- container##ondrop <- Dom.handler
- (fun e ->
- container##className <- Js.string "";
-
- let file =
- match Js.Opt.to_option (e##dataTransfer##files##item(0)) with
- | None -> assert false
- | Some thing -> thing
- in
- let reader = jsnew File.fileReader () in
- reader##onload <- Dom.handler
- (fun _ ->
- let s =
- match Js.Opt.to_option (File.CoerceTo.string (reader##result)) with
- | None -> assert false
- | Some str -> str
- in
- textbox##value <- s;
- execute ();
- textbox##value <- Js.string "";
- Js._false);
- reader##onerror <- Dom.handler
- (fun _ ->
- Firebug.console##log (Js.string "Drang and drop failed.");
- textbox##value <- Js.string "Printf.printf \"Drag and drop failed. Try again\"";
- execute ();
- textbox##value <- Js.string "";
- Js._true);
- reader##readAsText ((file :> (File.blob Js.t)));
- Js._false);
- (* end drop-able part *)
-
+ (* Start drag and drop part *)
+ let ev = DragnDrop.init () in
+ (* Customize dropable part *)
+ ev.DragnDrop.ondrop <- (fun e ->
+ container##className <- Js.string "";
+ let file =
+ match Js.Opt.to_option (e##dataTransfer##files##item(0)) with
+ | None -> assert false
+ | Some file -> file in
+
+ let reader = jsnew File.fileReader () in
+ reader##onload <- Dom.handler
+ (fun _ ->
+ let s =
+ match Js.Opt.to_option (File.CoerceTo.string (reader##result)) with
+ | None -> assert false
+ | Some str -> str
+ in
+ textbox##value <- s;
+ execute ();
+ textbox##value <- Js.string "";
+ Js._false);
+ reader##onerror <- Dom.handler
+ (fun _ ->
+ Firebug.console##log (Js.string "Drang and drop failed.");
+ textbox##value <- Js.string "Printf.printf \"Drag and drop failed. Try again\"";
+ execute ();
+ textbox##value <- Js.string "";
+ Js._true);
+ reader##readAsText ((file :> (File.blob Js.t)));
+ Js._false);
+ DragnDrop.make ~events:ev container;
+ (* End of Drag and drop part *)
let tbox_init_size = textbox##style##height in
Html.document##onkeydown <-
@@ -639,25 +519,31 @@ let run _ =
| _ -> Js._true
end
| _ -> Js._true));
- Tutorial.clear_fun := (fun _ ->
+
+ let clear () =
output_area##innerHTML <- (Js.string "");
textbox##focus();
- textbox##select()
- );
- Tutorial.reset_fun := (fun _ ->
+ textbox##select() in
+
+ let reset () =
output_area##innerHTML <- (Js.string "");
Toploop.initialize_toplevel_env ();
Toploop.input_name := "";
exec ppf "open Tutorial";
textbox##focus();
- textbox##select()
- );
- Tutorial.set_cols_fun := (fun i ->
- textbox##style##width <- Js.string ((string_of_int (i * 7)) ^ "px"));
- let send_button = text_button "Send" (fun () -> execute ()) in
- let clear_button = text_button "Clear" (fun () -> Tutorial.clear ()) in
- let reset_button = text_button "Reset" (fun () -> Tutorial.reset ()) in
- let save_button = text_button "Save" (fun () ->
+ textbox##select() in
+ let set_cols i =
+ textbox##style##width <- Js.string ((string_of_int (i * 7)) ^ "px") in
+
+ let send_button =
+ Button.create (Tutorial.translate "Send") (fun () -> execute ()) in
+ let clear_button =
+ Button.create
+ (Tutorial.translate "Clear") (fun () -> clear ()) in
+ let reset_button =
+ Button.create (Tutorial.translate "Reset") (fun () -> reset ()) in
+ let save_button =
+ Button.create (Tutorial.translate "Save") (fun () ->
let content = Js.to_string output_area##innerHTML in
let l = Regexp.split (Regexp.regexp ("\n")) content in
let content =
@@ -671,15 +557,18 @@ let run _ =
Js.string ("data:application/octet-stream," ^
(Js.to_string (Js.encodeURI content))) in
let _ = window##open_(uriContent, Js.string "Try OCaml", Js.null) in
- window##close ()
- )
- in
+ window##close ()) in
+
let update_lesson () =
update_lesson_number ();
update_lesson_step_number ();
update_lesson_text ();
make_code_clickable ();
+ Cookie.set_cookie "lang" (Tutorial.lang ());
+ Cookie.set_cookie "lesson" (string_of_int !Tutorial.this_lesson);
+ Cookie.set_cookie "step" (string_of_int !Tutorial.this_step)
in
+
(* Choose your language *)
let form = Html.createDiv doc in
let sel = Dom_html.createSelect doc in
@@ -693,23 +582,22 @@ let run _ =
Html.handler
(fun _ ->
Tutorial.set_lang (fst (List.nth Tutorial.langs sel##selectedIndex));
- set_cookie "lang" (Tutorial.lang ());
+ Cookie.set_cookie "lang" (Tutorial.lang ());
update_lesson ();
Js._true);
Dom.appendChild form sel;
let langs = get_element_by_id "languages" in
Dom.appendChild langs form;
- Tutorial.set_cols 80;
+ set_cols 80;
append_children "buttons" [
send_button; clear_button; reset_button; save_button];
(* Choice of lesson and step with URL *)
let update_lesson_step lesson step =
Tutorial.lesson lesson;
Tutorial.step step;
- update_lesson ()
- in
+ update_lesson () in
init_in_lesson :=
(let init = ref false in
@@ -718,27 +606,29 @@ let run _ =
init := true;
append_children "lesson-left-button" [
- image_button "images/left2.png" 16 "left2"
+ Button.create_with_image "images/left2.png" 16 (Tutorial.translate "left2")
(fun _ ->
Tutorial.lesson (!Tutorial.this_lesson-1);
update_lesson ();
);
];
append_children "lesson-right-button" [
- image_button "images/right2.png" 16 "right2"
+ Button.create_with_image "images/right2.png" 16 (Tutorial.translate "right2")
(fun _ ->
Tutorial.lesson (!Tutorial.this_lesson+1);
update_lesson ();
);
];
append_children "step-left-button" [
- image_button "images/left1.png" 16 "left1" (fun _ ->
- Tutorial.back();
+ Button.create_with_image "images/left1.png" 16 (Tutorial.translate"left1")
+ (fun _ ->
+ Tutorial.back();
update_lesson ();
);
];
append_children "step-right-button" [
- image_button "images/right1.png" 16 "right1" (fun _ ->
+ Button.create_with_image "images/right1.png" 16 (Tutorial.translate "right1")
+ (fun _ ->
Tutorial.next();
update_lesson ();
);
@@ -747,13 +637,40 @@ let run _ =
output_area##scrollTop <- output_area##scrollHeight;
make_code_clickable ();
+ clear ();
start ppf;
- (* Setting language *)
+
+ (* Function to handle cookie operations *)
+ let get_lang_from_cookie () =
+ let default_lang = "en" in
+ let cookie = Cookie.get_cookie () in
+ try
+ snd (List.find (fun (key, value) -> key = "lang" ) cookie)
+ with Not_found -> default_lang in
+
+ let get_lesson_from_cookie () =
+ let cookie = Cookie.get_cookie () in
+ try
+ let _, lesson = List.find (fun (key, value) -> key = "lesson" ) cookie in
+ int_of_string lesson
+ with Not_found -> 0 in
+
+ let get_step_from_cookie () =
+ let cookie = Cookie.get_cookie () in
+ try
+ let _, step = List.find (fun (key, value) -> key = "step" ) cookie in
+ int_of_string step
+ with Not_found -> 0 in
+
let set_lang_from_cookie () =
let lang = get_lang_from_cookie () in
- if lang <> "" then Tutorial.set_lang lang
- in
+ if lang <> "" then Tutorial.set_lang lang in
+ let set_lesson_step_from_cookie () =
+ let lesson = get_lesson_from_cookie () in
+ let step = get_step_from_cookie () in
+ update_lesson_step lesson step in
+
(* Check if language has change in URL *)
let url = Js.decodeURI loc##href in
let reg = Regexp.regexp ".*lang=([a-z][a-z]).*" in
@@ -764,14 +681,8 @@ let run _ =
match Regexp.matched_group r 1 with
None -> set_lang_from_cookie ()
| Some s ->
- Tutorial.set_lang s;
- set_cookie "lang" (Tutorial.lang ());
- in
- let set_lesson_step_from_cookie () =
- let lesson = get_lesson_from_cookie () in
- let step = get_step_from_cookie () in
- update_lesson_step lesson step
- in
+ Tutorial.set_lang s;
+ Cookie.set_cookie "lang" (Tutorial.lang ()) in
let reg_lesson = Regexp.regexp ".*lesson=([0-9]+).*" in
let reg_step = Regexp.regexp ".*step=([0-9]+).*" in
let _ =
@@ -781,7 +692,7 @@ let run _ =
match Regexp.matched_group r 1 with
None -> ()
| Some s ->
- set_cookie "lesson" s;
+ Cookie.set_cookie "lesson" s;
Tutorial.lesson (int_of_string s) in
let _ =
match Regexp.string_match reg_step (Js.to_string url) 0 with
@@ -790,17 +701,14 @@ let run _ =
match Regexp.matched_group r 1 with
None -> set_lesson_step_from_cookie ()
| Some s ->
- set_cookie "step" s;
- Tutorial.step (int_of_string s)
- in
+ Cookie.set_cookie "step" s;
+ Tutorial.step (int_of_string s) in
update_lesson_step !Tutorial.this_lesson !Tutorial.this_step;
Js._false
let main () =
- (* window##alert (Js.string "Starting..."); *)
try
ignore (run ());
- (* window##alert (Js.string "Done."); *)
with e ->
window##alert (Js.string
(Printf.sprintf "exception %s during init."
View
6 toplevel/toplevel.mli
@@ -1,7 +1,7 @@
-val get_by_id : string -> string
-val set_by_id : string -> string -> unit
-val get_by_name : string -> string
+(* val get_by_id : string -> string *)
+(* val set_by_id : string -> string -> unit *)
+(* val get_by_name : string -> string *)
val main : unit -> unit
View
1,197 toplevellib/ocaml-3.12.1-tryocaml.patch
@@ -0,0 +1,1197 @@
+diff -ruN ocaml-3.12.1/asmcomp/closure.ml ocaml-3.12.1-tryocaml/asmcomp/closure.ml
+--- ocaml-3.12.1/asmcomp/closure.ml 2010-09-02 15:29:21.000000000 +0200
++++ ocaml-3.12.1-tryocaml/asmcomp/closure.ml 2012-05-04 16:49:50.606385009 +0200
+@@ -574,6 +574,8 @@
+ Immutable -> Value_tuple(Array.of_list approxs)
+ | Mutable -> Value_unknown
+ end)
++ | Lprim(Prevapply loc, [arg; func]) ->
++ close fenv cenv (Lapply(func, [arg], loc))
+ | Lprim(Pfield n, [lam]) ->
+ let (ulam, approx) = close fenv cenv lam in
+ let fieldapprox =
+diff -ruN ocaml-3.12.1/bytecomp/bytegen.ml ocaml-3.12.1-tryocaml/bytecomp/bytegen.ml
+--- ocaml-3.12.1/bytecomp/bytegen.ml 2010-09-02 15:29:21.000000000 +0200
++++ ocaml-3.12.1-tryocaml/bytecomp/bytegen.ml 2012-02-16 11:16:34.411347846 +0100
+@@ -524,6 +524,8 @@
+ comp_expr env arg sz cont
+ | Lprim(Pignore, [arg]) ->
+ comp_expr env arg sz (add_const_unit cont)
++ | Lprim(Prevapply loc, [arg; f]) ->
++ comp_expr env (Lapply(f, [arg], loc)) sz cont
+ | Lprim(Pnot, [arg]) ->
+ let newcont =
+ match cont with
+diff -ruN ocaml-3.12.1/bytecomp/lambda.ml ocaml-3.12.1-tryocaml/bytecomp/lambda.ml
+--- ocaml-3.12.1/bytecomp/lambda.ml 2010-09-02 15:29:21.000000000 +0200
++++ ocaml-3.12.1-tryocaml/bytecomp/lambda.ml 2012-02-16 11:16:34.411347846 +0100
+@@ -19,6 +19,7 @@
+ type primitive =
+ Pidentity
+ | Pignore
++ | Prevapply of Location.t
+ (* Globals *)
+ | Pgetglobal of Ident.t
+ | Psetglobal of Ident.t
+diff -ruN ocaml-3.12.1/bytecomp/lambda.mli ocaml-3.12.1-tryocaml/bytecomp/lambda.mli
+--- ocaml-3.12.1/bytecomp/lambda.mli 2010-09-02 15:29:21.000000000 +0200
++++ ocaml-3.12.1-tryocaml/bytecomp/lambda.mli 2012-02-16 11:16:34.411347846 +0100
+@@ -19,6 +19,7 @@
+ type primitive =
+ Pidentity
+ | Pignore
++ | Prevapply of Location.t
+ (* Globals *)
+ | Pgetglobal of Ident.t
+ | Psetglobal of Ident.t
+diff -ruN ocaml-3.12.1/bytecomp/printlambda.ml ocaml-3.12.1-tryocaml/bytecomp/printlambda.ml
+--- ocaml-3.12.1/bytecomp/printlambda.ml 2010-09-02 15:29:21.000000000 +0200
++++ ocaml-3.12.1-tryocaml/bytecomp/printlambda.ml 2012-02-16 11:16:34.411347846 +0100
+@@ -92,6 +92,7 @@
+ let primitive ppf = function
+ | Pidentity -> fprintf ppf "id"
+ | Pignore -> fprintf ppf "ignore"
++ | Prevapply _ -> fprintf ppf "revapply"
+ | Pgetglobal id -> fprintf ppf "global %a" Ident.print id
+ | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
+ | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag
+diff -ruN ocaml-3.12.1/bytecomp/simplif.ml ocaml-3.12.1-tryocaml/bytecomp/simplif.ml
+--- ocaml-3.12.1/bytecomp/simplif.ml 2010-09-02 15:29:21.000000000 +0200
++++ ocaml-3.12.1-tryocaml/bytecomp/simplif.ml 2012-02-16 11:16:34.415347850 +0100
+@@ -375,7 +375,14 @@
+ | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
+ | Lletrec(bindings, body) ->
+ Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
+- | Lprim(p, ll) -> Lprim(p, List.map simplif ll)
++ | Lprim(p, ll) -> begin
++ let ll = List.map simplif ll in
++ match p, ll with
++ | Prevapply loc, [x; Lapply(f, args, _)] -> Lapply(f, args@[x], loc)
++ | Prevapply loc, [x; f] -> Lapply(f, [x], loc)
++ | Prevapply _, _ -> assert false
++ | _ -> Lprim(p, ll)
++ end
+ | Lswitch(l, sw) ->
+ let new_l = simplif l
+ and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
+diff -ruN ocaml-3.12.1/bytecomp/translcore.ml ocaml-3.12.1-tryocaml/bytecomp/translcore.ml
+--- ocaml-3.12.1/bytecomp/translcore.ml 2010-09-02 15:29:21.000000000 +0200
++++ ocaml-3.12.1-tryocaml/bytecomp/translcore.ml 2012-02-16 11:16:34.415347850 +0100
+@@ -285,7 +285,7 @@
+ { prim_name = "caml_obj_dup"; prim_arity = 1; prim_alloc = true;
+ prim_native_name = ""; prim_native_float = false }
+
+-let transl_prim prim args =
++let transl_prim loc prim args =
+ try
+ let (gencomp, intcomp, floatcomp, stringcomp,
+ nativeintcomp, int32comp, int64comp,
+@@ -322,7 +322,10 @@
+ end
+ with Not_found ->
+ try
+- let p = Hashtbl.find primitives_table prim.prim_name in
++ let p =
++ match prim.prim_name with
++ | "%revapply" -> Prevapply loc
++ | _ -> Hashtbl.find primitives_table prim.prim_name in
+ (* Try strength reduction based on the type of the argument *)
+ begin match (p, args) with
+ (Psetfield(n, _), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2)
+@@ -620,7 +623,7 @@
+ wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
+ | _ -> assert false
+ else begin
+- let prim = transl_prim p args in
++ let prim = transl_prim e.exp_loc p args in
+ match (prim, args) with
+ (Praise, [arg1]) ->
+ wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)]))
+diff -ruN ocaml-3.12.1/otherlibs/threads/pervasives.ml ocaml-3.12.1-tryocaml/otherlibs/threads/pervasives.ml
+--- ocaml-3.12.1/otherlibs/threads/pervasives.ml 2010-06-09 12:23:48.000000000 +0200
++++ ocaml-3.12.1-tryocaml/otherlibs/threads/pervasives.ml 2012-02-16 11:16:34.415347850 +0100
+@@ -28,6 +28,8 @@
+
+ exception Exit
+
++external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
++
+ (* Comparisons *)
+
+ external (=) : 'a -> 'a -> bool = "%equal"
+diff -ruN ocaml-3.12.1/parsing/lexer.mll ocaml-3.12.1-tryocaml/parsing/lexer.mll
+--- ocaml-3.12.1/parsing/lexer.mll 2010-04-08 05:58:41.000000000 +0200
++++ ocaml-3.12.1-tryocaml/parsing/lexer.mll 2012-05-04 17:10:14.172452351 +0200
+@@ -292,6 +292,9 @@
+ INT64 (cvt_int64_literal (Lexing.lexeme lexbuf))
+ with Failure _ ->
+ raise (Error(Literal_overflow "int64", Location.curr lexbuf)) }
++ | int_literal "I"
++ { let s = Lexing.lexeme lexbuf in
++ BIGINT (String.sub s 0 (String.length s - 1)) }
+ | int_literal "n"
+ { try
+ NATIVEINT (cvt_nativeint_literal (Lexing.lexeme lexbuf))
+@@ -346,6 +349,7 @@
+ token lexbuf
+ }
+ | "#" { SHARP }
++ | "##" { SHARPJS }
+ | "&" { AMPERSAND }
+ | "&&" { AMPERAMPER }
+ | "`" { BACKQUOTE }
+diff -ruN ocaml-3.12.1/parsing/parser.mly ocaml-3.12.1-tryocaml/parsing/parser.mly
+--- ocaml-3.12.1/parsing/parser.mly 2011-04-29 06:56:21.000000000 +0200
++++ ocaml-3.12.1-tryocaml/parsing/parser.mly 2012-05-04 17:13:48.013512739 +0200
+@@ -83,29 +83,53 @@
+ then String.sub f 1 (String.length f - 1)
+ else "-" ^ f
+
+-let mkuminus name arg =
++let pexp_constant rev cst =
++ if !Clflags.wrap_constants then
++ match cst with
++ Const_string _
++ | Const_char _ ->
++ Pexp_constant cst
++ | _ ->
++ let name =
++ match cst with
++ Const_string _
++ | Const_char _ -> assert false
++ | Const_nativeint _ -> "nativeint"
++ | Const_int64 _ -> "int64"
++ | Const_int32 _ -> "int32"
++ | Const_float _ -> "float"
++ | Const_int _ -> "int"
++ in
++ Pexp_apply(ghexp(Pexp_ident (Lident (Printf.sprintf "%s_%s_%s" name
++ (if rev then "to" else "of")
++ name))),
++ ["", mkexp (Pexp_constant cst)])
++ else
++ Pexp_constant cst
++
++let mkuminus rev name arg =
+ match name, arg.pexp_desc with
+ | "-", Pexp_constant(Const_int n) ->
+- mkexp(Pexp_constant(Const_int(-n)))
++ mkexp(pexp_constant rev (Const_int(-n)))
+ | "-", Pexp_constant(Const_int32 n) ->
+- mkexp(Pexp_constant(Const_int32(Int32.neg n)))
++ mkexp(pexp_constant rev (Const_int32(Int32.neg n)))
+ | "-", Pexp_constant(Const_int64 n) ->
+- mkexp(Pexp_constant(Const_int64(Int64.neg n)))
++ mkexp(pexp_constant rev (Const_int64(Int64.neg n)))
+ | "-", Pexp_constant(Const_nativeint n) ->
+- mkexp(Pexp_constant(Const_nativeint(Nativeint.neg n)))
++ mkexp(pexp_constant rev (Const_nativeint(Nativeint.neg n)))
+ | ("-" | "-."), Pexp_constant(Const_float f) ->
+- mkexp(Pexp_constant(Const_float(neg_float_string f)))
++ mkexp(pexp_constant rev (Const_float(neg_float_string f)))
+ | _ ->
+ mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
+
+ let mkuplus name arg =
+ let desc = arg.pexp_desc in
+ match name, desc with
+- | "+", Pexp_constant(Const_int _)
+- | "+", Pexp_constant(Const_int32 _)
+- | "+", Pexp_constant(Const_int64 _)
+- | "+", Pexp_constant(Const_nativeint _)
+- | ("+" | "+."), Pexp_constant(Const_float _) -> mkexp desc
++ | "+", Pexp_constant (Const_int _)
++ | "+", Pexp_constant (Const_int32 _)
++ | "+", Pexp_constant (Const_int64 _)
++ | "+", Pexp_constant (Const_nativeint _)
++ | ("+" | "+."), Pexp_constant (Const_float _) -> mkexp desc
+ | _ ->
+ mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
+
+@@ -208,6 +232,178 @@
+ let pat_of_label lbl =
+ mkpat (Ppat_var(Longident.last lbl))
+
++let rnd = Random.State.make [|0x513511d4|]
++let random_var () =
++ Format.sprintf "a%08Lx" (Random.State.int64 rnd 0x100000000L)
++let fresh_type () = mktyp (Ptyp_var (random_var ()))
++
++let unescape lab =
++ assert (lab <> "");
++ let lab =
++ if lab.[0] = '_' then String.sub lab 1 (String.length lab - 1) else lab
++ in
++ try
++ let i = String.rindex lab '_' in
++ if i = 0 then raise Not_found;
++ String.sub lab 0 i
++ with Not_found ->
++ lab
++
++let js_unsafe s = mkexp(Pexp_ident(Ldot(Ldot(Lident "Js","Unsafe"), s)))
++
++let js_prop_type field_name field_type =
++ mktyp( Ptyp_constr(
++ Ldot( Lident "Js", "gen_prop" ),
++ [mktyp(Ptyp_object [
++ mkfield (Pfield( field_name, field_type ));
++ mkfield Pfield_var ]) ]) )
++
++let js_field_type expr field_name field_type =
++ mkexp( Pexp_constraint(
++ expr,
++ Some( mktyp( Ptyp_constr(
++ Ldot( Lident "Js", "t" ),
++ [mktyp( Ptyp_object [
++ mkfield( Pfield( field_name, mktyp( Ptyp_poly( [], field_type ))));
++ mkfield Pfield_var ]) ]))),
++ None ))
++
++let make_js_get expr label =
++ let var = fresh_type () in
++ let t_var = js_prop_type "get" var in
++ let expr = js_field_type expr label t_var in
++ let call = mkexp(Pexp_apply(
++ js_unsafe "get",
++ [ "", expr;
++ "", mkexp(Pexp_constant(Const_string (unescape label)))] )) in
++ mkexp( Pexp_constraint( call, Some( mktyp( Ptyp_poly( [], var ))), None ))
++
++let make_js_set expr label param =
++ let var = fresh_type () in
++ let t_var = js_prop_type "set"
++ ( mktyp( Ptyp_poly(
++ [], mktyp( Ptyp_arrow(
++ "", var, mktyp (Ptyp_constr ((Lident "unit"), []))) )))) in
++ let expr = js_field_type expr label t_var in
++ mkexp(Pexp_apply(
++ js_unsafe "set",
++ [ "", expr;
++ "", mkexp(Pexp_constant(Const_string (unescape label)));
++ "", mkexp (Pexp_constraint( param, Some var, None )) ] ))
++
++let make_inject (expr,typ) =
++ mkexp(Pexp_apply(
++ js_unsafe "inject",
++ [ "",
++ mkexp (Pexp_constraint(
++ expr,
++ Some typ,
++ None ))]))
++
++let make_js_call expr label args =
++ let args = List.map (fun p -> p,fresh_type ()) args in
++ let ret_type = fresh_type () in
++ let method_type =
++ List.fold_right
++ (fun (_, arg_ty) rem_ty -> mktyp ( Ptyp_arrow ( "", arg_ty, rem_ty )))
++ args
++ ( mktyp ( Ptyp_constr( Ldot( Lident "Js", "meth" ), [ ret_type ] )))
++ in
++ let args = mkexp( Pexp_array( List.map make_inject args )) in
++ let expr = js_field_type expr label method_type in
++ let call = mkexp( Pexp_apply(
++ js_unsafe "meth_call",
++ [ "", expr;
++ "", mkexp( Pexp_constant( Const_string( unescape label )));
++ "", args ] )) in
++ mkexp( Pexp_constraint( call, Some ret_type, None ))
++
++let rnd = Random.State.make [|0x513511d4|]
++let random_var () =
++ Format.sprintf "a%08Lx" (Random.State.int64 rnd 0x100000000L)
++let fresh_type () = mktyp (Ptyp_var (random_var ()))
++
++let unescape lab =
++ assert (lab <> "");
++ let lab =
++ if lab.[0] = '_' then String.sub lab 1 (String.length lab - 1) else lab
++ in
++ try
++ let i = String.rindex lab '_' in
++ if i = 0 then raise Not_found;
++ String.sub lab 0 i
++ with Not_found ->
++ lab
++
++let js_unsafe s = mkexp(Pexp_ident(Ldot(Ldot(Lident "Js","Unsafe"), s)))
++
++let js_prop_type field_name field_type =
++ mktyp( Ptyp_constr(
++ Ldot( Lident "Js", "gen_prop" ),
++ [mktyp(Ptyp_object [
++ mkfield (Pfield( field_name,
++ mktyp( Ptyp_poly( [], field_type )) ));
++ mkfield Pfield_var ]) ]) )
++
++let js_field_type expr field_name field_type =
++ mkexp( Pexp_constraint(
++ expr,
++ Some( mktyp( Ptyp_constr(
++ Ldot( Lident "Js", "t" ),
++ [mktyp( Ptyp_object [
++ mkfield( Pfield( field_name, mktyp( Ptyp_poly( [], field_type ))));
++ mkfield Pfield_var ]) ]))),
++ None ))
++
++let make_js_get expr label =
++ let var = fresh_type () in
++ let t_var = js_prop_type "get" var in
++ let expr = js_field_type expr label t_var in
++ let call = mkexp(Pexp_apply(
++ js_unsafe "get",
++ [ "", expr;
++ "", mkexp(Pexp_constant(Const_string (unescape label)))] )) in
++ mkexp( Pexp_constraint( call, Some( var ), None ))
++
++let make_js_set expr label param =
++ let var = fresh_type () in
++ let t_var = js_prop_type "set"
++ ( mktyp( Ptyp_arrow(
++ "", var, mktyp (Ptyp_constr ((Lident "unit"), []))) )) in
++ let expr = js_field_type expr label t_var in
++ mkexp(Pexp_apply(
++ js_unsafe "set",
++ [ "", expr;
++ "", mkexp(Pexp_constant(Const_string (unescape label)));
++ "", mkexp (Pexp_constraint( param, Some var, None )) ] ))
++
++let make_inject (expr,typ) =
++ mkexp(Pexp_apply(
++ js_unsafe "inject",
++ [ "",
++ mkexp (Pexp_constraint(
++ expr,
++ Some typ,
++ None ))]))
++
++let make_js_call expr label args =
++ let args = List.map (fun p -> p,fresh_type ()) args in
++ let ret_type = fresh_type () in
++ let method_type =
++ List.fold_right
++ (fun (_, arg_ty) rem_ty -> mktyp ( Ptyp_arrow ( "", arg_ty, rem_ty )))
++ args
++ ( mktyp ( Ptyp_constr( Ldot( Lident "Js", "meth" ), [ ret_type ] )))
++ in
++ let args = mkexp( Pexp_array( List.map make_inject args )) in
++ let expr = js_field_type expr label method_type in
++ let call = mkexp( Pexp_apply(
++ js_unsafe "meth_call",
++ [ "", expr;
++ "", mkexp( Pexp_constant( Const_string( unescape label )));
++ "", args ] )) in
++ mkexp( Pexp_constraint( call, Some ret_type, None ))
++
+ %}
+
+ /* Tokens */
+@@ -305,6 +501,7 @@
+ %token RPAREN
+ %token SEMI
+ %token SEMISEMI
++%token SHARPJS
+ %token SHARP
+ %token SIG
+ %token STAR
+@@ -323,6 +520,7 @@
+ %token WHEN
+ %token WHILE
+ %token WITH
++%token <string> BIGINT
+
+ /* Precedences and associativities.
+
+@@ -376,11 +574,12 @@
+ %nonassoc prec_constant_constructor /* cf. simple_expr (C versus C x) */
+ %nonassoc prec_constr_appl /* above AS BAR COLONCOLON COMMA */
+ %nonassoc below_SHARP
+-%nonassoc SHARP /* simple_expr/toplevel_directive */
++%nonassoc SHARP /* simple_expr/toplevel_directive */
++%left SHARPJS
+ %nonassoc below_DOT
+ %nonassoc DOT
+ /* Finally, the first tokens of simple_expr are above everything else. */
+-%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT INT32 INT64
++%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT BIGINT INT INT32 INT64
+ LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
+ NEW NATIVEINT PREFIXOP STRING TRUE UIDENT
+
+@@ -928,7 +1127,7 @@
+ | expr COLONEQUAL expr
+ { mkinfix $1 ":=" $3 }
+ | subtractive expr %prec prec_unary_minus
+- { mkuminus $1 $2 }
++ { mkuminus false $1 $2 }
+ | additive expr %prec prec_unary_plus
+ { mkuplus $1 $2 }
+ | simple_expr DOT label_longident LESSMINUS expr
+@@ -956,7 +1155,15 @@
+ val_longident
+ { mkexp(Pexp_ident $1) }
+ | constant
+- { mkexp(Pexp_constant $1) }
++ { mkexp(pexp_constant false $1) }
++ | BIGINT
++ { mkexp(Pexp_apply(ghexp(Pexp_ident (Lident "big_int_of_string")),
++ ["", mkexp(Pexp_constant(Const_string $1))])) }
++ | BACKQUOTE constant
++ { mkexp(pexp_constant true $2) }
++ | BACKQUOTE BIGINT
++ { mkexp(Pexp_apply(ghexp(Pexp_ident(Lident "string_to_big_int")),
++ ["", mkexp(Pexp_constant(Const_string $2))])) }
+ | constr_longident %prec prec_constant_constructor
+ { mkexp(Pexp_construct($1, None, false)) }
+ | name_tag %prec prec_constant_constructor
+@@ -1021,6 +1228,16 @@
+ { mkexp(Pexp_override []) }
+ | simple_expr SHARP label
+ { mkexp(Pexp_send($1, $3)) }
++ | simple_expr SHARPJS label
++ { make_js_get $1 $3 }
++ | simple_expr SHARPJS label LESSMINUS expr
++ { make_js_set $1 $3 $5 }
++ | simple_expr SHARPJS label LPAREN expr_comma_list RPAREN
++ { make_js_call $1 $3 (List.rev $5) }
++ | simple_expr SHARPJS label LPAREN expr RPAREN
++ { make_js_call $1 $3 [$5] }
++ | simple_expr SHARPJS label LPAREN RPAREN
++ { make_js_call $1 $3 [] }
+ | LPAREN MODULE module_expr COLON package_type RPAREN
+ { mkexp (Pexp_pack ($3, $5)) }
+ | LPAREN MODULE module_expr COLON error
+diff -ruN ocaml-3.12.1/stdlib/pervasives.mli ocaml-3.12.1-tryocaml/stdlib/pervasives.mli
+--- ocaml-3.12.1/stdlib/pervasives.mli 2011-05-17 15:31:32.000000000 +0200
++++ ocaml-3.12.1-tryocaml/stdlib/pervasives.mli 2012-02-16 11:16:34.419347861 +0100
+@@ -40,7 +40,6 @@
+ (** The [Exit] exception is not raised by any library function. It is
+ provided for use in your programs.*)
+
+-
+ (** {6 Comparisons} *)
+
+ external ( = ) : 'a -> 'a -> bool = "%equal"
+diff -ruN ocaml-3.12.1/toplevel/genprintval.ml ocaml-3.12.1-tryocaml/toplevel/genprintval.ml
+--- ocaml-3.12.1/toplevel/genprintval.ml 2009-10-26 11:53:16.000000000 +0100
++++ ocaml-3.12.1-tryocaml/toplevel/genprintval.ml 2012-05-04 17:23:18.640342322 +0200
+@@ -21,6 +21,8 @@
+ open Types
+ open Outcometree
+
++exception Not_handled
++
+ module type OBJ =
+ sig
+ type t
+@@ -45,6 +47,10 @@
+ val install_printer :
+ Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit
+ val remove_printer : Path.t -> unit
++ val install_printer2 :
++ Path.t -> Types.type_expr -> (Env.t -> Types.type_expr -> t ->
++ Outcometree.out_value) -> unit
++ val remove_printer2 : Path.t -> unit
+ val outval_of_untyped_exception : t -> Outcometree.out_value
+ val outval_of_value :
+ int -> int ->
+@@ -52,6 +58,11 @@
+ Env.t -> t -> type_expr -> Outcometree.out_value
+ end
+
++ (* An abstract type *)
++
++let abstract_type =
++ Ctype.newty (Tconstr (Pident (Ident.create "abstract"), [], ref Mnil))
++
+ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
+
+ type t = O.t
+@@ -111,11 +122,12 @@
+ (fun x -> Oval_int64 (O.obj x : int64))
+ ] : (Path.t * type_expr * (O.t -> Outcometree.out_value)) list)
+
++
+ let install_printer path ty fn =
+ let print_val ppf obj =
+ try fn ppf obj with
+- | exn ->
+- fprintf ppf "<printer %a raised an exception>" Printtyp.path path in
++ | exn ->
++ fprintf ppf "<printer %a raised an exception>" Printtyp.path path in
+ let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
+ printers := (path, ty, printer) :: !printers
+
+@@ -168,8 +180,28 @@
+
+ (* The main printing function *)
+
++ let printers2 = ref []
++
++ let install_printer2 path ty fn =
++ printers2 := (path, ty, fn) :: !printers2
++
++ let remove_printer2 path =
++ let rec remove = function
++ | [] -> raise Not_found
++ | (p, ty, fn as printer) :: rem ->
++ if Path.same p path then rem else printer :: remove rem in
++ printers2 := remove !printers2
++
++ let find_printer2 env ty obj =
++ let rec find = function
++ | [] -> raise Not_found
++ | (name, sch, printer) :: remainder ->
++ if Ctype.moregeneral env false sch ty
++ then printer env ty obj
++ else find remainder
++ in find !printers2
++
+ let outval_of_value max_steps max_depth check_depth env obj ty =
+-
+ let printer_steps = ref max_steps in
+
+ let rec tree_of_val depth obj ty =
+@@ -179,149 +211,152 @@
+ try
+ find_printer env ty obj
+ with Not_found ->
+- match (Ctype.repr ty).desc with
+- | Tvar ->
+- Oval_stuff "<poly>"
+- | Tarrow(_, ty1, ty2, _) ->
+- Oval_stuff "<fun>"
+- | Ttuple(ty_list) ->
+- Oval_tuple (tree_of_val_list 0 depth obj ty_list)
+- | Tconstr(path, [], _) when Path.same path Predef.path_exn ->
+- tree_of_exception depth obj
+- | Tconstr(path, [ty_arg], _)
+- when Path.same path Predef.path_list ->
+- if O.is_block obj then
+- match check_depth depth obj ty with
+- Some x -> x
+- | None ->
+- let rec tree_of_conses tree_list obj =
+- if !printer_steps < 0 || depth < 0 then
+- Oval_ellipsis :: tree_list
+- else if O.is_block obj then
+- let tree =
+- tree_of_val (depth - 1) (O.field obj 0) ty_arg in
+- let next_obj = O.field obj 1 in
+- tree_of_conses (tree :: tree_list) next_obj
+- else tree_list
+- in
+- Oval_list (List.rev (tree_of_conses [] obj))
+- else
+- Oval_list []
+- | Tconstr(path, [ty_arg], _)
+- when Path.same path Predef.path_array ->
+- let length = O.size obj in
+- if length > 0 then
+- match check_depth depth obj ty with
+- Some x -> x
+- | None ->
+- let rec tree_of_items tree_list i =
+- if !printer_steps < 0 || depth < 0 then
+- Oval_ellipsis :: tree_list
+- else if i < length then
+- let tree =
+- tree_of_val (depth - 1) (O.field obj i) ty_arg in
+- tree_of_items (tree :: tree_list) (i + 1)
+- else tree_list
+- in
+- Oval_array (List.rev (tree_of_items [] 0))
+- else
+- Oval_array []
+- | Tconstr (path, [ty_arg], _)
+- when Path.same path Predef.path_lazy_t ->
+- if Lazy.lazy_is_val (O.obj obj)
+- then let v = tree_of_val depth (Lazy.force (O.obj obj)) ty_arg in
+- Oval_constr (Oide_ident "lazy", [v])
+- else Oval_stuff "<lazy>"
+- | Tconstr(path, ty_list, _) ->
+- begin try
+- let decl = Env.find_type path env in
+- match decl with
+- | {type_kind = Type_abstract; type_manifest = None} ->
+- Oval_stuff "<abstr>"
+- | {type_kind = Type_abstract; type_manifest = Some body} ->
+- tree_of_val depth obj
+- (try Ctype.apply env decl.type_params body ty_list with
+- Ctype.Cannot_apply -> abstract_type)
+- | {type_kind = Type_variant constr_list} ->
+- let tag =
+- if O.is_block obj
+- then Cstr_block(O.tag obj)
+- else Cstr_constant(O.obj obj) in
+- let (constr_name, constr_args) =
+- Datarepr.find_constr_by_tag tag constr_list in
+- let ty_args =
+- List.map
+- (function ty ->
+- try Ctype.apply env decl.type_params ty ty_list with
+- Ctype.Cannot_apply -> abstract_type)
+- constr_args in
+- tree_of_constr_with_args (tree_of_constr env path)
+- constr_name 0 depth obj ty_args
+- | {type_kind = Type_record(lbl_list, rep)} ->
+- begin match check_depth depth obj ty with
+- Some x -> x
+- | None ->
+- let rec tree_of_fields pos = function
+- | [] -> []
+- | (lbl_name, _, lbl_arg) :: remainder ->
+- let ty_arg =
+- try
+- Ctype.apply env decl.type_params lbl_arg
+- ty_list
+- with
+- Ctype.Cannot_apply -> abstract_type in
+- let lid = tree_of_label env path lbl_name in
+- let v =
+- tree_of_val (depth - 1) (O.field obj pos)
+- ty_arg
+- in
+- (lid, v) :: tree_of_fields (pos + 1) remainder
+- in
+- Oval_record (tree_of_fields 0 lbl_list)
+- end
+- with
+- Not_found -> (* raised by Env.find_type *)
+- Oval_stuff "<abstr>"
+- | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
+- Oval_stuff "<unknown constructor>"
+- end
+- | Tvariant row ->
+- let row = Btype.row_repr row in
+- if O.is_block obj then
+- let tag : int = O.obj (O.field obj 0) in
+- let rec find = function
+- | (l, f) :: fields ->
+- if Btype.hash_variant l = tag then
+- match Btype.row_field_repr f with
+- | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
+- let args =
+- tree_of_val (depth - 1) (O.field obj 1) ty in
+- Oval_variant (l, Some args)
+- | _ -> find fields
+- else find fields
+- | [] -> Oval_stuff "<variant>" in
+- find row.row_fields
+- else
+- let tag : int = O.obj obj in
+- let rec find = function
+- | (l, _) :: fields ->
+- if Btype.hash_variant l = tag then
+- Oval_variant (l, None)
+- else find fields
+- | [] -> Oval_stuff "<variant>" in
+- find row.row_fields
+- | Tobject (_, _) ->
+- Oval_stuff "<obj>"
+- | Tsubst ty ->
+- tree_of_val (depth - 1) obj ty
+- | Tfield(_, _, _, _) | Tnil | Tlink _ ->
+- fatal_error "Printval.outval_of_value"
+- | Tpoly (ty, _) ->
+- tree_of_val (depth - 1) obj ty
+- | Tunivar ->
+- Oval_stuff "<poly>"
+- | Tpackage _ ->
+- Oval_stuff "<module>"
++ try
++ find_printer2 env ty obj
++ with Not_found ->
++ match (Ctype.repr ty).desc with
++ | Tvar ->
++ Oval_stuff "<poly>"
++ | Tarrow(_, ty1, ty2, _) ->
++ Oval_stuff "<fun>"
++ | Ttuple(ty_list) ->
++ Oval_tuple (tree_of_val_list 0 depth obj ty_list)
++ | Tconstr(path, [], _) when Path.same path Predef.path_exn ->
++ tree_of_exception depth obj
++ | Tconstr(path, [ty_arg], _)
++ when Path.same path Predef.path_list ->
++ if O.is_block obj then
++ match check_depth depth obj ty with
++ Some x -> x
++ | None ->
++ let rec tree_of_conses tree_list obj =
++ if !printer_steps < 0 || depth < 0 then
++ Oval_ellipsis :: tree_list
++ else if O.is_block obj then
++ let tree =
++ tree_of_val (depth - 1) (O.field obj 0) ty_arg in
++ let next_obj = O.field obj 1 in
++ tree_of_conses (tree :: tree_list) next_obj
++ else tree_list
++ in
++ Oval_list (List.rev (tree_of_conses [] obj))
++ else
++ Oval_list []
++ | Tconstr(path, [ty_arg], _)
++ when Path.same path Predef.path_array ->
++ let length = O.size obj in
++ if length > 0 then
++ match check_depth depth obj ty with
++ Some x -> x
++ | None ->
++ let rec tree_of_items tree_list i =
++ if !printer_steps < 0 || depth < 0 then
++ Oval_ellipsis :: tree_list
++ else if i < length then
++ let tree =
++ tree_of_val (depth - 1) (O.field obj i) ty_arg in
++ tree_of_items (tree :: tree_list) (i + 1)
++ else tree_list
++ in
++ Oval_array (List.rev (tree_of_items [] 0))
++ else
++ Oval_array []
++ | Tconstr (path, [ty_arg], _)
++ when Path.same path Predef.path_lazy_t ->
++ if Lazy.lazy_is_val (O.obj obj)
++ then let v = tree_of_val depth (Lazy.force (O.obj obj)) ty_arg in
++ Oval_constr (Oide_ident "lazy", [v])
++ else Oval_stuff "<lazy>"
++ | Tconstr(path, ty_list, _) ->
++ begin try
++ let decl = Env.find_type path env in
++ match decl with
++ | {type_kind = Type_abstract; type_manifest = None} ->
++ Oval_stuff "<abstr>"
++ | {type_kind = Type_abstract; type_manifest = Some body} ->
++ tree_of_val depth obj
++ (try Ctype.apply env decl.type_params body ty_list with
++ Ctype.Cannot_apply -> abstract_type)
++ | {type_kind = Type_variant constr_list} ->
++ let tag =
++ if O.is_block obj
++ then Cstr_block(O.tag obj)
++ else Cstr_constant(O.obj obj) in
++ let (constr_name, constr_args) =
++ Datarepr.find_constr_by_tag tag constr_list in
++ let ty_args =
++ List.map
++ (function ty ->
++ try Ctype.apply env decl.type_params ty ty_list with
++ Ctype.Cannot_apply -> abstract_type)
++ constr_args in
++ tree_of_constr_with_args (tree_of_constr env path)
++ constr_name 0 depth obj ty_args
++ | {type_kind = Type_record(lbl_list, rep)} ->
++ begin match check_depth depth obj ty with
++ Some x -> x
++ | None ->
++ let rec tree_of_fields pos = function
++ | [] -> []
++ | (lbl_name, _, lbl_arg) :: remainder ->
++ let ty_arg =
++ try
++ Ctype.apply env decl.type_params lbl_arg
++ ty_list
++ with
++ Ctype.Cannot_apply -> abstract_type in
++ let lid = tree_of_label env path lbl_name in
++ let v =
++ tree_of_val (depth - 1) (O.field obj pos)
++ ty_arg
++ in
++ (lid, v) :: tree_of_fields (pos + 1) remainder
++ in
++ Oval_record (tree_of_fields 0 lbl_list)
++ end
++ with
++ Not_found -> (* raised by Env.find_type *)
++ Oval_stuff "<abstr>"
++ | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
++ Oval_stuff "<unknown constructor>"
++ end
++ | Tvariant row ->
++ let row = Btype.row_repr row in
++ if O.is_block obj then
++ let tag : int = O.obj (O.field obj 0) in
++ let rec find = function
++ | (l, f) :: fields ->
++ if Btype.hash_variant l = tag then
++ match Btype.row_field_repr f with
++ | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
++ let args =
++ tree_of_val (depth - 1) (O.field obj 1) ty in
++ Oval_variant (l, Some args)
++ | _ -> find fields
++ else find fields
++ | [] -> Oval_stuff "<variant>" in
++ find row.row_fields
++ else
++ let tag : int = O.obj obj in
++ let rec find = function
++ | (l, _) :: fields ->
++ if Btype.hash_variant l = tag then
++ Oval_variant (l, None)
++ else find fields
++ | [] -> Oval_stuff "<variant>" in
++ find row.row_fields
++ | Tobject (_, _) ->
++ Oval_stuff "<obj>"
++ | Tsubst ty ->
++ tree_of_val (depth - 1) obj ty
++ | Tfield(_, _, _, _) | Tnil | Tlink _ ->
++ fatal_error "Printval.outval_of_value"
++ | Tpoly (ty, _) ->
++ tree_of_val (depth - 1) obj ty
++ | Tunivar ->
++ Oval_stuff "<poly>"
++ | Tpackage _ ->
++ Oval_stuff "<module>"
+ end
+
+ and tree_of_val_list start depth obj ty_list =
+diff -ruN ocaml-3.12.1/toplevel/genprintval.mli ocaml-3.12.1-tryocaml/toplevel/genprintval.mli
+--- ocaml-3.12.1/toplevel/genprintval.mli 2002-04-18 09:27:47.000000000 +0200
++++ ocaml-3.12.1-tryocaml/toplevel/genprintval.mli 2012-04-18 17:21:03.029631882 +0200
+@@ -17,6 +17,8 @@
+ open Types
+ open Format
+
++val abstract_type : Types.type_expr
++
+ module type OBJ =
+ sig
+ type t
+@@ -34,13 +36,16 @@
+ exception Error
+ val same_value: value -> value -> bool
+ end
+-
++exception Not_handled
+ module type S =
+ sig
+ type t
+ val install_printer :
+ Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit
+ val remove_printer : Path.t -> unit
++ val install_printer2 :
++ Path.t -> Types.type_expr -> (Env.t -> Types.type_expr -> t -> Outcometree.out_value) -> unit
++ val remove_printer2 : Path.t -> unit
+ val outval_of_untyped_exception : t -> Outcometree.out_value
+ val outval_of_value :
+ int -> int ->
+diff -ruN ocaml-3.12.1/toplevel/opttopdirs.ml ocaml-3.12.1-tryocaml/toplevel/opttopdirs.ml
+--- ocaml-3.12.1/toplevel/opttopdirs.ml 2010-01-22 13:48:24.000000000 +0100
++++ ocaml-3.12.1-tryocaml/toplevel/opttopdirs.ml 2012-02-16 11:16:34.419347861 +0100
+@@ -97,8 +97,10 @@
+
+ (* Install, remove a printer *)
+
+-type 'a printer_type_new = Format.formatter -> 'a -> unit
+-type 'a printer_type_old = 'a -> unit
++type 'a printer_type2 = Format.formatter -> Types.type_expr -> 'a -> unit
++type 'a printer_type1 = Format.formatter -> 'a -> unit
++type 'a printer_type0 = 'a -> unit
++
+
+ let match_printer_type ppf desc typename =
+ let (printer_type, _) =
+@@ -122,9 +124,12 @@
+ let (path, desc) = Env.lookup_value lid !toplevel_env in
+ let (ty_arg, is_old_style) =
+ try
+- (match_printer_type ppf desc "printer_type_new", false)
++ (match_printer_type ppf desc "printer_type2", 2)
++ with Ctype.Unify _ ->
++ try
++ (match_printer_type ppf desc "printer_type1", 1)
+ with Ctype.Unify _ ->
+- (match_printer_type ppf desc "printer_type_old", true) in
++ (match_printer_type ppf desc "printer_type0", 0) in
+ (ty_arg, path, is_old_style)
+ with
+ | Not_found ->
+@@ -139,12 +144,14 @@
+ try
+ let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
+ let v = eval_path path in
+- let print_function =
+- if is_old_style then
+- (fun formatter repr -> Obj.obj v (Obj.obj repr))
+- else
+- (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
+- install_printer path ty_arg print_function
++ match is_old_style with
++ | 0 -> install_printer path ty_arg
++ (fun formatter repr -> Obj.obj v (Obj.obj repr))
++ | 1 -> install_printer path ty_arg
++ (fun formatter repr -> Obj.obj v (Obj.obj repr))
++ | 2 -> install_printer2 path ty_arg
++ (fun formatter ty repr -> Obj.obj v formatter ty (Obj.obj repr))
++ | _ -> assert false
+ with Exit -> ()
+
+ let dir_remove_printer ppf lid =
+diff -ruN ocaml-3.12.1/toplevel/topdirs.ml ocaml-3.12.1-tryocaml/toplevel/topdirs.ml
+--- ocaml-3.12.1/toplevel/topdirs.ml 2010-01-22 13:48:24.000000000 +0100
++++ ocaml-3.12.1-tryocaml/toplevel/topdirs.ml 2012-02-16 11:16:34.423347882 +0100
+@@ -135,8 +135,10 @@
+
+ (* Install, remove a printer *)
+
+-type 'a printer_type_new = Format.formatter -> 'a -> unit
+-type 'a printer_type_old = 'a -> unit
++type 'a printer_type2 = Env.t -> Types.type_expr -> 'a -> Outcometree.out_value
++type 'a printer_type1 = Format.formatter -> 'a -> unit
++type 'a printer_type0 = 'a -> unit
++
+
+ let match_printer_type ppf desc typename =
+ let (printer_type, _) =
+@@ -160,9 +162,12 @@
+ let (path, desc) = Env.lookup_value lid !toplevel_env in
+ let (ty_arg, is_old_style) =
+ try
+- (match_printer_type ppf desc "printer_type_new", false)
++ (match_printer_type ppf desc "printer_type2", 2)
++ with Ctype.Unify _ ->
++ try
++ (match_printer_type ppf desc "printer_type1", 1)
+ with Ctype.Unify _ ->
+- (match_printer_type ppf desc "printer_type_old", true) in
++ (match_printer_type ppf desc "printer_type0", 0) in
+ (ty_arg, path, is_old_style)
+ with
+ | Not_found ->
+@@ -177,12 +182,13 @@
+ try
+ let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
+ let v = eval_path path in
+- let print_function =
+- if is_old_style then
+- (fun formatter repr -> Obj.obj v (Obj.obj repr))
+- else
+- (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
+- install_printer path ty_arg print_function
++ match is_old_style with
++ | 0 -> install_printer path ty_arg
++ (fun formatter repr -> Obj.obj v (Obj.obj repr))
++ | 1 -> install_printer path ty_arg
++ (fun formatter repr -> Obj.obj v formatter (Obj.obj repr))
++ | 2 -> install_printer2 path ty_arg (Obj.obj v)
++ | _ -> assert false
+ with Exit -> ()
+
+ let dir_remove_printer ppf lid =
+diff -ruN ocaml-3.12.1/toplevel/topdirs.mli ocaml-3.12.1-tryocaml/toplevel/topdirs.mli
+--- ocaml-3.12.1/toplevel/topdirs.mli 2002-04-18 09:27:47.000000000 +0200
++++ ocaml-3.12.1-tryocaml/toplevel/topdirs.mli 2012-02-16 11:16:34.423347882 +0100
+@@ -27,8 +27,9 @@
+ val dir_untrace : formatter -> Longident.t -> unit
+ val dir_untrace_all : formatter -> unit -> unit
+
+-type 'a printer_type_new = Format.formatter -> 'a -> unit
+-type 'a printer_type_old = 'a -> unit
++type 'a printer_type2 = Env.t -> Types.type_expr -> 'a -> Outcometree.out_value
++type 'a printer_type1 = Format.formatter -> 'a -> unit
++type 'a printer_type0 = 'a -> unit
+
+ (* For topmain.ml. Maybe shouldn't be there *)
+ val load_file : formatter -> string -> bool
+diff -ruN ocaml-3.12.1/toplevel/toploop.ml ocaml-3.12.1-tryocaml/toplevel/toploop.ml
+--- ocaml-3.12.1/toplevel/toploop.ml 2009-01-25 23:46:15.000000000 +0100
++++ ocaml-3.12.1-tryocaml/toplevel/toploop.ml 2012-05-04 16:51:45.902956740 +0200
+@@ -95,6 +95,8 @@
+
+ let install_printer = Printer.install_printer
+ let remove_printer = Printer.remove_printer
++let install_printer2 = Printer.install_printer2
++let remove_printer2 = Printer.remove_printer2
+
+ (* Hooks for parsing functions *)
+
+@@ -435,3 +437,134 @@
+ toplevel_env := Compile.initial_env();
+ Sys.interactive := false;
+ use_silently ppf name
++
++let rec find_type2 env ty =
++ match (Ctype.repr ty).desc with
++ | Tconstr(path, ty_list, _) ->
++ begin
++ let decl = Env.find_type path env in
++ match decl with
++ | {type_kind = Type_abstract; type_manifest = None} ->
++ begin
++ match ty_list with
++ [ty1; ty2] -> (ty1, ty2)
++ | _ -> raise Not_found
++ end
++ | {type_kind = Type_abstract; type_manifest = Some body} ->
++ find_type2 env
++ ( Ctype.apply env decl.type_params body ty_list )
++ | _ -> raise Not_found
++ end
++ | _ -> raise Not_found
++
++let find_type2 env ty =
++ try
++ find_type2 env ty
++ with _ ->
++ (Genprintval.abstract_type, Genprintval.abstract_type)
++
++let rec find_type1 env ty =
++ match (Ctype.repr ty).desc with
++ | Tconstr(path, ty_list, _) ->
++ begin
++ let decl = Env.find_type path env in
++ match decl with
++ | {type_kind = Type_abstract; type_manifest = None} ->
++ begin
++ match ty_list with
++ [ty1] -> ty1
++ | _ -> raise Not_found
++ end
++ | {type_kind = Type_abstract; type_manifest = Some body} ->
++ find_type1 env
++ ( Ctype.apply env decl.type_params body ty_list )
++ | _ -> raise Not_found
++ end
++ | _ -> raise Not_found
++
++let find_type1 env ty =
++ try
++ find_type1 env ty
++ with _ ->
++ Genprintval.abstract_type
++
++let stringers = [
++ Predef.type_int, (fun i -> string_of_int (Obj.magic i));
++ Predef.type_float, (fun i -> string_of_float (Obj.magic i));
++ Predef.type_string, (fun i -> Printf.sprintf "\"%s\"" (String.escaped (Obj.magic i)));
++ Predef.type_char, (fun i -> String.make 1 (Obj.magic i));