diff options
| -rw-r--r-- | stdlib/.depend | 18 | ||||
| -rw-r--r-- | stdlib/Makefile | 4 | ||||
| -rw-r--r-- | stdlib/char.ml | 37 | ||||
| -rw-r--r-- | stdlib/char.mli | 5 | ||||
| -rw-r--r-- | stdlib/filename.ml | 99 | ||||
| -rw-r--r-- | stdlib/hashtbl.ml | 143 | ||||
| -rw-r--r-- | stdlib/hashtbl.mli | 46 | ||||
| -rw-r--r-- | stdlib/string.ml | 21 | ||||
| -rw-r--r-- | stdlib/string.mli | 13 |
9 files changed, 282 insertions, 104 deletions
diff --git a/stdlib/.depend b/stdlib/.depend index d3cb9523e..4ab0a28ca 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -4,14 +4,14 @@ arg.cmo: array.cmi list.cmi printf.cmi string.cmi sys.cmi arg.cmi arg.cmx: array.cmx list.cmx printf.cmx string.cmx sys.cmx arg.cmi array.cmo: list.cmi array.cmi array.cmx: list.cmx array.cmi -char.cmo: string.cmi char.cmi -char.cmx: string.cmx char.cmi +char.cmo: char.cmi +char.cmx: char.cmi digest.cmo: string.cmi digest.cmi digest.cmx: string.cmx digest.cmi filename.cmo: string.cmi sys.cmi filename.cmi filename.cmx: string.cmx sys.cmx filename.cmi -format.cmo: queue.cmi string.cmi format.cmi -format.cmx: queue.cmx string.cmx format.cmi +format.cmo: string.cmi format.cmi +format.cmx: string.cmx format.cmi gc.cmo: printf.cmi gc.cmi gc.cmx: printf.cmx gc.cmi genlex.cmo: char.cmi hashtbl.cmi list.cmi stream.cmi string.cmi genlex.cmi @@ -26,8 +26,10 @@ map.cmo: map.cmi map.cmx: map.cmi obj.cmo: obj.cmi obj.cmx: obj.cmi -oo.cmo: array.cmi hashtbl.cmi list.cmi obj.cmi random.cmi sort.cmi oo.cmi -oo.cmx: array.cmx hashtbl.cmx list.cmx obj.cmx random.cmx sort.cmx oo.cmi +oo.cmo: array.cmi hashtbl.cmi list.cmi map.cmi obj.cmi random.cmi sort.cmi \ + sys.cmi oo.cmi +oo.cmx: array.cmx hashtbl.cmx list.cmx map.cmx obj.cmx random.cmx sort.cmx \ + sys.cmx oo.cmi parsing.cmo: array.cmi lexing.cmi obj.cmi parsing.cmi parsing.cmx: array.cmx lexing.cmx obj.cmx parsing.cmi pervasives.cmo: pervasives.cmi @@ -48,7 +50,7 @@ stack.cmo: list.cmi stack.cmi stack.cmx: list.cmx stack.cmi stream.cmo: list.cmi obj.cmi string.cmi stream.cmi stream.cmx: list.cmx obj.cmx string.cmx stream.cmi -string.cmo: list.cmi string.cmi -string.cmx: list.cmx string.cmi +string.cmo: char.cmi list.cmi string.cmi +string.cmx: char.cmx list.cmx string.cmi sys.cmo: sys.cmi sys.cmx: sys.cmi diff --git a/stdlib/Makefile b/stdlib/Makefile index 0ec5282f6..535286133 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -8,7 +8,7 @@ CAMLOPT=$(RUNTIME) $(OPTCOMPILER) CAMLDEP=../boot/ocamlrun ../tools/ocamldep CPPFLAGS=-DUNIX -OBJS=pervasives.cmo list.cmo string.cmo char.cmo array.cmo sys.cmo \ +OBJS=pervasives.cmo list.cmo char.cmo string.cmo array.cmo sys.cmo \ hashtbl.cmo sort.cmo filename.cmo obj.cmo lexing.cmo parsing.cmo \ set.cmo map.cmo stack.cmo queue.cmo stream.cmo \ printf.cmo format.cmo arg.cmo printexc.cmo gc.cmo \ @@ -73,5 +73,5 @@ clean:: include .depend -depend: beforedepend +depend: $(CAMLDEP) *.mli *.ml > .depend diff --git a/stdlib/char.ml b/stdlib/char.ml index 077719d8c..37062dcb4 100644 --- a/stdlib/char.ml +++ b/stdlib/char.ml @@ -21,19 +21,40 @@ let chr n = external is_printable: char -> bool = "is_printable" +external string_create: int -> string = "create_string" +external string_unsafe_get : string -> int -> char = "%string_unsafe_get" +external string_unsafe_set : string -> int -> char -> unit + = "%string_unsafe_set" + let escaped = function '\'' -> "\\'" | '\\' -> "\\\\" | '\n' -> "\\n" | '\t' -> "\\t" - | c -> if is_printable c then - String.make 1 c - else begin + | c -> if is_printable c then begin + let s = string_create 1 in + string_unsafe_set s 1 c; + s + end else begin let n = code c in - let s = String.create 4 in - String.unsafe_set s 0 '\\'; - String.unsafe_set s 1 (unsafe_chr (48 + n / 100)); - String.unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10)); - String.unsafe_set s 3 (unsafe_chr (48 + n mod 10)); + let s = string_create 4 in + string_unsafe_set s 0 '\\'; + string_unsafe_set s 1 (unsafe_chr (48 + n / 100)); + string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10)); + string_unsafe_set s 3 (unsafe_chr (48 + n mod 10)); s end + +let lowercase c = + if (c >= 'A' && c <= 'Z') + || (c >= '\192' && c <= '\214') + || (c >= '\217' && c <= '\222') + then unsafe_chr(code c + 32) + else c + +let uppercase c = + if (c >= 'a' && c <= 'z') + || (c >= '\224' && c <= '\246') + || (c >= '\249' && c <= '\254') + then unsafe_chr(code c - 32) + else c diff --git a/stdlib/char.mli b/stdlib/char.mli index bccfc15d5..fe82e0e52 100644 --- a/stdlib/char.mli +++ b/stdlib/char.mli @@ -23,7 +23,10 @@ val escaped : char -> string (* Return a string representing the given character, with special characters escaped following the lexical conventions of Caml Light. *) - +val lowercase: char -> char +val uppercase: char -> char + (* Convert the given character to its equivalent lowercase or + uppercase character, respectively. *) (*--*) external unsafe_chr: int -> char = "%identity" diff --git a/stdlib/filename.ml b/stdlib/filename.ml index c962f7915..378263cbd 100644 --- a/stdlib/filename.ml +++ b/stdlib/filename.ml @@ -2,7 +2,7 @@ (* *) (* Objective Caml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) @@ -11,7 +11,7 @@ (* $Id$ *) -let systype = (Sys.get_config()).Sys.os_type;; +let systype = (Sys.get_config()).Sys.os_type let current_dir_name = match systype with @@ -19,26 +19,24 @@ let current_dir_name = | "Win32" -> "." | "MacOS" -> ":" | _ -> failwith "Filename.current_dir_name: unknown system" -;; let unix_concat dirname filename = let l = String.length dirname in if l = 0 or dirname.[l-1] = '/' then dirname ^ filename else dirname ^ "/" ^ filename -;; + let wnt_concat dirname filename = let l = String.length dirname in if l = 0 or (let c = dirname.[l-1] in c = '/' or c = '\\' or c = ':') then dirname ^ filename else dirname ^ "\\" ^ filename -;; + let mac_concat dirname filename = let l = String.length dirname in if l = 0 or dirname.[l-1] = ':' then dirname ^ filename else dirname ^ ":" ^ filename -;; let concat = match systype with @@ -46,22 +44,21 @@ let concat = | "Win32" -> wnt_concat | "MacOS" -> mac_concat | _ -> failwith "Filename.concat: unknown system" -;; let unix_is_absolute n = - (String.length n >= 1 & String.sub n 0 1 = "/") - or (String.length n >= 2 & String.sub n 0 2 = "./") - or (String.length n >= 3 & String.sub n 0 3 = "../") -;; + (String.length n >= 1 && String.sub n 0 1 = "/") + || (String.length n >= 2 && String.sub n 0 2 = "./") + || (String.length n >= 3 && String.sub n 0 3 = "../") + let wnt_is_absolute n = - (String.length n >= 1 & - (let s = String.sub n 0 1 in s = "/" or s = "\\")) - or (String.length n >= 2 & - (let s = String.sub n 0 2 in s = "./" or s = ".\\")) - or (String.length n >= 3 & - (let s = String.sub n 0 3 in s = "../" or s = "..\\")) - or (String.length n >= 2 & String.get n 1 = ':') -;; + (String.length n >= 1 && + (let s = String.sub n 0 1 in s = "/" || s = "\\")) + || (String.length n >= 2 && + (let s = String.sub n 0 2 in s = "./" || s = ".\\")) + || (String.length n >= 3 && + (let s = String.sub n 0 3 in s = "../" || s = "..\\")) + || (String.length n >= 2 && String.get n 1 = ':') + let mac_is_absolute n = try for i = 0 to String.length n - 1 do @@ -69,7 +66,6 @@ let mac_is_absolute n = done; false with Exit -> true -;; let is_absolute = match systype with @@ -77,30 +73,19 @@ let is_absolute = | "Win32" -> wnt_is_absolute | "MacOS" -> mac_is_absolute | _ -> failwith "Filename.is_absolute: unknown system" -;; - -let lowercase s = - let l = String.length s in - let n = String.create l in - for i = 0 to l - 1 do - let c = s.[i] in - n.[i] <- (if c >= 'A' & c <= 'Z' then Char.chr(Char.code c + 32) else c) - done; - n -;; let unix_check_suffix name suff = - String.length name >= String.length suff & + String.length name >= String.length suff && String.sub name (String.length name - String.length suff) (String.length suff) = suff -;; + let wnt_check_suffix name suff = - String.length name >= String.length suff & + String.length name >= String.length suff && (let s = String.sub name (String.length name - String.length suff) (String.length suff) in - lowercase s = lowercase suff) -;; -let mac_check_suffix = unix_check_suffix;; + String.lowercase s = String.lowercase suff) + +let mac_check_suffix = unix_check_suffix let check_suffix = match systype with @@ -108,12 +93,10 @@ let check_suffix = | "Win32" -> wnt_check_suffix | "MacOS" -> mac_check_suffix | _ -> failwith "Filename.check_suffix: unknown system" -;; let chop_suffix name suff = let n = String.length name - String.length suff in if n < 0 then invalid_arg "Filename.chop_suffix" else String.sub name 0 n -;; let rindex s c = let rec pos i = @@ -121,21 +104,19 @@ let rindex s c = else if s.[i] = c then i else pos (i - 1) in pos (String.length s - 1) -;; -let rindexsep s = + +let wnt_rindexsep s = let rec pos i = if i < 0 then raise Not_found - else if (let c = s.[i] in c = '/' or c = '\\' or c = ':') then i + else if (let c = s.[i] in c = '/' || c = '\\' || c = ':') then i else pos (i - 1) in pos (String.length s - 1) -;; let chop_extension name = try String.sub name 0 (rindex name '.') with Not_found -> invalid_arg "Filename.chop_extension" -;; let unix_basename name = try @@ -143,7 +124,7 @@ let unix_basename name = String.sub name p (String.length name - p) with Not_found -> name -;; + let unix_dirname name = try match rindex name '/' with @@ -151,34 +132,33 @@ let unix_dirname name = | n -> String.sub name 0 n with Not_found -> "." -;; + let wnt_basename name = try - let p = rindexsep name + 1 in + let p = wnt_rindexsep name + 1 in String.sub name p (String.length name - p) with Not_found -> name -;; + let wnt_dirname name = try - match rindexsep name with + match wnt_rindexsep name with 0 -> "\\" | n -> String.sub name 0 n with Not_found -> "." -;; + let mac_basename name = try let p = rindex name ':' + 1 in String.sub name p (String.length name - p) with Not_found -> name -;; + let mac_dirname name = try match rindex name ':' with | 0 -> ":" | n -> String.sub name 0 n with Not_found -> ":" -;; let basename = match systype with @@ -186,14 +166,13 @@ let basename = | "Win32" -> wnt_basename | "MacOS" -> mac_basename | _ -> failwith "Filename.basename: unknown system" -;; + let dirname = match systype with | "Unix" -> unix_dirname | "Win32" -> wnt_dirname | "MacOS" -> mac_dirname | _ -> failwith "Filename.dirname: unknown system" -;; let temporary_directory = match systype with @@ -201,12 +180,18 @@ let temporary_directory = | "Win32" -> (try Sys.getenv "TEMP" with Not_found -> "C:\\temp") | "MacOS" -> (try Sys.getenv "TempFolder" with Not_found -> ":") | _ -> failwith "Filename.temporary_directory: unknown system" -;; + +external open_desc: string -> open_flag list -> int -> int = "sys_open" +external close_desc: int -> unit = "sys_close" let temp_file prefix suffix = let rec try_name counter = let name = concat temporary_directory (prefix ^ string_of_int counter ^ suffix) in - if Sys.file_exists name then try_name (counter + 1) else name + try + close_desc(open_desc name [Open_wronly; Open_creat; Open_excl] 0o666); + name + with Sys_error _ -> + try_name (counter + 1) in try_name 0 -;; + diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml index 52a62784a..ba5995b3e 100644 --- a/stdlib/hashtbl.ml +++ b/stdlib/hashtbl.ml @@ -13,11 +13,15 @@ (* Hash tables *) -(* We do dynamic hashing, and we double the size of the table when - buckets become too long, but without re-hashing the elements. *) +external hash_param : int -> int -> 'a -> int = "hash_univ_param" "noalloc" + +let hash x = hash_param 10 100 x + +(* We do dynamic hashing, and resize the table and rehash the elements + when buckets become too long. *) type ('a, 'b) t = - { mutable max_len: int; (* max length of a bucket *) + { mutable max_len: int; (* max length of a bucket *) mutable data: ('a, 'b) bucketlist array } (* the buckets *) and ('a, 'b) bucketlist = @@ -25,34 +29,41 @@ and ('a, 'b) bucketlist = | Cons of 'a * 'b * ('a, 'b) bucketlist let create initial_size = - { max_len = 2; data = Array.create initial_size Empty } + { max_len = 3; data = Array.create initial_size Empty } let clear h = for i = 0 to Array.length h.data - 1 do h.data.(i) <- Empty done -let resize h = - let n = Array.length h.data in - let newdata = Array.create (n+n) Empty in - Array.blit h.data 0 newdata 0 n; - Array.blit h.data 0 newdata n n; - h.data <- newdata; - h.max_len <- 2 * h.max_len - +let resize hashfun tbl = + let odata = tbl.data in + let osize = Array.length odata in + let nsize = 2 * osize + 1 in + let ndata = Array.create nsize Empty in + let rec insert_bucket idx = function + Empty -> () + | Cons(key, data, rest) -> + insert_bucket idx rest; (* preserve original order of elements *) + let nidx = (hashfun key) mod nsize in + ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in + for i = 0 to osize - 1 do + insert_bucket i odata.(i) + done; + tbl.data <- ndata; + tbl.max_len <- 2 * tbl.max_len + let rec bucket_too_long n bucket = if n < 0 then true else match bucket with Empty -> false - | Cons(_,_,rest) -> bucket_too_long (pred n) rest - -external hash_param : int -> int -> 'a -> int = "hash_univ_param" "noalloc" + | Cons(_,_,rest) -> bucket_too_long (n - 1) rest let add h key info = let i = (hash_param 10 100 key) mod (Array.length h.data) in let bucket = Cons(key, info, h.data.(i)) in - h.data.(i) <- bucket; - if bucket_too_long h.max_len bucket then resize h + h.data.(i) <- bucket; + if bucket_too_long h.max_len bucket then resize hash h let remove h key = let rec remove_bucket = function @@ -61,7 +72,7 @@ let remove h key = | Cons(k, i, next) -> if k = key then next else Cons(k, i, remove_bucket next) in let i = (hash_param 10 100 key) mod (Array.length h.data) in - h.data.(i) <- remove_bucket h.data.(i) + h.data.(i) <- remove_bucket h.data.(i) let find h key = match h.data.((hash_param 10 100 key) mod (Array.length h.data)) with @@ -93,17 +104,93 @@ let find_all h key = find_in_bucket h.data.((hash_param 10 100 key) mod (Array.length h.data)) let iter f h = + let rec do_bucket = function + Empty -> + () + | Cons(k, d, rest) -> + f k d; do_bucket rest in let d = h.data in - let len = Array.length d in - for i = 0 to len - 1 do - let rec do_bucket = function - Empty -> - () - | Cons(k, d, rest) -> - if (hash_param 10 100 k) mod len = i - then begin f k d; do_bucket rest end - else do_bucket rest in + for i = 0 to Array.length d - 1 do do_bucket d.(i) done -let hash x = hash_param 50 500 x +(* Functorial interface *) + +module type HashedType = + sig + type t + val equal: t -> t -> bool + val hash: t -> int + end + +module type S = + sig + type key + type 'a t + val create: int -> 'a t + val clear: 'a t -> unit + val add: 'a t -> key -> 'a -> unit + val remove: 'a t -> key -> unit + val find: 'a t -> key -> 'a + val find_all: 'a t -> key -> 'a list + val iter: (key -> 'a -> 'b) -> 'a t -> unit + end + +module Make(H: HashedType): (S with type key = H.t) = + struct + type key = H.t + type 'a hashtbl = (key, 'a) t + type 'a t = 'a hashtbl + let create = create + let clear = clear + + let add h key info = + let i = (H.hash key) mod (Array.length h.data) in + let bucket = Cons(key, info, h.data.(i)) in + h.data.(i) <- bucket; + if bucket_too_long h.max_len bucket then resize H.hash h + + let remove h key = + let rec remove_bucket = function + Empty -> + Empty + | Cons(k, i, next) -> + if H.equal k key + then next + else Cons(k, i, remove_bucket next) in + let i = (H.hash key) mod (Array.length h.data) in + h.data.(i) <- remove_bucket h.data.(i) + + let find h key = + match h.data.((H.hash key) mod (Array.length h.data)) with + Empty -> raise Not_found + | Cons(k1, d1, rest1) -> + if H.equal key k1 then d1 else + match rest1 with + Empty -> raise Not_found + | Cons(k2, d2, rest2) -> + if H.equal key k2 then d2 else + match rest2 with + Empty -> raise Not_found + | Cons(k3, d3, rest3) -> + if H.equal key k3 then d3 else begin + let rec find = function + Empty -> + raise Not_found + | Cons(k, d, rest) -> + if H.equal key k then d else find rest + in find rest3 + end + + let find_all h key = + let rec find_in_bucket = function + Empty -> + [] + | Cons(k, d, rest) -> + if H.equal k key + then d :: find_in_bucket rest + else find_in_bucket rest in + find_in_bucket h.data.((H.hash key) mod (Array.length h.data)) + + let iter = iter + end diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli index e31448b79..c3bf841ca 100644 --- a/stdlib/hashtbl.mli +++ b/stdlib/hashtbl.mli @@ -15,6 +15,8 @@ (* Hash tables are hashed association tables, with in-place modification. *) +(*** Generic interface *) + type ('a, 'b) t (* The type of hash tables from type ['a] to type ['b]. *) @@ -57,6 +59,50 @@ val iter : ('a -> 'b -> 'c) -> ('a, 'b) t -> unit [f] is unspecified. Each binding is presented exactly once to [f]. *) +(*** Functorial interface *) + +module type HashedType = + sig + type t + val equal: t -> t -> bool + val hash: t -> int + end + (* The input signature of the functor [Hashtbl.Make]. + [t] is the type of keys. + [equal] is the equality predicate used to compare keys. + [hash] is a hashing function on keys, returning a non-negative + integer. It must be such that if two keys are equal according + to [equal], then they must have identical hash values as computed + by [hash]. + Examples: suitable ([equal], [hash]) pairs for arbitrary key + types include + ([(=)], [Hashtbl.hash]) for comparing objects by structure, + ([(==)], [Hashtbl.hash]) for comparing objects by addresses + (e.g. for mutable or cyclic keys). *) + +module type S = + sig + type key + type 'a t + val create: int -> 'a t + val clear: 'a t -> unit + val add: 'a t -> key -> 'a -> unit + val remove: 'a t -> key -> unit + val find: 'a t -> key -> 'a + val find_all: 'a t -> key -> 'a list + val iter: (key -> 'a -> 'b) -> 'a t -> unit + end + +module Make(H: HashedType): (S with type key = H.t) + + (* The functor [Hashtbl.Make] returns a structure containing + a type [key] of keys and a type ['a t] of hash tables + associating data of type ['a] to keys of type [key]. + The operations perform similarly to those of the generic + interface, but use the hashing and equality functions + specified in the functor argument [H] instead of generic + equality and hashing. *) + (*** The polymorphic hash primitive *) val hash : 'a -> int diff --git a/stdlib/string.ml b/stdlib/string.ml index ad7f6524b..243751581 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -115,3 +115,24 @@ let escaped s = done; s' end + +let map f s = + let l = length s in + if l = 0 then s else begin + let r = create l in + for i = 0 to l - 1 do unsafe_set r i (f(unsafe_get s i)) done; + r + end + +let uppercase s = map Char.uppercase s +let lowercase s = map Char.uppercase s + +let apply1 f s = + if length s = 0 then s else begin + let r = copy s in + unsafe_set r 0 (f(unsafe_get s 0)); + r + end + +let capitalize s = apply1 Char.uppercase s +let uncapitalize s = apply1 Char.lowercase s diff --git a/stdlib/string.mli b/stdlib/string.mli index 3ae892940..b1b4a66b3 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -70,6 +70,19 @@ val escaped: string -> string by escape sequences, following the lexical conventions of Caml Light. *) +val uppercase: string -> string + (* Return a copy of the argument, with all lowercase letters + translated to uppercase. *) +val lowercase: string -> string + (* Return a copy of the argument, with all uppercase letters + translated to lowercase. *) +val capitalize: string -> string + (* Return a copy of the argument, with the first letter + set to uppercase. *) +val uncapitalize: string -> string + (* Return a copy of the argument, with the first letter + set to lowercase. *) + (*--*) external unsafe_get : string -> int -> char = "%string_unsafe_get" |