Ekdohibs/camlboot
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Make interp compatible with ocamlopt

Browse Source
This commit is contained in:
Nathanaël Courant 2021-02-17 15:15:10 +01:00
parent dc70540748
commit f375799b0d
19 changed files with 236 additions and 635 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
interpreter/interp.ml
View File

@ -7,7 +7,8 @@ let parse filename =
let inc = try open_in filename with e -> Format.eprintf "Error opening file: %s@." filename; raise e in
let lexbuf = Lexing.from_channel inc in
Location.init lexbuf filename;
let parsed = Parser.implementation Lexer.real_token lexbuf in
(* let parsed = Parser.implementation Lexer.real_token lexbuf in *)
let parsed = Parse.implementation lexbuf in
close_in inc;
parsed

9
miniml/compiler/compile.scm
View File

@ -199,7 +199,8 @@
(letdef
(LPAREN RPAREN EQ expr) : (mkdef "_" #nil $4)
(lident_ext list_labelled_arg EQ expr) : (mkdef $1 $2 $4))
(lident_ext list_labelled_arg EQ expr) : (mkdef $1 $2 $4)
(lident_ext list_labelled_arg COLON type_ignore EQ expr) : (mkdef $1 $2 $6))
(list_labelled_arg
( ) : #nil
@ -1160,6 +1161,7 @@
(cons "%lslint" "%118")
(cons "%lsrint" "%119")
(cons "%asrint" "%120")
(cons "%boolnot" "%88")
(cons "%negfloat" "caml_neg_float")
(cons "%addfloat" "caml_add_float")
@ -1201,6 +1203,11 @@
(cons "%floatarray_unsafe_get" "caml_floatarray_unsafe_get")
(cons "%floatarray_unsafe_set" "caml_floatarray_unsafe_set")
(cons "%obj_size" "%79")
(cons "%obj_field" "caml_array_unsafe_get")
(cons "%obj_set_field" "caml_array_unsafe_set")
(cons "%obj_is_int" "%129")
(cons "%int64_neg" "caml_int64_neg")
(cons "%int64_add" "caml_int64_add")
(cons "%int64_sub" "caml_int64_sub")

8
miniml/interp/Makefile
View File

@ -1,4 +1,6 @@
MINIML=guile ../compiler/compile.scm std.ml --open Std
TIMED=../../timed.sh
MINIML=guile ../compiler/compile.scm std_miniml_prefix.ml --open Std_miniml_prefix std.ml --open Std std_miniml.ml --open Std_miniml
OCAMLRUN=../../ocaml-src/byterun/ocamlrun
OCAMLLEX=../../ocaml-src/byterun/ocamlrun ../../ocaml-src/boot/ocamllex
@ -38,6 +40,10 @@ cvt_emit.byte: $(COMMONOBJS) cvt_emit.ml
interp.byte: $(INTERPOBJS)
$(MINIML) $(INTERPOBJS) -o $@
interpopt.opt: $(INTERPOBJS)
./genfileopt.sh
$(TIMED) ./interp -nopervasives -nostdlib -w -20-21 ../../ocaml-src/asmrun/libasmrun.a interpopt.ml -o interpopt.opt -ccopt "-lm -lpthread -ldl"
lexer.ml: lex.byte lexer.mll
$(OCAMLRUN) lex.byte lexer.mll

4
miniml/interp/arg.ml
View File

@ -395,6 +395,6 @@ let write_aux sep file args =
Array.iter (fun s -> fprintf oc "%s%c" s sep) args;
close_out oc
let write_arg = write_aux '\n'
let write_arg file args = write_aux '\n' file args
let write_arg0 = write_aux '\x00'
let write_arg0 file args = write_aux '\x00' file args

1
miniml/interp/clflags.ml
View File

@ -1,3 +1,2 @@
let fast = ref false
let applicative_functors = ref true
let color = ref None

21
miniml/interp/docstrings.ml
View File

@ -130,7 +130,6 @@ let add_info_attrs info attrs =
type text = docstring list
let empty_text = []
let empty_text_lazy = lazy []
let text_loc = {txt = "ocaml.text"; loc = Location.none}
@ -281,22 +280,10 @@ let symbol_docs () =
{ docs_pre = get_pre_docs (Parsing.symbol_start_pos ());
docs_post = get_post_docs (Parsing.symbol_end_pos ()); }
let symbol_docs_lazy () =
let p1 = Parsing.symbol_start_pos () in
let p2 = Parsing.symbol_end_pos () in
lazy { docs_pre = get_pre_docs p1;
docs_post = get_post_docs p2; }
let rhs_docs pos1 pos2 =
{ docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1);
docs_post = get_post_docs (Parsing.rhs_end_pos pos2); }
let rhs_docs_lazy pos1 pos2 =
let p1 = Parsing.rhs_start_pos pos1 in
let p2 = Parsing.rhs_end_pos pos2 in
lazy { docs_pre = get_pre_docs p1;
docs_post = get_post_docs p2; }
let mark_symbol_docs () =
mark_pre_docs (Parsing.symbol_start_pos ());
mark_post_docs (Parsing.symbol_end_pos ())
@ -314,20 +301,12 @@ let rhs_info pos =
let symbol_text () =
get_text (Parsing.symbol_start_pos ())
let symbol_text_lazy () =
let pos = Parsing.symbol_start_pos () in
lazy (get_text pos)
let rhs_text pos =
get_text (Parsing.rhs_start_pos pos)
let rhs_post_text pos =
get_post_text (Parsing.rhs_end_pos pos)
let rhs_text_lazy pos =
let pos = Parsing.rhs_start_pos pos in
lazy (get_text pos)
let symbol_pre_extra_text () =
get_pre_extra_text (Parsing.symbol_start_pos ())

2
miniml/interp/format.ml
View File

@ -45,7 +45,7 @@ let mkprintf is_format print_fun ff fmt cont =
cont ()
end
in
loop 0
Obj.magic (loop 0)
let getff ff = ff.out_string
let printf fmt = mkprintf true getff { out_string = print_string } fmt (fun () -> ())

18
miniml/interp/genfileopt.sh Executable file
View File

@ -0,0 +1,18 @@
#!/usr/bin/env bash
files=( int32.ml int64.ml nativeint.ml seq.ml char.ml bytes.ml string.ml digest.ml marshal.ml array.ml list.ml stack.ml hashtbl.ml map.ml set.ml buffer.ml format.ml printf.ml arg.ml gc.ml filename.ml lexing.ml parsing.ml misc.ml clflags.ml location.ml asttypes.mli warnings.ml syntaxerr.ml longident.ml parsetree.mli docstrings.ml ast_helper.ml parser.ml lexer.ml parse.ml ../../interpreter/conf.ml ../../interpreter/data.ml ../../interpreter/envir.ml ../../interpreter/runtime_lib.ml ../../interpreter/runtime_base.ml ../../interpreter/eval.ml ../../interpreter/runtime_stdlib.ml ../../interpreter/runtime_compiler.ml ../../interpreter/primitives.ml ../../interpreter/interp.ml )
modules=( Int32 Int64 Nativeint Seq Char Bytes String Digest Marshal Array List Stack Hashtbl Map Set Buffer Format Printf Arg Gc Filename Lexing Parsing Misc Clflags Location Asttypes Warnings Syntaxerr Longident Parsetree Docstrings Ast_helper Parser Lexer Parse Conf Data Envir Runtime_lib Runtime_base Eval Runtime_stdlib Runtime_compiler Primitives Interp )
out=interpopt.ml
cat std_opt_prefix.ml > $out
cat std.ml >> $out
for i in "${!files[@]}"; do
f=${files[$i]}
m=${modules[$i]}
echo "module $m = struct" >> $out
echo "# 1 \"$f\"" >> $out
cat $f >> $out
echo "# $(($(wc -l < $out) + 2)) \"$out\"" >> $out
echo "end" >> $out
echo >> $out
done
echo >> $out
echo "let () = __atexit ()" >> $out

5
miniml/interp/interp.opt Executable file
View File

@ -0,0 +1,5 @@
#!/usr/bin/env bash
r=$(dirname $0)
root=$r/../..
ulimit -s 200000
OCAMLRUNPARAM=b OCAMLINTERP_STDLIB_PATH=$root/ocaml-src/stdlib/ OCAMLINTERP_SRC_PATH=$root/ocaml-src/ OCAMLINTERP_COMMAND=ocamlopt $r/interpopt.opt "$@"

4
miniml/interp/lex.sh Executable file
View File

@ -0,0 +1,4 @@
#!/usr/bin/env bash
r=$(dirname $0)
root=$r/../..
$root/_boot/byterun/ocamlrun $r/lex.byte "$@"

98
miniml/interp/lexer.mll
View File

@ -100,8 +100,8 @@ let keyword_table =
(* To buffer string literals *)
let string_buffer = Buffer.create 256
let reset_string_buffer _ = Buffer.reset string_buffer
let get_stored_string _ = Buffer.contents string_buffer
let reset_string_buffer () = Buffer.reset string_buffer
let get_stored_string () = Buffer.contents string_buffer
let store_string_char c = Buffer.add_char string_buffer c
let store_string_utf_8_uchar u = Buffer.add_utf_8_uchar string_buffer u
@ -111,9 +111,9 @@ let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf)
(* To store the position of the beginning of a string and comment *)
let string_start_loc = ref Location.none;;
let comment_start_loc = ref [];;
let in_comment _ = !comment_start_loc <> [];;
let in_comment () = !comment_start_loc <> [];;
let is_in_string = ref false
let in_string _ = !is_in_string
let in_string () = !is_in_string
let print_warnings = ref true
(* Escaped chars are interpreted in strings unless they are in comments. *)
@ -141,24 +141,22 @@ let hex_digit_value d = (* assert (d in '0'..'9' 'a'..'f' 'A'..'F') *)
if d >= 65 then d - 55 else
d - 48
let rec hex_num_value_loop lexbuf last acc i =
if i > last then
acc
else
let value = hex_digit_value (Lexing.lexeme_char lexbuf i) in
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
let rec loop acc i = match i > last with
| true -> acc
| false ->
let value = hex_digit_value (Lexing.lexeme_char lexbuf i) in
loop (16 * acc + value) (i + 1)
in
loop 0 first
let char_for_backslash c = match c with
let char_for_backslash = function
| 'n' -> '\010'
| 'r' -> '\013'
| 'b' -> '\008'
| 't' -> '\009'
| c -> c
let char_for_decimal_code lexbuf i =
let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
@ -180,21 +178,21 @@ let char_for_hexadecimal_code lexbuf i =
let byte = hex_num_value lexbuf ~first:i ~last:(i+1) in
Char.chr byte
let ie_err lexbuf e =
raise
(Error (Illegal_escape (Lexing.lexeme lexbuf ^ e), Location.curr lexbuf))
let uchar_for_uchar_escape lexbuf =
let err e =
raise
(Error (Illegal_escape (Lexing.lexeme lexbuf ^ e), Location.curr lexbuf))
in
let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in
let first = 3 (* skip opening \u{ *) in
let last = len - 2 (* skip closing } *) in
let digit_count = last - first + 1 in
match digit_count > 6 with
| true -> ie_err lexbuf ", too many digits, expected 1 to 6 hexadecimal digits"
| true -> err ", too many digits, expected 1 to 6 hexadecimal digits"
| 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") *) assert false
err (", " ^ Printf.sprintf "%X" cp ^ " is not a Unicode scalar value")
(* recover the name from a LABEL or OPTLABEL token *)
@ -242,14 +240,13 @@ let add_docstring_comment ds =
in
add_comment com
let comments _ = List.rev !comment_list
let comments () = List.rev !comment_list
(* Error report *)
(*
open Format
let report_error ppf e = (* match e with
let report_error ppf = function
| Illegal_character c ->
fprintf ppf "Illegal character (%s)" (Char.escaped c)
| Illegal_escape s ->
@ -271,17 +268,16 @@ let report_error ppf e = (* match e with
begin match explanation with
| None -> ()
| Some expl -> fprintf ppf ": %s" expl
end *) assert false
end
let _ =
let () =
Location.register_error_of_exn
(fun e -> match e with
(function
| Error (err, loc) ->
Some (Location.error_of_printer loc report_error err)
| _ ->
None
)
*)
}
@ -415,6 +411,15 @@ rule token = parse
else
COMMENT ("*" ^ s, loc)
}
| "(**" (('*'+) as stars)
{ let s, loc =
with_comment_buffer
(fun lexbuf ->
store_string ("*" ^ stars);
comment lexbuf)
lexbuf
in
COMMENT (s, loc) }
| "(*)"
{ if !print_warnings then
Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start;
@ -435,8 +440,8 @@ rule token = parse
STAR
}
| "#"
{ let pos = lexbuf.lex_start_p in
if (pos.pos_cnum <> pos.pos_bol)
{ let at_beginning_of_line pos = (pos.pos_cnum = pos.pos_bol) in
if not (at_beginning_of_line lexbuf.lex_start_p)
then HASH
else try directive lexbuf with Failure _ -> HASH
}
@ -517,12 +522,12 @@ and directive = parse
[^ '\010' '\013'] *
{
match int_of_string num with
(* | exception _ ->
| exception _ ->
(* PR#7165 *)
let loc = Location.curr lexbuf in
let explanation = "line number out of range" in
let error = Invalid_directive ("#" ^ directive, Some explanation) in
raise (Error (error, loc)) *)
raise (Error (error, loc))
| line_num ->
(* Documentation says that the line number should be
positive, but we have never guarded against this and it
@ -539,9 +544,8 @@ and comment = parse
| "*)"
{ match !comment_start_loc with
| [] -> assert false
| _ :: l -> match l with
| [] -> comment_start_loc := []; Location.curr lexbuf
| _ -> comment_start_loc := l;
| [_] -> comment_start_loc := []; Location.curr lexbuf
| _ :: l -> comment_start_loc := l;
store_lexeme lexbuf;
comment lexbuf
}
@ -550,7 +554,7 @@ and comment = parse
string_start_loc := Location.curr lexbuf;
store_string_char '\"';
is_in_string := true;
(*begin try string lexbuf
begin try string lexbuf
with Error (Unterminated_string, str_start) ->
match !comment_start_loc with
| [] -> assert false
@ -559,8 +563,7 @@ and comment = parse
comment_start_loc := [];
raise (Error (Unterminated_string_in_comment (start, str_start),
loc))
end;*)
string lexbuf;
end;
is_in_string := false;
store_string_char '\"';
comment lexbuf }
@ -571,7 +574,7 @@ and comment = parse
string_start_loc := Location.curr lexbuf;
store_lexeme lexbuf;
is_in_string := true;
(*begin try quoted_string delim lexbuf
begin try quoted_string delim lexbuf
with Error (Unterminated_string, str_start) ->
match !comment_start_loc with
| [] -> assert false
@ -580,10 +583,8 @@ and comment = parse
comment_start_loc := [];
raise (Error (Unterminated_string_in_comment (start, str_start),
loc))
end;*)
quoted_string delim lexbuf;
end;
is_in_string := false;
assert false;
store_string_char '|';
store_string delim;
store_string_char '}';
@ -651,7 +652,7 @@ and string = parse
Location.curr lexbuf))
*)
let loc = Location.curr lexbuf in
Location.prerr_warning loc Warnings.Illegal_backslash
Location.prerr_warning loc Warnings.Illegal_backslash;
end;
store_lexeme lexbuf;
string lexbuf
@ -698,7 +699,7 @@ and skip_hash_bang = parse
| "" { () }
{
(*
let token_with_comments lexbuf =
match !preprocessor with
| None -> token lexbuf
@ -792,21 +793,14 @@ and skip_hash_bang = parse
tok
in
loop NoLine Initial lexbuf
*)
let rec real_token lexbuf =
match token lexbuf with
| COMMENT _ -> real_token lexbuf
| EOL -> real_token lexbuf
| DOCSTRING _ -> real_token lexbuf
| tok -> tok
let init _ =
let init () =
is_in_string := false;
comment_start_loc := [];
comment_list := [];
match !preprocessor with
| None -> ()
| Some a -> let (init, _preprocess) = a in init ()
| Some (init, _preprocess) -> init ()
let set_preprocessor init preprocess =
escaped_newlines := true;

444
miniml/interp/location.ml
View File

@ -69,220 +69,10 @@ let rhs_loc n = {
let input_name = ref "_none_"
let input_lexbuf = ref (None : lexbuf option)
(* Terminal info *)
(*
let status = ref Terminfo.Uninitialised
*)
let num_loc_lines = ref 0 (* number of lines already printed after input *)
let print_updating_num_loc_lines ppf f arg = (*
let open Format in
let out_functions = pp_get_formatter_out_functions ppf () in
let out_string str start len =
let rec count i c =
if i = start + len then c
else if String.get str i = '\n' then count (succ i) (succ c)
else count (succ i) c in
num_loc_lines := !num_loc_lines + count start 0 ;
out_functions.out_string str start len in
pp_set_formatter_out_functions ppf
{ out_functions with out_string } ;
f ppf arg ;
pp_print_flush ppf ();
pp_set_formatter_out_functions ppf out_functions *) assert false
(* Highlight the locations using standout mode. *)
let highlight_terminfo ppf lb locs = (*
Format.pp_print_flush ppf (); (* avoid mixing Format and normal output *)
(* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
let pos0 = -lb.lex_abs_pos in
(* Do nothing if the buffer does not contain the whole phrase. *)
if pos0 < 0 then raise Exit;
(* Count number of lines in phrase *)
let lines = ref !num_loc_lines in
for i = pos0 to lb.lex_buffer_len - 1 do
if Bytes.get lb.lex_buffer i = '\n' then incr lines
done;
(* If too many lines, give up *)
if !lines >= Terminfo.num_lines stdout - 2 then raise Exit;
(* Move cursor up that number of lines *)
flush stdout; Terminfo.backup stdout !lines;
(* Print the input, switching to standout for the location *)
let bol = ref false in
print_string "# ";
for pos = 0 to lb.lex_buffer_len - pos0 - 1 do
if !bol then (print_string " "; bol := false);
if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then
Terminfo.standout stdout true;
if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then
Terminfo.standout stdout false;
let c = Bytes.get lb.lex_buffer (pos + pos0) in
print_char c;
bol := (c = '\n')
done;
(* Make sure standout mode is over *)
Terminfo.standout stdout false;
(* Position cursor back to original location *)
Terminfo.resume stdout !num_loc_lines;
flush stdout *) assert false
(* Highlight the location by printing it again. *)
let highlight_dumb ~print_chars ppf lb loc = (*
(* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
let pos0 = -lb.lex_abs_pos in
(* Do nothing if the buffer does not contain the whole phrase. *)
if pos0 < 0 then raise Exit;
let end_pos = lb.lex_buffer_len - pos0 - 1 in
(* Determine line numbers for the start and end points *)
let line_start = ref 0 and line_end = ref 0 in
for pos = 0 to end_pos do
if Bytes.get lb.lex_buffer (pos + pos0) = '\n' then begin
if loc.loc_start.pos_cnum > pos then incr line_start;
if loc.loc_end.pos_cnum > pos then incr line_end;
end
done;
Format.fprintf ppf "@[<v>";
(* Print character location (useful for Emacs) *)
if print_chars then begin
Format.fprintf ppf "Characters %i-%i:@,"
loc.loc_start.pos_cnum loc.loc_end.pos_cnum
end;
(* Print the input, underlining the location *)
Format.pp_print_string ppf " ";
let line = ref 0 in
let pos_at_bol = ref 0 in
for pos = 0 to end_pos do
match Bytes.get lb.lex_buffer (pos + pos0) with
| '\n' ->
if !line = !line_start && !line = !line_end then begin
(* loc is on one line: underline location *)
Format.fprintf ppf "@, ";
for _i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
Format.pp_print_char ppf ' '
done;
for _i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do
Format.pp_print_char ppf '^'
done
end;
if !line >= !line_start && !line <= !line_end then begin
Format.fprintf ppf "@,";
if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf " "
end;
incr line;
pos_at_bol := pos + 1
| '\r' -> () (* discard *)
| c ->
if !line = !line_start && !line = !line_end then
(* loc is on one line: print whole line *)
Format.pp_print_char ppf c
else if !line = !line_start then
(* first line of multiline loc:
print a dot for each char before loc_start *)
if pos < loc.loc_start.pos_cnum then
Format.pp_print_char ppf '.'
else
Format.pp_print_char ppf c
else if !line = !line_end then
(* last line of multiline loc: print a dot for each char
after loc_end, even whitespaces *)
if pos < loc.loc_end.pos_cnum then
Format.pp_print_char ppf c
else
Format.pp_print_char ppf '.'
else if !line > !line_start && !line < !line_end then
(* intermediate line of multiline loc: print whole line *)
Format.pp_print_char ppf c
done;
Format.fprintf ppf "@]" *) assert false
let show_code_at_location ppf lb loc =
highlight_dumb ~print_chars:false ppf lb loc
(* Highlight the location using one of the supported modes. *)
let rec highlight_locations ppf locs = (*
match !status with
Terminfo.Uninitialised ->
status := Terminfo.setup stdout; highlight_locations ppf locs
| Terminfo.Bad_term ->
begin match !input_lexbuf with
None -> false
| Some lb ->
let norepeat =
try Sys.getenv "TERM" = "norepeat" with Not_found -> false in
if norepeat then false else
let loc1 = List.hd locs in
try highlight_dumb ~print_chars:true ppf lb loc1; true
with Exit -> false
end
| Terminfo.Good_term ->
begin match !input_lexbuf with
None -> false
| Some lb ->
try highlight_terminfo ppf lb locs; true
with Exit -> false
end *) assert false
(* Print the location in some way or another *)
(* open Format *)
(*
let rewrite_absolute_path =
let init = ref false in
let map_cache = ref None in
fun path ->
if not !init then begin
init := true;
match Sys.getenv "BUILD_PATH_PREFIX_MAP" with
| exception Not_found -> ()
| encoded_map ->
match Build_path_prefix_map.decode_map encoded_map with
| Error err ->
Misc.fatal_errorf
"Invalid value for the environment variable \
BUILD_PATH_PREFIX_MAP: %s" err
| Ok map -> map_cache := Some map
end;
match !map_cache with
| None -> path
| Some map -> Build_path_prefix_map.rewrite map path
*)
let rewrite_absolute_path _ = assert false
let absolute_path s = (* (* This function could go into Filename *)
let open Filename in
let s =
if not (is_relative s) then s
else (rewrite_absolute_path (concat (Sys.getcwd ()) s))
in
(* Now simplify . and .. components *)
let rec aux s =
let base = basename s in
let dir = dirname s in
if dir = s then dir
else if base = current_dir_name then aux dir
else if base = parent_dir_name then dirname (aux dir)
else concat (aux dir) base
in
aux s *) assert false
let show_filename file =
(* if !absname then absolute_path file else file *) assert false
let print_filename ppf file =
Format.fprintf ppf "%s" file
let reset () =
num_loc_lines := 0
(*
let (msg_file, msg_line, msg_chars, msg_to, msg_colon) =
("File \"", "\", line ", ", characters ", "-", ":")
*)
let msg_file = "File \""
let msg_line = "\", line "
let msg_chars = ", characters "
@ -294,26 +84,7 @@ let get_pos_info pos =
(pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
;;
let setup_colors () =
(* Misc.Color.setup !Clflags.color *) ()
(*
let print_loc ppf loc = (*
setup_colors ();
let (file, line, startchar) = get_pos_info loc.loc_start in
let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
if file = "//toplevel//" then begin
if highlight_locations ppf [loc] then () else
fprintf ppf "Characters %i-%i"
loc.loc_start.pos_cnum loc.loc_end.pos_cnum
end else begin
fprintf ppf "%s@{<loc>%a%s%i" msg_file print_filename file msg_line line;
if startchar >= 0 then
fprintf ppf "%s%i%s%i" msg_chars startchar msg_to endchar;
fprintf ppf "@}"
end *) assert false
;;
*)
let setup_colors () = ()
let print_loc ppf loc =
let (file, line, startchar) = get_pos_info loc.loc_start in
@ -321,77 +92,19 @@ let print_loc ppf loc =
Format.fprintf ppf "%s%a%s%d" msg_file print_filename file msg_line line;
if startchar >= 0 then
Format.fprintf ppf "%s%d%s%d" msg_chars startchar msg_to endchar
;;
let default_printer ppf loc = (*
setup_colors ();
if loc.loc_start.pos_fname = "//toplevel//"
&& highlight_locations ppf [loc] then ()
else fprintf ppf "@{<loc>%a@}%s@," print_loc loc msg_colon *) assert false
;;
let printer = ref default_printer
let print ppf loc = (* !printer ppf loc *) assert false
let error_prefix = "Error"
let warning_prefix = "Warning"
let print_error_prefix ppf = (*
setup_colors ();
fprintf ppf "@{<error>%s@}" error_prefix; *) assert false
;;
let print_compact ppf loc = assert false (*
if loc.loc_start.pos_fname = "//toplevel//"
&& highlight_locations ppf [loc] then ()
else begin
let (file, line, startchar) = get_pos_info loc.loc_start in
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 *)
;;
let print_error ppf loc = (*
fprintf ppf "%a%t:" print loc print_error_prefix; *) assert false
;;
let print_error ppf loc =
Format.fprintf ppf "%a%s:" print_loc loc error_prefix
let print_error_cur_file ppf () = print_error ppf (in_file !input_name);;
let default_warning_printer loc ppf w = (*
match Warnings.report w with
| `Inactive -> ()
| `Active { Warnings. number; message; is_error; sub_locs } ->
setup_colors ();
fprintf ppf "@[<v>";
print ppf loc;
if is_error
then
fprintf ppf "%t (%s %d): %s@," print_error_prefix
(String.uncapitalize_ascii warning_prefix) number message
else fprintf ppf "@{<warning>%s@} %d: %s@," warning_prefix number message;
List.iter
(fun (loc, msg) ->
if loc <> none then fprintf ppf " %a %s@," print loc msg
)
sub_locs;
fprintf ppf "@]" *) assert false
;;
let print_warning loc ppf w = ()
let prerr_warning loc w = ()
let warning_printer = ref default_warning_printer ;;
let print_warning loc ppf w =
(* print_updating_num_loc_lines ppf (!warning_printer loc) 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 = {
type 'a loc = {
txt : 'a;
loc : t;
}
@ -399,145 +112,6 @@ type loc = {
let mkloc txt loc = { txt=txt ; loc=loc }
let mknoloc txt = mkloc txt none
(*
type error =
{
loc: t;
msg: string;
sub: error list;
if_highlight: string; (* alternative message if locations are highlighted *)
}
let pp_ksprintf ?before k fmt =
let buf = Buffer.create 64 in
let ppf = Format.formatter_of_buffer buf in
Misc.Color.set_color_tag_handling ppf;
begin match before with
| None -> ()
| Some f -> f ppf
end;
kfprintf
(fun _ ->
pp_print_flush ppf ();
let msg = Buffer.contents buf in
k msg)
ppf fmt
(* Shift the formatter's offset by the length of the error prefix, which
is always added by the compiler after the message has been formatted *)
let print_phanton_error_prefix ppf =
Format.pp_print_as ppf (String.length error_prefix + 2 (* ": " *)) ""
let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt =
pp_ksprintf
~before:print_phanton_error_prefix
(fun msg -> {loc=loc; msg=msg; sub=sub; if_highlight=if_highlight})
fmt
let error ?(loc = none) ?(sub = []) ?(if_highlight = "") msg =
{loc=loc; msg=msg; sub=sub; if_highlight=if_highlight}
(* let error_of_exn : (exn -> error option) list ref = ref [] *)
let register_error_of_exn f = (* error_of_exn := f :: !error_of_exn *) assert false
exception Already_displayed_error (* = Warnings.Errors *)
(*
let error_of_exn exn =
match exn with
| Already_displayed_error -> Some `Already_displayed
| _ ->
let rec loop = function
| [] -> None
| f :: rest ->
match f exn with
| Some error -> Some (`Ok error)
| None -> loop rest
in
loop !error_of_exn
let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) =
let highlighted =
if if_highlight <> "" && loc.loc_start.pos_fname = "//toplevel//" then
let rec collect_locs locs {loc; sub; _} =
List.fold_left collect_locs (loc :: locs) sub
in
let locs = collect_locs [] err in
highlight_locations ppf locs
else
false
in
if highlighted then
Format.pp_print_string ppf if_highlight
else begin
fprintf ppf "@[<v>%a %s" print_error loc msg;
List.iter (Format.fprintf ppf "@,@[<2>%a@]" default_error_reporter) sub;
fprintf ppf "@]"
end
let error_reporter = ref default_error_reporter
let report_error ppf err =
print_updating_num_loc_lines ppf !error_reporter err
;;
let error_of_printer loc print x =
errorf ~loc "%a@?" print x
let error_of_printer_file print x =
error_of_printer (in_file !input_name) print x
let () =
register_error_of_exn
(function
| Sys_error msg ->
Some (errorf ~loc:(in_file !input_name)
"I/O error: %s" msg)
| Misc.HookExnWrapper {error = e; hook_name;
hook_info={Misc.sourcefile}} ->
let sub = match error_of_exn e with
| None | Some `Already_displayed -> error (Printexc.to_string e)
| Some (`Ok err) -> err
in
Some
(errorf ~loc:(in_file sourcefile)
"In hook %S:" hook_name
~sub:[sub])
| _ -> None
)
external reraise : exn -> 'a = "%reraise"
let rec report_exception_rec n ppf exn =
try
match error_of_exn exn with
| None -> reraise exn
| Some `Already_displayed -> ()
| Some (`Ok err) -> fprintf ppf "@[%a@]@." report_error err
with exn when n > 0 -> report_exception_rec (n-1) ppf exn
let report_exception ppf exn = report_exception_rec 5 ppf exn
*)
exception Error of error
(*
let () =
register_error_of_exn
(function
| Error e -> Some e
| _ -> None
)
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)) *) ()
let register_error_of_exn f = ()
let deprecated ?(def = none) ?(use = none) loc msg = ()
let error_of_printer loc print x = assert false

178
miniml/interp/parser.mly
View File

@ -104,7 +104,7 @@ let mkexp_cons consloc args loc =
let mkpat_cons consloc args loc =
Pat.mk ~loc (Ppat_construct(mkloc (Lident "::") consloc, Some args))
let rec mktailexp nilloc el = match el with
let rec mktailexp nilloc = function
[] ->
let loc = { nilloc with loc_ghost = true } in
let nil = { txt = Lident "[]"; loc = loc } in
@ -118,7 +118,7 @@ let rec mktailexp nilloc el = match el with
let arg = Exp.mk ~loc (Pexp_tuple [e1; exp_el]) in
mkexp_cons {loc with loc_ghost = true} arg loc
let rec mktailpat nilloc pl = match pl with
let rec mktailpat nilloc = function
[] ->
let loc = { nilloc with loc_ghost = true } in
let nil = { txt = Lident "[]"; loc = loc } in
@ -135,24 +135,24 @@ let rec mktailpat nilloc pl = match pl with
let mkstrexp e attrs =
{ pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
let mkexp_constraint e ts =
let (t1, t2) = ts in
match t2 with
| None -> (match t1 with None -> assert false | Some t -> ghexp(Pexp_constraint(e, t)))
| Some t -> ghexp(Pexp_coerce(e, t1, t))
let mkexp_constraint e (t1, t2) =
match t1, t2 with
| Some t, None -> ghexp(Pexp_constraint(e, t))
| _, Some t -> ghexp(Pexp_coerce(e, t1, t))
| None, None -> assert false
let mkexp_opt_constraint e c = match c with
let mkexp_opt_constraint e = function
| None -> e
| Some constraint_ -> mkexp_constraint e constraint_
let mkpat_opt_constraint p c = match c with
let mkpat_opt_constraint p = function
| None -> p
| Some typ -> mkpat (Ppat_constraint(p, typ))
let array_function str name =
ghloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name)))
let syntax_error _ =
let syntax_error () =
raise Syntaxerr.Escape_error
let unclosed opening_name opening_num closing_name closing_num =
@ -160,21 +160,20 @@ let unclosed opening_name opening_num closing_name closing_num =
rhs_loc closing_num, closing_name)))
let expecting pos nonterm =
raise (Syntaxerr.Error(Syntaxerr.Expecting(rhs_loc pos, nonterm)))
raise Syntaxerr.(Error(Expecting(rhs_loc pos, nonterm)))
let not_expecting pos nonterm =
raise (Syntaxerr.Error(Syntaxerr.Not_expecting(rhs_loc pos, nonterm)))
raise Syntaxerr.(Error(Not_expecting(rhs_loc pos, nonterm)))
let bigarray_function str name =
ghloc (Ldot(Ldot(Lident "Bigarray", str), name))
let bigarray_untuplify exp =
match exp.pexp_desc with
| Pexp_tuple explist -> explist
let bigarray_untuplify = function
{ pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
| exp -> [exp]
let bigarray_get arr arg =
(* let get = if !Clflags.fast then "unsafe_get" else "get" in
let get = if !Clflags.fast then "unsafe_get" else "get" in
match bigarray_untuplify arg with
[c1] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)),
@ -187,10 +186,9 @@ let bigarray_get arr arg =
[Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3]))
| coords ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")),
[Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))*)
assert false
[Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))
let bigarray_set arr arg newval = (*
let bigarray_set arr arg newval =
let set = if !Clflags.fast then "unsafe_set" else "set" in
match bigarray_untuplify arg with
[c1] ->
@ -208,7 +206,7 @@ let bigarray_set arr arg newval = (*
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")),
[Nolabel, arr;
Nolabel, ghexp(Pexp_array coords);
Nolabel, newval]))*) assert false
Nolabel, newval]))
let lapply p1 p2 =
if !Clflags.applicative_functors
@ -230,8 +228,7 @@ let wrap_type_annotation newtypes core_type body =
let exp = mk_newtypes newtypes exp in
(exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))
let wrap_exp_attrs body extattrs =
let (ext, attrs) = extattrs in
let wrap_exp_attrs body (ext, attrs) =
(* todo: keep exact location for the entire attribute *)
let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
match ext with
@ -241,8 +238,7 @@ let wrap_exp_attrs body extattrs =
let mkexp_attrs d attrs =
wrap_exp_attrs (mkexp d) attrs
let wrap_typ_attrs typ extattrs =
let (ext, attrs) = extattrs in
let wrap_typ_attrs typ (ext, attrs) =
(* todo: keep exact location for the entire attribute *)
let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in
match ext with
@ -252,8 +248,7 @@ let wrap_typ_attrs typ extattrs =
let mktyp_attrs d attrs =
wrap_typ_attrs (mktyp d) attrs
let wrap_pat_attrs pat extattrs =
let (ext, attrs) = extattrs in
let wrap_pat_attrs pat (ext, attrs) =
(* todo: keep exact location for the entire attribute *)
let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in
match ext with
@ -320,8 +315,8 @@ type let_binding =
{ lb_pattern: pattern;
lb_expression: expression;
lb_attributes: attributes;
lb_docs: docs Lazy.t;
lb_text: text Lazy.t;
lb_docs: docs;
lb_text: text;
lb_loc: Location.t; }
type let_bindings =
@ -330,14 +325,13 @@ type let_bindings =
lbs_extension: string Asttypes.loc option;
lbs_loc: Location.t }
let mklb first pe attrs =
let (p, e) = pe in
let mklb first (p, e) attrs =
{ lb_pattern = p;
lb_expression = e;
lb_attributes = attrs;
lb_docs = symbol_docs_lazy ();
lb_text = if first then empty_text_lazy
else symbol_text_lazy ();
lb_docs = symbol_docs ();
lb_text = if first then empty_text
else symbol_text ();
lb_loc = symbol_rloc (); }
let mklbs ext rf lb =
@ -354,8 +348,8 @@ let val_of_let_bindings lbs =
List.map
(fun lb ->
Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
~docs:(Lazy.force lb.lb_docs)
~text:(Lazy.force lb.lb_text)
~docs:(lb.lb_docs)
~text:(lb.lb_text)
lb.lb_pattern lb.lb_expression)
lbs.lbs_bindings
in
@ -384,7 +378,7 @@ let class_of_let_bindings lbs body =
lbs.lbs_bindings
in
if lbs.lbs_extension <> None then
raise (Syntaxerr.Error(Syntaxerr.Not_expecting(lbs.lbs_loc, "extension")));
raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "extension")));
mkclass(Pcl_let (lbs.lbs_rec, List.rev bindings, body))
@ -392,15 +386,18 @@ let class_of_let_bindings lbs body =
and extract the package type during type-checking. In that case,
the assertions below should be turned into explicit checks. *)
let package_type_of_module_type pmty =
let map_cstr = fun cstr -> match cstr with
let err loc s =
raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s)))
in
let map_cstr = function
| Pwith_type (lid, ptyp) ->
let loc = ptyp.ptype_loc in
if ptyp.ptype_params <> [] then
assert false;
err loc "parametrized types are not supported";
if ptyp.ptype_cstrs <> [] then
assert false;
err loc "constrained types are not supported";
if ptyp.ptype_private <> Public then
assert false;
err loc "private types are not supported";
(* restrictions below are checked by the 'with_constraint' rule *)
assert (ptyp.ptype_kind = Ptype_abstract);
@ -412,17 +409,16 @@ let package_type_of_module_type pmty =
in
(lid, ty)
| _ ->
assert false
err pmty.pmty_loc "only 'with type t =' constraints are supported"
in
match pmty.pmty_desc with
| Pmty_ident lid -> (lid, [])
| Pmty_with(z, cstrs) -> (
match z.pmty_desc with
| Pmty_ident lid -> (lid, List.map map_cstr cstrs)
| _ -> assert false
)
match pmty with
| {pmty_desc = Pmty_ident lid} -> (lid, [])
| {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} ->
(lid, List.map map_cstr cstrs)
| _ ->
assert false
err pmty.pmty_loc
"only module type identifier and 'with type' constraints are supported"
%}
@ -717,7 +713,7 @@ module_expr:
| FUNCTOR attributes functor_args MINUSGREATER module_expr
{ let modexp =
List.fold_left
(fun acc nt -> let (n, t) = nt in mkmod(Pmod_functor(n, t, acc)))
(fun acc (n, t) -> mkmod(Pmod_functor(n, t, acc)))
$5 $3
in wrap_mod_attrs modexp $2 }
| module_expr paren_module_expr
@ -862,7 +858,7 @@ module_type:
%prec below_WITH
{ let mty =
List.fold_left
(fun acc nt -> let (n, t) = nt in mkmty(Pmty_functor(n, t, acc)))
(fun acc (n, t) -> mkmty(Pmty_functor(n, t, acc)))
$5 $3
in wrap_mty_attrs mty $2 }
| module_type MINUSGREATER module_type
@ -1415,23 +1411,23 @@ expr:
| simple_expr DOT LBRACE expr RBRACE LESSMINUS expr
{ bigarray_set $1 $4 $7 }
| simple_expr DOTOP LBRACKET expr RBRACKET LESSMINUS expr
{ let id = mkexp (Pexp_ident( ghloc (Lident ("." ^ $2 ^ "[]<-")))) in
mkexp (Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7])) }
{ let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "[]<-")) in
mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) }
| simple_expr DOTOP LPAREN expr RPAREN LESSMINUS expr
{ let id = mkexp (Pexp_ident( ghloc (Lident ("." ^ $2 ^ "()<-")))) in
mkexp (Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7])) }
{ let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "()<-")) in
mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) }
| simple_expr DOTOP LBRACE expr RBRACE LESSMINUS expr
{ let id = mkexp (Pexp_ident( ghloc (Lident ("." ^ $2 ^ "{}<-")))) in
mkexp (Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7])) }
{ let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "{}<-")) in
mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) }
| simple_expr DOT mod_longident DOTOP LBRACKET expr RBRACKET LESSMINUS expr
{ let id = mkexp (Pexp_ident( ghloc (Ldot($3,"." ^ $4 ^ "[]<-")))) in
mkexp (Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9])) }
{ let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3,"." ^ $4 ^ "[]<-")) in
mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) }
| simple_expr DOT mod_longident DOTOP LPAREN expr RPAREN LESSMINUS expr
{ let id = mkexp (Pexp_ident( ghloc (Ldot($3, "." ^ $4 ^ "()<-")))) in
mkexp (Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9])) }
{ let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "()<-")) in
mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) }
| simple_expr DOT mod_longident DOTOP LBRACE expr RBRACE LESSMINUS expr
{ let id = mkexp (Pexp_ident( ghloc (Ldot($3, "." ^ $4 ^ "{}<-")))) in
mkexp (Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9])) }
{ let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "{}<-")) in
mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) }
| label LESSMINUS expr
{ mkexp(Pexp_setinstvar(mkrhs $1 1, $3)) }
| ASSERT ext_attributes simple_expr %prec below_HASH
@ -1489,33 +1485,33 @@ simple_expr:
| simple_expr DOT LBRACKET seq_expr error
{ unclosed "[" 3 "]" 5 }
| simple_expr DOTOP LBRACKET expr RBRACKET
{ let id = mkexp (Pexp_ident( ghloc (Lident ("." ^ $2 ^ "[]")))) in
mkexp (Pexp_apply(id, [Nolabel, $1; Nolabel, $4])) }
{ let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "[]")) in
mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) }
| simple_expr DOTOP LBRACKET expr error
{ unclosed "[" 3 "]" 5 }
| simple_expr DOTOP LPAREN expr RPAREN
{ let id = mkexp (Pexp_ident( ghloc (Lident ("." ^ $2 ^ "()")))) in
mkexp (Pexp_apply(id, [Nolabel, $1; Nolabel, $4])) }
{ let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "()")) in
mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) }
| simple_expr DOTOP LPAREN expr error
{ unclosed "(" 3 ")" 5 }
| simple_expr DOTOP LBRACE expr RBRACE
{ let id = mkexp (Pexp_ident( ghloc (Lident ("." ^ $2 ^ "{}")))) in
mkexp (Pexp_apply(id, [Nolabel, $1; Nolabel, $4])) }
{ let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "{}")) in
mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) }
| simple_expr DOTOP LBRACE expr error
{ unclosed "{" 3 "}" 5 }
| simple_expr DOT mod_longident DOTOP LBRACKET expr RBRACKET
{ let id = mkexp (Pexp_ident( ghloc (Ldot($3, "." ^ $4 ^ "[]")))) in
mkexp (Pexp_apply(id, [Nolabel, $1; Nolabel, $6])) }
{ let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "[]")) in
mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) }
| simple_expr DOT mod_longident DOTOP LBRACKET expr error
{ unclosed "[" 5 "]" 7 }
| simple_expr DOT mod_longident DOTOP LPAREN expr RPAREN
{ let id = mkexp (Pexp_ident( ghloc (Ldot($3, "." ^ $4 ^ "()")))) in
mkexp (Pexp_apply(id, [Nolabel, $1; Nolabel, $6])) }
{ let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "()")) in
mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) }
| simple_expr DOT mod_longident DOTOP LPAREN expr error
{ unclosed "(" 5 ")" 7 }
| simple_expr DOT mod_longident DOTOP LBRACE expr RBRACE
{ let id = mkexp (Pexp_ident( ghloc (Ldot($3, "." ^ $4 ^ "{}")))) in
mkexp (Pexp_apply(id, [Nolabel, $1; Nolabel, $6])) }
{ let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "{}")) in
mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) }
| simple_expr DOT mod_longident DOTOP LBRACE expr error
{ unclosed "{" 5 "}" 7 }
| simple_expr DOT LBRACE expr RBRACE
@ -1632,8 +1628,10 @@ let_binding_body:
| val_ident type_constraint EQUAL seq_expr
{ let v = mkpatvar $1 1 in (* PR#7344 *)
let t =
let x, y = $2 in
match y with Some t -> t | None -> match x with Some t -> t | None -> assert false
match $2 with
Some t, None -> t
| _, Some t -> t
| _ -> assert false
in
(ghpat(Ppat_constraint(v, ghtyp(Ptyp_poly([],t)))),
mkexp_constraint $4 $2) }
@ -1820,15 +1818,15 @@ simple_pattern_not_ident:
| simple_delimited_pattern
{ $1 }
| mod_longident DOT simple_delimited_pattern
{ mkpat (Ppat_open(mkrhs $1 1, $3)) }
{ mkpat @@ Ppat_open(mkrhs $1 1, $3) }
| mod_longident DOT LBRACKET RBRACKET
{ mkpat (Ppat_open(mkrhs $1 1, mkpat (
Ppat_construct ( mkrhs (Lident "[]") 4, None)))) }
{ mkpat @@ Ppat_open(mkrhs $1 1, mkpat @@
Ppat_construct ( mkrhs (Lident "[]") 4, None)) }
| mod_longident DOT LPAREN RPAREN
{ mkpat (Ppat_open( mkrhs $1 1, mkpat (
Ppat_construct ( mkrhs (Lident "()") 4, None) ))) }
{ mkpat @@ Ppat_open( mkrhs $1 1, mkpat @@
Ppat_construct ( mkrhs (Lident "()") 4, None) ) }
| mod_longident DOT LPAREN pattern RPAREN
{ mkpat (Ppat_open (mkrhs $1 1, $4))}
{ mkpat @@ Ppat_open (mkrhs $1 1, $4)}
| mod_longident DOT LPAREN pattern error
{unclosed "(" 3 ")" 5 }
| mod_longident DOT LPAREN error
@ -2092,10 +2090,9 @@ label_declaration:
label_declaration_semi:
mutable_flag label COLON poly_type_no_attr attributes SEMI attributes
{
let info =
let ri = rhs_info 5 in
match ri with
| Some _ -> ri
let info =
match rhs_info 5 with
| Some _ as info_before_semi -> info_before_semi
| None -> symbol_info ()
in
Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:($5 @ $7)
@ -2253,7 +2250,7 @@ simple_core_type:
simple_core_type2 %prec below_HASH
{ $1 }
| LPAREN core_type_comma_list RPAREN %prec below_HASH
{ match $2 with [] -> raise Parse_error | sty :: l -> match l with [] -> sty | _ -> raise Parse_error }
{ match $2 with [sty] -> sty | _ -> raise Parse_error }
;
simple_core_type2:
@ -2360,9 +2357,8 @@ field:
field_semi:
label COLON poly_type_no_attr attributes SEMI attributes
{ let info =
let ri = rhs_info 4 in
match ri with
| Some _ -> ri
match rhs_info 4 with
| Some _ as info_before_semi -> info_before_semi
| None -> symbol_info ()
in
( Otag (mkrhs $1 1, add_info_attrs info ($4 @ $6), $3)) }

4
miniml/interp/parsetree.mli
View File

@ -540,7 +540,7 @@ and class_type_field_desc =
| Pctf_extension of extension
(* [%%id] *)
and class_infos =
and 'a class_infos =
{
pci_virt: virtual_flag;
pci_params: (core_type * variance) list;
@ -745,7 +745,7 @@ and open_description =
open X - popen_override = Fresh
*)
and include_infos =
and 'a include_infos =
{
pincl_mod: 'a;
pincl_loc: Location.t;

54
miniml/interp/std.ml
View File

@ -22,11 +22,10 @@ external ( > ) : 'a -> 'a -> bool = "caml_greaterthan"
external ( == ) : 'a -> 'a -> bool = "%eq"
external ( != ) : 'a -> 'a -> bool = "%noteq"
external raise : exn -> 'a = "%raise"
external fst : 'a * 'b -> 'a = "%field0"
external snd : 'a * 'b -> 'a = "%field1"
external snd : 'a * 'b -> 'b = "%field1"
let invalid_arg x = raise (Invalid_argument x)
let failwith x = raise (Failure x)
@ -43,13 +42,9 @@ let max x y = if x >= y then x else y
let abs x = if x < 0 then -x else x
type bool = false | true
type 'a ref = { mutable contents : 'a }
type ('a, 'b) result = Ok of 'a | Error of 'b
type 'a list = [] | (::) of 'a * 'a list
type 'a option = None | Some of 'a
let assert b = if b = 0 then raise (Assert_failure ("", 0, 0))
exception Exit
@ -60,24 +55,24 @@ external __string_set : string -> int -> char -> unit = "caml_bytes_set"
module Obj = struct
type t
let obj x = x
let repr x = x
let magic x = x
external obj : t -> 'a = "%identity"
external repr : 'a -> t = "%identity"
external magic : 'a -> 'b = "%identity"
external is_block : t -> bool = "caml_obj_is_block"
external new_block : int -> int -> t = "caml_obj_block"
external tag : t -> int = "caml_obj_tag"
external set_tag : t -> int -> unit = "caml_obj_set_tag"
external size : t -> int = "%79" (* VECTLENGTH "caml_obj_size" *)
external field : t -> int -> t = "%80" (* GETVECTITEM "caml_obj_field" *)
external set_field : t -> int -> t -> unit = "%81" (* SETVECTITEM "caml_obj_set_field" *)
external is_int : t -> bool = "%129"
external size : t -> int = "%obj_size"
external field : t -> int -> t = "%obj_field"
external set_field : t -> int -> t -> unit = "%obj_set_field"
external is_int : t -> bool = "%obj_is_int"
let lazy_tag = 246
let forward_tag = 250
let string_tag = 252
end
let lazy x = x
module Lazy = struct let force x = x end
let int_of_char x = x
let char_of_int x = x
let int_of_char (x : char) : int = Obj.magic x
let char_of_int (x : int) : char = Obj.magic x
external string_length : string -> int = "%string_length"
external bytes_length : bytes -> int = "%bytes_length"
@ -93,8 +88,12 @@ let ( ^ ) s1 s2 =
string_blit s2 0 s l1 l2;
bytes_unsafe_to_string s
(* 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
module Uchar = struct
type t
let unsafe_of_int (x : int) : t = Obj.magic x
let to_int (x : t) : int = Obj.magic x
let is_valid (x : int) = true
end
let rec ( @ ) l1 l2 = match l1 with [] -> l2 | x :: l1 -> x :: (l1 @ l2)
@ -103,16 +102,17 @@ let ( ! ) x = x.contents
let ( := ) x y = x.contents <- y
let incr x = x := !x + 1
let decr x = x := !x - 1
let not x = 1 - x
external not : bool -> bool = "%boolnot"
external __mkatom0 : unit -> 'a array = "%58"
let __atom0 = __mkatom0 ()
external __array_make: int -> 'a -> 'a array = "caml_make_vect"
let __atom0 = __array_make 0 0
external int_of_string : string -> int = "caml_int_of_string"
external format_int : string -> int -> string = "caml_format_int"
let string_of_int n = format_int "%d" n
type in_channel
type out_channel
external unsafe_input : in_channel -> bytes -> int -> int -> unit = "caml_ml_input"
@ -161,10 +161,10 @@ let open_out_gen mode perm name =
c
let open_out name =
open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 438 (* 0o666 *) name
open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name
let open_out_bin name =
open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 438 (* 0o666 *) name
open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
external close_in : in_channel -> unit = "caml_ml_close_channel"
let close_in_noerr ic = try close_in ic with _ -> ()
@ -343,8 +343,8 @@ let valid_float_lexem s =
let l = string_length s in
let rec loop i =
if i >= l then s ^ "." else
match s.[i] with
| c when (c = '-' || '0' <= c && c <= '9') -> loop (i + 1)
match __string_get s i with
| '-' | '0' .. '9' -> loop (i + 1)
| _ -> s
in
loop 0

6
miniml/interp/std_miniml.ml Normal file
View File

@ -0,0 +1,6 @@
let assert b = if b = 0 then raise (Assert_failure ("", 0, 0))
let lazy x = x
module Lazy = struct
let force x = x
end

2
miniml/interp/std_miniml_prefix.ml Normal file
View File

@ -0,0 +1,2 @@
type bool = false | true
type 'a option = None | Some of 'a

4
miniml/interp/std_opt_prefix.ml Normal file
View File

@ -0,0 +1,4 @@
external ( || ) : bool -> bool -> bool = "%sequor"
external ( && ) : bool -> bool -> bool = "%sequand"
external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"

6
miniml/interp/warnings.ml
View File

@ -20,6 +20,12 @@
- manual/manual/cmds/native.etex
*)
type loc = {
loc_start: Lexing.position;
loc_end: Lexing.position;
loc_ghost: bool;
}
type t =
| Comment_start (* 1 *)
| Comment_not_end (* 2 *)