diff options
| -rw-r--r-- | Makefile | 3 | ||||
| -rw-r--r-- | byterun/floats.c | 28 | ||||
| -rw-r--r-- | stdlib/printf.ml | 11 | ||||
| -rw-r--r-- | stdlib/scanf.ml | 11 | ||||
| -rw-r--r-- | typing/typecore.ml | 47 | ||||
| -rw-r--r-- | typing/typecore.mli | 4 |
6 files changed, 69 insertions, 35 deletions
@@ -487,7 +487,8 @@ partialclean:: beforedepend:: asmcomp/emit.ml tools/cvt_emit: tools/cvt_emit.mll - cd tools; $(MAKE) CAMLC="../$(CAMLRUN) ../ocamlc -I ../stdlib" cvt_emit + cd tools; \ + $(MAKE) CAMLC="../$(CAMLRUN) ../boot/ocamlc -I ../stdlib" cvt_emit # The "expunge" utility diff --git a/byterun/floats.c b/byterun/floats.c index 16cbb5aba..6ef592026 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -106,6 +106,34 @@ CAMLprim value caml_format_float(value fmt, value arg) return res; } +/*CAMLprim*/ value caml_float_of_substring(value vs, value idx, value l) +{ + char parse_buffer[64]; + char * buf, * src, * dst, * end; + mlsize_t len, lenvs; + double d; + long flen = Int_val(l); + long fidx = Int_val(idx); + + lenvs = caml_string_length(vs); + len = + fidx >= 0 && fidx < lenvs && flen > 0 && flen <= lenvs - fidx + ? flen : 0; + buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1); + src = String_val(vs) + fidx; + dst = buf; + while (len--) { + char c = *src++; + if (c != '_') *dst++ = c; + } + *dst = 0; + if (dst == buf) caml_failwith("float_of_string"); + d = strtod((const char *) buf, &end); + if (buf != parse_buffer) caml_stat_free(buf); + if (end != dst) caml_failwith("float_of_string"); + return caml_copy_double(d); +} + CAMLprim value caml_float_of_string(value vs) { char parse_buffer[64]; diff --git a/stdlib/printf.ml b/stdlib/printf.ml index 29bf75deb..116873e9e 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -23,7 +23,7 @@ external format_float: string -> float -> string = "caml_format_float" let bad_conversion fmt i c = invalid_arg ("printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^ - string_of_int i ^ " in format ``" ^ fmt ^ "''");; + string_of_int i ^ " in format string ``" ^ fmt ^ "''");; let incomplete_format fmt = invalid_arg @@ -88,9 +88,10 @@ let format_int_with_conv conv fmt i = (* Returns the position of the last character of the meta format string, starting from position [i], inside a given format [fmt]. According to the character [conv], the meta format string is - enclosed by the delimitors %{ and %} (when [conv = '{']) - or %( and %) (when [conv = '(']). Hence [sub_format] returns the - index of the character ')' or '}' that ends the meta format. *) + enclosed by the delimitors %{ and %} (when [conv = '{']) or %( and + %) (when [conv = '(']). Hence, [sub_format] returns the index of + the character ')' or '}' that ends the meta format, according to + the character [conv]. *) let sub_format incomplete_format bad_conversion conv fmt i = let len = String.length fmt in let rec sub_fmt c i = @@ -106,7 +107,7 @@ let sub_format incomplete_format bad_conversion conv fmt i = | '(' | '{' as c -> let j = sub_fmt c (j + 1) in sub (j + 1) | ')' | '}' as c -> - if c = close then j else bad_conversion fmt j c + if c = close then j else bad_conversion fmt i c | _ -> sub (j + 1) in sub i in sub_fmt conv i;; diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index eb532e12f..03fa94014 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -252,14 +252,15 @@ let scanf_bad_input ib = function bad_input (Printf.sprintf "scanf: bad input at char number %i: %s" i s) | x -> raise x;; -let incomplete_format fmt = - invalid_arg - (Printf.sprintf "scanf: premature end of format string ``%s''" fmt);; - let bad_conversion fmt i c = invalid_arg (Printf.sprintf - "scanf: bad conversion %%%c, at char number %i in format %S" c i fmt);; + "scanf: bad conversion %%%c, at char number %i \ + in format string ``%s''" c i fmt);; + +let incomplete_format fmt = + invalid_arg + (Printf.sprintf "scanf: premature end of format string ``%s''" fmt);; let bad_float () = bad_input "no dot or exponent part found in float token";; diff --git a/typing/typecore.ml b/typing/typecore.ml index d73fd8b32..869de177b 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -37,8 +37,8 @@ type error = | Label_multiply_defined of Longident.t | Label_missing of string list | Label_not_mutable of Longident.t - | Bad_format of string - | Bad_conversion of string * string + | Incomplete_format of string + | Bad_conversion of string * int * char | Undefined_method of type_expr * string | Undefined_inherited_method of string | Unbound_class of Longident.t @@ -624,21 +624,21 @@ and is_nonexpansive_opt = function None -> true | Some e -> is_nonexpansive e -(* Typing of printf formats. +(* Typing of printf formats. (Handling of * modifiers contributed by Thorsten Ohl.) *) let type_format loc fmt = let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in + let bad_conversion fmt i c = + raise (Error (loc, Bad_conversion (fmt, i, c))) in + let incomplete_format fmt = + raise (Error (loc, Incomplete_format fmt)) in + let rec type_in_format fmt = let len = String.length fmt in - let bad_conversion fmt i c = - raise (Error (loc, Bad_conversion (fmt, String.sub fmt i len))) in - let incomplete i = - raise (Error (loc, Bad_format (String.sub fmt i (len - i)))) in - let ty_input = newvar () and ty_result = newvar () and ty_aresult = newvar () in @@ -647,29 +647,31 @@ let type_format loc fmt = let rec scan_format i = if i >= len then - if !meta = 0 then ty_aresult, ty_result else incomplete (i - 1) else + if !meta = 0 + then ty_aresult, ty_result + else incomplete_format fmt else match fmt.[i] with | '%' -> scan_opts i (i + 1) | _ -> scan_format (i + 1) and scan_opts i j = - if j >= len then incomplete i else + if j >= len then incomplete_format fmt else match fmt.[j] with | '_' -> scan_rest true i (j + 1) | _ -> scan_rest false i j and scan_rest skip i j = let rec scan_flags i j = - if j >= len then incomplete i else + if j >= len then incomplete_format fmt else match fmt.[j] with | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1) | _ -> scan_width i j and scan_width i j = scan_width_or_prec_value scan_precision i j and scan_decimal_string scan i j = - if j >= len then incomplete i else + if j >= len then incomplete_format fmt else match fmt.[j] with | '0' .. '9' -> scan_decimal_string scan i (j + 1) | _ -> scan i j and scan_width_or_prec_value scan i j = - if j >= len then incomplete i else + if j >= len then incomplete_format fmt else match fmt.[j] with | '*' -> let ty_aresult, ty_result = scan i (j + 1) in @@ -677,7 +679,7 @@ let type_format loc fmt = | '-' | '+' -> scan_decimal_string scan i (j + 1) | _ -> scan_decimal_string scan i j and scan_precision i j = - if j >= len then incomplete i else + if j >= len then incomplete_format fmt else match fmt.[j] with | '.' -> scan_width_or_prec_value scan_conversion i (j + 1) | _ -> scan_conversion i j @@ -688,7 +690,7 @@ let type_format loc fmt = if skip then ty_result else ty_arrow ty_arg ty_result and scan_conversion i j = - if j >= len then incomplete i else + if j >= len then incomplete_format fmt else match fmt.[j] with | '%' | '!' -> scan_format (j + 1) | 's' | 'S' | '[' -> conversion j Predef.type_string @@ -718,10 +720,9 @@ let type_format loc fmt = end | '{' | '(' as c -> let j = j + 1 in - if j >= len then incomplete i else + if j >= len then incomplete_format fmt else let sj = - Printf.sub_format - (fun fmt -> incomplete 0) bad_conversion c fmt j in + Printf.sub_format incomplete_format bad_conversion c fmt j in let sfmt = String.sub fmt j (sj - j - 1) in let ty_sfmt = type_in_format sfmt in begin match c with @@ -1995,10 +1996,12 @@ let report_error ppf = function print_labels labels | Label_not_mutable lid -> fprintf ppf "The record field label %a is not mutable" longident lid - | Bad_format s -> - fprintf ppf "Bad format %S" s - | Bad_conversion (fmt, conv) -> - fprintf ppf "Bad conversion %S in format %S" fmt conv + | Incomplete_format s -> + fprintf ppf "Premature end of format string ``%S''" s + | Bad_conversion (fmt, i, c) -> + fprintf ppf + "Bad conversion %%%c, at char number %d \ + in format string ``%s''" c i fmt | Undefined_method (ty, me) -> reset_and_mark_loops ty; fprintf ppf diff --git a/typing/typecore.mli b/typing/typecore.mli index 3a337c2de..993bcb9c1 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -74,8 +74,8 @@ type error = | Label_multiply_defined of Longident.t | Label_missing of string list | Label_not_mutable of Longident.t - | Bad_format of string - | Bad_conversion of string * string + | Incomplete_format of string + | Bad_conversion of string * int * char | Undefined_method of type_expr * string | Undefined_inherited_method of string | Unbound_class of Longident.t |