Replace pa_optcomp with cppo.
This commit is contained in:
Peter Zotov
parent
7c8a68eea6
commit
257bfa7eb6
13
_oasis
13
_oasis
|
|
@ -2,8 +2,8 @@
|
|||
# | Package parameters |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
OASISFormat: 0.3
|
||||
OCamlVersion: >= 3.12
|
||||
OASISFormat: 0.4
|
||||
OCamlVersion: >= 4.01
|
||||
Name: utop
|
||||
Version: 1.15
|
||||
LicenseFile: LICENSE
|
||||
|
|
@ -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
|
||||
|
|
@ -31,13 +33,6 @@ Flag camlp4
|
|||
Description: camlp4 support
|
||||
Default: true
|
||||
|
||||
Library "optcomp"
|
||||
Install: false
|
||||
Path: syntax
|
||||
Modules: Pa_optcomp
|
||||
BuildDepends: camlp4, camlp4.quotations.o
|
||||
CompiledObject: byte
|
||||
|
||||
Library utop
|
||||
Path: src/lib
|
||||
Modules:
|
||||
|
|
|
|||
5
_tags
5
_tags
|
|
@ -1,10 +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
|
||||
<**/*.ml>: syntax_camlp4o, pkg_lwt.syntax
|
||||
|
||||
# Use compiler interfaces
|
||||
<src/**/*.ml{,i}>: use_compiler_libs
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ let () =
|
|||
dispatch
|
||||
(fun hook ->
|
||||
dispatch_default hook;
|
||||
Ocamlbuild_cppo.dispatcher hook;
|
||||
match hook with
|
||||
| Before_options ->
|
||||
Options.make_links := false
|
||||
|
|
@ -34,20 +35,20 @@ let () =
|
|||
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]
|
||||
let findlib_version = BaseEnvLight.var_get "findlib_version" env in
|
||||
let findlib_version =
|
||||
Scanf.sscanf findlib_version "%d.%d.%d" (fun major minor patchlevel ->
|
||||
Printf.sprintf "FINDLIB_VERSION %d" (major * 10000 + minor * 100 + patchlevel))
|
||||
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"];
|
||||
|
||||
(* Cppo *)
|
||||
flag ["cppo"] & S[A"-D"; A ocaml_version; A"-D"; A findlib_version];
|
||||
|
||||
(* Add directories for compiler-libraries: *)
|
||||
let paths = List.filter Sys.file_exists [path; path / "typing"; path / "parsing"; path / "utils"] in
|
||||
|
|
|
|||
6
opam
6
opam
|
|
@ -15,6 +15,10 @@ depends: [
|
|||
"lambda-term" {>= "1.2"}
|
||||
"lwt"
|
||||
"react" {>= "1.0.0"}
|
||||
"cppo" {>= "1.0.1"}
|
||||
"oasis" {>= "0.3.0"}
|
||||
]
|
||||
ocaml-version: [>= "3.12"]
|
||||
depopts: [
|
||||
"camlp4"
|
||||
]
|
||||
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
|
||||
|
|
@ -189,7 +189,7 @@ type 'a result =
|
|||
|
||||
exception Need_more
|
||||
|
||||
#if ocaml_version <= (3, 12, 1)
|
||||
#if OCAML_VERSION <= 031201
|
||||
let input_name = ""
|
||||
#else
|
||||
let input_name = "//toplevel//"
|
||||
|
|
@ -244,7 +244,7 @@ let parse_default parse str eos_is_error =
|
|||
| Syntaxerr.Other loc ->
|
||||
Error ([mkloc loc],
|
||||
"Syntax error")
|
||||
#if ocaml_version >= (4, 01, 0)
|
||||
#if OCAML_VERSION >= 040100
|
||||
| Syntaxerr.Expecting (loc, nonterm) ->
|
||||
Error ([mkloc loc],
|
||||
Printf.sprintf "Syntax error: %s expected." nonterm)
|
||||
|
|
@ -252,7 +252,7 @@ let parse_default parse str eos_is_error =
|
|||
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,7 +286,7 @@ let rec last head tail =
|
|||
| head :: tail ->
|
||||
last head tail
|
||||
|
||||
#if ocaml_version >= (4, 0, 0)
|
||||
#if OCAML_VERSION >= 040000
|
||||
let with_loc loc str = {
|
||||
Location.txt = str;
|
||||
Location.loc = loc;
|
||||
|
|
@ -316,7 +316,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,7 +359,7 @@ let check_phrase phrase =
|
|||
try
|
||||
let _ =
|
||||
discard_formatters [Format.err_formatter] (fun () ->
|
||||
#if ocaml_version > (4, 00, 1)
|
||||
#if OCAML_VERSION > 040001
|
||||
Env.reset_cache_toplevel ();
|
||||
#endif
|
||||
Toploop.execute_phrase false null check_phrase)
|
||||
|
|
@ -658,7 +658,7 @@ let () =
|
|||
|
||||
let topfind_log, set_topfind_log = S.create ~eq:(fun _ _ -> false) []
|
||||
|
||||
#if findlib_version >= (1, 4)
|
||||
#if FINDLIB_VERSION >= 010400
|
||||
let () =
|
||||
let real_log = !Topfind.log in
|
||||
Topfind.log := fun str ->
|
||||
|
|
@ -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,10 +394,10 @@ 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)
|
||||
#elif OCAML_VERSION >= 040000
|
||||
let field_name (id, _, _) = Ident.name id
|
||||
let constructor_name (id, _, _) = Ident.name id
|
||||
#else
|
||||
|
|
@ -413,7 +413,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 +426,19 @@ 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)
|
||||
#if OCAML_VERSION >= 040000
|
||||
|
||||
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 +453,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 +462,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 +477,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 +492,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 +501,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
|
||||
|
|
@ -561,7 +561,7 @@ let rec fields_of_module_type = function
|
|||
|
||||
#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 +606,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 +620,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 +671,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 +679,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 +941,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
|
||||
|
|
@ -89,7 +89,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 +261,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 +308,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,7 +347,7 @@ let () =
|
|||
| Toplevel expression rewriting |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
#if ocaml_version >= (4, 0, 0)
|
||||
#if OCAML_VERSION >= 040000
|
||||
let with_loc loc str = {
|
||||
Location.txt = str;
|
||||
Location.loc = loc;
|
||||
|
|
@ -375,7 +375,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 +394,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 +416,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,7 +490,7 @@ let is_persistent_in_env longident =
|
|||
with Not_found ->
|
||||
false
|
||||
|
||||
#if ocaml_version >= (4, 0, 0)
|
||||
#if OCAML_VERSION >= 040000
|
||||
let str_items_of_typed_structure tstr = tstr.Typedtree.str_items
|
||||
let str_desc_of_typed_str_item tstr = tstr.Typedtree.str_desc
|
||||
#else
|
||||
|
|
@ -498,7 +498,7 @@ 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
|
||||
| ({ Parsetree.pstr_desc = Parsetree.Pstr_eval e;
|
||||
|
|
@ -610,11 +610,11 @@ 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)
|
||||
#if OCAML_VERSION > 040001
|
||||
Env.reset_cache_toplevel ();
|
||||
#endif
|
||||
if !Clflags.dump_parsetree then Printast.top_phrase pp phrase;
|
||||
#if ocaml_version > (4, 00, 1)
|
||||
#if OCAML_VERSION > 040001
|
||||
if !Clflags.dump_source then Pprintast.top_phrase pp phrase;
|
||||
#endif
|
||||
ignore (Toploop.execute_phrase true pp phrase);
|
||||
|
|
@ -695,7 +695,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;
|
||||
|
|
@ -825,7 +825,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,7 +1012,7 @@ end
|
|||
| Extra macros |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
#if ocaml_version > (4, 00, 1)
|
||||
#if OCAML_VERSION > 040001
|
||||
|
||||
let typeof sid =
|
||||
let id = Longident.parse sid in
|
||||
|
|
@ -1041,7 +1041,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 +1058,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
|
||||
|
|
@ -1149,7 +1149,7 @@ let print_version_num () =
|
|||
let autoload = ref true
|
||||
|
||||
let args = Arg.align [
|
||||
#if ocaml_version >= (3, 13, 0)
|
||||
#if OCAML_VERSION >= 031300
|
||||
"-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";
|
||||
|
|
@ -1159,14 +1159,14 @@ 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)
|
||||
#if OCAML_VERSION >= 040100
|
||||
"-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
|
||||
|
|
@ -1203,12 +1203,12 @@ 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)
|
||||
#if OCAML_VERSION >= 040100
|
||||
"-dsource", Arg.Set Clflags.dump_source, " Dump OCaml source after rewriting";
|
||||
#endif
|
||||
]
|
||||
|
||||
#if ocaml_version >= (4, 01, 0)
|
||||
#if OCAML_VERSION >= 040100
|
||||
let () = Clflags.real_paths := false
|
||||
#endif
|
||||
|
||||
|
|
@ -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