console/boot
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

major refactor

Browse Source
This commit is contained in:
cqc
2021-08-10 00:05:00 -05:00
parent 548bc0da64
commit 4f191e2fae
16 changed files with 113 additions and 132 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
bin/dune
View File

@ -1,30 +0,0 @@
(executables
(names main)
(modes byte)
(modules main)
(link_flags (-linkall))
(libraries topinf
tsdl
tgls.tgles2
wall
zed
irmin-unix
ocaml-compiler-libs.common
ocaml-compiler-libs.bytecomp
ocaml-compiler-libs.toplevel
findlib))
(library
(name topinf)
(modes byte)
(modules topinf)
(libraries tsdl
tgls.tgles2
wall
zed
irmin-unix
ocaml-compiler-libs.common
ocaml-compiler-libs.bytecomp
ocaml-compiler-libs.toplevel
findlib))

6
bin/init.ml
View File

@ -1,6 +0,0 @@
#directory "";;
let x = 1.0;;
assert (x = 1.0)

12
bin/topinf.mli
View File

@ -1,12 +0,0 @@
(* Accessors for the table of toplevel value bindings. These functions
must appear as first and second exported functions in this module.
(See module Translmod.) *)
val getvalue : string -> Obj.t
val setvalue : string -> Obj.t -> unit
val print_toplevel_value_bindings : unit -> unit
type evalenv = Format.formatter -> string -> unit
val init : Format.formatter -> evalenv

36
dune Normal file
View File

@ -0,0 +1,36 @@
(env
(dev
(flags (:standard -warn-error -A))))
(executable
(name main)
(modes byte)
(modules main)
(link_flags (-linkall))
(libraries
topinf
tsdl
tgls.tgles2
wall
zed
irmin-unix
ocaml-compiler-libs.common
ocaml-compiler-libs.bytecomp
ocaml-compiler-libs.toplevel))
(executable
(name test)
(modes byte)
(modules test)
(link_flags (-linkall))
(libraries
topinf))
(library
(name topinf)
(modes byte)
(modules topinf)
(libraries
fmt
ocaml-compiler-libs.toplevel))

1
dune-project
View File

@ -1,2 +1,3 @@
(lang dune 2.8)
(name komm)
(wrapped_executables false)

0
bin/fonts/NotoEmoji-Regular.ttf → fonts/NotoEmoji-Regular.ttf
View File

0
bin/fonts/Roboto-Bold.ttf → fonts/Roboto-Bold.ttf
View File

0
bin/fonts/Roboto-Light.ttf → fonts/Roboto-Light.ttf
View File

0
bin/fonts/Roboto-Regular.ttf → fonts/Roboto-Regular.ttf
View File

0
bin/fonts/entypo.ttf → fonts/entypo.ttf
View File

14
init.ml Normal file
View File

@ -0,0 +1,14 @@
(* $Id$ -*- tuareg -*- *)
#directory "/home/cqc/p/pinephone/komm/komm/_build/default/.topinf.objs/byte";;
open Topinf;;
let print_directives () =
Format.eprintf "directive_info_table:@.";
Hashtbl.iter (fun n _ -> Format.eprintf "\t%s@." n) Topinf.directive_info_table;;
#directory "+compiler-libs";;
let print_modules () =
Format.eprintf "Env.fold_modules:\n";
Env.fold_modules (fun modname _ _ () -> Format.eprintf "\t%s@." modname) None !Topinf.toplevel_env ();;
print_modules ();;

2
lib/dune
View File

@ -1,2 +0,0 @@
(library
(name komm))

30
bin/main.ml → main.ml
View File

@ -1,4 +1,3 @@
[@@@ocaml.warning "-6-9-26-27-32-34"]
open Lwt.Infix
module F = Fmt
@ -50,16 +49,6 @@ module Display = struct
let event_of_sdlevent ev =
match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
| `Text_editing ->
F.epr
"event_of_sdlevent: `Text_editing\n\
\twindow_id=%d\n\
\ttext=%s\n\
\tstart=%d\n\
\tlength=%d@."
(Sdl.Event.get ev Sdl.Event.text_editing_window_id)
(Sdl.Event.get ev Sdl.Event.text_editing_text)
(Sdl.Event.get ev Sdl.Event.text_editing_start)
(Sdl.Event.get ev Sdl.Event.text_editing_length);
`None
| `Text_input -> `Text_input (Sdl.Event.get ev Sdl.Event.text_input_text)
| (`Key_down | `Key_up) as w ->
@ -84,9 +73,6 @@ module Display = struct
}
in
let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in
(* (match w with `Key_down -> F.epr "key_down: " | `Key_up -> F.epr "key_up: ");
F.epr "%s@." (str_of_key k);
F.epr "\tkeyboard_repeat=%d\n" repeat ; *)
if repeat < 1 then
match w with `Key_down -> `Key_down k | `Key_up -> `Key_up k
else `None
@ -94,7 +80,6 @@ module Display = struct
let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in
`Mouse mouse_xy
| `Quit ->
F.epr "Quit Event\n";
`Quit
| _ -> (*F.epr "Unknown Event@." ; *) `None
@ -157,7 +142,6 @@ module Display = struct
let display_frame frame render =
(* create and fill event list *)
let tstart = ticks () in
let ev = Sdl.Event.create () in
let el = ref [ `None ] in
while Sdl.wait_event_timeout (Some ev) 50 (* HACK *) do
@ -188,7 +172,6 @@ module Display = struct
| a -> Some a (*| a -> Some a*))
!el;
if List.length !el > 0 then (
(* F.epr "Passing in %d events\n" (List.length !el); *)
let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
let _, (_, image) =
render
@ -211,7 +194,7 @@ module Display = struct
let width = float width and height = float height in
Wall.Renderer.render frame.wall ~width ~height image;
Sdl.gl_swap_window frame.sdl_win;
(*F.epr "event loop took %0.6f seconds\n" (ticks () -. tstart); *) Ok ())
Ok ())
else Ok ()
let run frame render () =
@ -361,7 +344,6 @@ let draw_pp height fpp (s : Display.state) =
let font_height = fm.ascent -. fm.descent +. fm.line_gap in
let max_x = ref 0. in
let out_string text o l =
(* F.epr "\tout_string: %s %s@." (String.sub text o l) (str_of_box !sc.box);*)
let sp = !sc in
push @@ simple_text font (String.sub text o l) !sc;
max_x := max !max_x (Box2.maxx !box);
@ -377,7 +359,6 @@ let draw_pp height fpp (s : Display.state) =
()
in
let out_newline () =
(* F.epr "\tout_newline: %s@." (str_of_box !sc.box);)*)
sc :=
{
!sc with
@ -388,11 +369,9 @@ let draw_pp height fpp (s : Display.state) =
}
in
let out_spaces n =
(* F.epr "\tout_spaces: n=%d %s@." n (str_of_box !sc.box);*)
let wpx = Text.Font.text_width font " " in
if Box2.ox !sc.box +. (float n *. wpx) > Box2.maxx !sc.box then (
(* WRAP *)
F.epr "out_spaces: ===== WRAP =======@.";
out_newline ());
let so = !sc in
let bo = Box2.v (Box2.o !sc.box) (P2.v (float n *. wpx) height) in
@ -405,7 +384,6 @@ let draw_pp height fpp (s : Display.state) =
sc := { !sc with box = Box2.of_pts (Box2.br_pt bo) (Box2.max so.box) }
in
let out_indent n =
(* F.epr "\tout_indent: n=%d %s@." n (str_of_box !sc.box);*)
let p = min (Box2.w !sc.box -. 1.) (height *. 2.0 *. float n) in
sc :=
{
@ -446,7 +424,6 @@ let draw_pp height fpp (s : Display.state) =
let margin = int_of_float (Box2.w s.box /. Text.Font.text_width font " ") in
let max_indent = margin - 1 in
Format.pp_safe_set_geometry pp ~max_indent ~margin;
(* F.epr "draw_pp: margin = %d, max_indent = %d@." (Format.pp_get_margin pp ()) (Format.pp_get_max_indent pp ());*)
fpp pp;
Format.pp_force_newline pp ();
(!sc, (Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box)), !node))
@ -486,7 +463,6 @@ let draw_textedit (te : textedit) height (s : Display.state) =
| _ -> ())
| `Key_up _ -> ()
| `Text_input s ->
F.epr "draw_textedit: `Text_input %s@." s;
Zed_edit.insert ctx (Zed_rope.of_string (Zed_string.of_utf8 s));
()
| _ -> ())
@ -608,10 +584,8 @@ let draw_top (t : top) height (s : Display.state) =
(* HACK use Lazy.? *)
Display.handle_keyevents s.events (function
| `Key_up { char = '\r'; mods = [ Ctrl ]; _ } ->
F.epr "draw_top: previous t.res=@.";
format_symbolic_output_buffer F.stderr
(Format.flush_symbolic_output_buffer t.res);
Topinf.print_toplevel_value_bindings ();
(* HACK overwriting stdout formatter because fucking ocaml/toplevel/topdirs.ml hardcodes it *)
Format.pp_set_formatter_out_functions Format.std_formatter
(out_funs_of_sob t.res);
@ -642,7 +616,7 @@ let draw_top (t : top) height (s : Display.state) =
]
s
let top_1 = make_top "../../rootstore" ()
let top_1 = make_top "../rootstore" ()
let draw_komm (s : Display.state) =
let node, state, box = (ref I.empty, ref s, ref s.box) in

6
test.ml Normal file
View File

@ -0,0 +1,6 @@
let eval = (Topinf.init Format.std_formatter) Format.std_formatter in
eval "#use \"init.ml\";;";

83
bin/topinf.ml → topinf.ml
View File

@ -1,9 +1,6 @@
[@@@ocaml.warning "-6-9-26-27-32-33-34"]
[@@@ocaml.warning "-32"]
module F = Fmt
let _ = F.epr "topinf.ml comin at ya @."
open Format
open Misc
open Parsetree
@ -39,17 +36,15 @@ let phrase_buffer = Buffer.create 1024
let toplevel_value_bindings : Obj.t String.Map.t ref = ref String.Map.empty
let getvalue name =
F.epr "Topinf.getvalue %s@." name;
try String.Map.find name !toplevel_value_bindings
with Not_found -> fatal_error (name ^ " unbound at toplevel")
let setvalue name v =
F.epr "Topinf.setvalue %s@." name;
toplevel_value_bindings := String.Map.add name v !toplevel_value_bindings
let print_toplevel_value_bindings () =
let print_toplevel_value_bindings ppf =
String.Map.iter
(fun k v -> F.epr "toplevel_value_bindings: %s\n" k)
(fun k _ -> F.pf ppf "toplevel_value_bindings: %s\n" k)
!toplevel_value_bindings
(* copied in lots of ocaml/lambda/translmod.ml *)
@ -75,8 +70,6 @@ let cons_opt x_opt xs = match x_opt with None -> xs | Some x -> x :: xs
(* Keep track of the root path (from the root of the namespace to the
currently compiled module expression). Useful for naming extensions. *)
let global_path glob = Some (Pident glob)
let functor_path path param =
match path with None -> None | Some p -> Some (Papply (p, Pident param))
@ -237,7 +230,7 @@ let compose_coercions c1 c2 =
let primitive_declarations = ref ([] : Primitive.description list)
let record_primitive = function
| { val_kind = Val_prim p; val_loc } ->
| { val_kind = Val_prim p; val_loc; _ } ->
Translprim.check_primitive_arity val_loc p;
primitive_declarations := p :: !primitive_declarations
| _ -> ()
@ -276,13 +269,13 @@ let init_shape id modl =
and init_shape_struct env sg =
match sg with
| [] -> []
| Sig_value (subid, { val_kind = Val_reg; val_type = ty; val_loc = loc }, _)
| Sig_value (subid, { val_kind = Val_reg; val_type = ty; val_loc = loc; _ }, _)
:: rem ->
let init_v =
match Ctype.expand_head env ty with
| { desc = Tarrow (_, _, _, _) } ->
| { desc = Tarrow (_, _, _, _); _} ->
const_int 0 (* camlinternalMod.Function *)
| { desc = Tconstr (p, _, _) } when Path.same p Predef.path_lazy_t ->
| { desc = Tconstr (p, _, _); _} when Path.same p Predef.path_lazy_t ->
const_int 1 (* camlinternalMod.Lazy *)
| _ ->
let not_a_function =
@ -291,12 +284,12 @@ let init_shape id modl =
raise (Initialization_failure not_a_function)
in
init_v :: init_shape_struct env rem
| Sig_value (_, { val_kind = Val_prim _ }, _) :: rem ->
| Sig_value (_, { val_kind = Val_prim _; _}, _) :: rem ->
init_shape_struct env rem
| Sig_value _ :: _rem -> assert false
| Sig_type (id, tdecl, _, _) :: rem ->
init_shape_struct (Env.add_type ~check:false id tdecl env) rem
| Sig_typext (subid, { ext_loc = loc }, _, _) :: _ ->
| Sig_typext (subid, { ext_loc = loc; _}, _, _) :: _ ->
raise
(Initialization_failure
(Unsafe { reason = Unsafe_typext; loc; subid }))
@ -458,7 +451,7 @@ let transl_class_bindings ~scopes cl_list =
let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in
( ids,
List.map
(fun ({ ci_id_class = id; ci_expr = cl; ci_virt = vf }, meths) ->
(fun ({ ci_id_class = id; ci_expr = cl; ci_virt = vf; _}, meths) ->
(id, transl_class ~scopes ids id meths cl vf))
cl_list )
@ -684,7 +677,7 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function
ext.tyexn_constructor,
body ),
size )
| Tstr_module ({ mb_presence = Mp_present } as mb) -> (
| Tstr_module ({ mb_presence = Mp_present; _} as mb) -> (
let id = mb.mb_id in
(* Translate module first *)
let subscopes =
@ -728,7 +721,7 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function
in
( Llet (pure_module mb.mb_expr, Pgenval, id, module_body, body),
size ))
| Tstr_module ({ mb_presence = Mp_absent } as mb) ->
| Tstr_module ({ mb_presence = Mp_absent; _} as mb) ->
List.iter
(Translattribute.check_attribute_on_module mb.mb_expr)
mb.mb_attributes;
@ -861,11 +854,9 @@ let set_toplevel_unique_name id =
aliased_idents := Ident.add id (Ident.unique_toplevel_name id) !aliased_idents
let toplevel_name id =
F.epr "toplevel_name: %s @." (Ident.name id);
try Ident.find_same id !aliased_idents with Not_found -> Ident.name id
let toploop_getvalue id =
F.epr "toploop_getvalue: %s @." (Ident.name id);
Lapply
{
ap_loc = Loc_unknown;
@ -885,7 +876,6 @@ let toploop_getvalue id =
}
let toploop_setvalue id lam =
F.epr "toploop_setvalue: %s @." (Ident.name id);
Lapply
{
ap_loc = Loc_unknown;
@ -906,7 +896,6 @@ let toploop_setvalue id lam =
}
let toploop_setvalue_id id =
F.epr "toploop_setvalue_id: %s @." (Ident.name id);
toploop_setvalue id (Lambda.Lvar id)
let close_toplevel_term (lam, ()) =
@ -919,7 +908,7 @@ let transl_toplevel_item ~scopes (item : structure_item) =
match item.str_desc with
| Tstr_eval (expr, _)
| Tstr_value
(Nonrecursive, [ { vb_pat = { pat_desc = Tpat_any }; vb_expr = expr } ])
(Nonrecursive, [ { vb_pat = { pat_desc = Tpat_any; _}; vb_expr = expr; _} ])
->
(* special compilation for toplevel "let _ = expr", so
that Toploop can display the result of the expression.
@ -942,9 +931,9 @@ let transl_toplevel_item ~scopes (item : structure_item) =
toploop_setvalue ext.tyexn_constructor.ext_id
(transl_extension_constructor ~scopes item.str_env None
ext.tyexn_constructor)
| Tstr_module { mb_id = None; mb_presence = Mp_present; mb_expr = modl } ->
| Tstr_module { mb_id = None; mb_presence = Mp_present; mb_expr = modl; _} ->
transl_module ~scopes Tcoerce_none None modl
| Tstr_module { mb_id = Some id; mb_presence = Mp_present; mb_expr = modl } ->
| Tstr_module { mb_id = Some id; mb_presence = Mp_present; mb_expr = modl; _} ->
(* we need to use the unique name for the module because of issues
with "open" (PR#8133) *)
set_toplevel_unique_name id;
@ -1018,7 +1007,7 @@ let transl_toplevel_item ~scopes (item : structure_item) =
mid,
transl_module ~scopes Tcoerce_none None od.open_expr,
set_idents 0 ids ))
| Tstr_module ({ mb_presence = Mp_absent } as mb) ->
| Tstr_module ({ mb_presence = Mp_absent; _} as mb) ->
List.iter
(Translattribute.check_attribute_on_module mb.mb_expr)
mb.mb_attributes;
@ -1227,7 +1216,7 @@ let load_lambda ppf lam =
(* Print the outcome of an evaluation *)
let pr_item =
Printtyp.print_items (fun env -> function
| Sig_value (id, { val_kind = Val_reg; val_type }, _) ->
| Sig_value (id, { val_kind = Val_reg; val_type; _}, _) ->
Some (outval_of_value env (getvalue (toplevel_name id)) val_type)
| _ -> None)
@ -1327,10 +1316,10 @@ let execute_phrase print_outcome ppf phr =
( Asttypes.Nonrecursive,
[
{
vb_pat = { pat_desc = Tpat_any };
vb_expr = exp;
vb_pat = { pat_desc = Tpat_any; _};
vb_expr = exp; _
};
] ) );
] ) ); _
};
] ->
let outv = outval_of_value newenv v exp.exp_type in
@ -1361,7 +1350,7 @@ let execute_phrase print_outcome ppf phr =
with x ->
toplevel_env := oldenv;
raise x)
| Ptop_dir { pdir_name = { Location.txt = dir_name }; pdir_arg } -> (
| Ptop_dir { pdir_name = { Location.txt = dir_name; _}; pdir_arg; _} -> (
let d =
try Some (Hashtbl.find directive_table dir_name)
with Not_found -> None
@ -1380,10 +1369,10 @@ let execute_phrase print_outcome ppf phr =
| Directive_none f, None ->
f ();
true
| Directive_string f, Some { pdira_desc = Pdir_string s } ->
| Directive_string f, Some { pdira_desc = Pdir_string s; _} ->
f s;
true
| Directive_int f, Some { pdira_desc = Pdir_int (n, None) } -> (
| Directive_int f, Some { pdira_desc = Pdir_int (n, None); _} -> (
match Int_literal_converter.int n with
| n ->
f n;
@ -1394,13 +1383,13 @@ let execute_phrase print_outcome ppf phr =
integers for directive `%s'.@."
dir_name;
false)
| Directive_int _, Some { pdira_desc = Pdir_int (_, Some _) } ->
| Directive_int _, Some { pdira_desc = Pdir_int (_, Some _); _} ->
fprintf ppf "Wrong integer literal for directive `%s'.@." dir_name;
false
| Directive_ident f, Some { pdira_desc = Pdir_ident lid } ->
| Directive_ident f, Some { pdira_desc = Pdir_ident lid; _} ->
f lid;
true
| Directive_bool f, Some { pdira_desc = Pdir_bool b } ->
| Directive_bool f, Some { pdira_desc = Pdir_bool b; _} ->
f b;
true
| _ ->
@ -1769,10 +1758,6 @@ module Topdirs = struct
Some (path, args)
| _ -> None
type 'a printer_type_new = Format.formatter -> 'a -> unit
type 'a printer_type_old = 'a -> unit
let printer_type ppf typename =
let printer_type =
match
@ -1915,7 +1900,7 @@ module Topdirs = struct
&& (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag)
&&
match Ctype.(repr (expand_head !toplevel_env desc.val_type)) with
| { desc = Tarrow _ } -> true
| { desc = Tarrow _; _ } -> true
| _ -> false
then (
match is_traced clos with
@ -2058,7 +2043,7 @@ module Topdirs = struct
if is_exception_constructor env desc.cstr_res then raise Not_found;
let path =
match Ctype.repr desc.cstr_res with
| { desc = Tconstr (path, _, _) } -> path
| { desc = Tconstr (path, _, _); _} -> path
| _ -> raise Not_found
in
let type_decl = Env.find_type path env in
@ -2335,7 +2320,6 @@ end
type evalenv = Format.formatter -> string -> unit
let eval lb ppf (text : string) =
F.epr "Topmain.eval: \n";
Topdirs.std_out := ppf;
(read_interactive_input :=
fun buffer _ ->
@ -2345,21 +2329,16 @@ let eval lb ppf (text : string) =
String.length text);
let snap = Btype.snapshot () in
try
F.epr "Topmain.eval: 1 reset@.";
Buffer.reset phrase_buffer;
(* Reset the phrase buffer, then flush the lexing buffer. *)
Lexing.flush_input lb;
(* calls read_interactive_input to fill buffer again *)
Location.reset ();
Warnings.reset_fatal ();
F.epr "Topmain.eval: 2 parse_toplevel_phrase@.";
let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
F.epr "Topmain.eval: 3 preprocess_phrase@.";
let phr = preprocess_phrase ppf phr in
F.epr "Topmain.eval: 4 Env.reset_cache_toplevel@.";
Env.reset_cache_toplevel ();
F.epr "Topmain.eval: 5 execute_phrase=%b@." (execute_phrase true ppf phr);
F.epr "Topmain.eval: 6 handle exceptions@."
ignore (execute_phrase true ppf phr)
with
| End_of_file ->
F.epr "Topmain.eval End_of_file exception\n";
@ -2379,7 +2358,6 @@ let eval lb ppf (text : string) =
let preload_objects = ref [ (*"komm.cma"*) ]
let init ppf =
F.epr "Topmain.init: \n";
Topdirs.std_out := ppf;
Clflags.include_dirs :=
List.rev_append [ Sys.getcwd () ] !Clflags.include_dirs;
@ -2395,12 +2373,9 @@ let init ppf =
Compmisc.read_clflags_from_env ();
set_paths ();
(try
F.epr "Load_path.get_paths: @.";
List.iter (fun s -> F.epr "\t%s\n" s) (Load_path.get_paths ());
let res =
List.for_all
(fun name ->
F.epr "Topdirs.load_file: name=%s@." name;
Topdirs.load_file ppf name)
(List.rev !preload_objects @ !Compenv.first_objfiles)
in

25
topinf.mli Normal file
View File

@ -0,0 +1,25 @@
(* Accessors for the table of toplevel value bindings. These functions
must appear as first and second exported functions in this module.
(See module Translmod.) *)
val getvalue : string -> Obj.t
val setvalue : string -> Obj.t -> unit
(* End accessors for table of toplevel value bindings that must be first in the module signature *)
val print_toplevel_value_bindings : Format.formatter -> unit
val toplevel_env : Env.t ref
type evalenv = Format.formatter -> string -> unit
val init : Format.formatter -> evalenv
type directive_fun =
| Directive_none of (unit -> unit)
| Directive_string of (string -> unit)
| Directive_int of (int -> unit)
| Directive_ident of (Longident.t -> unit)
| Directive_bool of (bool -> unit)
type directive_info = { section : string; doc : string }
val directive_info_table : (string, directive_info) Hashtbl.t