Miniml: support more primitives to be able to run the parser
This commit is contained in:
Ekdohibs
parent
8a7a3d7a05
commit
4e3db63291
@ -10,6 +10,7 @@
|
||||
"end", END;
|
||||
"exception", EXCEPTION;
|
||||
"external", EXTERNAL;
|
||||
"false", UIDENT "false";
|
||||
"fun", FUN;
|
||||
"if", IF;
|
||||
"in", IN;
|
||||
@ -22,6 +23,7 @@
|
||||
"rec", REC;
|
||||
"struct", STRUCT;
|
||||
"then", THEN;
|
||||
"true", UIDENT "true";
|
||||
"try", TRY;
|
||||
"type", TYPE;
|
||||
"with", WITH
|
||||
|
||||
158
miniml/interp/buffer.ml
Normal file
158
miniml/interp/buffer.ml
Normal file
@ -0,0 +1,158 @@
|
||||
(**************************************************************************)
|
||||
(* *)
|
||||
(* OCaml *)
|
||||
(* *)
|
||||
(* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1999 Institut National de Recherche en Informatique et *)
|
||||
(* en Automatique. *)
|
||||
(* *)
|
||||
(* All rights reserved. This file is distributed under the terms of *)
|
||||
(* the GNU Lesser General Public License version 2.1, with the *)
|
||||
(* special exception on linking described in the file LICENSE. *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
(* Extensible buffers *)
|
||||
|
||||
type t =
|
||||
{mutable buffer : bytes;
|
||||
mutable position : int;
|
||||
mutable length : int;
|
||||
initial_buffer : bytes}
|
||||
|
||||
let create n =
|
||||
let n = if n < 1 then 1 else n in
|
||||
let s = Bytes.create n in
|
||||
{buffer = s; position = 0; length = n; initial_buffer = s}
|
||||
|
||||
let contents b = Bytes.sub_string b.buffer 0 b.position
|
||||
let to_bytes b = Bytes.sub b.buffer 0 b.position
|
||||
|
||||
let sub b ofs len =
|
||||
if ofs < 0 || len < 0 || ofs > b.position - len
|
||||
then invalid_arg "Buffer.sub"
|
||||
else Bytes.sub_string b.buffer ofs len
|
||||
|
||||
|
||||
let blit src srcoff dst dstoff len =
|
||||
if len < 0 || srcoff < 0 || srcoff > src.position - len
|
||||
|| dstoff < 0 || dstoff > (Bytes.length dst) - len
|
||||
then invalid_arg "Buffer.blit"
|
||||
else
|
||||
Bytes.unsafe_blit src.buffer srcoff dst dstoff len
|
||||
|
||||
|
||||
let nth b ofs =
|
||||
if ofs < 0 || ofs >= b.position then
|
||||
invalid_arg "Buffer.nth"
|
||||
else Bytes.unsafe_get b.buffer ofs
|
||||
|
||||
|
||||
let length b = b.position
|
||||
|
||||
let clear b = b.position <- 0
|
||||
|
||||
let reset b =
|
||||
b.position <- 0; b.buffer <- b.initial_buffer;
|
||||
b.length <- Bytes.length b.buffer
|
||||
|
||||
let rec make_new_len new_len x =
|
||||
if x > !new_len then () else begin new_len := 2 * !new_len; make_new_len new_len x end
|
||||
|
||||
let resize b more =
|
||||
let len = b.length in
|
||||
let new_len = ref len in
|
||||
(* while b.position + more > !new_len do new_len := 2 * !new_len done; *)
|
||||
make_new_len new_len (b.position + more);
|
||||
let new_buffer = Bytes.create !new_len in
|
||||
(* PR#6148: let's keep using [blit] rather than [unsafe_blit] in
|
||||
this tricky function that is slow anyway. *)
|
||||
Bytes.blit b.buffer 0 new_buffer 0 b.position;
|
||||
b.buffer <- new_buffer;
|
||||
b.length <- !new_len
|
||||
|
||||
let add_char b c =
|
||||
let pos = b.position in
|
||||
if pos >= b.length then resize b 1;
|
||||
Bytes.unsafe_set b.buffer pos c;
|
||||
b.position <- pos + 1
|
||||
|
||||
let add_utf_8_uchar b u = let u = Uchar.to_int u in
|
||||
if u < 0 then assert false
|
||||
else if u <= 127 then
|
||||
add_char b (Char.unsafe_chr u)
|
||||
else if u <= 2047 then (*
|
||||
let pos = b.position in
|
||||
if pos + 2 > b.length then resize b 2;
|
||||
Bytes.unsafe_set b.buffer (pos )
|
||||
(Char.unsafe_chr (0xC0 lor (u lsr 6)));
|
||||
Bytes.unsafe_set b.buffer (pos + 1)
|
||||
(Char.unsafe_chr (0x80 lor (u land 0x3F)));
|
||||
b.position <- pos + 2
|
||||
else if u <= 65535 then
|
||||
let pos = b.position in
|
||||
if pos + 3 > b.length then resize b 3;
|
||||
Bytes.unsafe_set b.buffer (pos )
|
||||
(Char.unsafe_chr (0xE0 lor (u lsr 12)));
|
||||
Bytes.unsafe_set b.buffer (pos + 1)
|
||||
(Char.unsafe_chr (0x80 lor ((u lsr 6) land 0x3F)));
|
||||
Bytes.unsafe_set b.buffer (pos + 2)
|
||||
(Char.unsafe_chr (0x80 lor (u land 0x3F)));
|
||||
b.position <- pos + 3
|
||||
else if u <= 1114111 then
|
||||
let pos = b.position in
|
||||
if pos + 4 > b.length then resize b 4;
|
||||
Bytes.unsafe_set b.buffer (pos )
|
||||
(Char.unsafe_chr (0xF0 lor (u lsr 18)));
|
||||
Bytes.unsafe_set b.buffer (pos + 1)
|
||||
(Char.unsafe_chr (0x80 lor ((u lsr 12) land 0x3F)));
|
||||
Bytes.unsafe_set b.buffer (pos + 2)
|
||||
(Char.unsafe_chr (0x80 lor ((u lsr 6) land 0x3F)));
|
||||
Bytes.unsafe_set b.buffer (pos + 3)
|
||||
(Char.unsafe_chr (0x80 lor (u land 0x3F)));
|
||||
b.position <- pos + 4
|
||||
else assert false *) assert false
|
||||
|
||||
let add_substring b s offset len =
|
||||
if offset < 0 || len < 0 || offset > String.length s - len
|
||||
then invalid_arg "Buffer.add_substring/add_subbytes";
|
||||
let new_position = b.position + len in
|
||||
if new_position > b.length then resize b len;
|
||||
Bytes.blit_string s offset b.buffer b.position len;
|
||||
b.position <- new_position
|
||||
|
||||
let add_subbytes b s offset len =
|
||||
add_substring b (Bytes.unsafe_to_string s) offset len
|
||||
|
||||
let add_string b s =
|
||||
let len = String.length s in
|
||||
let new_position = b.position + len in
|
||||
if new_position > b.length then resize b len;
|
||||
Bytes.blit_string s 0 b.buffer b.position len;
|
||||
b.position <- new_position
|
||||
|
||||
let add_bytes b s = add_string b (Bytes.unsafe_to_string s)
|
||||
|
||||
let add_buffer b bs =
|
||||
add_subbytes b bs.buffer 0 bs.position
|
||||
|
||||
(* read up to [len] bytes from [ic] into [b]. *)
|
||||
let rec add_channel_rec b ic len =
|
||||
if len > 0 then (
|
||||
let n = input ic b.buffer b.position len in
|
||||
b.position <- b.position + n;
|
||||
if n = 0 then raise End_of_file
|
||||
else add_channel_rec b ic (len-n) (* n <= len *)
|
||||
)
|
||||
|
||||
let add_channel b ic len =
|
||||
if len < 0 then (* PR#5004 *)
|
||||
invalid_arg "Buffer.add_channel";
|
||||
if b.position + len > b.length then resize b len;
|
||||
add_channel_rec b ic len
|
||||
|
||||
let output_buffer oc b =
|
||||
output oc b.buffer 0 b.position
|
||||
|
||||
|
||||
@ -134,19 +134,18 @@ let empty_text = []
|
||||
let empty_text_lazy = lazy []
|
||||
|
||||
let text_loc = {txt = "ocaml.text"; loc = Location.none}
|
||||
(*
|
||||
|
||||
let text_attr ds =
|
||||
let open Parsetree in
|
||||
let exp =
|
||||
{ pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None));
|
||||
pexp_loc = ds.ds_loc;
|
||||
pexp_attributes = []; }
|
||||
{ Parsetree.pexp_desc = Parsetree.Pexp_constant (Parsetree.Pconst_string(ds.ds_body, None));
|
||||
Parsetree.pexp_loc = ds.ds_loc;
|
||||
Parsetree.pexp_attributes = []; }
|
||||
in
|
||||
let item =
|
||||
{ pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
|
||||
{ Parsetree.pstr_desc = Parsetree.Pstr_eval (exp, []); Parsetree.pstr_loc = exp.Parsetree.pexp_loc }
|
||||
in
|
||||
(text_loc, PStr [item])
|
||||
*)
|
||||
(text_loc, Parsetree.PStr [item])
|
||||
|
||||
let add_text_attrs dsl attrs = (*
|
||||
let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in
|
||||
(List.map text_attr fdsl) @ attrs *) attrs
|
||||
@ -183,10 +182,10 @@ let associate_docstrings dsl = (*
|
||||
dsl *) ()
|
||||
|
||||
(* Map from positions to pre docstrings *)
|
||||
|
||||
(*
|
||||
let pre_table =
|
||||
Hashtbl.create 50
|
||||
|
||||
*)
|
||||
let set_pre_docstrings pos dsl =
|
||||
(* if dsl <> [] then Hashtbl.add pre_table pos dsl *) ()
|
||||
|
||||
@ -204,10 +203,10 @@ let mark_pre_docs pos =
|
||||
with Not_found -> () *) ()
|
||||
|
||||
(* Map from positions to post docstrings *)
|
||||
|
||||
(*
|
||||
let post_table =
|
||||
Hashtbl.create 50
|
||||
|
||||
*)
|
||||
let set_post_docstrings pos dsl =
|
||||
(*if dsl <> [] then Hashtbl.add post_table pos dsl *) ()
|
||||
|
||||
@ -231,10 +230,10 @@ let get_info pos =
|
||||
with Not_found -> None*) None
|
||||
|
||||
(* Map from positions to floating docstrings *)
|
||||
|
||||
(*
|
||||
let floating_table =
|
||||
Hashtbl.create 50
|
||||
|
||||
*)
|
||||
let set_floating_docstrings pos dsl =
|
||||
(* if dsl <> [] then Hashtbl.add floating_table pos dsl *) ()
|
||||
|
||||
@ -251,10 +250,10 @@ let get_post_text pos =
|
||||
with Not_found -> [] *) []
|
||||
|
||||
(* Maps from positions to extra docstrings *)
|
||||
|
||||
(*
|
||||
let pre_extra_table =
|
||||
Hashtbl.create 50
|
||||
|
||||
*)
|
||||
let set_pre_extra_docstrings pos dsl =
|
||||
(* if dsl <> [] then Hashtbl.add pre_extra_table pos dsl *) ()
|
||||
|
||||
@ -263,10 +262,10 @@ let get_pre_extra_text pos =
|
||||
let dsl = Hashtbl.find pre_extra_table pos in
|
||||
get_docstrings dsl
|
||||
with Not_found -> [] *) []
|
||||
|
||||
(*
|
||||
let post_extra_table =
|
||||
Hashtbl.create 50
|
||||
|
||||
*)
|
||||
let set_post_extra_docstrings pos dsl =
|
||||
(* if dsl <> [] then Hashtbl.add post_extra_table pos dsl *) ()
|
||||
|
||||
@ -345,10 +344,10 @@ let rhs_post_extra_text pos =
|
||||
(* (Re)Initialise all comment state *)
|
||||
|
||||
let init () =
|
||||
docstrings := [];
|
||||
docstrings := [] (*;
|
||||
Hashtbl.reset pre_table;
|
||||
Hashtbl.reset post_table;
|
||||
Hashtbl.reset floating_table;
|
||||
Hashtbl.reset pre_extra_table;
|
||||
Hashtbl.reset post_extra_table
|
||||
Hashtbl.reset post_extra_table*)
|
||||
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
#!/usr/bin/env bash
|
||||
files=( lexing.ml parsing.ml clflags.ml location.ml asttypes.mli warnings.ml syntaxerr.ml docstrings.ml longident.ml parsetree.mli ast_helper.ml parser.ml lexer.ml )
|
||||
modules=( Lexing Parsing Clflags Location Asttypes Warnings Syntaxerr Docstrings Longident Parsetree Ast_helper Parser Lexer )
|
||||
files=( buffer.ml lexing.ml parsing.ml clflags.ml location.ml asttypes.mli warnings.ml syntaxerr.ml docstrings.ml longident.ml parsetree.mli ast_helper.ml parser.ml lexer.ml )
|
||||
modules=( Buffer Lexing Parsing Clflags Location Asttypes Warnings Syntaxerr Docstrings Longident Parsetree Ast_helper Parser Lexer )
|
||||
out=out.ml
|
||||
cat std.ml > $out
|
||||
for i in "${!files[@]}"; do
|
||||
|
||||
@ -146,7 +146,7 @@ let rec hex_num_value_loop lexbuf last acc i =
|
||||
acc
|
||||
else
|
||||
let value = hex_digit_value (Lexing.lexeme_char lexbuf i) in
|
||||
loop (16 * acc + value) (i + 1)
|
||||
hex_num_value_loop lexbuf last (16 * acc + value) (i + 1)
|
||||
|
||||
let hex_num_value lexbuf ~first ~last =
|
||||
hex_num_value_loop lexbuf last 0 first
|
||||
@ -164,7 +164,7 @@ let char_for_decimal_code lexbuf i =
|
||||
(Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in
|
||||
if (c < 0 || c > 255) then
|
||||
if in_comment ()
|
||||
then (* 'x' *) assert false
|
||||
then 'x'
|
||||
else raise (Error(Illegal_escape (Lexing.lexeme lexbuf),
|
||||
Location.curr lexbuf))
|
||||
else Char.chr c
|
||||
@ -193,7 +193,7 @@ let uchar_for_uchar_escape lexbuf =
|
||||
| false ->
|
||||
let cp = hex_num_value lexbuf ~first ~last in
|
||||
if Uchar.is_valid cp then Uchar.unsafe_of_int cp else
|
||||
ie_err lexbuf (", " ^ Printf.sprintf "%X" cp ^ " is not a Unicode scalar value")
|
||||
(* ie_err lexbuf (", " ^ Printf.sprintf "%X" cp ^ " is not a Unicode scalar value") *) assert false
|
||||
|
||||
(* recover the name from a LABEL or OPTLABEL token *)
|
||||
|
||||
@ -245,6 +245,7 @@ let comments _ = List.rev !comment_list
|
||||
|
||||
(* Error report *)
|
||||
|
||||
(*
|
||||
open Format
|
||||
|
||||
let report_error ppf e = (* match e with
|
||||
@ -279,6 +280,7 @@ let _ =
|
||||
| _ ->
|
||||
None
|
||||
)
|
||||
*)
|
||||
|
||||
}
|
||||
|
||||
|
||||
@ -326,7 +326,7 @@ let print_error_prefix ppf = (*
|
||||
fprintf ppf "@{<error>%s@}" error_prefix; *) assert false
|
||||
;;
|
||||
|
||||
let print_compact ppf loc =
|
||||
let print_compact ppf loc = assert false (*
|
||||
if loc.loc_start.pos_fname = "//toplevel//"
|
||||
&& highlight_locations ppf [loc] then ()
|
||||
else begin
|
||||
@ -334,7 +334,7 @@ let print_compact ppf loc =
|
||||
let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
|
||||
fprintf ppf "%a:%i" print_filename file line;
|
||||
if startchar >= 0 then fprintf ppf ",%i--%i" startchar endchar
|
||||
end
|
||||
end *)
|
||||
;;
|
||||
|
||||
let print_error ppf loc = (*
|
||||
@ -371,11 +371,11 @@ let print_warning loc ppf w =
|
||||
|
||||
(* let formatter_for_warnings = ref err_formatter;; *)
|
||||
let prerr_warning loc w = assert false (*print_warning loc !formatter_for_warnings w;;*)
|
||||
|
||||
(*
|
||||
let echo_eof () =
|
||||
print_newline ();
|
||||
incr num_loc_lines
|
||||
|
||||
*)
|
||||
type loc = {
|
||||
txt : 'a;
|
||||
loc : t;
|
||||
@ -520,8 +520,9 @@ let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
|
||||
pp_ksprintf
|
||||
~before:print_phanton_error_prefix
|
||||
(fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
|
||||
|
||||
*)
|
||||
*)
|
||||
let deprecated ?(def = none) ?(use = none) loc msg =
|
||||
prerr_warning loc (Warnings.Deprecated (msg, def, use))
|
||||
*)
|
||||
*)
|
||||
(* prerr_warning loc (Warnings.Deprecated (msg, def, use)) *) ()
|
||||
|
||||
|
||||
|
||||
@ -75,12 +75,13 @@ let ghsig d = Sig.mk ~loc:(symbol_gloc()) d
|
||||
|
||||
let mkinfix arg1 name arg2 =
|
||||
mkexp(Pexp_apply(mkoperator name 2, [Nolabel, arg1; Nolabel, arg2]))
|
||||
(*
|
||||
|
||||
let neg_string f =
|
||||
if String.length f > 0 && f.[0] = '-'
|
||||
then String.sub f 1 (String.length f - 1)
|
||||
else "-" ^ f
|
||||
|
||||
|
||||
(*
|
||||
let mkuminus name arg =
|
||||
match name, arg.pexp_desc with
|
||||
| "-", Pexp_constant(Pconst_integer (n,m)) ->
|
||||
@ -97,7 +98,11 @@ let mkuplus name arg =
|
||||
| ("+" | "+."), Pexp_constant(Pconst_float _) -> mkexp desc
|
||||
| _ ->
|
||||
mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))
|
||||
*)
|
||||
*)
|
||||
|
||||
let mkuminus name arg = mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))
|
||||
let mkuplus name arg = mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))
|
||||
|
||||
let mkexp_cons consloc args loc =
|
||||
Exp.mk ~loc (Pexp_construct(mkloc (Lident "::") consloc, Some args))
|
||||
|
||||
|
||||
@ -126,31 +126,33 @@ let clear_parser() =
|
||||
|
||||
let current_lookahead_fun = ref (fun _ -> false)
|
||||
|
||||
(*
|
||||
let yyparse tables start lexer lexbuf =
|
||||
let rec loop cmd arg =
|
||||
|
||||
let rec yyloop tables lexer lexbuf cmd arg =
|
||||
match parse_engine tables env cmd arg with
|
||||
Read_token ->
|
||||
let t = Obj.repr(lexer lexbuf) in
|
||||
env.symb_start <- lexbuf.lex_start_p;
|
||||
env.symb_end <- lexbuf.lex_curr_p;
|
||||
loop Token_read t
|
||||
yyloop tables lexer lexbuf Token_read t
|
||||
| Raise_parse_error ->
|
||||
raise Parse_error
|
||||
| Compute_semantic_action ->
|
||||
let (action, value) =
|
||||
try
|
||||
(Semantic_action_computed, tables.actions.(env.rule_number) env)
|
||||
try let act = tables.actions.(env.rule_number) in
|
||||
(Semantic_action_computed, act env)
|
||||
with Parse_error ->
|
||||
(Error_detected, Obj.repr ()) in
|
||||
loop action value
|
||||
yyloop tables lexer lexbuf action value
|
||||
| Grow_stacks_1 ->
|
||||
grow_stacks(); loop Stacks_grown_1 (Obj.repr ())
|
||||
grow_stacks(); yyloop tables lexer lexbuf Stacks_grown_1 (Obj.repr ())
|
||||
| Grow_stacks_2 ->
|
||||
grow_stacks(); loop Stacks_grown_2 (Obj.repr ())
|
||||
grow_stacks(); yyloop tables lexer lexbuf Stacks_grown_2 (Obj.repr ())
|
||||
| Call_error_function ->
|
||||
tables.error_function "syntax error";
|
||||
loop Error_detected (Obj.repr ()) in
|
||||
let f = tables.error_function in f "syntax error";
|
||||
yyloop tables lexer lexbuf Error_detected (Obj.repr ())
|
||||
|
||||
let yyparse tables start lexer lexbuf =
|
||||
|
||||
let init_asp = env.asp
|
||||
and init_sp = env.sp
|
||||
and init_stackbase = env.stackbase
|
||||
@ -162,7 +164,7 @@ let yyparse tables start lexer lexbuf =
|
||||
env.curr_char <- start;
|
||||
env.symb_end <- lexbuf.lex_curr_p;
|
||||
try
|
||||
loop Start (Obj.repr ())
|
||||
yyloop tables lexer lexbuf Start (Obj.repr ())
|
||||
with exn ->
|
||||
let curr_char = env.curr_char in
|
||||
env.asp <- init_asp;
|
||||
@ -176,27 +178,27 @@ let yyparse tables start lexer lexbuf =
|
||||
YYexit v ->
|
||||
Obj.magic v
|
||||
| _ ->
|
||||
current_lookahead_fun :=
|
||||
(* current_lookahead_fun :=
|
||||
(fun tok ->
|
||||
if Obj.is_block tok
|
||||
then tables.transl_block.(Obj.tag tok) = curr_char
|
||||
else tables.transl_const.(Obj.magic tok) = curr_char);
|
||||
raise exn
|
||||
raise exn *) assert false
|
||||
|
||||
let peek_val env n =
|
||||
Obj.magic env.v_stack.(env.asp - n)
|
||||
|
||||
let symbol_start_pos () =
|
||||
let rec loop i =
|
||||
let rec symbol_loop i =
|
||||
if i <= 0 then env.symb_end_stack.(env.asp)
|
||||
else begin
|
||||
let st = env.symb_start_stack.(env.asp - i + 1) in
|
||||
let en = env.symb_end_stack.(env.asp - i + 1) in
|
||||
if st <> en then st else loop (i - 1)
|
||||
if st <> en then st else symbol_loop (i - 1)
|
||||
end
|
||||
in
|
||||
loop env.rule_len
|
||||
*)
|
||||
|
||||
let symbol_start_pos () =
|
||||
symbol_loop env.rule_len
|
||||
|
||||
|
||||
let symbol_end_pos () = env.symb_end_stack.(env.asp)
|
||||
let rhs_start_pos n = env.symb_start_stack.(env.asp - (env.rule_len - n))
|
||||
|
||||
@ -12,5 +12,3 @@ value times(value x, value y) { return Val_long(Long_val(x) * Long_val(y)); }
|
||||
value caml_assert(value x) { assert (Long_val(x)); return Val_long(0); }
|
||||
value fst(value x) { return Field(x, 0); }
|
||||
value snd(value x) { return Field(x, 1); }
|
||||
value ref_get(value x) { return Field(x, 0); }
|
||||
value ref_set(value x, value s) { CAMLparam2(x, s); Store_field(x, 0, s); CAMLreturn (Val_long(0)); }
|
||||
|
||||
@ -1,10 +1,19 @@
|
||||
exception Not_found
|
||||
exception End_of_file
|
||||
exception Failure of string
|
||||
let false = 0
|
||||
let true = 1
|
||||
exception Invalid_argument of string
|
||||
let invalid_arg x = raise (Invalid_argument x)
|
||||
let failwith x = raise (Failure x)
|
||||
|
||||
module Obj = struct let repr x = x let magic x = x end
|
||||
type bool = false | true
|
||||
type ref = { mutable contents : 'a }
|
||||
|
||||
module Obj = struct
|
||||
let repr x = x
|
||||
let magic x = x
|
||||
external is_block : = "caml_obj_is_block"
|
||||
external tag : = "caml_obj_tag"
|
||||
end
|
||||
let lazy x = x
|
||||
module Lazy = struct let force x = x end
|
||||
|
||||
@ -16,8 +25,61 @@ module List = struct
|
||||
let rec fold_right f l acc = match l with [] -> acc | x :: l -> f x (fold_right f l acc)
|
||||
end
|
||||
|
||||
module Bytes = struct
|
||||
external blit : = "caml_blit_bytes"
|
||||
external unsafe_blit : = "caml_blit_bytes"
|
||||
external blit_string : = "caml_blit_string"
|
||||
external create : = "caml_create_bytes"
|
||||
external get : = "caml_bytes_get"
|
||||
external unsafe_get : = "caml_bytes_get"
|
||||
external unsafe_set : = "caml_bytes_set"
|
||||
external unsafe_of_string : = "caml_bytes_of_string"
|
||||
external unsafe_to_string : = "caml_string_of_bytes"
|
||||
external length : = "caml_ml_bytes_length"
|
||||
|
||||
let copy s =
|
||||
let len = length s in
|
||||
let r = create len in
|
||||
unsafe_blit s 0 r 0 len;
|
||||
r
|
||||
|
||||
let to_string b = unsafe_to_string (copy b)
|
||||
let of_string s = copy (unsafe_of_string s)
|
||||
|
||||
let sub s ofs len =
|
||||
if ofs < 0 || len < 0 || ofs > length s - len
|
||||
then invalid_arg "String.sub / Bytes.sub"
|
||||
else begin
|
||||
let r = create len in
|
||||
unsafe_blit s ofs r 0 len;
|
||||
r
|
||||
end
|
||||
|
||||
let sub_string b ofs len = unsafe_to_string (sub b ofs len)
|
||||
end
|
||||
|
||||
module Char = struct let code x = x let chr x = x let unsafe_chr x = x end
|
||||
module Uchar = struct let unsafe_of_int x = x let to_int x = x let is_valid x = true end
|
||||
|
||||
let rec list_concat l1 l2 = match l1 with [] -> l2 | x :: l1 -> x :: list_concat l1 l2
|
||||
|
||||
external compare : = "caml_compare"
|
||||
external eq : = "caml_equal"
|
||||
external neq : = "caml_notequal"
|
||||
external lessequal : = "caml_lessequal"
|
||||
external lessthan : = "caml_lessthan"
|
||||
|
||||
let ref x = { contents = x }
|
||||
let ref_get x = x.contents
|
||||
let ref_set x y = x.contents <- y
|
||||
let incr x = ref_set x (ref_get x + 1)
|
||||
let not x = 1 - x
|
||||
|
||||
module Array = struct
|
||||
external blit : = "caml_array_blit"
|
||||
external make : = "caml_make_vect"
|
||||
end
|
||||
|
||||
external array_get : = "caml_array_get"
|
||||
external array_set : = "caml_array_set"
|
||||
external int_of_string : = "caml_int_of_string"
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user