Merge pull request #103 from diml/die-camlp4-die
Remove hard dependency on camlp4
This commit is contained in:
Peter Zotov
commit
11442761a0
25
_oasis
25
_oasis
|
|
@ -2,12 +2,12 @@
|
|||
# | Package parameters |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
OASISFormat: 0.3
|
||||
OCamlVersion: >= 3.12
|
||||
OASISFormat: 0.4
|
||||
OCamlVersion: >= 4.01
|
||||
Name: utop
|
||||
Version: 1.15
|
||||
LicenseFile: LICENSE
|
||||
License: BSD3
|
||||
License: BSD-3-clause
|
||||
Authors: Jeremie Dimino
|
||||
Maintainers: Jeremie Dimino <jeremie@dimino.org>
|
||||
Homepage: https://github.com/diml/utop
|
||||
|
|
@ -15,6 +15,8 @@ BuildTools: ocamlbuild
|
|||
Plugins: DevFiles (0.3), META (0.3)
|
||||
XDevFilesEnableMakefile: false
|
||||
FilesAB: src/lib/uTop_version.ml.ab
|
||||
AlphaFeatures: ocamlbuild_more_args
|
||||
XOCamlbuildPluginTags: package(cppo_ocamlbuild)
|
||||
Synopsis: Universal toplevel for OCaml
|
||||
Description:
|
||||
utop is an improved toplevel for OCaml. It can run in a terminal or
|
||||
|
|
@ -27,12 +29,9 @@ Description:
|
|||
# | The toplevel |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
Library "optcomp"
|
||||
Install: false
|
||||
Path: syntax
|
||||
Modules: Pa_optcomp
|
||||
BuildDepends: camlp4, camlp4.quotations.o
|
||||
CompiledObject: byte
|
||||
Flag camlp4
|
||||
Description: camlp4 support
|
||||
Default: false
|
||||
|
||||
Library utop
|
||||
Path: src/lib
|
||||
|
|
@ -46,11 +45,13 @@ Library utop
|
|||
UTop_token,
|
||||
UTop_complete,
|
||||
UTop_styles
|
||||
BuildDepends: findlib, lambda-term (>= 1.2), lwt.syntax, threads
|
||||
BuildDepends: threads, findlib, lambda-term (>= 1.2)
|
||||
XMETADescription: utop configuration
|
||||
XMETARequires: findlib, lambda-term
|
||||
|
||||
Library "utop-camlp4"
|
||||
Build$: flag(camlp4)
|
||||
Install$: flag(camlp4)
|
||||
FindlibName: camlp4
|
||||
FindlibParent: utop
|
||||
Path: src/camlp4
|
||||
|
|
@ -64,7 +65,7 @@ Executable utop
|
|||
Path: src/top
|
||||
CompiledObject: byte
|
||||
MainIs: uTop_top.ml
|
||||
BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads
|
||||
BuildDepends: threads, findlib, lambda-term, utop
|
||||
DataFiles: utop.el ($datadir/emacs/site-lisp)
|
||||
|
||||
Executable "utop-full"
|
||||
|
|
@ -72,7 +73,7 @@ Executable "utop-full"
|
|||
Path: src/top
|
||||
CompiledObject: byte
|
||||
MainIs: uTop_top_full.ml
|
||||
BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads
|
||||
BuildDepends: threads, findlib, lambda-term, utop
|
||||
DataFiles: utop.el ($datadir/emacs/site-lisp)
|
||||
|
||||
# +-------------------------------------------------------------------+
|
||||
|
|
|
|||
8
_tags
8
_tags
|
|
@ -1,13 +1,7 @@
|
|||
# -*- conf -*-
|
||||
|
||||
# Use camlp4 on all files
|
||||
<**/*.ml>: syntax_camlp4o, pkg_lwt.syntax, pa_optcomp
|
||||
|
||||
# Do not use optcomp on syntax extensions
|
||||
<syntax/*.ml>: -pa_optcomp
|
||||
|
||||
# Use compiler interfaces
|
||||
<src/**/*.ml{,i}>: use_compiler_libs
|
||||
<src/**/*.ml{,i}>: package(compiler-libs)
|
||||
|
||||
# Use camlp5
|
||||
<src/camlp5/**/*.ml{,i}>: use_camlp5
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ let () =
|
|||
dispatch
|
||||
(fun hook ->
|
||||
dispatch_default hook;
|
||||
Ocamlbuild_cppo.dispatcher hook;
|
||||
match hook with
|
||||
| Before_options ->
|
||||
Options.make_links := false
|
||||
|
|
@ -31,30 +32,16 @@ let () =
|
|||
flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg";
|
||||
|
||||
let env = BaseEnvLight.load () in
|
||||
let path = BaseEnvLight.var_get "compiler_libs" env in
|
||||
let stdlib = BaseEnvLight.var_get "standard_library" env in
|
||||
|
||||
let findlib_version = BaseEnvLight.var_get "findlib_version" env in
|
||||
let findlib_version =
|
||||
Scanf.sscanf findlib_version "%d.%d" (Printf.sprintf "findlib_version=(%d, %d)")
|
||||
let ocaml_version =
|
||||
Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun major minor patchlevel ->
|
||||
(* e.g. #define OCAML_VERSION 040201 *)
|
||||
Printf.sprintf "OCAML_VERSION %d" (major * 10000 + minor * 100 + patchlevel))
|
||||
in
|
||||
|
||||
(* Optcomp *)
|
||||
let args =
|
||||
S[A"-ppopt"; A"syntax/pa_optcomp.cmo";
|
||||
A"-ppopt"; A"-let"; A"-ppopt"; A findlib_version]
|
||||
in
|
||||
flag ["ocaml"; "compile"; "pa_optcomp"] args;
|
||||
flag ["ocaml"; "ocamldep"; "pa_optcomp"] args;
|
||||
flag ["ocaml"; "doc"; "pa_optcomp"] args;
|
||||
dep ["ocaml"; "ocamldep"; "pa_optcomp"] ["syntax/pa_optcomp.cmo"];
|
||||
|
||||
(* Add directories for compiler-libraries: *)
|
||||
let paths = List.filter Sys.file_exists [path; path / "typing"; path / "parsing"; path / "utils"] in
|
||||
let paths = List.map (fun path -> S [A "-I"; A path]) paths in
|
||||
flag ["ocaml"; "compile"; "use_compiler_libs"] & S paths;
|
||||
flag ["ocaml"; "ocamldep"; "use_compiler_libs"] & S paths;
|
||||
flag ["ocaml"; "doc"; "use_compiler_libs"] & S paths;
|
||||
(* Cppo *)
|
||||
flag ["cppo"] & S[A"-D"; A ocaml_version];
|
||||
|
||||
let paths = [A "-I"; A "+camlp5"] in
|
||||
flag ["ocaml"; "compile"; "use_camlp5"] & S paths;
|
||||
|
|
@ -70,8 +57,8 @@ let () =
|
|||
let packages =
|
||||
Tags.fold
|
||||
(fun tag packages ->
|
||||
if String.is_prefix "pkg_" tag && not (String.is_suffix tag ".syntax") then
|
||||
String.after tag 4 :: packages
|
||||
if String.is_prefix "package(" tag then
|
||||
String.sub tag 8 (String.length tag - 9) :: packages
|
||||
else
|
||||
packages)
|
||||
(tags_of_pathname "src/top/uTop_top.byte")
|
||||
|
|
|
|||
14
opam
14
opam
|
|
@ -4,17 +4,21 @@ authors: ["Jérémie Dimino"]
|
|||
homepage: "https://github.com/diml/utop"
|
||||
license: "BSD3"
|
||||
build: [
|
||||
["./configure" "--prefix" prefix]
|
||||
["./configure" "--prefix" prefix "--%{camlp4:enable}%-camlp4"]
|
||||
[make]
|
||||
[make "install"]
|
||||
]
|
||||
build-doc: [["ocaml" "setup.ml" "-doc"]]
|
||||
remove: [["ocamlfind" "remove" "utop"]]
|
||||
depends: [
|
||||
"ocamlfind"
|
||||
"ocamlfind" {>= "1.4.0"}
|
||||
"lambda-term" {>= "1.2"}
|
||||
"lwt"
|
||||
"react" {>= "1.0.0"}
|
||||
"oasis" {>= "0.3.0"}
|
||||
"react" {>= "1.0.0"}
|
||||
"cppo" {>= "1.0.1"}
|
||||
"oasis" {>= "0.3.0"}
|
||||
]
|
||||
ocaml-version: [>= "3.12"]
|
||||
depopts: [
|
||||
"camlp4"
|
||||
]
|
||||
available: [ ocaml-version >= "4.01" ]
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ open Camlp4.PreCast
|
|||
|
||||
module Ast2pt = Camlp4.Struct.Camlp4Ast2OCamlAst.Make(Ast)
|
||||
|
||||
#if ocaml_version < (4, 2, 0)
|
||||
#if OCAML_VERSION < 040200
|
||||
external cast_toplevel_phrase : Camlp4_import.Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase = "%identity"
|
||||
#else
|
||||
let cast_toplevel_phrase x = x
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
(* Must be the same as driver/errors.mli from ocaml sources. *)
|
||||
open Format
|
||||
val report_error : formatter -> exn -> unit
|
||||
|
|
@ -13,6 +13,8 @@ open LTerm_text
|
|||
open LTerm_geom
|
||||
open LTerm_style
|
||||
|
||||
let (>>=) = Lwt.(>>=)
|
||||
|
||||
module String_set = Set.Make(String)
|
||||
|
||||
let version = UTop_version.version
|
||||
|
|
@ -122,25 +124,26 @@ let collect_formatters buf pps f =
|
|||
(* First flush all formatters. *)
|
||||
List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
|
||||
(* Save all formatter functions. *)
|
||||
let save = List.map (fun pp -> Format.pp_get_all_formatter_output_functions pp ()) pps in
|
||||
let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in
|
||||
let restore () =
|
||||
List.iter2
|
||||
(fun pp (out, flush, newline, spaces) ->
|
||||
(fun pp out_functions ->
|
||||
Format.pp_print_flush pp ();
|
||||
Format.pp_set_all_formatter_output_functions pp ~out ~flush ~newline ~spaces)
|
||||
Format.pp_set_formatter_out_functions pp out_functions)
|
||||
pps save
|
||||
in
|
||||
(* Output functions. *)
|
||||
let out str ofs len = Buffer.add_substring buf str ofs len in
|
||||
let flush = ignore in
|
||||
let newline () = Buffer.add_char buf '\n' in
|
||||
let spaces n = for i = 1 to n do Buffer.add_char buf ' ' done in
|
||||
let out_string str ofs len = Buffer.add_substring buf str ofs len
|
||||
and out_flush = ignore
|
||||
and out_newline () = Buffer.add_char buf '\n'
|
||||
and out_spaces n = for i = 1 to n do Buffer.add_char buf ' ' done in
|
||||
let out_functions = { Format.out_string; out_flush; out_newline; out_spaces } in
|
||||
(* Replace formatter functions. *)
|
||||
let cols = (S.value size).cols in
|
||||
List.iter
|
||||
(fun pp ->
|
||||
Format.pp_set_margin pp cols;
|
||||
Format.pp_set_all_formatter_output_functions pp ~out ~flush ~newline ~spaces)
|
||||
Format.pp_set_formatter_out_functions pp out_functions)
|
||||
pps;
|
||||
try
|
||||
let x = f () in
|
||||
|
|
@ -154,21 +157,21 @@ let discard_formatters pps f =
|
|||
(* First flush all formatters. *)
|
||||
List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
|
||||
(* Save all formatter functions. *)
|
||||
let save = List.map (fun pp -> Format.pp_get_all_formatter_output_functions pp ()) pps in
|
||||
let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in
|
||||
let restore () =
|
||||
List.iter2
|
||||
(fun pp (out, flush, newline, spaces) ->
|
||||
(fun pp out_functions ->
|
||||
Format.pp_print_flush pp ();
|
||||
Format.pp_set_all_formatter_output_functions pp ~out ~flush ~newline ~spaces)
|
||||
Format.pp_set_formatter_out_functions pp out_functions)
|
||||
pps save
|
||||
in
|
||||
(* Output functions. *)
|
||||
let out str ofs len = () in
|
||||
let flush = ignore in
|
||||
let newline = ignore in
|
||||
let spaces = ignore in
|
||||
let out_functions = {
|
||||
Format.out_string = (fun _ _ _ -> ()); out_flush = ignore;
|
||||
out_newline = ignore; out_spaces = ignore;
|
||||
} in
|
||||
(* Replace formatter functions. *)
|
||||
List.iter (fun pp -> Format.pp_set_all_formatter_output_functions pp ~out ~flush ~newline ~spaces) pps;
|
||||
List.iter (fun pp -> Format.pp_set_formatter_out_functions pp out_functions) pps;
|
||||
try
|
||||
let x = f () in
|
||||
restore ();
|
||||
|
|
@ -189,11 +192,7 @@ type 'a result =
|
|||
|
||||
exception Need_more
|
||||
|
||||
#if ocaml_version <= (3, 12, 1)
|
||||
let input_name = ""
|
||||
#else
|
||||
let input_name = "//toplevel//"
|
||||
#endif
|
||||
|
||||
let lexbuf_of_string eof str =
|
||||
let pos = ref 0 in
|
||||
|
|
@ -244,15 +243,13 @@ let parse_default parse str eos_is_error =
|
|||
| Syntaxerr.Other loc ->
|
||||
Error ([mkloc loc],
|
||||
"Syntax error")
|
||||
#if ocaml_version >= (4, 01, 0)
|
||||
| Syntaxerr.Expecting (loc, nonterm) ->
|
||||
Error ([mkloc loc],
|
||||
Printf.sprintf "Syntax error: %s expected." nonterm)
|
||||
| Syntaxerr.Variable_in_scope (loc, var) ->
|
||||
Error ([mkloc loc],
|
||||
Printf.sprintf "In this scoped type, variable '%s is reserved for the local type %s." var var)
|
||||
#endif
|
||||
#if ocaml_version >= (4, 2, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Syntaxerr.Not_expecting (loc, nonterm) ->
|
||||
Error ([mkloc loc],
|
||||
Printf.sprintf "Syntax error: %s not expected" nonterm)
|
||||
|
|
@ -286,14 +283,10 @@ let rec last head tail =
|
|||
| head :: tail ->
|
||||
last head tail
|
||||
|
||||
#if ocaml_version >= (4, 0, 0)
|
||||
let with_loc loc str = {
|
||||
Location.txt = str;
|
||||
Location.loc = loc;
|
||||
}
|
||||
#else
|
||||
let with_loc loc str = str
|
||||
#endif
|
||||
|
||||
(* Check that the given phrase can be evaluated without typing/compile
|
||||
errors. *)
|
||||
|
|
@ -316,7 +309,7 @@ let check_phrase phrase =
|
|||
(* Construct "let _ () = let module _ = struct <items> end in ()" in order to test
|
||||
the typing and compilation of [items] without evaluating them. *)
|
||||
let unit = with_loc loc (Longident.Lident "()") in
|
||||
#if ocaml_version < (4, 2, 0)
|
||||
#if OCAML_VERSION < 040200
|
||||
let structure = {
|
||||
pmod_loc = loc;
|
||||
pmod_desc = Pmod_structure (item :: items);
|
||||
|
|
@ -359,9 +352,7 @@ let check_phrase phrase =
|
|||
try
|
||||
let _ =
|
||||
discard_formatters [Format.err_formatter] (fun () ->
|
||||
#if ocaml_version > (4, 00, 1)
|
||||
Env.reset_cache_toplevel ();
|
||||
#endif
|
||||
Toploop.execute_phrase false null check_phrase)
|
||||
in
|
||||
(* The phrase is safe. *)
|
||||
|
|
@ -595,10 +586,10 @@ For a complete description of utop, look at the utop(1) manual page."));
|
|||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let print_error msg =
|
||||
lwt term = Lazy.force LTerm.stdout in
|
||||
lwt () = LTerm.set_style term !UTop_private.error_style in
|
||||
lwt () = Lwt_io.print msg in
|
||||
lwt () = LTerm.set_style term LTerm_style.none in
|
||||
Lazy.force LTerm.stdout >>= fun term ->
|
||||
LTerm.set_style term !UTop_private.error_style >>= fun () ->
|
||||
Lwt_io.print msg >>= fun () ->
|
||||
LTerm.set_style term LTerm_style.none >>= fun () ->
|
||||
LTerm.flush term
|
||||
|
||||
let handle_findlib_error = function
|
||||
|
|
@ -611,6 +602,14 @@ let handle_findlib_error = function
|
|||
| exn ->
|
||||
raise exn
|
||||
|
||||
let check_for_camlp4_support () =
|
||||
try
|
||||
ignore (Fl_package_base.query "utop.camlp4");
|
||||
true
|
||||
with Fl_package_base.No_such_package("utop.camlp4", "") ->
|
||||
Lwt_main.run (print_error "utop was built without camlp4 support.\n");
|
||||
false
|
||||
|
||||
let set_syntax syntax =
|
||||
match get_syntax (), syntax with
|
||||
| Normal, Normal
|
||||
|
|
@ -619,25 +618,21 @@ let set_syntax syntax =
|
|||
()
|
||||
| (Camlp4o | Camlp4r), _ ->
|
||||
Lwt_main.run (print_error "Camlp4 already loaded, you cannot change the syntax now.\n")
|
||||
| Normal, Camlp4o -> begin
|
||||
set_syntax Camlp4o;
|
||||
set_phrase_terminator ";;";
|
||||
try
|
||||
| Normal, Camlp4o ->
|
||||
if check_for_camlp4_support () then begin
|
||||
Topfind.syntax "camlp4o";
|
||||
Topfind.load_deeply ["utop.camlp4"]
|
||||
with exn ->
|
||||
handle_findlib_error exn
|
||||
end
|
||||
| Normal, Camlp4r -> begin
|
||||
set_syntax Camlp4r;
|
||||
set_phrase_terminator ";";
|
||||
add_keyword "value";
|
||||
try
|
||||
Topfind.load_deeply ["utop.camlp4"];
|
||||
set_syntax Camlp4o;
|
||||
set_phrase_terminator ";;"
|
||||
end
|
||||
| Normal, Camlp4r ->
|
||||
if check_for_camlp4_support () then begin
|
||||
Topfind.syntax "camlp4r";
|
||||
Topfind.load_deeply ["utop.camlp4"]
|
||||
with exn ->
|
||||
handle_findlib_error exn
|
||||
end
|
||||
Topfind.load_deeply ["utop.camlp4"];
|
||||
set_syntax Camlp4r;
|
||||
set_phrase_terminator ";";
|
||||
add_keyword "value"
|
||||
end
|
||||
|
||||
let () =
|
||||
Hashtbl.add
|
||||
|
|
@ -658,13 +653,11 @@ let () =
|
|||
|
||||
let topfind_log, set_topfind_log = S.create ~eq:(fun _ _ -> false) []
|
||||
|
||||
#if findlib_version >= (1, 4)
|
||||
let () =
|
||||
let real_log = !Topfind.log in
|
||||
Topfind.log := fun str ->
|
||||
set_topfind_log (str :: S.value topfind_log);
|
||||
if S.value topfind_verbose then real_log str
|
||||
#endif
|
||||
|
||||
let () =
|
||||
Hashtbl.add
|
||||
|
|
@ -302,7 +302,7 @@ let list_directories dir =
|
|||
String_set.empty
|
||||
(try Sys.readdir (if dir = "" then Filename.current_dir_name else dir) with Sys_error _ -> [||]))
|
||||
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
let path () =
|
||||
let path_separator =
|
||||
match Sys.os_type with
|
||||
|
|
@ -394,12 +394,9 @@ let visible_modules () =
|
|||
acc)
|
||||
String_set.empty !Config.load_path)
|
||||
|
||||
#if ocaml_version >= (4, 2, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
let field_name { ld_id = id } = Ident.name id
|
||||
let constructor_name { cd_id = id } = Ident.name id
|
||||
#elif ocaml_version >= (4, 0, 0)
|
||||
let field_name (id, _, _) = Ident.name id
|
||||
let constructor_name (id, _, _) = Ident.name id
|
||||
#else
|
||||
let field_name (name, _, _) = name
|
||||
let constructor_name (name, _) = name
|
||||
|
|
@ -413,7 +410,7 @@ let add_fields_of_type decl acc =
|
|||
List.fold_left (fun acc field -> add (field_name field) acc) acc fields
|
||||
| Type_abstract ->
|
||||
acc
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Type_open ->
|
||||
acc
|
||||
#endif
|
||||
|
|
@ -426,19 +423,17 @@ let add_names_of_type decl acc =
|
|||
List.fold_left (fun acc field -> add (field_name field) acc) acc fields
|
||||
| Type_abstract ->
|
||||
acc
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Type_open ->
|
||||
acc
|
||||
#endif
|
||||
|
||||
#if ocaml_version >= (4, 0, 0)
|
||||
|
||||
let rec names_of_module_type = function
|
||||
| Mty_signature decls ->
|
||||
List.fold_left
|
||||
(fun acc decl -> match decl with
|
||||
| Sig_value (id, _)
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Sig_typext (id, _, _)
|
||||
#else
|
||||
| Sig_exception (id, _)
|
||||
|
|
@ -453,7 +448,7 @@ let rec names_of_module_type = function
|
|||
String_set.empty decls
|
||||
| Mty_ident path -> begin
|
||||
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
|
||||
#if ocaml_version < (4, 2, 0)
|
||||
#if OCAML_VERSION < 040200
|
||||
| Some Modtype_abstract -> String_set.empty
|
||||
| Some Modtype_manifest module_type -> names_of_module_type module_type
|
||||
#else
|
||||
|
|
@ -462,7 +457,7 @@ let rec names_of_module_type = function
|
|||
#endif
|
||||
| None -> String_set.empty
|
||||
end
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Mty_alias path -> begin
|
||||
match lookup_env Env.find_module path !Toploop.toplevel_env with
|
||||
| None -> String_set.empty
|
||||
|
|
@ -477,7 +472,7 @@ let rec fields_of_module_type = function
|
|||
List.fold_left
|
||||
(fun acc decl -> match decl with
|
||||
| Sig_value (id, _)
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Sig_typext (id, _, _)
|
||||
#else
|
||||
| Sig_exception (id, _)
|
||||
|
|
@ -492,7 +487,7 @@ let rec fields_of_module_type = function
|
|||
String_set.empty decls
|
||||
| Mty_ident path -> begin
|
||||
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
|
||||
#if ocaml_version < (4, 2, 0)
|
||||
#if OCAML_VERSION < 040200
|
||||
| Some Modtype_abstract -> String_set.empty
|
||||
| Some Modtype_manifest module_type -> fields_of_module_type module_type
|
||||
#else
|
||||
|
|
@ -501,7 +496,7 @@ let rec fields_of_module_type = function
|
|||
#endif
|
||||
| None -> String_set.empty
|
||||
end
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Mty_alias path -> begin
|
||||
match lookup_env Env.find_module path !Toploop.toplevel_env with
|
||||
| None -> String_set.empty
|
||||
|
|
@ -511,57 +506,7 @@ let rec fields_of_module_type = function
|
|||
| _ ->
|
||||
String_set.empty
|
||||
|
||||
#else
|
||||
|
||||
let rec names_of_module_type = function
|
||||
| Tmty_signature decls ->
|
||||
List.fold_left
|
||||
(fun acc decl -> match decl with
|
||||
| Tsig_value(id, _)
|
||||
| Tsig_exception(id, _)
|
||||
| Tsig_module(id, _, _)
|
||||
| Tsig_modtype(id, _)
|
||||
| Tsig_class(id, _, _)
|
||||
| Tsig_cltype(id, _, _) ->
|
||||
add (Ident.name id) acc
|
||||
| Tsig_type(id, decl, _) ->
|
||||
add_names_of_type decl (add (Ident.name id) acc))
|
||||
String_set.empty decls
|
||||
| Tmty_ident path -> begin
|
||||
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
|
||||
| Some Tmodtype_abstract -> String_set.empty
|
||||
| Some Tmodtype_manifest module_type -> names_of_module_type module_type
|
||||
| None -> String_set.empty
|
||||
end
|
||||
| _ ->
|
||||
String_set.empty
|
||||
|
||||
let rec fields_of_module_type = function
|
||||
| Tmty_signature decls ->
|
||||
List.fold_left
|
||||
(fun acc decl -> match decl with
|
||||
| Tsig_value(id, _)
|
||||
| Tsig_exception(id, _)
|
||||
| Tsig_module(id, _, _)
|
||||
| Tsig_modtype(id, _)
|
||||
| Tsig_class(id, _, _)
|
||||
| Tsig_cltype(id, _, _) ->
|
||||
acc
|
||||
| Tsig_type(id, decl, _) ->
|
||||
add_fields_of_type decl acc)
|
||||
String_set.empty decls
|
||||
| Tmty_ident path -> begin
|
||||
match lookup_env Env.find_modtype path !Toploop.toplevel_env with
|
||||
| Some Tmodtype_abstract -> String_set.empty
|
||||
| Some Tmodtype_manifest module_type -> fields_of_module_type module_type
|
||||
| None -> String_set.empty
|
||||
end
|
||||
| _ ->
|
||||
String_set.empty
|
||||
|
||||
#endif
|
||||
|
||||
#if ocaml_version < (4, 2, 0)
|
||||
#if OCAML_VERSION < 040200
|
||||
let lookup_module = Env.lookup_module
|
||||
let find_module = Env.find_module
|
||||
#else
|
||||
|
|
@ -606,7 +551,7 @@ let list_global_names () =
|
|||
loop (add (Ident.name id) acc) summary
|
||||
| Env.Env_type(summary, id, decl) ->
|
||||
loop (add_names_of_type decl (add (Ident.name id) acc)) summary
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Env.Env_extension(summary, id, _) ->
|
||||
#else
|
||||
| Env.Env_exception(summary, id, _) ->
|
||||
|
|
@ -620,7 +565,7 @@ let list_global_names () =
|
|||
loop (add (Ident.name id) acc) summary
|
||||
| Env.Env_cltype(summary, id, _) ->
|
||||
loop (add (Ident.name id) acc) summary
|
||||
#if ocaml_version >= (4, 2, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Env.Env_functor_arg(summary, id) ->
|
||||
loop (add (Ident.name id) acc) summary
|
||||
#endif
|
||||
|
|
@ -671,7 +616,7 @@ let list_global_fields () =
|
|||
loop (add (Ident.name id) acc) summary
|
||||
| Env.Env_type(summary, id, decl) ->
|
||||
loop (add_fields_of_type decl (add (Ident.name id) acc)) summary
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Env.Env_extension(summary, id, _) ->
|
||||
#else
|
||||
| Env.Env_exception(summary, id, _) ->
|
||||
|
|
@ -679,7 +624,7 @@ let list_global_fields () =
|
|||
loop (add (Ident.name id) acc) summary
|
||||
| Env.Env_module(summary, id, _) ->
|
||||
loop (add (Ident.name id) acc) summary
|
||||
#if ocaml_version >= (4, 2, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Env.Env_functor_arg(summary, id) ->
|
||||
loop (add (Ident.name id) acc) summary
|
||||
#endif
|
||||
|
|
@ -941,7 +886,7 @@ let complete ~syntax ~phrase_terminator ~input =
|
|||
(loc.idx2 - Zed_utf8.length name,
|
||||
List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result)
|
||||
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
(* Completion on #ppx. *)
|
||||
| [(Symbol "#", _); (Lident ("ppx"), _); (String false, loc)] ->
|
||||
let file = String.sub input (loc.ofs1 + 1) (String.length input - loc.ofs1 - 1) in
|
||||
|
|
@ -8,7 +8,6 @@
|
|||
*)
|
||||
|
||||
open CamomileLibraryDyn.Camomile
|
||||
open Lwt
|
||||
open Lwt_react
|
||||
open LTerm_text
|
||||
open LTerm_geom
|
||||
|
|
@ -16,6 +15,8 @@ open UTop_token
|
|||
open UTop_styles
|
||||
open UTop_private
|
||||
|
||||
let return, (>>=) = Lwt.return, Lwt.(>>=)
|
||||
|
||||
module String_set = Set.Make(String)
|
||||
|
||||
exception Term of int
|
||||
|
|
@ -29,10 +30,14 @@ let save_history () =
|
|||
| None ->
|
||||
return ()
|
||||
| Some fn ->
|
||||
try_lwt
|
||||
LTerm_history.save UTop.history ?max_size:!UTop.history_file_max_size ?max_entries:!UTop.history_file_max_entries fn
|
||||
with Unix.Unix_error (error, func, arg) ->
|
||||
Lwt_log.error_f "cannot save history to %S: %s: %s" fn func (Unix.error_message error)
|
||||
Lwt.catch
|
||||
(fun () -> LTerm_history.save UTop.history
|
||||
?max_size:!UTop.history_file_max_size
|
||||
?max_entries:!UTop.history_file_max_entries fn)
|
||||
(function
|
||||
| Unix.Unix_error (error, func, arg) ->
|
||||
Lwt_log.error_f "cannot save history to %S: %s: %s" fn func (Unix.error_message error)
|
||||
| exn -> Lwt.fail exn)
|
||||
|
||||
let init_history () =
|
||||
(* Save history on exit. *)
|
||||
|
|
@ -42,10 +47,13 @@ let init_history () =
|
|||
| None ->
|
||||
return ()
|
||||
| Some fn ->
|
||||
try_lwt
|
||||
LTerm_history.load UTop.history fn
|
||||
with Unix.Unix_error (error, func, arg) ->
|
||||
Lwt_log.error_f "cannot load history from %S: %s: %s" fn func (Unix.error_message error)
|
||||
Lwt.catch
|
||||
(fun () -> LTerm_history.load UTop.history fn)
|
||||
(function
|
||||
| Unix.Unix_error (error, func, arg) ->
|
||||
Lwt_log.error_f "cannot load history from %S: %s: %s"
|
||||
fn func (Unix.error_message error)
|
||||
| exn -> Lwt.fail exn)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| offset --> index |
|
||||
|
|
@ -89,7 +97,7 @@ let parse_and_check input eos_is_error =
|
|||
let buf = Buffer.create 32 in
|
||||
let preprocess input =
|
||||
match input with
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| UTop.Value (Parsetree.Ptop_def pstr) ->
|
||||
begin try
|
||||
let pstr = Pparse.apply_rewriters ~tool_name:"ocaml"
|
||||
|
|
@ -261,13 +269,13 @@ let rec map_items unwrap wrap items =
|
|||
| Outcometree.Osig_class (_, name, _, _, rs)
|
||||
| Outcometree.Osig_class_type (_, name, _, _, rs)
|
||||
| Outcometree.Osig_module (name, _, rs)
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Outcometree.Osig_type ({ Outcometree.otype_name = name }, rs) ->
|
||||
#else
|
||||
| Outcometree.Osig_type ((name, _, _, _, _), rs) ->
|
||||
#endif
|
||||
(name, rs)
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Outcometree.Osig_typext ({ Outcometree.oext_name = name}, _)
|
||||
#else
|
||||
| Outcometree.Osig_exception (name, _)
|
||||
|
|
@ -308,7 +316,7 @@ let rec map_items unwrap wrap items =
|
|||
wrap (Outcometree.Osig_type (oty, Outcometree.Orec_first)) extra :: items'
|
||||
else
|
||||
items
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
| Outcometree.Osig_typext _
|
||||
#else
|
||||
| Outcometree.Osig_exception _
|
||||
|
|
@ -347,14 +355,10 @@ let () =
|
|||
| Toplevel expression rewriting |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
#if ocaml_version >= (4, 0, 0)
|
||||
let with_loc loc str = {
|
||||
Location.txt = str;
|
||||
Location.loc = loc;
|
||||
}
|
||||
#else
|
||||
let with_loc loc str = str
|
||||
#endif
|
||||
|
||||
(* A rule for rewriting a toplevel expression. *)
|
||||
type rewrite_rule = {
|
||||
|
|
@ -375,7 +379,7 @@ let longident_async_thread_safe_block_on_async_exn =
|
|||
Longident.parse "Async.Std.Thread_safe.block_on_async_exn"
|
||||
let longident_unit = Longident.Lident "()"
|
||||
|
||||
#if ocaml_version < (4, 2, 0)
|
||||
#if OCAML_VERSION < 040200
|
||||
(* Wrap <expr> into: fun () -> <expr> *)
|
||||
let wrap_unit loc e =
|
||||
let i = with_loc loc longident_unit in
|
||||
|
|
@ -394,7 +398,7 @@ let () =
|
|||
Hashtbl.add rewrite_rules (Longident.Ldot (Longident.Lident "Lwt", "t")) {
|
||||
required_values = [longident_lwt_main_run];
|
||||
rewrite = (fun loc e ->
|
||||
#if ocaml_version < (4, 2, 0)
|
||||
#if OCAML_VERSION < 040200
|
||||
{ Parsetree.pexp_desc =
|
||||
Parsetree.Pexp_apply
|
||||
({ Parsetree.pexp_desc = Parsetree.Pexp_ident (with_loc loc longident_lwt_main_run);
|
||||
|
|
@ -416,7 +420,7 @@ let () =
|
|||
let rule = {
|
||||
required_values = [longident_async_thread_safe_block_on_async_exn];
|
||||
rewrite = (fun loc e ->
|
||||
#if ocaml_version < (4, 2, 0)
|
||||
#if OCAML_VERSION < 040200
|
||||
{ Parsetree.pexp_desc =
|
||||
Parsetree.Pexp_apply
|
||||
({ Parsetree.pexp_desc = Parsetree.Pexp_ident
|
||||
|
|
@ -490,17 +494,9 @@ let is_persistent_in_env longident =
|
|||
with Not_found ->
|
||||
false
|
||||
|
||||
#if ocaml_version >= (4, 0, 0)
|
||||
let str_items_of_typed_structure tstr = tstr.Typedtree.str_items
|
||||
let str_desc_of_typed_str_item tstr = tstr.Typedtree.str_desc
|
||||
#else
|
||||
let str_items_of_typed_structure tstr = tstr
|
||||
let str_desc_of_typed_str_item tstr = tstr
|
||||
#endif
|
||||
|
||||
#if ocaml_version < (4, 2, 0)
|
||||
#if OCAML_VERSION < 040200
|
||||
let rewrite_str_item pstr_item tstr_item =
|
||||
match pstr_item, str_desc_of_typed_str_item tstr_item with
|
||||
match pstr_item, tstr_item.Typedtree.str_desc with
|
||||
| ({ Parsetree.pstr_desc = Parsetree.Pstr_eval e;
|
||||
Parsetree.pstr_loc = loc },
|
||||
Typedtree.Tstr_eval { Typedtree.exp_type = typ }) -> begin
|
||||
|
|
@ -518,7 +514,7 @@ let rewrite_str_item pstr_item tstr_item =
|
|||
pstr_item
|
||||
#else
|
||||
let rewrite_str_item pstr_item tstr_item =
|
||||
match pstr_item, str_desc_of_typed_str_item tstr_item with
|
||||
match pstr_item, tstr_item.Typedtree.str_desc with
|
||||
| ({ Parsetree.pstr_desc = Parsetree.Pstr_eval (e, _);
|
||||
Parsetree.pstr_loc = loc },
|
||||
Typedtree.Tstr_eval ({ Typedtree.exp_type = typ }, _)) -> begin
|
||||
|
|
@ -541,8 +537,7 @@ let rewrite phrase =
|
|||
| Parsetree.Ptop_def pstr ->
|
||||
if (UTop.get_auto_run_lwt () || UTop.get_auto_run_async ()) && List.exists is_eval pstr then
|
||||
let tstr, _, _ = Typemod.type_structure !Toploop.toplevel_env pstr Location.none in
|
||||
let tstr = str_items_of_typed_structure tstr in
|
||||
Parsetree.Ptop_def (List.map2 rewrite_str_item pstr tstr)
|
||||
Parsetree.Ptop_def (List.map2 rewrite_str_item pstr tstr.Typedtree.str_items)
|
||||
else
|
||||
Parsetree.Ptop_def pstr
|
||||
| Parsetree.Ptop_dir _ ->
|
||||
|
|
@ -553,20 +548,22 @@ let rewrite phrase =
|
|||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let rec read_phrase term =
|
||||
try_lwt
|
||||
(new read_phrase ~term)#run
|
||||
with Sys.Break ->
|
||||
lwt () = LTerm.fprintl term "Interrupted." in
|
||||
read_phrase term
|
||||
Lwt.catch
|
||||
(fun () -> (new read_phrase ~term)#run)
|
||||
(function
|
||||
| Sys.Break ->
|
||||
LTerm.fprintl term "Interrupted." >>= fun () ->
|
||||
read_phrase term
|
||||
| exn -> Lwt.fail exn)
|
||||
|
||||
let update_margin pp cols =
|
||||
if Format.pp_get_margin pp () <> cols then
|
||||
Format.pp_set_margin pp cols
|
||||
|
||||
let print_error term msg =
|
||||
lwt () = LTerm.set_style term styles.style_error in
|
||||
lwt () = Lwt_io.print msg in
|
||||
lwt () = LTerm.set_style term LTerm_style.none in
|
||||
LTerm.set_style term styles.style_error >>= fun () ->
|
||||
Lwt_io.print msg >>= fun () ->
|
||||
LTerm.set_style term LTerm_style.none >>= fun () ->
|
||||
LTerm.flush term
|
||||
|
||||
let rec loop term =
|
||||
|
|
@ -582,18 +579,18 @@ let rec loop term =
|
|||
(* Read interactively user input. *)
|
||||
let phrase_opt =
|
||||
Lwt_main.run (
|
||||
try_lwt
|
||||
lwt result, warnings = read_phrase term in
|
||||
(* Print warnings before errors. *)
|
||||
lwt () = Lwt_io.print warnings in
|
||||
match result with
|
||||
| UTop.Value phrase ->
|
||||
return (Some phrase)
|
||||
| UTop.Error (_, msg) ->
|
||||
lwt () = print_error term msg in
|
||||
return None
|
||||
finally
|
||||
LTerm.flush term
|
||||
Lwt.finalize
|
||||
(fun () ->
|
||||
read_phrase term >>= fun (result, warnings) ->
|
||||
(* Print warnings before errors. *)
|
||||
Lwt_io.print warnings >>= fun () ->
|
||||
match result with
|
||||
| UTop.Value phrase ->
|
||||
return (Some phrase)
|
||||
| UTop.Error (_, msg) ->
|
||||
print_error term msg >>= fun () ->
|
||||
return None)
|
||||
(fun () -> LTerm.flush term)
|
||||
)
|
||||
in
|
||||
|
||||
|
|
@ -610,13 +607,9 @@ let rec loop term =
|
|||
let pp = Format.formatter_of_buffer buffer in
|
||||
Format.pp_set_margin pp (LTerm.size term).cols;
|
||||
(try
|
||||
#if ocaml_version > (4, 00, 1)
|
||||
Env.reset_cache_toplevel ();
|
||||
#endif
|
||||
if !Clflags.dump_parsetree then Printast.top_phrase pp phrase;
|
||||
#if ocaml_version > (4, 00, 1)
|
||||
if !Clflags.dump_source then Pprintast.top_phrase pp phrase;
|
||||
#endif
|
||||
ignore (Toploop.execute_phrase true pp phrase);
|
||||
(* Flush everything. *)
|
||||
Format.pp_print_flush Format.std_formatter ();
|
||||
|
|
@ -677,10 +670,10 @@ let welcome term =
|
|||
LTerm_draw.draw_styled ctx 1 ((size.cols - String.length message) / 2) (eval [B_fg LTerm_style.yellow; S message]);
|
||||
|
||||
(* Render to the screen. *)
|
||||
lwt () = LTerm.print_box term matrix in
|
||||
LTerm.print_box term matrix >>= fun () ->
|
||||
|
||||
(* Move to after the box. *)
|
||||
lwt () = LTerm.fprint term "\n" in
|
||||
LTerm.fprint term "\n" >>= fun () ->
|
||||
|
||||
LTerm.flush term
|
||||
|
||||
|
|
@ -695,7 +688,7 @@ let read_input_classic prompt buffer len =
|
|||
else
|
||||
Lwt_io.read_char_opt Lwt_io.stdin >>= function
|
||||
| Some c ->
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
Bytes.set buffer i c;
|
||||
#else
|
||||
buffer.[i] <- c;
|
||||
|
|
@ -707,7 +700,7 @@ let read_input_classic prompt buffer len =
|
|||
| None ->
|
||||
return (i, true)
|
||||
in
|
||||
Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >> loop 0)
|
||||
Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >>= fun () -> loop 0)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Emacs mode |
|
||||
|
|
@ -825,7 +818,7 @@ module Emacs(M : sig end) = struct
|
|||
(* Rewrite toplevel expressions. *)
|
||||
let phrase = rewrite phrase in
|
||||
try
|
||||
#if ocaml_version > (4, 00, 1)
|
||||
#if OCAML_VERSION > 040001
|
||||
Env.reset_cache_toplevel ();
|
||||
#endif
|
||||
ignore (Toploop.execute_phrase true Format.std_formatter phrase);
|
||||
|
|
@ -1012,8 +1005,6 @@ end
|
|||
| Extra macros |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
#if ocaml_version > (4, 00, 1)
|
||||
|
||||
let typeof sid =
|
||||
let id = Longident.parse sid in
|
||||
let env = !Toploop.toplevel_env in
|
||||
|
|
@ -1041,7 +1032,7 @@ let typeof sid =
|
|||
Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not)
|
||||
with Not_found ->
|
||||
try
|
||||
#if ocaml_version < (4, 02, 0)
|
||||
#if OCAML_VERSION < 040200
|
||||
let (path, mod_typ) = Env.lookup_module id env in
|
||||
#else
|
||||
let path = Env.lookup_module id env ~load:true in
|
||||
|
|
@ -1058,7 +1049,7 @@ let typeof sid =
|
|||
try
|
||||
let cstr_desc = Env.lookup_constructor id env in
|
||||
match cstr_desc.Types.cstr_tag with
|
||||
#if ocaml_version < (4, 02, 0)
|
||||
#if OCAML_VERSION < 040200
|
||||
| Types.Cstr_exception (_path, loc) ->
|
||||
let path, exn_decl = Typedecl.transl_exn_rebind env loc id in
|
||||
let id = Ident.create (Path.name path) in
|
||||
|
|
@ -1083,13 +1074,10 @@ let typeof sid =
|
|||
let str = Buffer.contents buf in
|
||||
Lwt_main.run (Lazy.force LTerm.stdout >>= fun term -> render_out_phrase term str)
|
||||
|
||||
|
||||
let () =
|
||||
Hashtbl.add Toploop.directive_table "typeof"
|
||||
(Toploop.Directive_string typeof)
|
||||
|
||||
#endif
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Entry point |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
|
@ -1149,9 +1137,7 @@ let print_version_num () =
|
|||
let autoload = ref true
|
||||
|
||||
let args = Arg.align [
|
||||
#if ocaml_version >= (3, 13, 0)
|
||||
"-absname", Arg.Set Location.absname, " Show absolute filenames in error message";
|
||||
#endif
|
||||
"-I", Arg.String (fun dir -> Clflags.include_dirs := Misc.expand_directory Config.standard_library dir :: !Clflags.include_dirs), "<dir> Add <dir> to the list of include directories";
|
||||
"-init", Arg.String (fun s -> Clflags.init_file := Some s), "<file> Load <file> instead of default init file";
|
||||
"-labels", Arg.Clear Clflags.classic, " Use commuting label mode";
|
||||
|
|
@ -1159,17 +1145,15 @@ let args = Arg.align [
|
|||
"-noassert", Arg.Set Clflags.noassert, " Do not compile assertion checks";
|
||||
"-nolabels", Arg.Set Clflags.classic, " Ignore non-optional labels in types";
|
||||
"-nostdlib", Arg.Set Clflags.no_std_include, " Do not add default directory to the list of include directories";
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
"-ppx", Arg.String (fun ppx -> Clflags.all_ppx := ppx :: !Clflags.all_ppx), "<command> Pipe abstract syntax trees through preprocessor <command>";
|
||||
#endif
|
||||
"-principal", Arg.Set Clflags.principal, " Check principality of type inference";
|
||||
#if ocaml_version >= (4, 02, 0)
|
||||
#if OCAML_VERSION >= 040200
|
||||
"-safe-string", Arg.Clear Clflags.unsafe_string, " Make strings immutable";
|
||||
#endif
|
||||
#if ocaml_version >= (4, 01, 0)
|
||||
"-short-paths", Arg.Clear Clflags.real_paths, " Shorten paths in types (the default)";
|
||||
"-no-short-paths", Arg.Set Clflags.real_paths, " Do not shorten paths in types";
|
||||
#endif
|
||||
"-rectypes", Arg.Set Clflags.recursive_types, " Allow arbitrary recursive types";
|
||||
"-stdin", Arg.Unit (fun () -> run_script ""), " Read script from standard input";
|
||||
"-strict-sequence", Arg.Set Clflags.strict_sequence, " Left-hand part of a sequence must have type unit";
|
||||
|
|
@ -1203,14 +1187,10 @@ let args = Arg.align [
|
|||
"-require", Arg.String (fun s -> preload := `Packages (UTop.split_words s) :: !preload),
|
||||
"<package> Load this package";
|
||||
"-dparsetree", Arg.Set Clflags.dump_parsetree, " Dump OCaml AST after rewriting";
|
||||
#if ocaml_version > (4, 00, 1)
|
||||
"-dsource", Arg.Set Clflags.dump_source, " Dump OCaml source after rewriting";
|
||||
#endif
|
||||
]
|
||||
|
||||
#if ocaml_version >= (4, 01, 0)
|
||||
let () = Clflags.real_paths := false
|
||||
#endif
|
||||
|
||||
let app_name = Filename.basename Sys.executable_name
|
||||
let usage = Printf.sprintf "Usage: %s <options> <object-files> [script-file [arguments]]\noptions are:" app_name
|
||||
|
|
@ -1272,13 +1252,14 @@ let common_init () =
|
|||
catch Sys.sigterm
|
||||
|
||||
let load_inputrc () =
|
||||
try_lwt
|
||||
LTerm_inputrc.load ()
|
||||
with
|
||||
| Unix.Unix_error (error, func, arg) ->
|
||||
Lwt_log.error_f "cannot load key bindings from %S: %s: %s" LTerm_inputrc.default func (Unix.error_message error)
|
||||
| LTerm_inputrc.Parse_error (fname, line, msg) ->
|
||||
Lwt_log.error_f "error in key bindings file %S, line %d: %s" fname line msg
|
||||
Lwt.catch
|
||||
LTerm_inputrc.load
|
||||
(function
|
||||
| Unix.Unix_error (error, func, arg) ->
|
||||
Lwt_log.error_f "cannot load key bindings from %S: %s: %s" LTerm_inputrc.default func (Unix.error_message error)
|
||||
| LTerm_inputrc.Parse_error (fname, line, msg) ->
|
||||
Lwt_log.error_f "error in key bindings file %S, line %d: %s" fname line msg
|
||||
| exn -> Lwt.fail exn)
|
||||
|
||||
let main_aux () =
|
||||
Arg.parse args file_argument usage;
|
||||
|
|
@ -1296,7 +1277,7 @@ let main_aux () =
|
|||
(* Set the initial size. *)
|
||||
UTop_private.set_size (S.const (LTerm.size term));
|
||||
(* Load user data. *)
|
||||
Lwt_main.run (join [UTop_styles.load (); load_inputrc ()]);
|
||||
Lwt_main.run (Lwt.join [UTop_styles.load (); load_inputrc ()]);
|
||||
(* Display a welcome message. *)
|
||||
Lwt_main.run (welcome term);
|
||||
(* Common initialization. *)
|
||||
|
|
@ -7,9 +7,10 @@
|
|||
* This file is a part of utop.
|
||||
*)
|
||||
|
||||
open Lwt
|
||||
open UTop_token
|
||||
|
||||
let return, (>>=) = Lwt.return, Lwt.(>>=)
|
||||
|
||||
module String_set = Set.Make (String)
|
||||
|
||||
type styles = {
|
||||
|
|
@ -56,41 +57,43 @@ let styles = {
|
|||
|
||||
let load () =
|
||||
let fn = Filename.concat LTerm_resources.home ".utoprc" in
|
||||
try_lwt
|
||||
lwt res = LTerm_resources.load fn in
|
||||
styles.style_keyword <- LTerm_resources.get_style "keyword" res;
|
||||
styles.style_symbol <- LTerm_resources.get_style "symbol" res;
|
||||
styles.style_ident <- LTerm_resources.get_style "identifier" res;
|
||||
styles.style_module <- LTerm_resources.get_style "module" res;
|
||||
styles.style_constant <- LTerm_resources.get_style "constant" res;
|
||||
styles.style_char <- LTerm_resources.get_style "char" res;
|
||||
styles.style_string <- LTerm_resources.get_style "string" res;
|
||||
styles.style_quotation <- LTerm_resources.get_style "quotation" res;
|
||||
styles.style_comment <- LTerm_resources.get_style "comment" res;
|
||||
styles.style_doc <- LTerm_resources.get_style "doc" res;
|
||||
styles.style_blanks <- LTerm_resources.get_style "blanks" res;
|
||||
styles.style_error <- LTerm_resources.get_style "error" res;
|
||||
styles.style_directive <- LTerm_resources.get_style "directive" res;
|
||||
styles.style_paren <- LTerm_resources.get_style "parenthesis" res;
|
||||
styles.style_font <- (match LTerm_resources.get "font" res with
|
||||
| "" -> None
|
||||
| str -> Some str);
|
||||
styles.style_foreground <- LTerm_resources.get_color "foreground" res;
|
||||
styles.style_background <- LTerm_resources.get_color "background" res;
|
||||
styles.style_cursor <- LTerm_resources.get_color "cursor" res;
|
||||
(match String.lowercase (LTerm_resources.get "profile" res) with
|
||||
| "light" -> UTop.set_profile UTop.Light
|
||||
| "dark" -> UTop.set_profile UTop.Dark
|
||||
| "" -> ()
|
||||
| str -> raise (LTerm_resources.Error (Printf.sprintf "invalid profile %S" str)));
|
||||
UTop_private.error_style := styles.style_error;
|
||||
UTop_private.autoload := LTerm_resources.get_bool "autoload" res <> Some false;
|
||||
return ()
|
||||
with
|
||||
Lwt.catch
|
||||
(fun () ->
|
||||
LTerm_resources.load fn >>= fun res ->
|
||||
styles.style_keyword <- LTerm_resources.get_style "keyword" res;
|
||||
styles.style_symbol <- LTerm_resources.get_style "symbol" res;
|
||||
styles.style_ident <- LTerm_resources.get_style "identifier" res;
|
||||
styles.style_module <- LTerm_resources.get_style "module" res;
|
||||
styles.style_constant <- LTerm_resources.get_style "constant" res;
|
||||
styles.style_char <- LTerm_resources.get_style "char" res;
|
||||
styles.style_string <- LTerm_resources.get_style "string" res;
|
||||
styles.style_quotation <- LTerm_resources.get_style "quotation" res;
|
||||
styles.style_comment <- LTerm_resources.get_style "comment" res;
|
||||
styles.style_doc <- LTerm_resources.get_style "doc" res;
|
||||
styles.style_blanks <- LTerm_resources.get_style "blanks" res;
|
||||
styles.style_error <- LTerm_resources.get_style "error" res;
|
||||
styles.style_directive <- LTerm_resources.get_style "directive" res;
|
||||
styles.style_paren <- LTerm_resources.get_style "parenthesis" res;
|
||||
styles.style_font <- (match LTerm_resources.get "font" res with
|
||||
| "" -> None
|
||||
| str -> Some str);
|
||||
styles.style_foreground <- LTerm_resources.get_color "foreground" res;
|
||||
styles.style_background <- LTerm_resources.get_color "background" res;
|
||||
styles.style_cursor <- LTerm_resources.get_color "cursor" res;
|
||||
(match String.lowercase (LTerm_resources.get "profile" res) with
|
||||
| "light" -> UTop.set_profile UTop.Light
|
||||
| "dark" -> UTop.set_profile UTop.Dark
|
||||
| "" -> ()
|
||||
| str -> raise (LTerm_resources.Error (Printf.sprintf "invalid profile %S" str)));
|
||||
UTop_private.error_style := styles.style_error;
|
||||
UTop_private.autoload := LTerm_resources.get_bool "autoload" res <> Some false;
|
||||
return ())
|
||||
(function
|
||||
| Unix.Unix_error(Unix.ENOENT, _, _) ->
|
||||
return ()
|
||||
| Unix.Unix_error (error, func, arg) ->
|
||||
Lwt_log.error_f "cannot load styles from %S: %s: %s" fn func (Unix.error_message error)
|
||||
| exn -> Lwt.fail exn)
|
||||
|
||||
let rec stylise_filter_layout stylise tokens =
|
||||
match tokens with
|
||||
|
|
|
|||
|
|
@ -1,882 +0,0 @@
|
|||
(*
|
||||
* pa_optcomp.ml
|
||||
* -------------
|
||||
* Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of optcomp.
|
||||
*)
|
||||
|
||||
open Camlp4.Sig
|
||||
open Camlp4.PreCast
|
||||
|
||||
external filter : 'a Gram.not_filtered -> 'a = "%identity"
|
||||
external not_filtered : 'a -> 'a Gram.not_filtered = "%identity"
|
||||
|
||||
(* Subset of supported caml types *)
|
||||
type typ =
|
||||
| Tvar of string
|
||||
| Tbool
|
||||
| Tint
|
||||
| Tchar
|
||||
| Tstring
|
||||
| Ttuple of typ list
|
||||
|
||||
(* Subset of supported caml values *)
|
||||
type value =
|
||||
| Bool of bool
|
||||
| Int of int
|
||||
| Char of char
|
||||
| String of string
|
||||
| Tuple of value list
|
||||
|
||||
type ident = string
|
||||
(* An identifier. It is either a lower or a upper identifier. *)
|
||||
|
||||
module Env = Map.Make(struct type t = ident let compare = compare end)
|
||||
|
||||
type env = value Env.t
|
||||
|
||||
type directive =
|
||||
| Dir_let of Ast.patt * Ast.expr
|
||||
| Dir_default of Ast.patt * Ast.expr
|
||||
| Dir_if of Ast.expr
|
||||
| Dir_else
|
||||
| Dir_elif of Ast.expr
|
||||
| Dir_endif
|
||||
| Dir_include of Ast.expr
|
||||
| Dir_error of Ast.expr
|
||||
| Dir_warning of Ast.expr
|
||||
| Dir_directory of Ast.expr
|
||||
|
||||
(* This one is not part of optcomp but this is one of the directives
|
||||
handled by camlp4 we probably want to use. *)
|
||||
| Dir_default_quotation of Ast.expr
|
||||
|
||||
(* Quotations are evaluated by the token filters, but are expansed
|
||||
after. Evaluated quotations are kept in this table, which quotation
|
||||
id to to values: *)
|
||||
let quotations : (int, value) Hashtbl.t = Hashtbl.create 42
|
||||
|
||||
let next_quotation_id =
|
||||
let r = ref 0 in
|
||||
fun _ -> incr r; !r
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Environment |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let env = ref Env.empty
|
||||
let define id value = env := Env.add id value !env
|
||||
|
||||
let _ =
|
||||
define "ocaml_version" (Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun major minor patchlevel -> Tuple [Int major; Int minor; Int patchlevel]))
|
||||
|
||||
let dirs = ref []
|
||||
let add_include_dir dir = dirs := dir :: !dirs
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Dependencies |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
module String_set = Set.Make(String)
|
||||
|
||||
(* All depencies of the file being parsed *)
|
||||
let dependencies = ref String_set.empty
|
||||
|
||||
(* Where to write dependencies *)
|
||||
let dependency_filename = ref None
|
||||
|
||||
(* The file being parsed. This is set when the first (token, location)
|
||||
pair is fetched. *)
|
||||
let source_filename = ref None
|
||||
|
||||
let write_depencies () =
|
||||
match !dependency_filename, !source_filename with
|
||||
| None, _
|
||||
| _, None ->
|
||||
()
|
||||
|
||||
| Some dependency_filename, Some source_filename ->
|
||||
let oc = open_out dependency_filename in
|
||||
if not (String_set.is_empty !dependencies) then begin
|
||||
output_string oc "# automatically generated by optcomp\n";
|
||||
output_string oc source_filename;
|
||||
output_string oc ": ";
|
||||
output_string oc (String.concat " " (String_set.elements !dependencies));
|
||||
output_char oc '\n'
|
||||
end;
|
||||
close_out oc
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Value to expression/pattern conversion |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let rec expr_of_value _loc = function
|
||||
| Bool true -> <:expr< true >>
|
||||
| Bool false -> <:expr< false >>
|
||||
| Int x -> <:expr< $int:string_of_int x$ >>
|
||||
| Char x -> <:expr< $chr:Char.escaped x$ >>
|
||||
| String x -> <:expr< $str:String.escaped x$ >>
|
||||
| Tuple [] -> <:expr< () >>
|
||||
| Tuple [x] -> expr_of_value _loc x
|
||||
| Tuple l -> <:expr< $tup:Ast.exCom_of_list (List.map (expr_of_value _loc) l)$ >>
|
||||
|
||||
let rec patt_of_value _loc = function
|
||||
| Bool true -> <:patt< true >>
|
||||
| Bool false -> <:patt< false >>
|
||||
| Int x -> <:patt< $int:string_of_int x$ >>
|
||||
| Char x -> <:patt< $chr:Char.escaped x$ >>
|
||||
| String x -> <:patt< $str:String.escaped x$ >>
|
||||
| Tuple [] -> <:patt< () >>
|
||||
| Tuple [x] -> patt_of_value _loc x
|
||||
| Tuple l -> <:patt< $tup:Ast.paCom_of_list (List.map (patt_of_value _loc) l)$ >>
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Value printing |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let string_of_value string_of_bool v =
|
||||
let buf = Buffer.create 128 in
|
||||
let rec aux = function
|
||||
| Bool b ->
|
||||
Buffer.add_string buf (string_of_bool b)
|
||||
| Int n ->
|
||||
Buffer.add_string buf (string_of_int n)
|
||||
| Char ch ->
|
||||
Buffer.add_char buf '\'';
|
||||
Buffer.add_string buf (Char.escaped ch);
|
||||
Buffer.add_char buf '\''
|
||||
| String s ->
|
||||
Buffer.add_char buf '"';
|
||||
Buffer.add_string buf (String.escaped s);
|
||||
Buffer.add_char buf '"'
|
||||
| Tuple [] ->
|
||||
Buffer.add_string buf "()"
|
||||
| Tuple (x :: l) ->
|
||||
Buffer.add_char buf '(';
|
||||
aux x;
|
||||
List.iter
|
||||
(fun x ->
|
||||
Buffer.add_string buf ", ";
|
||||
aux x)
|
||||
l;
|
||||
Buffer.add_char buf ')'
|
||||
in
|
||||
aux v;
|
||||
Buffer.contents buf
|
||||
|
||||
let string_of_value_o v =
|
||||
string_of_value
|
||||
(function
|
||||
| true -> "true"
|
||||
| false -> "false")
|
||||
v
|
||||
|
||||
let string_of_value_r v =
|
||||
string_of_value
|
||||
(function
|
||||
| true -> "True"
|
||||
| false -> "False")
|
||||
v
|
||||
|
||||
let string_of_value_no_pretty v =
|
||||
let buf = Buffer.create 128 in
|
||||
let rec aux = function
|
||||
| Bool b ->
|
||||
Buffer.add_string buf (string_of_bool b)
|
||||
| Int n ->
|
||||
Buffer.add_string buf (string_of_int n)
|
||||
| Char ch ->
|
||||
Buffer.add_char buf ch
|
||||
| String s ->
|
||||
Buffer.add_string buf s;
|
||||
| Tuple [] ->
|
||||
Buffer.add_string buf "()"
|
||||
| Tuple (x :: l) ->
|
||||
Buffer.add_char buf '(';
|
||||
aux x;
|
||||
List.iter
|
||||
(fun x ->
|
||||
Buffer.add_string buf ", ";
|
||||
aux x)
|
||||
l;
|
||||
Buffer.add_char buf ')'
|
||||
in
|
||||
aux v;
|
||||
Buffer.contents buf
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Expression evaluation |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let rec type_of_value = function
|
||||
| Bool _ -> Tbool
|
||||
| Int _ -> Tint
|
||||
| Char _ -> Tchar
|
||||
| String _ -> Tstring
|
||||
| Tuple l -> Ttuple (List.map type_of_value l)
|
||||
|
||||
let rec string_of_type = function
|
||||
| Tvar v -> "'" ^ v
|
||||
| Tbool -> "bool"
|
||||
| Tint -> "int"
|
||||
| Tchar -> "char"
|
||||
| Tstring -> "string"
|
||||
| Ttuple l -> "(" ^ String.concat " * " (List.map string_of_type l) ^ ")"
|
||||
|
||||
let invalid_type loc expected real =
|
||||
Loc.raise loc (Failure
|
||||
(Printf.sprintf "this expression has type %s but is used with type %s"
|
||||
(string_of_type real) (string_of_type expected)))
|
||||
|
||||
let type_of_patt patt =
|
||||
let rec aux (a, n) = function
|
||||
| <:patt< $tup:x$ >> ->
|
||||
let l, x = List.fold_left
|
||||
(fun (l, x) patt -> let t, x = aux x patt in (t :: l, x))
|
||||
([], (a, n)) (Ast.list_of_patt x []) in
|
||||
(Ttuple(List.rev l), x)
|
||||
| _ ->
|
||||
(Tvar(Printf.sprintf "%c%s"
|
||||
(char_of_int (Char.code 'a' + a))
|
||||
(if n = 0 then "" else string_of_int n)),
|
||||
if a = 25 then (0, n + 1) else (a + 1, n))
|
||||
in
|
||||
fst (aux (0, 0) patt)
|
||||
|
||||
let rec eval env = function
|
||||
|
||||
(* Literals *)
|
||||
| <:expr< true >> -> Bool true
|
||||
| <:expr< false >> -> Bool false
|
||||
| <:expr< $int:x$ >> -> Int(int_of_string x)
|
||||
| <:expr< $chr:x$ >> -> Char(Camlp4.Struct.Token.Eval.char x)
|
||||
| <:expr< $str:x$ >> -> String(Camlp4.Struct.Token.Eval.string ~strict:() x)
|
||||
|
||||
(* Tuples *)
|
||||
| <:expr< $tup:x$ >> -> Tuple(List.map (eval env) (Ast.list_of_expr x []))
|
||||
|
||||
(* Variables *)
|
||||
| <:expr@loc< $lid:x$ >>
|
||||
| <:expr@loc< $uid:x$ >> ->
|
||||
begin try
|
||||
Env.find x env
|
||||
with
|
||||
Not_found ->
|
||||
Loc.raise loc (Failure (Printf.sprintf "unbound value %s" x))
|
||||
end
|
||||
|
||||
(* Value comparing *)
|
||||
| <:expr< $x$ = $y$ >> -> let x, y = eval_same env x y in Bool(x = y)
|
||||
| <:expr< $x$ < $y$ >> -> let x, y = eval_same env x y in Bool(x < y)
|
||||
| <:expr< $x$ > $y$ >> -> let x, y = eval_same env x y in Bool(x > y)
|
||||
| <:expr< $x$ <= $y$ >> -> let x, y = eval_same env x y in Bool(x <= y)
|
||||
| <:expr< $x$ >= $y$ >> -> let x, y = eval_same env x y in Bool(x >= y)
|
||||
| <:expr< $x$ <> $y$ >> -> let x, y = eval_same env x y in Bool(x <> y)
|
||||
|
||||
(* min and max *)
|
||||
| <:expr< min $x$ $y$ >> -> let x, y = eval_same env x y in min x y
|
||||
| <:expr< max $x$ $y$ >> -> let x, y = eval_same env x y in max x y
|
||||
|
||||
(* Arithmetic *)
|
||||
| <:expr< $x$ + $y$ >> -> Int(eval_int env x + eval_int env y)
|
||||
| <:expr< $x$ - $y$ >> -> Int(eval_int env x - eval_int env y)
|
||||
| <:expr< $x$ * $y$ >> -> Int(eval_int env x * eval_int env y)
|
||||
| <:expr< $x$ / $y$ >> -> Int(eval_int env x / eval_int env y)
|
||||
| <:expr< $x$ mod $y$ >> -> Int(eval_int env x mod eval_int env y)
|
||||
|
||||
(* Boolean operations *)
|
||||
| <:expr< not $x$ >> -> Bool(not (eval_bool env x))
|
||||
| <:expr< $x$ or $y$ >> -> Bool(eval_bool env x || eval_bool env y)
|
||||
| <:expr< $x$ || $y$ >> -> Bool(eval_bool env x || eval_bool env y)
|
||||
| <:expr< $x$ && $y$ >> -> Bool(eval_bool env x && eval_bool env y)
|
||||
|
||||
(* String operations *)
|
||||
| <:expr< $x$ ^ $y$ >> -> String(eval_string env x ^ eval_string env y)
|
||||
|
||||
(* Pair operations *)
|
||||
| <:expr< fst $x$ >> -> fst (eval_pair env x)
|
||||
| <:expr< snd $x$ >> -> snd (eval_pair env x)
|
||||
|
||||
(* Conversions *)
|
||||
| <:expr@loc< to_string $x$ >> ->
|
||||
String(string_of_value_no_pretty (eval env x))
|
||||
| <:expr@loc< to_int $x$ >> ->
|
||||
Int
|
||||
(match eval env x with
|
||||
| String x -> begin
|
||||
try
|
||||
int_of_string x
|
||||
with exn ->
|
||||
Loc.raise loc exn
|
||||
end
|
||||
| Int x ->
|
||||
x
|
||||
| Char x ->
|
||||
int_of_char x
|
||||
| Bool _ ->
|
||||
Loc.raise loc (Failure "cannot convert a boolean to an integer")
|
||||
| Tuple _ ->
|
||||
Loc.raise loc (Failure "cannot convert a tuple to an integer"))
|
||||
| <:expr@loc< to_bool $x$ >> ->
|
||||
Bool
|
||||
(match eval env x with
|
||||
| String x -> begin
|
||||
try
|
||||
bool_of_string x
|
||||
with exn ->
|
||||
Loc.raise loc exn
|
||||
end
|
||||
| Int x ->
|
||||
Loc.raise loc (Failure "cannot convert an integer to a boolean")
|
||||
| Char x ->
|
||||
Loc.raise loc (Failure "cannot convert a character to a boolean")
|
||||
| Bool x ->
|
||||
x
|
||||
| Tuple _ ->
|
||||
Loc.raise loc (Failure "cannot convert a tuple to a boolean"))
|
||||
| <:expr@loc< to_char $x$ >> ->
|
||||
Char
|
||||
(match eval env x with
|
||||
| String x ->
|
||||
if String.length x = 1 then
|
||||
x.[0]
|
||||
else
|
||||
Loc.raise loc (Failure (Printf.sprintf "cannot convert a string of length %d to a character" (String.length x)))
|
||||
| Int x -> begin
|
||||
try
|
||||
char_of_int x
|
||||
with exn ->
|
||||
Loc.raise loc exn
|
||||
end
|
||||
| Char x ->
|
||||
x
|
||||
| Bool _ ->
|
||||
Loc.raise loc (Failure "cannot convert a boolean to a character")
|
||||
| Tuple _ ->
|
||||
Loc.raise loc (Failure "cannot convert a tuple to a character"))
|
||||
|
||||
(* Pretty printing *)
|
||||
| <:expr@loc< show $x$ >> ->
|
||||
String(string_of_value_o (eval env x))
|
||||
|
||||
(* Let-binding *)
|
||||
| <:expr< let $p$ = $x$ in $y$ >> ->
|
||||
let vx = eval env x in
|
||||
let env =
|
||||
try
|
||||
bind true env p vx
|
||||
with Exit ->
|
||||
invalid_type (Ast.loc_of_expr x) (type_of_patt p) (type_of_value vx)
|
||||
in
|
||||
eval env y
|
||||
|
||||
| e -> Loc.raise (Ast.loc_of_expr e) (Stream.Error "expression not supported")
|
||||
|
||||
and bind override env patt value = match patt with
|
||||
| <:patt< $lid:id$ >>
|
||||
| <:patt< $uid:id$ >> ->
|
||||
if override || not (Env.mem id env) then
|
||||
Env.add id value env
|
||||
else
|
||||
env
|
||||
|
||||
| <:patt< $tup:patts$ >> ->
|
||||
let patts = Ast.list_of_patt patts [] in
|
||||
begin match value with
|
||||
| Tuple values when List.length values = List.length patts ->
|
||||
List.fold_left2 (bind override) env patts values
|
||||
| _ ->
|
||||
raise Exit
|
||||
end
|
||||
|
||||
| <:patt< _ >> ->
|
||||
env
|
||||
|
||||
| _ ->
|
||||
Loc.raise (Ast.loc_of_patt patt) (Stream.Error "pattern not supported")
|
||||
|
||||
and eval_same env ex ey =
|
||||
let vx = eval env ex and vy = eval env ey in
|
||||
let tx = type_of_value vx and ty = type_of_value vy in
|
||||
if tx = ty then
|
||||
(vx, vy)
|
||||
else
|
||||
invalid_type (Ast.loc_of_expr ey) tx ty
|
||||
|
||||
and eval_int env e = match eval env e with
|
||||
| Int x -> x
|
||||
| v -> invalid_type (Ast.loc_of_expr e) Tint (type_of_value v)
|
||||
|
||||
and eval_bool env e = match eval env e with
|
||||
| Bool x -> x
|
||||
| v -> invalid_type (Ast.loc_of_expr e) Tbool (type_of_value v)
|
||||
|
||||
and eval_string env e = match eval env e with
|
||||
| String x -> x
|
||||
| v -> invalid_type (Ast.loc_of_expr e) Tstring (type_of_value v)
|
||||
|
||||
and eval_char env e = match eval env e with
|
||||
| Char x -> x
|
||||
| v -> invalid_type (Ast.loc_of_expr e) Tchar (type_of_value v)
|
||||
|
||||
and eval_pair env e = match eval env e with
|
||||
| Tuple [x; y] -> (x, y)
|
||||
| v -> invalid_type (Ast.loc_of_expr e) (Ttuple [Tvar "a"; Tvar "b"]) (type_of_value v)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Parsing of directives |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let rec skip_space stream = match Stream.peek stream with
|
||||
| Some((BLANKS _ | COMMENT _), _) ->
|
||||
Stream.junk stream;
|
||||
skip_space stream
|
||||
| _ ->
|
||||
()
|
||||
|
||||
let rec parse_eol stream =
|
||||
let tok, loc = Stream.next stream in
|
||||
match tok with
|
||||
| BLANKS _ | COMMENT _ ->
|
||||
parse_eol stream
|
||||
| NEWLINE | EOI ->
|
||||
()
|
||||
| _ ->
|
||||
Loc.raise loc (Stream.Error "end of line expected")
|
||||
|
||||
(* Return wether a keyword can be interpreted as an identifier *)
|
||||
let keyword_is_id str =
|
||||
let rec aux i =
|
||||
if i = String.length str then
|
||||
true
|
||||
else
|
||||
match str.[i] with
|
||||
| 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' ->
|
||||
aux (i + 1)
|
||||
| _ ->
|
||||
false
|
||||
in
|
||||
aux 0
|
||||
|
||||
let parse_ident stream =
|
||||
skip_space stream;
|
||||
let tok, loc = Stream.next stream in
|
||||
begin match tok with
|
||||
| LIDENT id | UIDENT id ->
|
||||
(id, loc)
|
||||
| KEYWORD kwd when keyword_is_id kwd ->
|
||||
(kwd, loc)
|
||||
| _ ->
|
||||
Loc.raise loc (Stream.Error "identifier expected")
|
||||
end
|
||||
|
||||
let parse_until entry is_stop_token stream =
|
||||
(* Lists of opened brackets *)
|
||||
let opened_brackets = ref [] in
|
||||
let eoi = ref None in
|
||||
let end_loc = ref Loc.ghost in
|
||||
|
||||
(* Return the next token of [stream] until all opened parentheses
|
||||
have been closed and a newline is reached *)
|
||||
let rec next_token _ =
|
||||
match !eoi with
|
||||
| Some _ as x -> x
|
||||
| None ->
|
||||
Some(match Stream.next stream, !opened_brackets with
|
||||
| (tok, loc), [] when is_stop_token tok ->
|
||||
end_loc := loc;
|
||||
let x = (EOI, loc) in
|
||||
eoi := Some x;
|
||||
x
|
||||
|
||||
| (EOI, loc), _ ->
|
||||
end_loc := loc;
|
||||
let x = (EOI, loc) in
|
||||
eoi := Some x;
|
||||
x
|
||||
|
||||
| ((KEYWORD ("(" | "[" | "{" as b) | SYMBOL ("(" | "[" | "{" as b)), _) as x, l ->
|
||||
opened_brackets := b :: l;
|
||||
x
|
||||
|
||||
| ((KEYWORD ")" | SYMBOL ")"), loc) as x, "(" :: l ->
|
||||
opened_brackets := l;
|
||||
x
|
||||
|
||||
| ((KEYWORD "]" | SYMBOL "]"), loc) as x, "[" :: l ->
|
||||
opened_brackets := l;
|
||||
x
|
||||
|
||||
| ((KEYWORD "}" | SYMBOL "}"), loc) as x, "{" :: l ->
|
||||
opened_brackets := l;
|
||||
x
|
||||
|
||||
| x, _ ->
|
||||
x)
|
||||
in
|
||||
|
||||
let expr =
|
||||
Gram.parse_tokens_before_filter entry
|
||||
(not_filtered (Stream.from next_token))
|
||||
in
|
||||
(expr, Loc.join !end_loc)
|
||||
|
||||
let parse_expr stream =
|
||||
parse_until Syntax.expr_eoi (fun tok -> tok = NEWLINE) stream
|
||||
|
||||
let parse_patt stream =
|
||||
parse_until Syntax.patt_eoi (function
|
||||
| SYMBOL "=" | KEYWORD "=" -> true
|
||||
| _ -> false) stream
|
||||
|
||||
let parse_directive stream = match Stream.peek stream with
|
||||
| Some((KEYWORD "#" | SYMBOL "#"), loc) -> begin
|
||||
Stream.junk stream;
|
||||
|
||||
let dir, loc_dir = parse_ident stream in
|
||||
|
||||
match dir with
|
||||
|
||||
| "let" ->
|
||||
let patt, _ = parse_patt stream in
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_let(patt, expr), Loc.merge loc end_loc)
|
||||
|
||||
| "let_default" ->
|
||||
let patt, _ = parse_patt stream in
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_default(patt, expr), Loc.merge loc end_loc)
|
||||
|
||||
| "if" ->
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_if expr, Loc.merge loc end_loc)
|
||||
|
||||
| "else" ->
|
||||
parse_eol stream;
|
||||
Some(Dir_else, Loc.merge loc loc_dir)
|
||||
|
||||
| "elif" ->
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_elif expr, Loc.merge loc end_loc)
|
||||
|
||||
| "endif" ->
|
||||
parse_eol stream;
|
||||
Some(Dir_endif, Loc.merge loc loc_dir)
|
||||
|
||||
| "include" ->
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_include expr, Loc.merge loc end_loc)
|
||||
|
||||
| "directory" ->
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_directory expr, Loc.merge loc end_loc)
|
||||
|
||||
| "error" ->
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_error expr, Loc.merge loc end_loc)
|
||||
|
||||
| "warning" ->
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_warning expr, Loc.merge loc end_loc)
|
||||
|
||||
| "default_quotation" ->
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_default_quotation expr, Loc.merge loc end_loc)
|
||||
|
||||
| _ ->
|
||||
Loc.raise loc_dir (Stream.Error (Printf.sprintf "unknown directive ``%s''" dir))
|
||||
end
|
||||
|
||||
| _ ->
|
||||
None
|
||||
|
||||
let parse_command_line_define str =
|
||||
match Gram.parse_string Syntax.expr (Loc.mk "<command line>") str with
|
||||
| <:expr< $lid:id$ = $e$ >>
|
||||
| <:expr< $uid:id$ = $e$ >> -> define id (eval !env e)
|
||||
| _ -> invalid_arg str
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Block skipping |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let rec skip_line stream =
|
||||
match Stream.next stream with
|
||||
| NEWLINE, _ -> ()
|
||||
| EOI, loc -> Loc.raise loc (Stream.Error "#endif missing")
|
||||
| _ -> skip_line stream
|
||||
|
||||
let rec next_directive stream = match parse_directive stream with
|
||||
| Some dir -> dir
|
||||
| None -> skip_line stream; next_directive stream
|
||||
|
||||
let rec next_endif stream =
|
||||
let dir, loc = next_directive stream in
|
||||
match dir with
|
||||
| Dir_if _ -> skip_if stream; next_endif stream
|
||||
| Dir_else
|
||||
| Dir_elif _
|
||||
| Dir_endif -> dir
|
||||
| _ -> next_endif stream
|
||||
|
||||
and skip_if stream =
|
||||
let dir, loc = next_directive stream in
|
||||
match dir with
|
||||
| Dir_if _ ->
|
||||
skip_if stream;
|
||||
skip_if stream
|
||||
|
||||
| Dir_else ->
|
||||
skip_else stream
|
||||
|
||||
| Dir_elif _ ->
|
||||
skip_if stream
|
||||
|
||||
| Dir_endif ->
|
||||
()
|
||||
|
||||
| _ -> skip_if stream
|
||||
|
||||
and skip_else stream =
|
||||
let dir, loc = next_directive stream in
|
||||
match dir with
|
||||
| Dir_if _ ->
|
||||
skip_if stream;
|
||||
skip_else stream
|
||||
|
||||
| Dir_else ->
|
||||
Loc.raise loc (Stream.Error "#else without #if")
|
||||
|
||||
| Dir_elif _ ->
|
||||
Loc.raise loc (Stream.Error "#elif without #if")
|
||||
|
||||
| Dir_endif ->
|
||||
()
|
||||
|
||||
| _ ->
|
||||
skip_else stream
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Token filtering |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type context = Ctx_if | Ctx_else
|
||||
|
||||
(* State of the token filter *)
|
||||
type state = {
|
||||
stream : (Gram.Token.t * Loc.t) Stream.t;
|
||||
(* Input stream *)
|
||||
|
||||
mutable bol : bool;
|
||||
(* Wether we are at the beginning of a line *)
|
||||
|
||||
mutable stack : context list;
|
||||
(* Nested contexts *)
|
||||
|
||||
on_eoi : Gram.Token.t * Loc.t -> Gram.Token.t * Loc.t;
|
||||
(* Eoi handler, it is used to restore the previous sate on #include
|
||||
directives *)
|
||||
}
|
||||
|
||||
(* Read and return one token *)
|
||||
let really_read state =
|
||||
let tok, loc = Stream.next state.stream in
|
||||
state.bol <- tok = NEWLINE;
|
||||
match tok with
|
||||
| QUOTATION ({ q_name = "optcomp" } as quot) ->
|
||||
let id = next_quotation_id () in
|
||||
Hashtbl.add quotations id (eval !env (Gram.parse_string
|
||||
Syntax.expr_eoi
|
||||
(Loc.move `start quot.q_shift loc)
|
||||
quot.q_contents));
|
||||
|
||||
(* Replace the quotation by its id *)
|
||||
(QUOTATION { quot with q_contents = string_of_int id }, loc)
|
||||
|
||||
| EOI ->
|
||||
(* If end of input is reached, we call the eoi handler. It may
|
||||
continue if we were parsing an included file *)
|
||||
if state.stack <> [] then
|
||||
Loc.raise loc (Stream.Error "#endif missing");
|
||||
state.on_eoi (tok, loc)
|
||||
|
||||
| _ ->
|
||||
(tok, loc)
|
||||
|
||||
(* Return the next token from a stream, interpreting directives. *)
|
||||
let rec next_token lexer state_ref =
|
||||
let state = !state_ref in
|
||||
if state.bol then
|
||||
match parse_directive state.stream, state.stack with
|
||||
| Some(Dir_if e, _), _ ->
|
||||
let rec aux e =
|
||||
if eval_bool !env e then begin
|
||||
state.stack <- Ctx_if :: state.stack;
|
||||
next_token lexer state_ref
|
||||
end else
|
||||
match next_endif state.stream with
|
||||
| Dir_else ->
|
||||
state.stack <- Ctx_else :: state.stack;
|
||||
next_token lexer state_ref
|
||||
|
||||
| Dir_elif e ->
|
||||
aux e
|
||||
|
||||
| Dir_endif ->
|
||||
next_token lexer state_ref
|
||||
|
||||
| _ ->
|
||||
assert false
|
||||
in
|
||||
aux e
|
||||
|
||||
| Some(Dir_else, loc), ([] | Ctx_else :: _) ->
|
||||
Loc.raise loc (Stream.Error "#else without #if")
|
||||
|
||||
| Some(Dir_elif _, loc), ([] | Ctx_else :: _) ->
|
||||
Loc.raise loc (Stream.Error "#elif without #if")
|
||||
|
||||
| Some(Dir_endif, loc), [] ->
|
||||
Loc.raise loc (Stream.Error "#endif without #if")
|
||||
|
||||
| Some(Dir_else, loc), Ctx_if :: l ->
|
||||
skip_else state.stream;
|
||||
state.stack <- l;
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_elif _, loc), Ctx_if :: l ->
|
||||
skip_if state.stream;
|
||||
state.stack <- l;
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_endif, loc), _ :: l ->
|
||||
state.stack <- l;
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_let(patt, expr), _), _ ->
|
||||
let value = eval !env expr in
|
||||
env := (
|
||||
try
|
||||
bind true !env patt value;
|
||||
with Exit ->
|
||||
invalid_type (Ast.loc_of_expr expr) (type_of_patt patt) (type_of_value value)
|
||||
);
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_default(patt, expr), _), _ ->
|
||||
let value = eval !env expr in
|
||||
env := (
|
||||
try
|
||||
bind false !env patt value;
|
||||
with Exit ->
|
||||
invalid_type (Ast.loc_of_expr expr) (type_of_patt patt) (type_of_value value)
|
||||
);
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_include e, _), _ ->
|
||||
let fname = eval_string !env e in
|
||||
(* Try to looks up in all include directories *)
|
||||
let fname =
|
||||
try
|
||||
List.find (fun dir -> Sys.file_exists (Filename.concat dir fname)) !dirs
|
||||
with
|
||||
(* Just try in the current directory *)
|
||||
Not_found -> fname
|
||||
in
|
||||
dependencies := String_set.add fname !dependencies;
|
||||
let ic = open_in fname in
|
||||
let nested_state = {
|
||||
stream = lexer fname ic;
|
||||
bol = true;
|
||||
stack = [];
|
||||
on_eoi = (fun _ ->
|
||||
(* Restore previous state and close channel on
|
||||
eoi *)
|
||||
state_ref := state;
|
||||
close_in ic;
|
||||
next_token lexer state_ref)
|
||||
} in
|
||||
(* Replace current state with the new one *)
|
||||
state_ref := nested_state;
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_directory e, loc), _ ->
|
||||
let dir = eval_string !env e in
|
||||
add_include_dir dir;
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_error e, loc), _ ->
|
||||
Loc.raise loc (Failure (eval_string !env e))
|
||||
|
||||
| Some(Dir_warning e, loc), _ ->
|
||||
Syntax.print_warning loc (eval_string !env e);
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_default_quotation e, loc), _ ->
|
||||
Syntax.Quotation.default := eval_string !env e;
|
||||
next_token lexer state_ref
|
||||
|
||||
| None, _ ->
|
||||
really_read state
|
||||
|
||||
else
|
||||
really_read state
|
||||
|
||||
let default_lexer fname ic =
|
||||
Token.Filter.filter (Gram.get_filter ()) (filter (Gram.lex (Loc.mk fname) (Stream.of_channel ic)))
|
||||
|
||||
let stream_filter lexer filter stream =
|
||||
(* Set the source filename *)
|
||||
begin
|
||||
match !source_filename with
|
||||
| Some _ ->
|
||||
()
|
||||
| None ->
|
||||
match Stream.peek stream with
|
||||
| None ->
|
||||
()
|
||||
| Some(tok, loc) ->
|
||||
source_filename := Some(Loc.file_name loc)
|
||||
end;
|
||||
let state_ref = ref { stream = stream;
|
||||
bol = true;
|
||||
stack = [];
|
||||
on_eoi = (fun x -> x) } in
|
||||
filter (Stream.from (fun _ -> Some(next_token lexer state_ref)))
|
||||
|
||||
let filter ?(lexer=default_lexer) stream = stream_filter lexer (fun x -> x) stream
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Quotations expansion |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let get_quotation_value str =
|
||||
Hashtbl.find quotations (int_of_string str)
|
||||
|
||||
let expand f loc _ contents =
|
||||
try
|
||||
f loc (get_quotation_value contents)
|
||||
with exn ->
|
||||
Loc.raise loc (Failure "fatal error in optcomp!")
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Registration |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let _ =
|
||||
Camlp4.Options.add "-let" (Arg.String parse_command_line_define)
|
||||
"<string> Binding for a #let directive.";
|
||||
Camlp4.Options.add "-I" (Arg.String add_include_dir)
|
||||
"<string> Add a directory to #include search path.";
|
||||
Camlp4.Options.add "-depend"
|
||||
(Arg.String (fun filename -> dependency_filename := Some filename))
|
||||
"<file> Write dependencies to <file>.";
|
||||
|
||||
Pervasives.at_exit write_depencies;
|
||||
|
||||
Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.expr_tag (expand expr_of_value);
|
||||
Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.patt_tag (expand patt_of_value);
|
||||
|
||||
Gram.Token.Filter.define_filter (Gram.get_filter ()) (stream_filter default_lexer)
|
||||
Loading…
Reference in New Issue