367 lines
12 KiB
OCaml
367 lines
12 KiB
OCaml
open Data
|
|
open Runtime_lib
|
|
open Runtime_base
|
|
|
|
let wrap_array_id a = ptr @@ Array a
|
|
|
|
let unwrap_array_id = onptr @@ function
|
|
| Array a -> a
|
|
| _ -> assert false
|
|
|
|
let unwrap_position = onptr @@ function
|
|
| Record r ->
|
|
Lexing.
|
|
{ pos_fname = unwrap_string !(SMap.find "pos_fname" r);
|
|
pos_lnum = unwrap_int !(SMap.find "pos_lnum" r);
|
|
pos_bol = unwrap_int !(SMap.find "pos_bol" r);
|
|
pos_cnum = unwrap_int !(SMap.find "pos_cnum" r)
|
|
}
|
|
| _ -> assert false
|
|
|
|
let wrap_position Lexing.{ pos_fname; pos_lnum; pos_bol; pos_cnum } =
|
|
ptr @@ Record
|
|
(SMap.of_seq
|
|
@@ List.to_seq
|
|
[ ("pos_fname", ref (wrap_string pos_fname));
|
|
("pos_lnum", ref (wrap_int pos_lnum));
|
|
("pos_bol", ref (wrap_int pos_bol));
|
|
("pos_cnum", ref (wrap_int pos_cnum))
|
|
])
|
|
|
|
let wrap_gc_stat
|
|
Gc.
|
|
{ minor_words;
|
|
promoted_words;
|
|
major_words;
|
|
minor_collections;
|
|
major_collections;
|
|
heap_words;
|
|
heap_chunks;
|
|
live_words;
|
|
live_blocks;
|
|
free_words;
|
|
free_blocks;
|
|
largest_free;
|
|
fragments;
|
|
compactions;
|
|
top_heap_words;
|
|
stack_size
|
|
}
|
|
=
|
|
ptr @@ Record
|
|
(SMap.of_seq
|
|
@@ List.to_seq
|
|
[ ("minor_words", ref (wrap_float minor_words));
|
|
("promoted_words", ref (wrap_float promoted_words));
|
|
("major_words", ref (wrap_float major_words));
|
|
("minor_collections", ref (wrap_int minor_collections));
|
|
("major_collections", ref (wrap_int major_collections));
|
|
("heap_words", ref (wrap_int heap_words));
|
|
("heap_chunks", ref (wrap_int heap_chunks));
|
|
("live_words", ref (wrap_int live_words));
|
|
("live_blocks", ref (wrap_int live_blocks));
|
|
("free_words", ref (wrap_int free_words));
|
|
("free_blocks", ref (wrap_int free_blocks));
|
|
("largest_free", ref (wrap_int largest_free));
|
|
("fragments", ref (wrap_int fragments));
|
|
("compactions", ref (wrap_int compactions));
|
|
("top_heap_words", ref (wrap_int top_heap_words));
|
|
("stack_size", ref (wrap_int stack_size))
|
|
])
|
|
|
|
type parser_env =
|
|
{ mutable s_stack : int array;
|
|
(* States *)
|
|
mutable v_stack : Obj.t array;
|
|
(* Semantic attributes *)
|
|
mutable symb_start_stack : Lexing.position array;
|
|
(* Start positions *)
|
|
mutable symb_end_stack : Lexing.position array;
|
|
(* End positions *)
|
|
mutable stacksize : int;
|
|
(* Size of the stacks *)
|
|
mutable stackbase : int;
|
|
(* Base sp for current parse *)
|
|
mutable curr_char : int;
|
|
(* Last token read *)
|
|
mutable lval : Obj.t;
|
|
(* Its semantic attribute *)
|
|
mutable symb_start : Lexing.position;
|
|
(* Start pos. of the current symbol*)
|
|
mutable symb_end : Lexing.position;
|
|
(* End pos. of the current symbol *)
|
|
mutable asp : int;
|
|
(* The stack pointer for attributes *)
|
|
mutable rule_len : int;
|
|
(* Number of rhs items in the rule *)
|
|
mutable rule_number : int;
|
|
(* Rule number to reduce by *)
|
|
mutable sp : int;
|
|
(* Saved sp for parse_engine *)
|
|
mutable state : int;
|
|
(* Saved state for parse_engine *)
|
|
mutable errflag : int
|
|
}
|
|
|
|
(* Saved error flag for parse_engine *)
|
|
|
|
type parse_tables =
|
|
{ actions : (parser_env -> Obj.t) array;
|
|
transl_const : int array;
|
|
transl_block : int array;
|
|
lhs : string;
|
|
len : string;
|
|
defred : string;
|
|
dgoto : string;
|
|
sindex : string;
|
|
rindex : string;
|
|
gindex : string;
|
|
tablesize : int;
|
|
table : string;
|
|
check : string;
|
|
error_function : string -> unit;
|
|
names_const : string;
|
|
names_block : string
|
|
}
|
|
|
|
type parser_input =
|
|
| Start
|
|
| Token_read
|
|
| Stacks_grown_1
|
|
| Stacks_grown_2
|
|
| Semantic_action_computed
|
|
| Error_detected
|
|
|
|
let unwrap_parser_input = onptr @@ function
|
|
| Constructor ("Start", _, None) -> Start
|
|
| Constructor ("Token_read", _, None) -> Token_read
|
|
| Constructor ("Stacks_grown_1", _, None) -> Stacks_grown_1
|
|
| Constructor ("Stacks_grown_2", _, None) -> Stacks_grown_2
|
|
| Constructor ("Semantic_action_computed", _, None) ->
|
|
Semantic_action_computed
|
|
| Constructor ("Error_detected", _, None) -> Error_detected
|
|
| _ -> assert false
|
|
|
|
type parser_output =
|
|
| Read_token
|
|
| Raise_parse_error
|
|
| Grow_stacks_1
|
|
| Grow_stacks_2
|
|
| Compute_semantic_action
|
|
| Call_error_function
|
|
|
|
let wrap_parser_output = function
|
|
| Read_token -> cc "Read_token" 0
|
|
| Raise_parse_error -> cc "Raise_parse_error" 1
|
|
| Grow_stacks_1 -> cc "Grow_stacks_1" 2
|
|
| Grow_stacks_2 -> cc "Grow_stacks_2" 3
|
|
| Compute_semantic_action -> cc "Compute_semantic_action" 4
|
|
| Call_error_function -> cc "Call_error_function" 5
|
|
|
|
let unwrap_parser_env = onptr @@ function
|
|
| Record r ->
|
|
{ s_stack = unwrap_array unwrap_int !(SMap.find "s_stack" r);
|
|
v_stack = Obj.magic (unwrap_array_id !(SMap.find "v_stack" r));
|
|
symb_start_stack =
|
|
unwrap_array unwrap_position !(SMap.find "symb_start_stack" r);
|
|
symb_end_stack =
|
|
unwrap_array unwrap_position !(SMap.find "symb_end_stack" r);
|
|
stacksize = unwrap_int !(SMap.find "stacksize" r);
|
|
stackbase = unwrap_int !(SMap.find "stackbase" r);
|
|
curr_char = unwrap_int !(SMap.find "curr_char" r);
|
|
lval = Obj.repr !(SMap.find "lval" r);
|
|
symb_start = unwrap_position !(SMap.find "symb_start" r);
|
|
symb_end = unwrap_position !(SMap.find "symb_end" r);
|
|
asp = unwrap_int !(SMap.find "asp" r);
|
|
rule_len = unwrap_int !(SMap.find "rule_len" r);
|
|
rule_number = unwrap_int !(SMap.find "rule_number" r);
|
|
sp = unwrap_int !(SMap.find "sp" r);
|
|
state = unwrap_int !(SMap.find "state" r);
|
|
errflag = unwrap_int !(SMap.find "errflag" r)
|
|
}
|
|
| _ -> assert false
|
|
|
|
let sync_parser_env pe = onptr @@ function
|
|
| Record r ->
|
|
SMap.find "s_stack" r := wrap_array wrap_int pe.s_stack;
|
|
SMap.find "v_stack" r := wrap_array_id (Obj.magic pe.v_stack);
|
|
SMap.find "symb_start_stack" r
|
|
:= wrap_array wrap_position pe.symb_start_stack;
|
|
SMap.find "symb_end_stack" r := wrap_array wrap_position pe.symb_end_stack;
|
|
SMap.find "stacksize" r := wrap_int pe.stacksize;
|
|
SMap.find "stackbase" r := wrap_int pe.stackbase;
|
|
SMap.find "curr_char" r := wrap_int pe.curr_char;
|
|
SMap.find "lval" r := Obj.obj pe.lval;
|
|
SMap.find "symb_start" r := wrap_position pe.symb_start;
|
|
SMap.find "symb_end" r := wrap_position pe.symb_end;
|
|
SMap.find "asp" r := wrap_int pe.asp;
|
|
SMap.find "rule_len" r := wrap_int pe.rule_len;
|
|
SMap.find "rule_number" r := wrap_int pe.rule_number;
|
|
SMap.find "sp" r := wrap_int pe.sp;
|
|
SMap.find "state" r := wrap_int pe.state;
|
|
SMap.find "errflag" r := wrap_int pe.errflag
|
|
| _ -> assert false
|
|
|
|
let apply_ref =
|
|
ref
|
|
(fun _ _ -> assert false
|
|
: value -> (Asttypes.arg_label * value) list -> value)
|
|
|
|
let unwrap_parse_tables syncenv = onptr @@ function
|
|
| Record r ->
|
|
let actions =
|
|
unwrap_array
|
|
(fun fv pe ->
|
|
sync_parser_env pe syncenv;
|
|
Obj.repr (!apply_ref fv [ (Asttypes.Nolabel, syncenv) ]))
|
|
!(SMap.find "actions" r)
|
|
in
|
|
{ actions;
|
|
transl_const = unwrap_array unwrap_int !(SMap.find "transl_const" r);
|
|
transl_block = unwrap_array unwrap_int !(SMap.find "transl_block" r);
|
|
lhs = unwrap_string_unsafe !(SMap.find "lhs" r);
|
|
len = unwrap_string_unsafe !(SMap.find "len" r);
|
|
defred = unwrap_string_unsafe !(SMap.find "defred" r);
|
|
dgoto = unwrap_string_unsafe !(SMap.find "dgoto" r);
|
|
sindex = unwrap_string_unsafe !(SMap.find "sindex" r);
|
|
rindex = unwrap_string_unsafe !(SMap.find "rindex" r);
|
|
gindex = unwrap_string_unsafe !(SMap.find "gindex" r);
|
|
tablesize = unwrap_int !(SMap.find "tablesize" r);
|
|
table = unwrap_string_unsafe !(SMap.find "table" r);
|
|
check = unwrap_string_unsafe !(SMap.find "check" r);
|
|
error_function =
|
|
(fun s ->
|
|
unwrap_unit
|
|
(!apply_ref
|
|
!(SMap.find "error_function" r)
|
|
[ (Asttypes.Nolabel, wrap_string s) ]));
|
|
names_const = unwrap_string_unsafe !(SMap.find "names_const" r);
|
|
names_block = unwrap_string_unsafe !(SMap.find "names_block" r)
|
|
}
|
|
| _ -> assert false
|
|
|
|
external parse_engine
|
|
: parse_tables ->
|
|
parser_env ->
|
|
parser_input ->
|
|
Obj.t ->
|
|
parser_output
|
|
= "caml_parse_engine"
|
|
|
|
external lex_engine
|
|
: Lexing.lex_tables ->
|
|
int ->
|
|
Lexing.lexbuf ->
|
|
int
|
|
= "caml_lex_engine"
|
|
|
|
external new_lex_engine
|
|
: Lexing.lex_tables ->
|
|
int ->
|
|
Lexing.lexbuf ->
|
|
int
|
|
= "caml_new_lex_engine"
|
|
|
|
let parse_engine_wrapper tables env input token =
|
|
let nenv = unwrap_parser_env env in
|
|
let tbls = unwrap_parse_tables env tables in
|
|
let obj =
|
|
if input = Semantic_action_computed
|
|
then Obj.repr token
|
|
else (
|
|
match Ptr.get token with
|
|
| Constructor (_c, d, None) -> Obj.repr d
|
|
| Constructor (_c, d, Some arg) ->
|
|
let w = Obj.repr (Some arg) in
|
|
Obj.set_tag w d;
|
|
w
|
|
| _ -> assert false)
|
|
in
|
|
let res = parse_engine tbls nenv input obj in
|
|
sync_parser_env nenv env;
|
|
res
|
|
|
|
let unwrap_lexbuf v =
|
|
match Ptr.get v with
|
|
| Record r ->
|
|
let open Lexing in
|
|
{ refill_buff = (fun _ -> assert false);
|
|
lex_buffer = unwrap_bytes !(SMap.find "lex_buffer" r);
|
|
lex_buffer_len = unwrap_int !(SMap.find "lex_buffer_len" r);
|
|
lex_abs_pos = unwrap_int !(SMap.find "lex_abs_pos" r);
|
|
lex_start_pos = unwrap_int !(SMap.find "lex_start_pos" r);
|
|
lex_curr_pos = unwrap_int !(SMap.find "lex_curr_pos" r);
|
|
lex_last_pos = unwrap_int !(SMap.find "lex_last_pos" r);
|
|
lex_last_action = unwrap_int !(SMap.find "lex_last_action" r);
|
|
lex_eof_reached = unwrap_bool !(SMap.find "lex_eof_reached" r);
|
|
lex_mem = unwrap_array unwrap_int !(SMap.find "lex_mem" r);
|
|
lex_start_p = unwrap_position !(SMap.find "lex_start_p" r);
|
|
lex_curr_p = unwrap_position !(SMap.find "lex_curr_p" r)
|
|
}
|
|
| _ -> assert false
|
|
|
|
let sync_lexbuf v lb =
|
|
match Ptr.get v with
|
|
| Record r ->
|
|
let open Lexing in
|
|
SMap.find "lex_buffer" r := wrap_bytes lb.lex_buffer;
|
|
SMap.find "lex_buffer_len" r := wrap_int lb.lex_buffer_len;
|
|
SMap.find "lex_abs_pos" r := wrap_int lb.lex_abs_pos;
|
|
SMap.find "lex_start_pos" r := wrap_int lb.lex_start_pos;
|
|
SMap.find "lex_curr_pos" r := wrap_int lb.lex_curr_pos;
|
|
SMap.find "lex_last_pos" r := wrap_int lb.lex_last_pos;
|
|
SMap.find "lex_last_action" r := wrap_int lb.lex_last_action;
|
|
SMap.find "lex_eof_reached" r := wrap_bool lb.lex_eof_reached;
|
|
SMap.find "lex_mem" r := wrap_array wrap_int lb.lex_mem;
|
|
SMap.find "lex_start_p" r := wrap_position lb.lex_start_p;
|
|
SMap.find "lex_curr_p" r := wrap_position lb.lex_curr_p
|
|
| _ -> assert false
|
|
|
|
let unwrap_lex_tables = onptr @@ function
|
|
| Record r ->
|
|
let gs f = unwrap_string_unsafe !(SMap.find f r) in
|
|
let open Lexing in
|
|
{ lex_base = gs "lex_base";
|
|
lex_backtrk = gs "lex_backtrk";
|
|
lex_default = gs "lex_default";
|
|
lex_trans = gs "lex_trans";
|
|
lex_check = gs "lex_check";
|
|
lex_base_code = gs "lex_base_code";
|
|
lex_backtrk_code = gs "lex_backtrk_code";
|
|
lex_default_code = gs "lex_default_code";
|
|
lex_trans_code = gs "lex_trans_code";
|
|
lex_check_code = gs "lex_check_code";
|
|
lex_code = gs "lex_code"
|
|
}
|
|
| _ -> assert false
|
|
|
|
let lex_engine_wrapper tables n lexbuf =
|
|
let nbuf = unwrap_lexbuf lexbuf in
|
|
let tbls = unwrap_lex_tables tables in
|
|
let res = lex_engine tbls n nbuf in
|
|
sync_lexbuf lexbuf nbuf;
|
|
res
|
|
|
|
let new_lex_engine_wrapper tables n lexbuf =
|
|
let nbuf = unwrap_lexbuf lexbuf in
|
|
let tbls = unwrap_lex_tables tables in
|
|
let res = new_lex_engine tbls n nbuf in
|
|
sync_lexbuf lexbuf nbuf;
|
|
res
|
|
|
|
let parse_engine_prim =
|
|
prim4
|
|
parse_engine_wrapper
|
|
wrap_exn
|
|
id
|
|
id
|
|
unwrap_parser_input
|
|
id
|
|
wrap_parser_output
|
|
|
|
let lex_engine_prim =
|
|
prim3 lex_engine_wrapper wrap_exn id unwrap_int id wrap_int
|
|
|
|
let new_lex_engine_prim =
|
|
prim3 new_lex_engine_wrapper wrap_exn id unwrap_int id wrap_int
|