update optcomp
Ignore-this: 524a25072a03d9507026255ae6189510 darcs-hash:20111223215332-c41ad-712fbfc49be95dd491957de824bbec079517be11
This commit is contained in:
Jeremie Dimino
parent
b340d4292d
commit
516f2c4800
|
|
@ -38,8 +38,8 @@ 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_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
|
||||
|
|
@ -62,9 +62,9 @@ let next_quotation_id =
|
|||
let r = ref 0 in
|
||||
fun _ -> incr r; !r
|
||||
|
||||
(* +-------------+
|
||||
| Environment |
|
||||
+-------------+ *)
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Environment |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let env = ref Env.empty
|
||||
let define id value = env := Env.add id value !env
|
||||
|
|
@ -75,9 +75,9 @@ let _ =
|
|||
let dirs = ref []
|
||||
let add_include_dir dir = dirs := dir :: !dirs
|
||||
|
||||
(* +--------------+
|
||||
| Dependencies |
|
||||
+--------------+ *)
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Dependencies |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
module String_set = Set.Make(String)
|
||||
|
||||
|
|
@ -108,9 +108,9 @@ let write_depencies () =
|
|||
end;
|
||||
close_out oc
|
||||
|
||||
(* +----------------------------------------+
|
||||
| Value to expression/pattern conversion |
|
||||
+----------------------------------------+ *)
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Value to expression/pattern conversion |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let rec expr_of_value _loc = function
|
||||
| Bool true -> <:expr< true >>
|
||||
|
|
@ -132,9 +132,83 @@ let rec patt_of_value _loc = function
|
|||
| Tuple [x] -> patt_of_value _loc x
|
||||
| Tuple l -> <:patt< $tup:Ast.paCom_of_list (List.map (patt_of_value _loc) l)$ >>
|
||||
|
||||
(* +-----------------------+
|
||||
| Expression evaluation |
|
||||
+-----------------------+ *)
|
||||
(* +-----------------------------------------------------------------+
|
||||
| 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
|
||||
|
|
@ -225,32 +299,101 @@ let rec eval env = function
|
|||
| <: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 env p vx
|
||||
with
|
||||
Exit -> invalid_type (Ast.loc_of_expr x) (type_of_patt p) (type_of_value vx)
|
||||
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 env patt value = match patt with
|
||||
| <:patt< $lid:id$ >> ->
|
||||
Env.add id value env
|
||||
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 env patts values
|
||||
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")
|
||||
|
||||
|
|
@ -274,13 +417,17 @@ 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 |
|
||||
+-----------------------+ *)
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Parsing of directives |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let rec skip_space stream = match Stream.peek stream with
|
||||
| Some((BLANKS _ | COMMENT _), _) ->
|
||||
|
|
@ -289,12 +436,6 @@ let rec skip_space stream = match Stream.peek stream with
|
|||
| _ ->
|
||||
()
|
||||
|
||||
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
|
||||
|
|
@ -324,37 +465,44 @@ let parse_ident stream =
|
|||
let tok, loc = Stream.next stream in
|
||||
begin match tok with
|
||||
| LIDENT id | UIDENT id ->
|
||||
id
|
||||
(id, loc)
|
||||
| KEYWORD kwd when keyword_is_id kwd ->
|
||||
kwd
|
||||
(kwd, loc)
|
||||
| _ ->
|
||||
Loc.raise loc (Stream.Error "identifier expected")
|
||||
end
|
||||
|
||||
let parse_expr stream =
|
||||
let parse_until entry is_stop_token stream =
|
||||
(* Lists of opened brackets *)
|
||||
let opened_brackets = ref [] 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 _ =
|
||||
Some(match Stream.next stream, !opened_brackets with
|
||||
| (NEWLINE, loc), [] ->
|
||||
EOI, loc
|
||||
| (tok, loc), [] when is_stop_token tok ->
|
||||
end_loc := loc;
|
||||
(EOI, loc)
|
||||
|
||||
| (KEYWORD("(" | "[" | "{" as b), _) as x, l ->
|
||||
| (EOI, loc), _ ->
|
||||
end_loc := loc;
|
||||
(EOI, loc)
|
||||
|
||||
| ((KEYWORD ("(" | "[" | "{" as b) | SYMBOL ("(" | "[" | "{" as b)), _) as x, l ->
|
||||
opened_brackets := b :: l;
|
||||
x
|
||||
|
||||
| (KEYWORD ")", loc) as x, "(" :: l ->
|
||||
| ((KEYWORD ")" | SYMBOL ")"), loc) as x, "(" :: l ->
|
||||
opened_brackets := l;
|
||||
x
|
||||
|
||||
| (KEYWORD "]", loc) as x, "[" :: l ->
|
||||
| ((KEYWORD "]" | SYMBOL "]"), loc) as x, "[" :: l ->
|
||||
opened_brackets := l;
|
||||
x
|
||||
|
||||
| (KEYWORD "}", loc) as x, "{" :: l ->
|
||||
| ((KEYWORD "}" | SYMBOL "}"), loc) as x, "{" :: l ->
|
||||
opened_brackets := l;
|
||||
x
|
||||
|
||||
|
|
@ -362,81 +510,77 @@ let parse_expr stream =
|
|||
x)
|
||||
in
|
||||
|
||||
Gram.parse_tokens_before_filter Syntax.expr_eoi
|
||||
(not_filtered (Stream.from next_token))
|
||||
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 "#", loc) ->
|
||||
| Some((KEYWORD "#" | SYMBOL "#"), loc) -> begin
|
||||
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
|
||||
let dir, loc_dir = parse_ident stream in
|
||||
|
||||
begin match parse_ident stream with
|
||||
match dir with
|
||||
|
||||
| "let" ->
|
||||
let id = parse_ident stream in
|
||||
parse_equal stream;
|
||||
let expr = parse_expr stream in
|
||||
Some(Dir_let(id, expr), loc)
|
||||
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 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)
|
||||
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" ->
|
||||
Some(Dir_if(parse_expr stream), loc)
|
||||
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)
|
||||
Some(Dir_else, Loc.merge loc loc_dir)
|
||||
|
||||
| "elif" ->
|
||||
Some(Dir_elif(parse_expr stream), loc)
|
||||
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)
|
||||
Some(Dir_endif, Loc.merge loc loc_dir)
|
||||
|
||||
| "include" ->
|
||||
Some(Dir_include(parse_expr stream), loc)
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_include expr, Loc.merge loc end_loc)
|
||||
|
||||
| "directory" ->
|
||||
Some(Dir_directory(parse_expr stream), loc)
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_directory expr, Loc.merge loc end_loc)
|
||||
|
||||
| "error" ->
|
||||
Some(Dir_error(parse_expr stream), loc)
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_error expr, Loc.merge loc end_loc)
|
||||
|
||||
| "warning" ->
|
||||
Some(Dir_warning(parse_expr stream), loc)
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_warning expr, Loc.merge loc end_loc)
|
||||
|
||||
| "default_quotation" ->
|
||||
Some(Dir_default_quotation(parse_expr stream), loc)
|
||||
let expr, end_loc = parse_expr stream in
|
||||
Some(Dir_default_quotation expr, Loc.merge loc end_loc)
|
||||
|
||||
| dir ->
|
||||
Loc.raise loc (Stream.Error (Printf.sprintf "bad directive ``%s''" dir))
|
||||
end
|
||||
| _ ->
|
||||
Loc.raise loc_dir (Stream.Error (Printf.sprintf "unknown directive ``%s''" dir))
|
||||
end
|
||||
|
||||
| _ ->
|
||||
None
|
||||
|
|
@ -447,9 +591,9 @@ let parse_command_line_define str =
|
|||
| <:expr< $uid:id$ = $e$ >> -> define id (eval !env e)
|
||||
| _ -> invalid_arg str
|
||||
|
||||
(* +----------------+
|
||||
| BLock skipping |
|
||||
+----------------+ *)
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Block skipping |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let rec skip_line stream =
|
||||
match Stream.next stream with
|
||||
|
|
@ -507,9 +651,9 @@ and skip_else stream =
|
|||
| _ ->
|
||||
skip_else stream
|
||||
|
||||
(* +-----------------+
|
||||
| Token filtering |
|
||||
+-----------------+ *)
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Token filtering |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type context = Ctx_if | Ctx_else
|
||||
|
||||
|
|
@ -555,7 +699,7 @@ let really_read state =
|
|||
(tok, loc)
|
||||
|
||||
(* Return the next token from a stream, interpreting directives. *)
|
||||
let rec next_token state_ref =
|
||||
let rec next_token lexer state_ref =
|
||||
let state = !state_ref in
|
||||
if state.bol then
|
||||
match parse_directive state.stream, state.stack with
|
||||
|
|
@ -563,18 +707,18 @@ let rec next_token state_ref =
|
|||
let rec aux e =
|
||||
if eval_bool !env e then begin
|
||||
state.stack <- Ctx_if :: state.stack;
|
||||
next_token state_ref
|
||||
next_token lexer state_ref
|
||||
end else
|
||||
match next_endif state.stream with
|
||||
| Dir_else ->
|
||||
state.stack <- Ctx_else :: state.stack;
|
||||
next_token state_ref
|
||||
next_token lexer state_ref
|
||||
|
||||
| Dir_elif e ->
|
||||
aux e
|
||||
|
||||
| Dir_endif ->
|
||||
next_token state_ref
|
||||
next_token lexer state_ref
|
||||
|
||||
| _ ->
|
||||
assert false
|
||||
|
|
@ -593,25 +737,36 @@ let rec next_token state_ref =
|
|||
| Some(Dir_else, loc), Ctx_if :: l ->
|
||||
skip_else state.stream;
|
||||
state.stack <- l;
|
||||
next_token state_ref
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_elif _, loc), Ctx_if :: l ->
|
||||
skip_if state.stream;
|
||||
state.stack <- l;
|
||||
next_token state_ref
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_endif, loc), _ :: l ->
|
||||
state.stack <- l;
|
||||
next_token state_ref
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_let(id, e), _), _ ->
|
||||
define id (eval !env e);
|
||||
next_token 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(id, e), _), _ ->
|
||||
if not (Env.mem id !env) then
|
||||
define id (eval !env e);
|
||||
next_token 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
|
||||
|
|
@ -626,7 +781,7 @@ let rec next_token state_ref =
|
|||
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)));
|
||||
stream = lexer fname ic;
|
||||
bol = true;
|
||||
stack = [];
|
||||
on_eoi = (fun _ ->
|
||||
|
|
@ -634,27 +789,27 @@ let rec next_token state_ref =
|
|||
eoi *)
|
||||
state_ref := state;
|
||||
close_in ic;
|
||||
next_token state_ref)
|
||||
next_token lexer state_ref)
|
||||
} in
|
||||
(* Replace current state with the new one *)
|
||||
state_ref := nested_state;
|
||||
next_token state_ref
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_directory e, loc), _ ->
|
||||
let dir = eval_string !env e in
|
||||
add_include_dir dir;
|
||||
next_token state_ref
|
||||
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 state_ref
|
||||
next_token lexer state_ref
|
||||
|
||||
| Some(Dir_default_quotation e, loc), _ ->
|
||||
Syntax.Quotation.default := eval_string !env e;
|
||||
next_token state_ref
|
||||
next_token lexer state_ref
|
||||
|
||||
| None, _ ->
|
||||
really_read state
|
||||
|
|
@ -662,41 +817,52 @@ let rec next_token state_ref =
|
|||
else
|
||||
really_read state
|
||||
|
||||
let stream_filter filter stream =
|
||||
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)
|
||||
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)))
|
||||
filter (Stream.from (fun _ -> Some(next_token lexer state_ref)))
|
||||
|
||||
(* +----------------------+
|
||||
| Quotations expansion |
|
||||
+----------------------+ *)
|
||||
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 (Hashtbl.find quotations (int_of_string contents))
|
||||
with
|
||||
exn -> Loc.raise loc (Failure "fatal error in optcomp!")
|
||||
f loc (get_quotation_value contents)
|
||||
with exn ->
|
||||
Loc.raise loc (Failure "fatal error in optcomp!")
|
||||
|
||||
(* +--------------+
|
||||
| Registration |
|
||||
+--------------+ *)
|
||||
(* +-----------------------------------------------------------------+
|
||||
| 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>.";
|
||||
|
|
@ -706,4 +872,4 @@ let _ =
|
|||
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
|
||||
Gram.Token.Filter.define_filter (Gram.get_filter ()) (stream_filter default_lexer)
|
||||
|
|
|
|||
Loading…
Reference in New Issue