ocaml 3.13 ready
Ignore-this: 390ddd9264558fd4af5b1d437e817982 darcs-hash:20110803175530-c41ad-a1aeeb47c9c3294e7815a62dcb3d532276a235bf
This commit is contained in:
Jeremie Dimino
parent
fa942b0750
commit
45ed680139
6
_oasis
6
_oasis
|
|
@ -18,6 +18,12 @@ Description: Universal toplevel for OCaml
|
|||
# | The toplevel |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
Library "optcomp"
|
||||
Install: false
|
||||
Path: syntax
|
||||
Modules: Pa_optcomp
|
||||
BuildDepends: camlp4.lib, camlp4.quotations.o
|
||||
|
||||
Library utop
|
||||
Path: src
|
||||
Modules: UTop
|
||||
|
|
|
|||
3
_tags
3
_tags
|
|
@ -1,6 +1,7 @@
|
|||
# -*- conf -*-
|
||||
|
||||
<**/*.ml>: syntax_camlp4o, pkg_lwt.syntax
|
||||
<**/*.ml>: syntax_camlp4o, pkg_lwt.syntax, pa_optcomp
|
||||
<syntax/*.ml>: -pa_optcomp
|
||||
<src/*>: use_compiler_libs, pkg_lambda-term, pkg_findlib
|
||||
<**/*.top>: use_utop
|
||||
<**/uTop_emacs_top.top>: pkg_threads
|
||||
|
|
|
|||
|
|
@ -22,6 +22,12 @@ let () =
|
|||
(* Use -linkpkg for creating toplevels *)
|
||||
flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg";
|
||||
|
||||
(* Optcomp *)
|
||||
flag ["ocaml"; "compile"; "pa_optcomp"] & S[A"-ppopt"; A "syntax/pa_optcomp.cmo"];
|
||||
flag ["ocaml"; "ocamldep"; "pa_optcomp"] & S[A"-ppopt"; A "syntax/pa_optcomp.cmo"];
|
||||
flag ["ocaml"; "doc"; "pa_optcomp"] & S[A"-ppopt"; A "syntax/pa_optcomp.cmo"];
|
||||
dep ["ocaml"; "ocamldep"; "pa_optcomp"] ["syntax/pa_optcomp.cmo"];
|
||||
|
||||
let env = BaseEnvLight.load () in
|
||||
let path = BaseEnvLight.var_get "compiler_libs" env in
|
||||
let stdlib = BaseEnvLight.var_get "standard_library" env in
|
||||
|
|
|
|||
|
|
@ -344,7 +344,11 @@ let add_fields_of_type decl acc =
|
|||
let add_names_of_type decl acc =
|
||||
match decl.type_kind with
|
||||
| Type_variant constructors ->
|
||||
#if ocaml_version >= (3, 13)
|
||||
List.fold_left (fun acc (name, _, _) -> add name acc) acc constructors
|
||||
#else
|
||||
List.fold_left (fun acc (name, _) -> add name acc) acc constructors
|
||||
#endif
|
||||
| Type_record(fields, _) ->
|
||||
List.fold_left (fun acc (name, _, _) -> add name acc) acc fields
|
||||
| Type_abstract ->
|
||||
|
|
|
|||
|
|
@ -0,0 +1,709 @@
|
|||
(*
|
||||
* 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 ident * Ast.expr
|
||||
| Dir_default of ident * 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" (fun major minor -> Tuple [Int major; Int minor]))
|
||||
|
||||
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)$ >>
|
||||
|
||||
(* +-----------------------+
|
||||
| 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 or 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)
|
||||
|
||||
(* Let-binding *)
|
||||
| <:expr< let $p$ = $x$ in $y$ >> ->
|
||||
let vx = eval env x in
|
||||
let env =
|
||||
try
|
||||
bind 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 env patt value = match patt with
|
||||
| <:patt< $lid:id$ >> ->
|
||||
Env.add id value 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 env patts values
|
||||
| _ ->
|
||||
raise Exit
|
||||
end
|
||||
|
||||
| _ ->
|
||||
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_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 parse_equal stream =
|
||||
skip_space stream;
|
||||
match Stream.next stream with
|
||||
| KEYWORD "=", _ -> ()
|
||||
| _, loc -> Loc.raise loc (Stream.Error "'=' expected")
|
||||
|
||||
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
|
||||
| KEYWORD kwd when keyword_is_id kwd ->
|
||||
kwd
|
||||
| _ ->
|
||||
Loc.raise loc (Stream.Error "identifier expected")
|
||||
end
|
||||
|
||||
let parse_expr stream =
|
||||
(* Lists of opened brackets *)
|
||||
let opened_brackets = ref [] in
|
||||
|
||||
(* Return the next token of [stream] until all opened parentheses
|
||||
have been closed and a newline is reached *)
|
||||
let rec next_token _ =
|
||||
Some(match Stream.next stream, !opened_brackets with
|
||||
| (NEWLINE, loc), [] ->
|
||||
EOI, loc
|
||||
|
||||
| (KEYWORD("(" | "[" | "{" as b), _) as x, l ->
|
||||
opened_brackets := b :: l;
|
||||
x
|
||||
|
||||
| (KEYWORD ")", loc) as x, "(" :: l ->
|
||||
opened_brackets := l;
|
||||
x
|
||||
|
||||
| (KEYWORD "]", loc) as x, "[" :: l ->
|
||||
opened_brackets := l;
|
||||
x
|
||||
|
||||
| (KEYWORD "}", loc) as x, "{" :: l ->
|
||||
opened_brackets := l;
|
||||
x
|
||||
|
||||
| x, _ ->
|
||||
x)
|
||||
in
|
||||
|
||||
Gram.parse_tokens_before_filter Syntax.expr_eoi
|
||||
(not_filtered (Stream.from next_token))
|
||||
|
||||
let parse_directive stream = match Stream.peek stream with
|
||||
| Some(KEYWORD "#", loc) ->
|
||||
Stream.junk stream;
|
||||
|
||||
(* Move the location to the beginning of the line *)
|
||||
let (file_name,
|
||||
start_line, start_bol, start_off,
|
||||
stop_line, stop_bol, stop_off,
|
||||
ghost) = Loc.to_tuple loc in
|
||||
let loc = Loc.of_tuple (file_name,
|
||||
start_line, start_bol, start_bol,
|
||||
start_line, start_bol, start_bol,
|
||||
ghost) in
|
||||
|
||||
begin match parse_ident stream with
|
||||
|
||||
| "let" ->
|
||||
let id = parse_ident stream in
|
||||
parse_equal stream;
|
||||
let expr = parse_expr stream in
|
||||
Some(Dir_let(id, expr), loc)
|
||||
|
||||
| "let_default" ->
|
||||
let id = parse_ident stream in
|
||||
parse_equal stream;
|
||||
let expr = parse_expr stream in
|
||||
Some(Dir_default(id, expr), loc)
|
||||
|
||||
(* For compatibility *)
|
||||
| "define" ->
|
||||
let id = parse_ident stream in
|
||||
let expr = parse_expr stream in
|
||||
Some(Dir_let(id, expr), loc)
|
||||
|
||||
(* For compatibility *)
|
||||
| "default" ->
|
||||
let id = parse_ident stream in
|
||||
let expr = parse_expr stream in
|
||||
Some(Dir_default(id, expr), loc)
|
||||
|
||||
| "if" ->
|
||||
Some(Dir_if(parse_expr stream), loc)
|
||||
|
||||
| "else" ->
|
||||
parse_eol stream;
|
||||
Some(Dir_else, loc)
|
||||
|
||||
| "elif" ->
|
||||
Some(Dir_elif(parse_expr stream), loc)
|
||||
|
||||
| "endif" ->
|
||||
parse_eol stream;
|
||||
Some(Dir_endif, loc)
|
||||
|
||||
| "include" ->
|
||||
Some(Dir_include(parse_expr stream), loc)
|
||||
|
||||
| "directory" ->
|
||||
Some(Dir_directory(parse_expr stream), loc)
|
||||
|
||||
| "error" ->
|
||||
Some(Dir_error(parse_expr stream), loc)
|
||||
|
||||
| "warning" ->
|
||||
Some(Dir_warning(parse_expr stream), loc)
|
||||
|
||||
| "default_quotation" ->
|
||||
Some(Dir_default_quotation(parse_expr stream), loc)
|
||||
|
||||
| dir ->
|
||||
Loc.raise loc (Stream.Error (Printf.sprintf "bad 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 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 state_ref
|
||||
end else
|
||||
match next_endif state.stream with
|
||||
| Dir_else ->
|
||||
state.stack <- Ctx_else :: state.stack;
|
||||
next_token state_ref
|
||||
|
||||
| Dir_elif e ->
|
||||
aux e
|
||||
|
||||
| Dir_endif ->
|
||||
next_token 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 state_ref
|
||||
|
||||
| Some(Dir_elif _, loc), Ctx_if :: l ->
|
||||
skip_if state.stream;
|
||||
state.stack <- l;
|
||||
next_token state_ref
|
||||
|
||||
| Some(Dir_endif, loc), _ :: l ->
|
||||
state.stack <- l;
|
||||
next_token state_ref
|
||||
|
||||
| Some(Dir_let(id, e), _), _ ->
|
||||
define id (eval !env e);
|
||||
next_token state_ref
|
||||
|
||||
| Some(Dir_default(id, e), _), _ ->
|
||||
if not (Env.mem id !env) then
|
||||
define id (eval !env e);
|
||||
next_token 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 = Gram.Token.Filter.filter (Gram.get_filter ()) (filter (Gram.lex (Loc.mk fname) (Stream.of_channel ic)));
|
||||
bol = true;
|
||||
stack = [];
|
||||
on_eoi = (fun _ ->
|
||||
(* Restore previous state and close channel on
|
||||
eoi *)
|
||||
state_ref := state;
|
||||
close_in ic;
|
||||
next_token state_ref)
|
||||
} in
|
||||
(* Replace current state with the new one *)
|
||||
state_ref := nested_state;
|
||||
next_token state_ref
|
||||
|
||||
| Some(Dir_directory e, loc), _ ->
|
||||
let dir = eval_string !env e in
|
||||
add_include_dir dir;
|
||||
next_token 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 state_ref
|
||||
|
||||
| Some(Dir_default_quotation e, loc), _ ->
|
||||
Syntax.Quotation.default := eval_string !env e;
|
||||
next_token state_ref
|
||||
|
||||
| None, _ ->
|
||||
really_read state
|
||||
|
||||
else
|
||||
really_read state
|
||||
|
||||
let stream_filter 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 state_ref)))
|
||||
|
||||
(* +----------------------+
|
||||
| Quotations expansion |
|
||||
+----------------------+ *)
|
||||
|
||||
let expand f loc _ contents =
|
||||
try
|
||||
f loc (Hashtbl.find quotations (int_of_string 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 "-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
|
||||
Loading…
Reference in New Issue