From f375799b0db233e1d2b1c1ab71ab52f3f2342654 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABl=20Courant?= Date: Wed, 17 Feb 2021 15:15:10 +0100 Subject: [PATCH] Make interp compatible with ocamlopt --- interpreter/interp.ml | 3 +- miniml/compiler/compile.scm | 9 +- miniml/interp/Makefile | 8 +- miniml/interp/arg.ml | 4 +- miniml/interp/clflags.ml | 1 - miniml/interp/docstrings.ml | 21 -- miniml/interp/format.ml | 2 +- miniml/interp/genfileopt.sh | 18 ++ miniml/interp/interp.opt | 5 + miniml/interp/lex.sh | 4 + miniml/interp/lexer.mll | 98 +++---- miniml/interp/location.ml | 444 +---------------------------- miniml/interp/parser.mly | 178 ++++++------ miniml/interp/parsetree.mli | 4 +- miniml/interp/std.ml | 54 ++-- miniml/interp/std_miniml.ml | 6 + miniml/interp/std_miniml_prefix.ml | 2 + miniml/interp/std_opt_prefix.ml | 4 + miniml/interp/warnings.ml | 6 + 19 files changed, 236 insertions(+), 635 deletions(-) create mode 100755 miniml/interp/genfileopt.sh create mode 100755 miniml/interp/interp.opt create mode 100755 miniml/interp/lex.sh create mode 100644 miniml/interp/std_miniml.ml create mode 100644 miniml/interp/std_miniml_prefix.ml create mode 100644 miniml/interp/std_opt_prefix.ml diff --git a/interpreter/interp.ml b/interpreter/interp.ml index 79cdb23..9419087 100644 --- a/interpreter/interp.ml +++ b/interpreter/interp.ml @@ -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 diff --git a/miniml/compiler/compile.scm b/miniml/compiler/compile.scm index a1489fc..78fcb72 100644 --- a/miniml/compiler/compile.scm +++ b/miniml/compiler/compile.scm @@ -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") diff --git a/miniml/interp/Makefile b/miniml/interp/Makefile index 0112be8..38125a1 100644 --- a/miniml/interp/Makefile +++ b/miniml/interp/Makefile @@ -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 diff --git a/miniml/interp/arg.ml b/miniml/interp/arg.ml index 4c9a68a..0cfb3a6 100644 --- a/miniml/interp/arg.ml +++ b/miniml/interp/arg.ml @@ -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 diff --git a/miniml/interp/clflags.ml b/miniml/interp/clflags.ml index b0f4887..5507a2b 100644 --- a/miniml/interp/clflags.ml +++ b/miniml/interp/clflags.ml @@ -1,3 +1,2 @@ let fast = ref false let applicative_functors = ref true -let color = ref None diff --git a/miniml/interp/docstrings.ml b/miniml/interp/docstrings.ml index 731c67e..ceffecf 100644 --- a/miniml/interp/docstrings.ml +++ b/miniml/interp/docstrings.ml @@ -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 ()) diff --git a/miniml/interp/format.ml b/miniml/interp/format.ml index 6008fea..fa57f88 100644 --- a/miniml/interp/format.ml +++ b/miniml/interp/format.ml @@ -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 () -> ()) diff --git a/miniml/interp/genfileopt.sh b/miniml/interp/genfileopt.sh new file mode 100755 index 0000000..434599c --- /dev/null +++ b/miniml/interp/genfileopt.sh @@ -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 \ No newline at end of file diff --git a/miniml/interp/interp.opt b/miniml/interp/interp.opt new file mode 100755 index 0000000..875cf83 --- /dev/null +++ b/miniml/interp/interp.opt @@ -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 "$@" \ No newline at end of file diff --git a/miniml/interp/lex.sh b/miniml/interp/lex.sh new file mode 100755 index 0000000..5ffbb63 --- /dev/null +++ b/miniml/interp/lex.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +r=$(dirname $0) +root=$r/../.. +$root/_boot/byterun/ocamlrun $r/lex.byte "$@" \ No newline at end of file diff --git a/miniml/interp/lexer.mll b/miniml/interp/lexer.mll index d9d408b..89079d4 100644 --- a/miniml/interp/lexer.mll +++ b/miniml/interp/lexer.mll @@ -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; diff --git a/miniml/interp/location.ml b/miniml/interp/location.ml index 0200792..ae08e0e 100644 --- a/miniml/interp/location.ml +++ b/miniml/interp/location.ml @@ -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 "@["; - (* 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@{%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 "@{%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 "@{%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 "@["; - 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 "@{%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 "@[%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 diff --git a/miniml/interp/parser.mly b/miniml/interp/parser.mly index 843bd7d..44e78ac 100644 --- a/miniml/interp/parser.mly +++ b/miniml/interp/parser.mly @@ -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)) } diff --git a/miniml/interp/parsetree.mli b/miniml/interp/parsetree.mli index 726431a..9f5de19 100644 --- a/miniml/interp/parsetree.mli +++ b/miniml/interp/parsetree.mli @@ -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; diff --git a/miniml/interp/std.ml b/miniml/interp/std.ml index dcfbde1..2adfe62 100644 --- a/miniml/interp/std.ml +++ b/miniml/interp/std.ml @@ -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 diff --git a/miniml/interp/std_miniml.ml b/miniml/interp/std_miniml.ml new file mode 100644 index 0000000..de7bc1d --- /dev/null +++ b/miniml/interp/std_miniml.ml @@ -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 diff --git a/miniml/interp/std_miniml_prefix.ml b/miniml/interp/std_miniml_prefix.ml new file mode 100644 index 0000000..7858deb --- /dev/null +++ b/miniml/interp/std_miniml_prefix.ml @@ -0,0 +1,2 @@ +type bool = false | true +type 'a option = None | Some of 'a diff --git a/miniml/interp/std_opt_prefix.ml b/miniml/interp/std_opt_prefix.ml new file mode 100644 index 0000000..1edb116 --- /dev/null +++ b/miniml/interp/std_opt_prefix.ml @@ -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" diff --git a/miniml/interp/warnings.ml b/miniml/interp/warnings.ml index 4e4ce7c..8d1a81b 100644 --- a/miniml/interp/warnings.ml +++ b/miniml/interp/warnings.ml @@ -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 *)