diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/arg.ml | 13 | ||||
| -rw-r--r-- | stdlib/arg.mli | 2 | ||||
| -rw-r--r-- | stdlib/camlinternalMod.ml | 12 | ||||
| -rw-r--r-- | stdlib/camlinternalOO.ml | 2 | ||||
| -rw-r--r-- | stdlib/format.ml | 1008 | ||||
| -rw-r--r-- | stdlib/gc.mli | 2 | ||||
| -rw-r--r-- | stdlib/int32.mli | 8 | ||||
| -rw-r--r-- | stdlib/int64.mli | 8 | ||||
| -rw-r--r-- | stdlib/printf.ml | 183 | ||||
| -rw-r--r-- | stdlib/printf.mli | 13 | ||||
| -rw-r--r-- | stdlib/weak.ml | 189 |
11 files changed, 740 insertions, 700 deletions
diff --git a/stdlib/arg.ml b/stdlib/arg.ml index dd6c517532..009e203753 100644 --- a/stdlib/arg.ml +++ b/stdlib/arg.ml @@ -65,7 +65,7 @@ let make_symlist prefix sep suffix l = let print_spec buf (key, spec, doc) = match spec with - | Symbol (l, _) -> bprintf buf " %s %s %s\n" key (make_symlist "{" "|" "}" l) + | Symbol (l, _) -> bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l) doc | _ -> bprintf buf " %s %s\n" key doc ;; @@ -225,13 +225,18 @@ let rec second_word s = with Not_found -> len ;; -let max_arg_len cur (kwd, _, doc) = - max cur (String.length kwd + second_word doc) +let max_arg_len cur (kwd, spec, doc) = + match spec with + | Symbol _ -> max cur (String.length kwd) + | _ -> max cur (String.length kwd + second_word doc) ;; let add_padding len ksd = match ksd with - | (_, Symbol _, _) -> ksd + | (kwd, (Symbol (l, _) as spec), msg) -> + let cutcol = second_word msg in + let spaces = String.make (len - cutcol + 3) ' ' in + (kwd, spec, "\n" ^ spaces ^ msg) | (kwd, spec, msg) -> let cutcol = second_word msg in let spaces = String.make (len - String.length kwd - cutcol) ' ' in diff --git a/stdlib/arg.mli b/stdlib/arg.mli index bc33d239fd..4e5ed08d1c 100644 --- a/stdlib/arg.mli +++ b/stdlib/arg.mli @@ -125,7 +125,7 @@ val align: (key * spec * doc) list -> (key * spec * doc) list;; space, according to the length of the keyword. Use a space as the first character in a doc string if you want to align the whole string. The doc strings corresponding to - [Symbol] arguments are not aligned. *) + [Symbol] arguments are aligned on the next line. *) val current : int ref (** Position (in {!Sys.argv}) of the argument being processed. You can diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml index 17419aef5f..12a77cc8fb 100644 --- a/stdlib/camlinternalMod.ml +++ b/stdlib/camlinternalMod.ml @@ -48,8 +48,16 @@ let rec update_mod shape o n = then begin overwrite o n; Obj.truncate o (Obj.size n) (* PR #4008 *) end else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x)) | Lazy -> - assert (Obj.tag n = Obj.lazy_tag); - overwrite o n + if Obj.tag n = Obj.lazy_tag then + Obj.set_field o 0 (Obj.field n 0) + else if Obj.tag n = Obj.forward_tag then begin (* PR#4316 *) + Obj.set_tag o Obj.forward_tag; + Obj.set_field o 0 (Obj.field n 0) + end else begin + (* forwarding pointer was shortcut by GC *) + Obj.set_tag o Obj.forward_tag; + Obj.set_field o 0 n + end | Class -> assert (Obj.tag n = 0 && Obj.size n = 4); overwrite o n diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml index 2205a37fec..2ffa71c0a2 100644 --- a/stdlib/camlinternalOO.ml +++ b/stdlib/camlinternalOO.ml @@ -262,7 +262,7 @@ let new_variable table name = try Vars.find name table.vars with Not_found -> let index = new_slot table in - table.vars <- Vars.add name index table.vars; + if name <> "" then table.vars <- Vars.add name index table.vars; index let to_array arr = diff --git a/stdlib/format.ml b/stdlib/format.ml index ca31832e89..6debd39d04 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -64,7 +64,9 @@ and tblock = Pp_tbox of int list ref (* Tabulation box *) size is set when the size of the block is known len is the declared length of the token. *) type pp_queue_elem = { - mutable elem_size : size; token : pp_token; length : int + mutable elem_size : size; + token : pp_token; + length : int; };; (* Scan stack: @@ -79,75 +81,80 @@ type pp_scan_elem = Scan_elem of int * pp_queue_elem;; type pp_format_elem = Format_elem of block_type * int;; (* General purpose queues, used in the formatter. *) -type 'a queue_elem = | Nil | Cons of 'a queue_cell -and 'a queue_cell = {mutable head : 'a; mutable tail : 'a queue_elem};; +type 'a queue_elem = + | Nil + | Cons of 'a queue_cell + +and 'a queue_cell = { + mutable head : 'a; + mutable tail : 'a queue_elem; +};; type 'a queue = { - mutable insert : 'a queue_elem; - mutable body : 'a queue_elem + mutable insert : 'a queue_elem; + mutable body : 'a queue_elem; };; (* The formatter specific tag handling functions. *) type formatter_tag_functions = { - mark_open_tag : tag -> string; - mark_close_tag : tag -> string; - print_open_tag : tag -> unit; - print_close_tag : tag -> unit; - + mark_open_tag : tag -> string; + mark_close_tag : tag -> string; + print_open_tag : tag -> unit; + print_close_tag : tag -> unit; };; (* A formatter with all its machinery. *) type formatter = { - mutable pp_scan_stack : pp_scan_elem list; - mutable pp_format_stack : pp_format_elem list; - mutable pp_tbox_stack : tblock list; - mutable pp_tag_stack : tag list; - mutable pp_mark_stack : tag list; - (* Global variables: default initialization is - set_margin 78 - set_min_space_left 0. *) - (* Value of right margin. *) - mutable pp_margin : int; - (* Minimal space left before margin, when opening a block. *) - mutable pp_min_space_left : int; - (* Maximum value of indentation: - no blocks can be opened further. *) - mutable pp_max_indent : int; - (* Space remaining on the current line. *) - mutable pp_space_left : int; - (* Current value of indentation. *) - mutable pp_current_indent : int; - (* True when the line has been broken by the pretty-printer. *) - mutable pp_is_new_line : bool; - (* Total width of tokens already printed. *) - mutable pp_left_total : int; - (* Total width of tokens ever put in queue. *) - mutable pp_right_total : int; - (* Current number of opened blocks. *) - mutable pp_curr_depth : int; - (* Maximum number of blocks which can be simultaneously opened. *) - mutable pp_max_boxes : int; - (* Ellipsis string. *) - mutable pp_ellipsis : string; - (* Output function. *) - mutable pp_output_function : string -> int -> int -> unit; - (* Flushing function. *) - mutable pp_flush_function : unit -> unit; - (* Output of new lines. *) - mutable pp_output_newline : unit -> unit; - (* Output of indentation spaces. *) - mutable pp_output_spaces : int -> unit; - (* Are tags printed ? *) - mutable pp_print_tags : bool; - (* Are tags marked ? *) - mutable pp_mark_tags : bool; - (* Find opening and closing markers of tags. *) - mutable pp_mark_open_tag : tag -> string; - mutable pp_mark_close_tag : tag -> string; - mutable pp_print_open_tag : tag -> unit; - mutable pp_print_close_tag : tag -> unit; - (* The pretty-printer queue. *) - mutable pp_queue : pp_queue_elem queue + mutable pp_scan_stack : pp_scan_elem list; + mutable pp_format_stack : pp_format_elem list; + mutable pp_tbox_stack : tblock list; + mutable pp_tag_stack : tag list; + mutable pp_mark_stack : tag list; + (* Global variables: default initialization is + set_margin 78 + set_min_space_left 0. *) + (* Value of right margin. *) + mutable pp_margin : int; + (* Minimal space left before margin, when opening a block. *) + mutable pp_min_space_left : int; + (* Maximum value of indentation: + no blocks can be opened further. *) + mutable pp_max_indent : int; + (* Space remaining on the current line. *) + mutable pp_space_left : int; + (* Current value of indentation. *) + mutable pp_current_indent : int; + (* True when the line has been broken by the pretty-printer. *) + mutable pp_is_new_line : bool; + (* Total width of tokens already printed. *) + mutable pp_left_total : int; + (* Total width of tokens ever put in queue. *) + mutable pp_right_total : int; + (* Current number of opened blocks. *) + mutable pp_curr_depth : int; + (* Maximum number of blocks which can be simultaneously opened. *) + mutable pp_max_boxes : int; + (* Ellipsis string. *) + mutable pp_ellipsis : string; + (* Output function. *) + mutable pp_output_function : string -> int -> int -> unit; + (* Flushing function. *) + mutable pp_flush_function : unit -> unit; + (* Output of new lines. *) + mutable pp_output_newline : unit -> unit; + (* Output of indentation spaces. *) + mutable pp_output_spaces : int -> unit; + (* Are tags printed ? *) + mutable pp_print_tags : bool; + (* Are tags marked ? *) + mutable pp_mark_tags : bool; + (* Find opening and closing markers of tags. *) + mutable pp_mark_open_tag : tag -> string; + mutable pp_mark_close_tag : tag -> string; + mutable pp_print_open_tag : tag -> unit; + mutable pp_print_close_tag : tag -> unit; + (* The pretty-printer queue. *) + mutable pp_queue : pp_queue_elem queue; };; (************************************************************** @@ -158,38 +165,39 @@ type formatter = { (* Queues auxilliaries. *) -let make_queue () = {insert = Nil; body = Nil};; +let make_queue () = { insert = Nil; body = Nil; };; let clear_queue q = q.insert <- Nil; q.body <- Nil;; let add_queue x q = - let c = Cons {head = x; tail = Nil} in - match q with - | {insert = Cons cell} -> q.insert <- c; cell.tail <- c - (* Invariant: when insert is Nil body should be Nil. *) - | _ -> q.insert <- c; q.body <- c;; + let c = Cons { head = x; tail = Nil; } in + match q with + | { insert = Cons cell } -> + q.insert <- c; cell.tail <- c + (* Invariant: when insert is Nil body should be Nil. *) + | _ -> q.insert <- c; q.body <- c;; exception Empty_queue;; let peek_queue = function - | {body = Cons {head = x}} -> x - | _ -> raise Empty_queue;; + | { body = Cons { head = x; }; } -> x + | _ -> raise Empty_queue;; let take_queue = function - | {body = Cons {head = x; tail = tl}} as q -> + | { body = Cons { head = x; tail = tl; }; } as q -> q.body <- tl; if tl = Nil then q.insert <- Nil; (* Maintain the invariant. *) x - | _ -> raise Empty_queue;; + | _ -> raise Empty_queue;; (* Enter a token in the pretty-printer queue. *) let pp_enqueue state ({length = len} as token) = - state.pp_right_total <- state.pp_right_total + len; - add_queue token state.pp_queue;; + state.pp_right_total <- state.pp_right_total + len; + add_queue token state.pp_queue;; let pp_clear_queue state = - state.pp_left_total <- 1; state.pp_right_total <- 1; - clear_queue state.pp_queue;; + state.pp_left_total <- 1; state.pp_right_total <- 1; + clear_queue state.pp_queue;; (* Pp_infinity: large value for default tokens size. @@ -216,47 +224,48 @@ let pp_infinity = 1000000010;; (* Output functions for the formatter. *) let pp_output_string state s = state.pp_output_function s 0 (String.length s) -and pp_output_newline state = state.pp_output_newline ();; - -let pp_display_blanks state n = state.pp_output_spaces n;; +and pp_output_newline state = state.pp_output_newline () +and pp_display_blanks state n = state.pp_output_spaces n +;; (* To format a break, indenting a new line. *) let break_new_line state offset width = - pp_output_newline state; - state.pp_is_new_line <- true; - let indent = state.pp_margin - width + offset in - (* Don't indent more than pp_max_indent. *) - let real_indent = min state.pp_max_indent indent in - state.pp_current_indent <- real_indent; - state.pp_space_left <- state.pp_margin - state.pp_current_indent; - pp_display_blanks state state.pp_current_indent;; + pp_output_newline state; + state.pp_is_new_line <- true; + let indent = state.pp_margin - width + offset in + (* Don't indent more than pp_max_indent. *) + let real_indent = min state.pp_max_indent indent in + state.pp_current_indent <- real_indent; + state.pp_space_left <- state.pp_margin - state.pp_current_indent; + pp_display_blanks state state.pp_current_indent;; (* To force a line break inside a block: no offset is added. *) let break_line state width = break_new_line state 0 width;; (* To format a break that fits on the current line. *) let break_same_line state width = - state.pp_space_left <- state.pp_space_left - width; - pp_display_blanks state width;; + state.pp_space_left <- state.pp_space_left - width; + pp_display_blanks state width;; (* To indent no more than pp_max_indent, if one tries to open a block beyond pp_max_indent, then the block is rejected on the left by simulating a break. *) let pp_force_break_line state = - match state.pp_format_stack with - | Format_elem (bl_ty, width) :: _ -> - if width > state.pp_space_left then - (match bl_ty with - | Pp_fits -> () | Pp_hbox -> () | _ -> break_line state width) - | _ -> pp_output_newline state;; + match state.pp_format_stack with + | Format_elem (bl_ty, width) :: _ -> + if width > state.pp_space_left then + (match bl_ty with + | Pp_fits -> () | Pp_hbox -> () + | _ -> break_line state width) + | _ -> pp_output_newline state;; (* To skip a token, if the previous line has been broken. *) let pp_skip_token state = - (* When calling pp_skip_token the queue cannot be empty. *) - match take_queue state.pp_queue with - {elem_size = size; length = len} -> - state.pp_left_total <- state.pp_left_total - len; - state.pp_space_left <- state.pp_space_left + int_of_size size;; + (* When calling pp_skip_token the queue cannot be empty. *) + match take_queue state.pp_queue with + | { elem_size = size; length = len; } -> + state.pp_left_total <- state.pp_left_total - len; + state.pp_space_left <- state.pp_space_left + int_of_size size;; (************************************************************** @@ -268,141 +277,147 @@ let pp_skip_token state = let format_pp_token state size = function | Pp_text s -> - state.pp_space_left <- state.pp_space_left - size; - pp_output_string state s; - state.pp_is_new_line <- false + state.pp_space_left <- state.pp_space_left - size; + pp_output_string state s; + state.pp_is_new_line <- false | Pp_begin (off, ty) -> - let insertion_point = state.pp_margin - state.pp_space_left in - if insertion_point > state.pp_max_indent then - (* can't open a block right there. *) - begin pp_force_break_line state end; - let offset = state.pp_space_left - off in - let bl_type = - begin match ty with - | Pp_vbox -> Pp_vbox - | _ -> if size > state.pp_space_left then ty else Pp_fits - end in - state.pp_format_stack <- - Format_elem (bl_type, offset) :: state.pp_format_stack + let insertion_point = state.pp_margin - state.pp_space_left in + if insertion_point > state.pp_max_indent then + (* can't open a block right there. *) + begin pp_force_break_line state end; + let offset = state.pp_space_left - off in + let bl_type = + begin match ty with + | Pp_vbox -> Pp_vbox + | _ -> if size > state.pp_space_left then ty else Pp_fits + end in + state.pp_format_stack <- + Format_elem (bl_type, offset) :: state.pp_format_stack | Pp_end -> - begin match state.pp_format_stack with - | x :: (y :: l as ls) -> state.pp_format_stack <- ls - | _ -> () (* No more block to close. *) - end + begin match state.pp_format_stack with + | x :: (y :: l as ls) -> state.pp_format_stack <- ls + | _ -> () (* No more block to close. *) + end | Pp_tbegin (Pp_tbox _ as tbox) -> - state.pp_tbox_stack <- tbox :: state.pp_tbox_stack + state.pp_tbox_stack <- tbox :: state.pp_tbox_stack | Pp_tend -> - begin match state.pp_tbox_stack with - | x :: ls -> state.pp_tbox_stack <- ls - | _ -> () (* No more tabulation block to close. *) - end + begin match state.pp_tbox_stack with + | x :: ls -> state.pp_tbox_stack <- ls + | _ -> () (* No more tabulation block to close. *) + end | Pp_stab -> - begin match state.pp_tbox_stack with - | Pp_tbox tabs :: _ -> - let rec add_tab n = function - | [] -> [n] - | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in - tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs - | _ -> () (* No opened tabulation block. *) - end + begin match state.pp_tbox_stack with + | Pp_tbox tabs :: _ -> + let rec add_tab n = function + | [] -> [n] + | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in + tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs + | _ -> () (* No opened tabulation block. *) + end | Pp_tbreak (n, off) -> - let insertion_point = state.pp_margin - state.pp_space_left in - begin match state.pp_tbox_stack with - | Pp_tbox tabs :: _ -> - let rec find n = function - | x :: l -> if x >= n then x else find n l - | [] -> raise Not_found in - let tab = - match !tabs with - | x :: l -> - begin try find insertion_point !tabs with Not_found -> x end - | _ -> insertion_point in - let offset = tab - insertion_point in - if offset >= 0 then break_same_line state (offset + n) else - break_new_line state (tab + off) state.pp_margin - | _ -> () (* No opened tabulation block. *) - end + let insertion_point = state.pp_margin - state.pp_space_left in + begin match state.pp_tbox_stack with + | Pp_tbox tabs :: _ -> + let rec find n = function + | x :: l -> if x >= n then x else find n l + | [] -> raise Not_found in + let tab = + match !tabs with + | x :: l -> + begin + try find insertion_point !tabs with + | Not_found -> x + end + | _ -> insertion_point in + let offset = tab - insertion_point in + if offset >= 0 + then break_same_line state (offset + n) + else break_new_line state (tab + off) state.pp_margin + | _ -> () (* No opened tabulation block. *) + end | Pp_newline -> - begin match state.pp_format_stack with - | Format_elem (_, width) :: _ -> break_line state width - | _ -> pp_output_newline state - end + begin match state.pp_format_stack with + | Format_elem (_, width) :: _ -> break_line state width + | _ -> pp_output_newline state + end | Pp_if_newline -> - if state.pp_current_indent != state.pp_margin - state.pp_space_left - then pp_skip_token state + if state.pp_current_indent != state.pp_margin - state.pp_space_left + then pp_skip_token state | Pp_break (n, off) -> - begin match state.pp_format_stack with - | Format_elem (ty, width) :: _ -> - begin match ty with - | Pp_hovbox -> - if size > state.pp_space_left - then break_new_line state off width - else break_same_line state n - | Pp_box -> - (* Have the line just been broken here ? *) - if state.pp_is_new_line then break_same_line state n else - if size > state.pp_space_left - then break_new_line state off width else - (* break the line here leads to new indentation ? *) - if state.pp_current_indent > state.pp_margin - width + off - then break_new_line state off width - else break_same_line state n - | Pp_hvbox -> break_new_line state off width - | Pp_fits -> break_same_line state n - | Pp_vbox -> break_new_line state off width - | Pp_hbox -> break_same_line state n - end - | _ -> () (* No opened block. *) - end + begin match state.pp_format_stack with + | Format_elem (ty, width) :: _ -> + begin match ty with + | Pp_hovbox -> + if size > state.pp_space_left + then break_new_line state off width + else break_same_line state n + | Pp_box -> + (* Have the line just been broken here ? *) + if state.pp_is_new_line then break_same_line state n else + if size > state.pp_space_left + then break_new_line state off width else + (* break the line here leads to new indentation ? *) + if state.pp_current_indent > state.pp_margin - width + off + then break_new_line state off width + else break_same_line state n + | Pp_hvbox -> break_new_line state off width + | Pp_fits -> break_same_line state n + | Pp_vbox -> break_new_line state off width + | Pp_hbox -> break_same_line state n + end + | _ -> () (* No opened block. *) + end | Pp_open_tag tag_name -> - let marker = state.pp_mark_open_tag tag_name in - pp_output_string state marker; - state.pp_mark_stack <- tag_name :: state.pp_mark_stack + let marker = state.pp_mark_open_tag tag_name in + pp_output_string state marker; + state.pp_mark_stack <- tag_name :: state.pp_mark_stack | Pp_close_tag -> - begin match state.pp_mark_stack with - | tag_name :: tags -> - let marker = state.pp_mark_close_tag tag_name in - pp_output_string state marker; - state.pp_mark_stack <- tags - | _ -> () (* No more tag to close. *) - end;; + begin match state.pp_mark_stack with + | tag_name :: tags -> + let marker = state.pp_mark_close_tag tag_name in + pp_output_string state marker; + state.pp_mark_stack <- tags + | _ -> () (* No more tag to close. *) + end +;; (* Print if token size is known or printing is delayed. Size is known when not negative. Printing is delayed when the text waiting in the queue requires more room to format than exists on the current line. *) let rec advance_left state = - try - match peek_queue state.pp_queue with - {elem_size = size; token = tok; length = len} -> - let size = int_of_size size in - if not - (size < 0 && - (state.pp_right_total - state.pp_left_total < state.pp_space_left)) - then begin - ignore(take_queue state.pp_queue); - format_pp_token state (if size < 0 then pp_infinity else size) tok; - state.pp_left_total <- len + state.pp_left_total; - advance_left state - end - with Empty_queue -> ();; + try + match peek_queue state.pp_queue with + | { elem_size = size; token = tok; length = len; } -> + let size = int_of_size size in + if not + (size < 0 && + (state.pp_right_total - state.pp_left_total < + state.pp_space_left)) then + begin + ignore(take_queue state.pp_queue); + format_pp_token state (if size < 0 then pp_infinity else size) tok; + state.pp_left_total <- len + state.pp_left_total; + advance_left state + end with + | Empty_queue -> ();; let enqueue_advance state tok = pp_enqueue state tok; advance_left state;; (* To enqueue a string : try to advance. *) let make_queue_elem size tok len = - {elem_size = size; token = tok; length = len};; + { elem_size = size; token = tok; length = len; };; let enqueue_string_as state size s = let len = int_of_size size in @@ -430,89 +445,99 @@ let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom;; Pattern matching on token in scan stack is also exhaustive, since scan_push is used on breaks and opening of boxes. *) let set_size state ty = - match state.pp_scan_stack with - | Scan_elem - (left_tot, - ({elem_size = size; token = tok} as queue_elem)) :: t -> - let size = int_of_size size in - (* test if scan stack contains any data that is not obsolete. *) - if left_tot < state.pp_left_total then clear_scan_stack state else - begin match tok with - | Pp_break (_, _) | Pp_tbreak (_, _) -> - if ty then - begin - queue_elem.elem_size <- size_of_int (state.pp_right_total + size); - state.pp_scan_stack <- t - end - | Pp_begin (_, _) -> - if not ty then - begin - queue_elem.elem_size <- size_of_int (state.pp_right_total + size); - state.pp_scan_stack <- t - end - | _ -> () (* scan_push is only used for breaks and boxes. *) + match state.pp_scan_stack with + | Scan_elem + (left_tot, + ({elem_size = size; token = tok} as queue_elem)) :: t -> + let size = int_of_size size in + (* test if scan stack contains any data that is not obsolete. *) + if left_tot < state.pp_left_total then clear_scan_stack state else + begin match tok with + | Pp_break (_, _) | Pp_tbreak (_, _) -> + if ty then + begin + queue_elem.elem_size <- size_of_int (state.pp_right_total + size); + state.pp_scan_stack <- t + end + | Pp_begin (_, _) -> + if not ty then + begin + queue_elem.elem_size <- size_of_int (state.pp_right_total + size); + state.pp_scan_stack <- t end - | _ -> () (* scan_stack is never empty. *);; + | _ -> () (* scan_push is only used for breaks and boxes. *) + end + | _ -> () (* scan_stack is never empty. *);; (* Push a token on scan stack. If b is true set_size is called. *) let scan_push state b tok = - pp_enqueue state tok; - if b then set_size state true; - state.pp_scan_stack <- - Scan_elem (state.pp_right_total, tok) :: state.pp_scan_stack;; + pp_enqueue state tok; + if b then set_size state true; + state.pp_scan_stack <- + Scan_elem (state.pp_right_total, tok) :: state.pp_scan_stack;; (* To open a new block : the user may set the depth bound pp_max_boxes any text nested deeper is printed as the ellipsis string. *) let pp_open_box_gen state indent br_ty = - state.pp_curr_depth <- state.pp_curr_depth + 1; - if state.pp_curr_depth < state.pp_max_boxes then - let elem = - make_queue_elem - (size_of_int (- state.pp_right_total)) - (Pp_begin (indent, br_ty)) - 0 in - scan_push state false elem else - if state.pp_curr_depth = state.pp_max_boxes - then enqueue_string state state.pp_ellipsis;; + state.pp_curr_depth <- state.pp_curr_depth + 1; + if state.pp_curr_depth < state.pp_max_boxes then + let elem = + make_queue_elem + (size_of_int (- state.pp_right_total)) + (Pp_begin (indent, br_ty)) + 0 in + scan_push state false elem else + if state.pp_curr_depth = state.pp_max_boxes + then enqueue_string state state.pp_ellipsis;; (* The box which is always opened. *) let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox;; (* Close a block, setting sizes of its subblocks. *) let pp_close_box state () = - if state.pp_curr_depth > 1 then - begin - if state.pp_curr_depth < state.pp_max_boxes then - begin - pp_enqueue state - {elem_size = size_of_int 0; token = Pp_end; length = 0}; - set_size state true; set_size state false - end; - state.pp_curr_depth <- state.pp_curr_depth - 1; - end;; + if state.pp_curr_depth > 1 then + begin + if state.pp_curr_depth < state.pp_max_boxes then + begin + pp_enqueue state + { elem_size = size_of_int 0; token = Pp_end; length = 0; }; + set_size state true; set_size state false + end; + state.pp_curr_depth <- state.pp_curr_depth - 1; + end;; (* Open a tag, pushing it on the tag stack. *) let pp_open_tag state tag_name = - if state.pp_print_tags then begin - state.pp_tag_stack <- tag_name :: state.pp_tag_stack; - state.pp_print_open_tag tag_name end; - if state.pp_mark_tags then - pp_enqueue state - {elem_size = size_of_int 0; token = Pp_open_tag tag_name; length = 0};; + if state.pp_print_tags then + begin + state.pp_tag_stack <- tag_name :: state.pp_tag_stack; + state.pp_print_open_tag tag_name + end; + if state.pp_mark_tags then + pp_enqueue state { + elem_size = size_of_int 0; + token = Pp_open_tag tag_name; + length = 0; + } +;; (* Close a tag, popping it from the tag stack. *) let pp_close_tag state () = - if state.pp_mark_tags then - pp_enqueue state - {elem_size = size_of_int 0; token = Pp_close_tag; length = 0}; - if state.pp_print_tags then - begin match state.pp_tag_stack with - | tag_name :: tags -> - state.pp_print_close_tag tag_name; - state.pp_tag_stack <- tags - | _ -> () (* No more tag to close. *) - end;; + if state.pp_mark_tags then + pp_enqueue state { + elem_size = size_of_int 0; + token = Pp_close_tag; + length = 0; + }; + if state.pp_print_tags then + begin + match state.pp_tag_stack with + | tag_name :: tags -> + state.pp_print_close_tag tag_name; + state.pp_tag_stack <- tags + | _ -> () (* No more tag to close. *) + end;; let pp_set_print_tags state b = state.pp_print_tags <- b;; let pp_set_mark_tags state b = state.pp_mark_tags <- b;; @@ -521,10 +546,10 @@ let pp_get_mark_tags state () = state.pp_mark_tags;; let pp_set_tags state b = pp_set_print_tags state b; pp_set_mark_tags state b;; let pp_get_formatter_tag_functions state () = { - mark_open_tag = state.pp_mark_open_tag; - mark_close_tag = state.pp_mark_close_tag; - print_open_tag = state.pp_print_open_tag; - print_close_tag = state.pp_print_close_tag; + mark_open_tag = state.pp_mark_open_tag; + mark_close_tag = state.pp_mark_close_tag; + print_open_tag = state.pp_print_open_tag; + print_close_tag = state.pp_print_close_tag; };; let pp_set_formatter_tag_functions state { @@ -540,26 +565,26 @@ let pp_set_formatter_tag_functions state { (* Initialize pretty-printer. *) let pp_rinit state = - pp_clear_queue state; - clear_scan_stack state; - state.pp_format_stack <- []; - state.pp_tbox_stack <- []; - state.pp_tag_stack <- []; - state.pp_mark_stack <- []; - state.pp_current_indent <- 0; - state.pp_curr_depth <- 0; - state.pp_space_left <- state.pp_margin; - pp_open_sys_box state;; + pp_clear_queue state; + clear_scan_stack state; + state.pp_format_stack <- []; + state.pp_tbox_stack <- []; + state.pp_tag_stack <- []; + state.pp_mark_stack <- []; + state.pp_current_indent <- 0; + state.pp_curr_depth <- 0; + state.pp_space_left <- state.pp_margin; + pp_open_sys_box state;; (* Flushing pretty-printer queue. *) let pp_flush_queue state b = - while state.pp_curr_depth > 1 do - pp_close_box state () - done; - state.pp_right_total <- pp_infinity; - advance_left state; - if b then pp_output_newline state; - pp_rinit state;; + while state.pp_curr_depth > 1 do + pp_close_box state () + done; + state.pp_right_total <- pp_infinity; + advance_left state; + if b then pp_output_newline state; + pp_rinit state;; (************************************************************** @@ -604,9 +629,9 @@ and pp_open_box state indent = pp_open_box_gen state indent Pp_box;; (* Print a new line after printing all queued text (same for print_flush but without a newline). *) let pp_print_newline state () = - pp_flush_queue state true; state.pp_flush_function () + pp_flush_queue state true; state.pp_flush_function () and pp_print_flush state () = - pp_flush_queue state false; state.pp_flush_function ();; + pp_flush_queue state false; state.pp_flush_function ();; (* To get a newline when one does not want to close the current block. *) let pp_force_newline state () = @@ -644,11 +669,13 @@ let pp_open_tbox state () = (* Close a tabulation block. *) let pp_close_tbox state () = - if state.pp_curr_depth > 1 then begin + if state.pp_curr_depth > 1 then + begin if state.pp_curr_depth < state.pp_max_boxes then let elem = make_queue_elem (size_of_int 0) Pp_tend 0 in enqueue_advance state elem; - state.pp_curr_depth <- state.pp_curr_depth - 1 end;; + state.pp_curr_depth <- state.pp_curr_depth - 1 + end;; (* Print a tabulation break. *) let pp_print_tbreak state width offset = @@ -709,15 +736,15 @@ let pp_set_margin state n = let n = pp_limit n in state.pp_margin <- n; let new_max_indent = - (* Try to maintain max_indent to its actual value. *) - if state.pp_max_indent <= state.pp_margin - then state.pp_max_indent else - (* If possible maintain pp_min_space_left to its actual value, - if this leads to a too small max_indent, take half of the - new margin, if it is greater than 1. *) - max (max (state.pp_margin - state.pp_min_space_left) - (state.pp_margin / 2)) 1 in - (* Rebuild invariants. *) + (* Try to maintain max_indent to its actual value. *) + if state.pp_max_indent <= state.pp_margin + then state.pp_max_indent else + (* If possible maintain pp_min_space_left to its actual value, + if this leads to a too small max_indent, take half of the + new margin, if it is greater than 1. *) + max (max (state.pp_margin - state.pp_min_space_left) + (state.pp_margin / 2)) 1 in + (* Rebuild invariants. *) pp_set_max_indent state new_max_indent;; let pp_get_margin state () = state.pp_margin;; @@ -753,51 +780,51 @@ let default_pp_print_open_tag s = ();; let default_pp_print_close_tag = default_pp_print_open_tag;; let pp_make_formatter f g h i = - (* The initial state of the formatter contains a dummy box. *) - let pp_q = make_queue () in - let sys_tok = - make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in - add_queue sys_tok pp_q; - let sys_scan_stack = - (Scan_elem (1, sys_tok)) :: scan_stack_bottom in - {pp_scan_stack = sys_scan_stack; - pp_format_stack = []; - pp_tbox_stack = []; - pp_tag_stack = []; - pp_mark_stack = []; - pp_margin = 78; - pp_min_space_left = 10; - pp_max_indent = 78 - 10; - pp_space_left = 78; - pp_current_indent = 0; - pp_is_new_line = true; - pp_left_total = 1; - pp_right_total = 1; - pp_curr_depth = 1; - pp_max_boxes = max_int; - pp_ellipsis = "."; - pp_output_function = f; - pp_flush_function = g; - pp_output_newline = h; - pp_output_spaces = i; - pp_print_tags = false; - pp_mark_tags = false; - pp_mark_open_tag = default_pp_mark_open_tag; - pp_mark_close_tag = default_pp_mark_close_tag; - pp_print_open_tag = default_pp_print_open_tag; - pp_print_close_tag = default_pp_print_close_tag; - pp_queue = pp_q - };; + (* The initial state of the formatter contains a dummy box. *) + let pp_q = make_queue () in + let sys_tok = + make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in + add_queue sys_tok pp_q; + let sys_scan_stack = + (Scan_elem (1, sys_tok)) :: scan_stack_bottom in + {pp_scan_stack = sys_scan_stack; + pp_format_stack = []; + pp_tbox_stack = []; + pp_tag_stack = []; + pp_mark_stack = []; + pp_margin = 78; + pp_min_space_left = 10; + pp_max_indent = 78 - 10; + pp_space_left = 78; + pp_current_indent = 0; + pp_is_new_line = true; + pp_left_total = 1; + pp_right_total = 1; + pp_curr_depth = 1; + pp_max_boxes = max_int; + pp_ellipsis = "."; + pp_output_function = f; + pp_flush_function = g; + pp_output_newline = h; + pp_output_spaces = i; + pp_print_tags = false; + pp_mark_tags = false; + pp_mark_open_tag = default_pp_mark_open_tag; + pp_mark_close_tag = default_pp_mark_close_tag; + pp_print_open_tag = default_pp_print_open_tag; + pp_print_close_tag = default_pp_print_close_tag; + pp_queue = pp_q; + };; (* Default function to output spaces. *) let blank_line = String.make 80 ' ';; let rec display_blanks state n = - if n > 0 then - if n <= 80 then state.pp_output_function blank_line 0 n else - begin - state.pp_output_function blank_line 0 80; - display_blanks state (n - 80) - end;; + if n > 0 then + if n <= 80 then state.pp_output_function blank_line 0 n else + begin + state.pp_output_function blank_line 0 80; + display_blanks state (n - 80) + end;; (* Default function to output new lines. *) let display_newline state () = state.pp_output_function "\n" 0 1;; @@ -816,9 +843,9 @@ let formatter_of_buffer b = let stdbuf = Buffer.create 512;; -let str_formatter = formatter_of_buffer stdbuf;; -let std_formatter = formatter_of_out_channel stdout;; -let err_formatter = formatter_of_out_channel stderr;; +let str_formatter = formatter_of_buffer stdbuf +and std_formatter = formatter_of_out_channel stdout +and err_formatter = formatter_of_out_channel stderr;; let flush_str_formatter () = pp_flush_queue str_formatter false; @@ -875,32 +902,32 @@ and set_ellipsis_text = pp_set_ellipsis_text std_formatter and get_ellipsis_text = pp_get_ellipsis_text std_formatter and set_formatter_out_channel = - pp_set_formatter_out_channel std_formatter + pp_set_formatter_out_channel std_formatter and set_formatter_output_functions = - pp_set_formatter_output_functions std_formatter + pp_set_formatter_output_functions std_formatter and get_formatter_output_functions = - pp_get_formatter_output_functions std_formatter + pp_get_formatter_output_functions std_formatter and set_all_formatter_output_functions = - pp_set_all_formatter_output_functions std_formatter + pp_set_all_formatter_output_functions std_formatter and get_all_formatter_output_functions = - pp_get_all_formatter_output_functions std_formatter + pp_get_all_formatter_output_functions std_formatter and set_formatter_tag_functions = - pp_set_formatter_tag_functions std_formatter + pp_set_formatter_tag_functions std_formatter and get_formatter_tag_functions = - pp_get_formatter_tag_functions std_formatter + pp_get_formatter_tag_functions std_formatter and set_print_tags = - pp_set_print_tags std_formatter + pp_set_print_tags std_formatter and get_print_tags = - pp_get_print_tags std_formatter + pp_get_print_tags std_formatter and set_mark_tags = - pp_set_mark_tags std_formatter + pp_set_mark_tags std_formatter and get_mark_tags = - pp_get_mark_tags std_formatter + pp_get_mark_tags std_formatter and set_tags = - pp_set_tags std_formatter + pp_set_tags std_formatter ;; @@ -942,24 +969,24 @@ let format_int_of_string fmt i s = (* Getting strings out of buffers. *) let get_buffer_out b = - let s = Buffer.contents b in - Buffer.reset b; - s;; + let s = Buffer.contents b in + Buffer.reset b; + s;; (* [ppf] is supposed to be a pretty-printer that outputs in buffer [b]: to extract contents of [ppf] as a string we flush [ppf] and get the string out of [b]. *) let string_out b ppf = - pp_flush_queue ppf false; - get_buffer_out b;; + pp_flush_queue ppf false; + get_buffer_out b;; (* Applies [printer] to a formatter that outputs on a fresh buffer, then returns the resulting material. *) let exstring printer arg = - let b = Buffer.create 512 in - let ppf = formatter_of_buffer b in - printer ppf arg; - string_out b ppf;; + let b = Buffer.create 512 in + let ppf = formatter_of_buffer b in + printer ppf arg; + string_out b ppf;; (* To turn out a character accumulator into the proper string result. *) let implode_rev s0 = function @@ -979,73 +1006,74 @@ let implode_rev s0 = function let mkprintf to_s get_out = let rec kprintf k fmt = + let len = Sformat.length fmt in let kpr fmt v = let ppf = get_out fmt in let print_as = ref None in let pp_print_as_char c = - match !print_as with - | None -> pp_print_char ppf c - | Some size -> - pp_print_as_size ppf size (String.make 1 c); - print_as := None + match !print_as with + | None -> pp_print_char ppf c + | Some size -> + pp_print_as_size ppf size (String.make 1 c); + print_as := None and pp_print_as_string s = - match !print_as with - | None -> pp_print_string ppf s - | Some size -> - pp_print_as_size ppf size s; - print_as := None in + match !print_as with + | None -> pp_print_string ppf s + | Some size -> + pp_print_as_size ppf size s; + print_as := None in let rec doprn n i = if i >= len then Obj.magic (k ppf) else match Sformat.get fmt i with | '%' -> - Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m + Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | '@' -> - let i = succ i in - if i >= len then invalid_format fmt i else - begin match Sformat.get fmt i with - | '[' -> - do_pp_open_box ppf n (succ i) - | ']' -> - pp_close_box ppf (); - doprn n (succ i) - | '{' -> - do_pp_open_tag ppf n (succ i) - | '}' -> - pp_close_tag ppf (); - doprn n (succ i) - | ' ' -> - pp_print_space ppf (); - doprn n (succ i) - | ',' -> - pp_print_cut ppf (); - doprn n (succ i) - | '?' -> - pp_print_flush ppf (); - doprn n (succ i) - | '.' -> - pp_print_newline ppf (); - doprn n (succ i) - | '\n' -> - pp_force_newline ppf (); - doprn n (succ i) - | ';' -> - do_pp_break ppf n (succ i) - | '<' -> - let got_size size n i = - print_as := Some size; - doprn n (skip_gt i) in - get_int n (succ i) got_size - | '@' as c -> - pp_print_as_char c; - doprn n (succ i) - | c -> invalid_format fmt i - end + let i = succ i in + if i >= len then invalid_format fmt i else + begin match Sformat.get fmt i with + | '[' -> + do_pp_open_box ppf n (succ i) + | ']' -> + pp_close_box ppf (); + doprn n (succ i) + | '{' -> + do_pp_open_tag ppf n (succ i) + | '}' -> + pp_close_tag ppf (); + doprn n (succ i) + | ' ' -> + pp_print_space ppf (); + doprn n (succ i) + | ',' -> + pp_print_cut ppf (); + doprn n (succ i) + | '?' -> + pp_print_flush ppf (); + doprn n (succ i) + | '.' -> + pp_print_newline ppf (); + doprn n (succ i) + | '\n' -> + pp_force_newline ppf (); + doprn n (succ i) + | ';' -> + do_pp_break ppf n (succ i) + | '<' -> + let got_size size n i = + print_as := Some size; + doprn n (skip_gt i) in + get_int n (succ i) got_size + | '@' as c -> + pp_print_as_char c; + doprn n (succ i) + | c -> invalid_format fmt i + end | c -> - pp_print_as_char c; - doprn n (succ i) + pp_print_as_char c; + doprn n (succ i) and cont_s n s i = pp_print_as_string s; doprn n i @@ -1067,123 +1095,131 @@ let mkprintf to_s get_out = kprintf (Obj.magic (fun _ -> doprn n i)) sfmt and get_int n i c = - if i >= len then invalid_integer fmt i else - match Sformat.get fmt i with - | ' ' -> get_int n (succ i) c - | '%' -> + if i >= len then invalid_integer fmt i else + match Sformat.get fmt i with + | ' ' -> get_int n (succ i) c + | '%' -> let cont_s n s i = c (format_int_of_string fmt i s) n i and cont_a n printer arg i = invalid_integer fmt i and cont_t n printer i = invalid_integer fmt i and cont_f n i = invalid_integer fmt i and cont_m n sfmt i = invalid_integer fmt i in Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m - | _ -> + | _ -> let rec get j = - if j >= len then invalid_integer fmt j else - match Sformat.get fmt j with - | '0' .. '9' | '-' -> get (succ j) - | _ -> - let size = - if j = i then size_of_int 0 else + if j >= len then invalid_integer fmt j else + match Sformat.get fmt j with + | '0' .. '9' | '-' -> get (succ j) + | _ -> + let size = + if j = i then size_of_int 0 else let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in format_int_of_string fmt j s in - c size n j in + c size n j in get i and skip_gt i = - if i >= len then invalid_format fmt i else - match Sformat.get fmt i with - | ' ' -> skip_gt (succ i) - | '>' -> succ i - | _ -> invalid_format fmt i + if i >= len then invalid_format fmt i else + match Sformat.get fmt i with + | ' ' -> skip_gt (succ i) + | '>' -> succ i + | _ -> invalid_format fmt i and get_box_kind i = - if i >= len then Pp_box, i else - match Sformat.get fmt i with - | 'h' -> - let i = succ i in - if i >= len then Pp_hbox, i else - begin match Sformat.get fmt i with - | 'o' -> + if i >= len then Pp_box, i else + match Sformat.get fmt i with + | 'h' -> + let i = succ i in + if i >= len then Pp_hbox, i else + begin match Sformat.get fmt i with + | 'o' -> let i = succ i in if i >= len then format_invalid_arg "bad box format" fmt i else begin match Sformat.get fmt i with | 'v' -> Pp_hovbox, succ i | c -> - format_invalid_arg - ("bad box name ho" ^ String.make 1 c) fmt i end - | 'v' -> Pp_hvbox, succ i - | c -> Pp_hbox, i - end - | 'b' -> Pp_box, succ i - | 'v' -> Pp_vbox, succ i - | _ -> Pp_box, i + format_invalid_arg + ("bad box name ho" ^ String.make 1 c) fmt i + end + | 'v' -> Pp_hvbox, succ i + | c -> Pp_hbox, i + end + | 'b' -> Pp_box, succ i + | 'v' -> Pp_vbox, succ i + | _ -> Pp_box, i and get_tag_name n i c = - let rec get accu n i j = - if j >= len - then c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j else - match Sformat.get fmt j with - | '>' -> c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j - | '%' -> - let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in - let cont_s n s i = get (s :: s0 :: accu) n i i - and cont_a n printer arg i = - let s = - if to_s - then (Obj.magic printer : unit -> _ -> string) () arg - else exstring printer arg in - get (s :: s0 :: accu) n i i - and cont_t n printer i = - let s = - if to_s - then (Obj.magic printer : unit -> string) () - else exstring (fun ppf () -> printer ppf) () in - get (s :: s0 :: accu) n i i - and cont_f n i = - format_invalid_arg "bad tag name specification" fmt i - and cont_m n sfmt i = - format_invalid_arg "bad tag name specification" fmt i in - Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m - | c -> get accu n i (succ j) in - get [] n i i + let rec get accu n i j = + if j >= len then + c (implode_rev + (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) + accu) + n j else + match Sformat.get fmt j with + | '>' -> + c (implode_rev + (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) + accu) + n j + | '%' -> + let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in + let cont_s n s i = get (s :: s0 :: accu) n i i + and cont_a n printer arg i = + let s = + if to_s + then (Obj.magic printer : unit -> _ -> string) () arg + else exstring printer arg in + get (s :: s0 :: accu) n i i + and cont_t n printer i = + let s = + if to_s + then (Obj.magic printer : unit -> string) () + else exstring (fun ppf () -> printer ppf) () in + get (s :: s0 :: accu) n i i + and cont_f n i = + format_invalid_arg "bad tag name specification" fmt i + and cont_m n sfmt i = + format_invalid_arg "bad tag name specification" fmt i in + Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m + | c -> get accu n i (succ j) in + get [] n i i and do_pp_break ppf n i = - if i >= len then begin pp_print_space ppf (); doprn n i end else - match Sformat.get fmt i with - | '<' -> + if i >= len then begin pp_print_space ppf (); doprn n i end else + match Sformat.get fmt i with + | '<' -> let rec got_nspaces nspaces n i = get_int n i (got_offset nspaces) and got_offset nspaces offset n i = pp_print_break ppf (int_of_size nspaces) (int_of_size offset); doprn n (skip_gt i) in get_int n (succ i) got_nspaces - | c -> pp_print_space ppf (); doprn n i + | c -> pp_print_space ppf (); doprn n i and do_pp_open_box ppf n i = - if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else - match Sformat.get fmt i with - | '<' -> + if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else + match Sformat.get fmt i with + | '<' -> let kind, i = get_box_kind (succ i) in let got_size size n i = pp_open_box_gen ppf (int_of_size size) kind; doprn n (skip_gt i) in get_int n i got_size - | c -> pp_open_box_gen ppf 0 Pp_box; doprn n i + | c -> pp_open_box_gen ppf 0 Pp_box; doprn n i and do_pp_open_tag ppf n i = - if i >= len then begin pp_open_tag ppf ""; doprn n i end else - match Sformat.get fmt i with - | '<' -> + if i >= len then begin pp_open_tag ppf ""; doprn n i end else + match Sformat.get fmt i with + | '<' -> let got_name tag_name n i = pp_open_tag ppf tag_name; doprn n (skip_gt i) in get_tag_name n (succ i) got_name - | c -> pp_open_tag ppf ""; doprn n i in + | c -> pp_open_tag ppf ""; doprn n i in doprn (Sformat.index_of_int 0) 0 in - Tformat.kapr kpr fmt in + Tformat.kapr kpr fmt in kprintf;; diff --git a/stdlib/gc.mli b/stdlib/gc.mli index 4d36a29f2e..736e324f3f 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -86,7 +86,7 @@ type control = mutable major_heap_increment : int; (** The minimum number of words to add to the - major heap when increasing it. Default: 62k. *) + major heap when increasing it. Default: 60k. *) mutable space_overhead : int; (** The major GC speed is computed from this parameter. diff --git a/stdlib/int32.mli b/stdlib/int32.mli index dc733ec9fc..eeafb1a2fc 100644 --- a/stdlib/int32.mli +++ b/stdlib/int32.mli @@ -160,9 +160,5 @@ val compare: t -> t -> int (** {6 Deprecated functions} *) external format : string -> int32 -> string = "caml_int32_format" -(** [Int32.format fmt n] return the string representation of the - 32-bit integer [n] in the format specified by [fmt]. - [fmt] is a [Printf]-style format consisting of exactly - one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification. - This function is deprecated; use {!Printf.sprintf} with a [%lx] format - instead. *) +(** Do not use this deprecated function. Instead, + used {!Printf.sprintf} with a [%l...] format. *) diff --git a/stdlib/int64.mli b/stdlib/int64.mli index 7bc39e6123..3b641338e7 100644 --- a/stdlib/int64.mli +++ b/stdlib/int64.mli @@ -182,9 +182,5 @@ val compare: t -> t -> int (** {6 Deprecated functions} *) external format : string -> int64 -> string = "caml_int64_format" -(** [Int64.format fmt n] return the string representation of the - 64-bit integer [n] in the format specified by [fmt]. - [fmt] is a {!Printf}-style format consisting of exactly one - [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification. - This function is deprecated; use {!Printf.sprintf} with a [%Lx] format - instead. *) +(** Do not use this deprecated function. Instead, + used {!Printf.sprintf} with a [%L...] format. *) diff --git a/stdlib/printf.ml b/stdlib/printf.ml index f4a27ca521..9652b14606 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -36,8 +36,6 @@ module Sformat = struct let add_int_index i idx = index_of_int (i + int_of_index idx);; let succ_index = add_int_index 1;; - (* Litteral position are one-based (hence pred p instead of p). *) - let index_of_litteral_position p = index_of_int (pred p);; external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int = "%string_length";; @@ -102,17 +100,7 @@ let format_string sfmt s = '*' in the format are replaced by integers taken from the [widths] list. extract_format returns a string. *) let extract_format fmt start stop widths = - let skip_positional_spec start = - match Sformat.unsafe_get fmt start with - | '0'..'9' -> - let rec skip_int_litteral i = - match Sformat.unsafe_get fmt i with - | '0'..'9' -> skip_int_litteral (succ i) - | '$' -> succ i - | _ -> start in - skip_int_litteral (succ start) - | _ -> start in - let start = skip_positional_spec (succ start) in + let start = succ start in let b = Buffer.create (stop - start + 10) in Buffer.add_char b '%'; let rec fill_format i widths = @@ -120,7 +108,7 @@ let extract_format fmt start stop widths = match (Sformat.unsafe_get fmt i, widths) with | ('*', h :: t) -> Buffer.add_string b (string_of_int h); - let i = skip_positional_spec (succ i) in + let i = succ i in fill_format i t | ('*', []) -> assert false (* should not happen *) @@ -175,7 +163,6 @@ let iter_on_format_args fmt add_conv add_char = if i > lim then incomplete_format fmt else match Sformat.unsafe_get fmt i with | '*' -> scan_flags skip (add_conv skip i 'i') - | '$' -> scan_flags skip (succ i) | '#' | '-' | ' ' | '+' -> scan_flags skip (succ i) | '_' -> scan_flags true (succ i) | '0'..'9' @@ -324,47 +311,8 @@ let kapr kpr fmt = else Obj.magic (fun x -> loop (succ i) (x :: args)) in loop 0 [];; -type positional_specification = - | Spec_none | Spec_index of Sformat.index;; - -(* To scan an optional positional parameter specification, - i.e. an integer followed by a [$]. - We do not support [*$] specifications, since this would lead to type checking - problems: the type of the specified [*$] parameter would be the type of the - corresponding argument to [printf], hence the type of the $n$-th argument to - [printf] with $n$ being the {\em value} of the integer argument defining - [*]; this means type dependency, which is out of scope of the Caml type - algebra. *) -let scan_positional_spec fmt got_spec n i = - match Sformat.unsafe_get fmt i with - | '0'..'9' as d -> - let rec get_int_litteral accu j = - match Sformat.unsafe_get fmt j with - | '0'..'9' as d -> - get_int_litteral (10 * accu + (int_of_char d - 48)) (succ j) - | '$' -> - if accu = 0 - then failwith "printf: bad positional specification (0)." else - got_spec (Spec_index (Sformat.index_of_litteral_position accu)) (succ j) - (* Not a positional specification. *) - | _ -> got_spec Spec_none i in - get_int_litteral (int_of_char d - 48) (succ i) - (* No positional specification. *) - | _ -> got_spec Spec_none i;; - -(* Get the position of the next argument to printf, according to the given - positional specification. *) -let next_index spec n = - match spec with - | Spec_none -> Sformat.succ_index n - | Spec_index _ -> n;; - -(* Get the position of the actual argument to printf, according to its - optional positional specification. *) -let get_index spec n = - match spec with - | Spec_none -> n - | Spec_index p -> p;; +(* Get the index of the next argument to printf. *) +let next_index n = Sformat.succ_index n;; (* Decode a format string and act on it. [fmt] is the printf format string, and [pos] points to a [%] character. @@ -388,67 +336,58 @@ let get_index spec n = Don't do this at home, kids. *) let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = - let get_arg spec n = - Obj.magic (args.(Sformat.int_of_index (get_index spec n))) in - - let rec scan_positional n widths i = - let got_spec spec i = scan_flags spec n widths i in - scan_positional_spec fmt got_spec n i + let get_arg n = + Obj.magic (args.(Sformat.int_of_index n)) in - and scan_flags spec n widths i = + let rec scan_flags n widths i = match Sformat.unsafe_get fmt i with | '*' -> - let got_spec wspec i = - let (width : int) = get_arg wspec n in - scan_flags spec (next_index wspec n) (width :: widths) i in - scan_positional_spec fmt got_spec n (succ i) + let (width : int) = get_arg n in + scan_flags (next_index n) (width :: widths) (succ i) | '0'..'9' - | '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i) - | _ -> scan_conv spec n widths i + | '.' | '#' | '-' | ' ' | '+' -> scan_flags n widths (succ i) + | _ -> scan_conv n widths i - and scan_conv spec n widths i = + and scan_conv n widths i = match Sformat.unsafe_get fmt i with | '%' -> cont_s n "%" (succ i) | 's' | 'S' as conv -> - let (x : string) = get_arg spec n in + let (x : string) = get_arg n in let x = if conv = 's' then x else "\"" ^ String.escaped x ^ "\"" in let s = (* optimize for common case %s *) if i = succ pos then x else format_string (extract_format fmt pos i widths) x in - cont_s (next_index spec n) s (succ i) + cont_s (next_index n) s (succ i) | 'c' | 'C' as conv -> - let (x : char) = get_arg spec n in + let (x : char) = get_arg n in let s = if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in - cont_s (next_index spec n) s (succ i) + cont_s (next_index n) s (succ i) | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' as conv -> - let (x : int) = get_arg spec n in + let (x : int) = get_arg n in let s = format_int (extract_format_int conv fmt pos i widths) x in - cont_s (next_index spec n) s (succ i) + cont_s (next_index n) s (succ i) | 'f' | 'e' | 'E' | 'g' | 'G' -> - let (x : float) = get_arg spec n in + let (x : float) = get_arg n in let s = format_float (extract_format fmt pos i widths) x in - cont_s (next_index spec n) s (succ i) + cont_s (next_index n) s (succ i) | 'F' -> - let (x : float) = get_arg spec n in - cont_s (next_index spec n) (string_of_float x) (succ i) + let (x : float) = get_arg n in + cont_s (next_index n) (string_of_float x) (succ i) | 'B' | 'b' -> - let (x : bool) = get_arg spec n in - cont_s (next_index spec n) (string_of_bool x) (succ i) + let (x : bool) = get_arg n in + cont_s (next_index n) (string_of_bool x) (succ i) | 'a' -> - let printer = get_arg spec n in - (* If the printer spec is Spec_none, go on as usual. - If the printer spec is Spec_index p, - printer's argument spec is Spec_index (succ_index p). *) - let n = Sformat.succ_index (get_index spec n) in - let arg = get_arg Spec_none n in - cont_a (next_index spec n) printer arg (succ i) + let printer = get_arg n in + let n = Sformat.succ_index n in + let arg = get_arg n in + cont_a (next_index n) printer arg (succ i) | 't' -> - let printer = get_arg spec n in - cont_t (next_index spec n) printer (succ i) + let printer = get_arg n in + cont_t (next_index n) printer (succ i) | 'l' | 'n' | 'L' as conv -> begin match Sformat.unsafe_get fmt (succ i) with | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> @@ -456,39 +395,39 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = let s = match conv with | 'l' -> - let (x : int32) = get_arg spec n in + let (x : int32) = get_arg n in format_int32 (extract_format fmt pos i widths) x | 'n' -> - let (x : nativeint) = get_arg spec n in + let (x : nativeint) = get_arg n in format_nativeint (extract_format fmt pos i widths) x | _ -> - let (x : int64) = get_arg spec n in + let (x : int64) = get_arg n in format_int64 (extract_format fmt pos i widths) x in - cont_s (next_index spec n) s (succ i) + cont_s (next_index n) s (succ i) | _ -> - let (x : int) = get_arg spec n in + let (x : int) = get_arg n in let s = format_int (extract_format_int 'n' fmt pos i widths) x in - cont_s (next_index spec n) s (succ i) + cont_s (next_index n) s (succ i) end | '!' -> cont_f n (succ i) | '{' | '(' as conv (* ')' '}' *) -> - let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg spec n in + let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg n in let i = succ i in let j = sub_format_for_printf conv fmt i in if conv = '{' (* '}' *) then (* Just print the format argument as a specification. *) cont_s - (next_index spec n) + (next_index n) (summarize_format_type xf) j else (* Use the format argument instead of the format specification. *) - cont_m (next_index spec n) xf j + cont_m (next_index n) xf j | (* '(' *) ')' -> cont_s n "" (succ i) | conv -> bad_conversion_format fmt i conv in - scan_positional n [] (succ pos);; + scan_flags n [] (succ pos);; let mkprintf to_s get_out outc outs flush k fmt = @@ -505,27 +444,27 @@ let mkprintf to_s get_out outc outs flush k fmt = match Sformat.unsafe_get fmt i with | '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | c -> outc out c; doprn n (succ i) - and cont_s n s i = - outs out s; doprn n i - and cont_a n printer arg i = - if to_s then - outs out ((Obj.magic printer : unit -> _ -> string) () arg) - else - printer out arg; - doprn n i - and cont_t n printer i = - if to_s then - outs out ((Obj.magic printer : unit -> string) ()) - else - printer out; - doprn n i - and cont_f n i = - flush out; doprn n i - and cont_m n xf i = - let m = Sformat.add_int_index (count_arguments_of_format xf) n in - pr (Obj.magic (fun _ -> doprn m i)) n xf v in - - doprn n 0 in + and cont_s n s i = + outs out s; doprn n i + and cont_a n printer arg i = + if to_s then + outs out ((Obj.magic printer : unit -> _ -> string) () arg) + else + printer out arg; + doprn n i + and cont_t n printer i = + if to_s then + outs out ((Obj.magic printer : unit -> string) ()) + else + printer out; + doprn n i + and cont_f n i = + flush out; doprn n i + and cont_m n xf i = + let m = Sformat.add_int_index (count_arguments_of_format xf) n in + pr (Obj.magic (fun _ -> doprn m i)) n xf v in + + doprn n 0 in let kpr = pr k (Sformat.index_of_int 0) in diff --git a/stdlib/printf.mli b/stdlib/printf.mli index e8bd7d6c92..6bd692d0b9 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -27,7 +27,7 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a Conversion specifications have the following form: - [% \[positional specifier\] \[flags\] \[width\] \[.precision\] type] + [% \[flags\] \[width\] \[.precision\] type] In short, a conversion specification consists in the [%] character, followed by optional modifiers and a type which is made of one or @@ -79,10 +79,6 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a - [!]: take no argument and flush the output. - [%]: take no argument and output one [%] character. - The optional [positional specifier] consists of an integer followed - by a [$]; the integer indicates which argument to use, the first - argument being denoted by 1. - The optional [flags] are: - [-]: left-justify the output (default is right justification). - [0]: for numerical conversions, pad with zeroes instead of spaces. @@ -102,10 +98,9 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a The integer in a [width] or [precision] can also be specified as [*], in which case an extra integer argument is taken to specify the corresponding [width] or [precision]. This integer argument - precedes immediately the argument to print, unless an optional - [positional specifier] is given to indicates which argument to - use. For instance, [%.*3$f] prints a [float] with as many fractional - digits as the value of the third argument. *) + precedes immediately the argument to print. + For instance, [%.*f] prints a [float] with as many fractional + digits as the value of the argument given before the float. *) val printf : ('a, out_channel, unit) format -> 'a (** Same as {!Printf.fprintf}, but output on [stdout]. *) diff --git a/stdlib/weak.ml b/stdlib/weak.ml index 317c3729f8..de5f85286b 100644 --- a/stdlib/weak.ml +++ b/stdlib/weak.ml @@ -26,6 +26,8 @@ external set : 'a t -> int -> 'a option -> unit = "caml_weak_set";; external get: 'a t -> int -> 'a option = "caml_weak_get";; external get_copy: 'a t -> int -> 'a option = "caml_weak_get_copy";; external check: 'a t -> int -> bool = "caml_weak_check";; +external blit: 'a t -> int -> 'a t -> int -> int -> unit = "caml_weak_blit";; +(* blit: src srcoff dst dstoff len *) let fill ar ofs len x = if ofs < 0 || len < 0 || ofs + len > length ar @@ -37,23 +39,6 @@ let fill ar ofs len x = end ;; -let blit ar1 of1 ar2 of2 len = - if of1 < 0 || of1 + len > length ar1 || of2 < 0 || of2 + len > length ar2 - then raise (Invalid_argument "Weak.blit") - else begin - if of2 > of1 then begin - for i = 0 to len - 1 do - set ar2 (of2 + i) (get ar1 (of1 + i)) - done - end else begin - for i = len - 1 downto 0 do - set ar2 (of2 + i) (get ar1 (of1 + i)) - done - end - end -;; - - (** Weak hash tables *) module type S = sig @@ -83,27 +68,35 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct type t = { mutable table : data weak_t array; - mutable totsize : int; (* sum of the bucket sizes *) - mutable limit : int; (* max ratio totsize/table length *) + mutable hashes : int array array; + mutable limit : int; (* bucket size limit *) + mutable oversize : int; (* number of oversize buckets *) + mutable rover : int; (* for internal bookkeeping *) };; - let get_index t d = (H.hash d land max_int) mod (Array.length t.table);; + let get_index t h = (h land max_int) mod (Array.length t.table);; + + let limit = 7;; + let over_limit = 2;; let create sz = let sz = if sz < 7 then 7 else sz in let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in { table = Array.create sz emptybucket; - totsize = 0; - limit = 3; + hashes = Array.create sz [| |]; + limit = limit; + oversize = 0; + rover = 0; };; let clear t = for i = 0 to Array.length t.table - 1 do t.table.(i) <- emptybucket; + t.hashes.(i) <- [| |]; done; - t.totsize <- 0; - t.limit <- 3; + t.limit <- limit; + t.oversize <- 0; ;; let fold f t init = @@ -126,85 +119,155 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct Array.iter (iter_bucket 0) t.table ;; - let count t = - let rec count_bucket i b accu = - if i >= length b then accu else - count_bucket (i+1) b (accu + (if check b i then 1 else 0)) + let iter_weak f t = + let rec iter_bucket i j b = + if i >= length b then () else + match check b i with + | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b + | false -> iter_bucket (i+1) j b in + Array.iteri (iter_bucket 0) t.table + ;; + + let rec count_bucket i b accu = + if i >= length b then accu else + count_bucket (i+1) b (accu + (if check b i then 1 else 0)) + ;; + + let count t = Array.fold_right (count_bucket 0) t.table 0 ;; - let next_sz n = min (3*n/2 + 3) (Sys.max_array_length - 1);; + let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length;; + let prev_sz n = ((n - 3) * 2 + 2) / 3;; + + let test_shrink_bucket t = + let bucket = t.table.(t.rover) in + let hbucket = t.hashes.(t.rover) in + let len = length bucket in + let prev_len = prev_sz len in + let live = count_bucket 0 bucket 0 in + if live <= prev_len then begin + let rec loop i j = + if j >= prev_len then begin + if check bucket i then loop (i + 1) j + else if check bucket j then begin + blit bucket j bucket i 1; + hbucket.(i) <- hbucket.(j); + loop (i + 1) (j - 1); + end else loop i (j - 1); + end; + in + loop 0 (length bucket - 1); + if prev_len = 0 then begin + t.table.(t.rover) <- emptybucket; + t.hashes.(t.rover) <- [| |]; + end else begin + Obj.truncate (Obj.repr bucket) (prev_len + 1); + Obj.truncate (Obj.repr hbucket) prev_len; + end; + if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1; + end; + t.rover <- (t.rover + 1) mod (Array.length t.table); + ;; let rec resize t = let oldlen = Array.length t.table in let newlen = next_sz oldlen in if newlen > oldlen then begin let newt = create newlen in - newt.limit <- t.limit + 100; (* prevent resizing of newt *) - fold (fun d () -> add newt d) t (); - (* assert Array.length newt.table = newlen; *) + let add_weak ob oh oi = + let setter nb ni _ = blit ob oi nb ni 1 in + let h = oh.(oi) in + add_aux newt setter None h (get_index newt h); + in + iter_weak add_weak t; t.table <- newt.table; - (* t.limit <- t.limit + 2; -- performance bug *) + t.hashes <- newt.hashes; + t.limit <- newt.limit; + t.oversize <- newt.oversize; + t.rover <- t.rover mod Array.length newt.table; + end else begin + t.limit <- max_int; (* maximum size already reached *) + t.oversize <- 0; end - and add_aux t d index = + and add_aux t setter d h index = let bucket = t.table.(index) in + let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i = if i >= sz then begin - let newsz = min (sz + 3) (Sys.max_array_length - 1) in - if newsz <= sz then failwith "Weak.Make : hash bucket cannot grow more"; + let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in + if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more"; let newbucket = weak_create newsz in + let newhashes = Array.make newsz 0 in blit bucket 0 newbucket 0 sz; - set newbucket i (Some d); + Array.blit hashes 0 newhashes 0 sz; + setter newbucket sz d; + newhashes.(sz) <- h; t.table.(index) <- newbucket; - t.totsize <- t.totsize + (newsz - sz); - if t.totsize > t.limit * Array.length t.table then resize t; + t.hashes.(index) <- newhashes; + if sz <= t.limit && newsz > t.limit then begin + t.oversize <- t.oversize + 1; + for i = 0 to over_limit do test_shrink_bucket t done; + end; + if t.oversize > Array.length t.table / over_limit then resize t; + end else if check bucket i then begin + loop (i + 1) end else begin - if check bucket i - then loop (i+1) - else set bucket i (Some d) - end + setter bucket i d; + hashes.(i) <- h; + end; in loop 0; + ;; - and add t d = add_aux t d (get_index t d) + let add t d = + let h = H.hash d in + add_aux t set (Some d) h (get_index t h); ;; let find_or t d ifnotfound = - let index = get_index t d in + let h = H.hash d in + let index = get_index t h in let bucket = t.table.(index) in + let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i = - if i >= sz then ifnotfound index - else begin + if i >= sz then ifnotfound h index + else if h = hashes.(i) then begin match get_copy bucket i with | Some v when H.equal v d -> begin match get bucket i with | Some v -> v - | None -> loop (i+1) + | None -> loop (i + 1) end - | _ -> loop (i+1) - end + | _ -> loop (i + 1) + end else loop (i + 1) in loop 0 ;; - let merge t d = find_or t d (fun index -> add_aux t d index; d);; + let merge t d = + find_or t d (fun h index -> add_aux t set (Some d) h index; d) + ;; - let find t d = find_or t d (fun index -> raise Not_found);; + let find t d = find_or t d (fun h index -> raise Not_found);; let find_shadow t d iffound ifnotfound = - let index = get_index t d in + let h = H.hash d in + let index = get_index t h in let bucket = t.table.(index) in + let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i = - if i >= sz then ifnotfound else begin + if i >= sz then ifnotfound + else if h = hashes.(i) then begin match get_copy bucket i with | Some v when H.equal v d -> iffound bucket i - | _ -> loop (i+1) - end + | _ -> loop (i + 1) + end else loop (i + 1) in loop 0 ;; @@ -214,20 +277,22 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct let mem t d = find_shadow t d (fun w i -> true) false;; let find_all t d = - let index = get_index t d in + let h = H.hash d in + let index = get_index t h in let bucket = t.table.(index) in + let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i accu = if i >= sz then accu - else begin + else if h = hashes.(i) then begin match get_copy bucket i with | Some v when H.equal v d -> begin match get bucket i with - | Some v -> loop (i+1) (v::accu) - | None -> loop (i+1) accu + | Some v -> loop (i + 1) (v :: accu) + | None -> loop (i + 1) accu end - | _ -> loop (i+1) accu - end + | _ -> loop (i + 1) accu + end else loop (i + 1) accu in loop 0 [] ;; |