diff options
Diffstat (limited to 'stdlib')
47 files changed, 0 insertions, 3638 deletions
diff --git a/stdlib/.depend b/stdlib/.depend deleted file mode 100644 index a225576552..0000000000 --- a/stdlib/.depend +++ /dev/null @@ -1,26 +0,0 @@ -format.cmi: list.cmi -gc.cmi: -lexing.cmi: obj.cmi -parsing.cmi: lexing.cmi obj.cmi -printexc.cmi: -arg.cmo: arg.cmi sys.cmi string.cmi list.cmi array.cmi printf.cmi -array.cmo: array.cmi list.cmi array.cmi -char.cmo: char.cmi char.cmi string.cmi -filename.cmo: filename.cmi string.cmi -format.cmo: format.cmi queue.cmi string.cmi list.cmi -gc.cmo: gc.cmi printf.cmi -hashtbl.cmo: hashtbl.cmi array.cmi -lexing.cmo: lexing.cmi string.cmi obj.cmi -list.cmo: list.cmi list.cmi -map.cmo: map.cmi -obj.cmo: obj.cmi -parsing.cmo: parsing.cmi array.cmi lexing.cmi obj.cmi -pervasives.cmo: pervasives.cmi -printexc.cmo: printexc.cmi obj.cmi -printf.cmo: printf.cmi string.cmi list.cmi obj.cmi -queue.cmo: queue.cmi -set.cmo: set.cmi -sort.cmo: sort.cmi -stack.cmo: stack.cmi list.cmi -string.cmo: string.cmi char.cmi string.cmi list.cmi -sys.cmo: sys.cmi diff --git a/stdlib/Makefile b/stdlib/Makefile deleted file mode 100644 index 38c7f74ae9..0000000000 --- a/stdlib/Makefile +++ /dev/null @@ -1,52 +0,0 @@ -include ../Makefile.config - -COMPILER=../camlc -CAMLC=../byterun/camlrun $(COMPILER) -CAMLDEP=../tools/camldep - -OBJS=pervasives.cmo list.cmo string.cmo char.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 \ - printf.cmo format.cmo arg.cmo printexc.cmo gc.cmo - -all: stdlib.cma cslheader - -install: - cp stdlib.cma *.cmi *.mli cslheader $(LIBDIR) - -stdlib.cma: $(OBJS) - $(CAMLC) -a -o stdlib.cma $(OBJS) - -cslheader: header.c ../Makefile.config - if $(SHARPBANGSCRIPTS); \ - then echo "#!$(BINDIR)/cslrun" > cslheader; \ - else $(CC) $(CCCOMPOPTS) $(CCLINKOPTS) header.c -o cslheader; \ - strip cslheader; fi - -pervasives.cmi: pervasives.mli - $(CAMLC) -nopervasives -c pervasives.mli - -pervasives.cmo: pervasives.ml - $(CAMLC) -nopervasives -c pervasives.ml - -.SUFFIXES: .mli .ml .cmi .cmo - -.mli.cmi: - $(CAMLC) $(COMPFLAGS) -c $< - -.ml.cmo: - $(CAMLC) $(COMPFLAGS) -c $< - -$(OBJS): pervasives.cmi - -$(OBJS): $(COMPILER) -$(OBJS:.cmo=.cmi): $(COMPILER) - -clean: - rm -f *.cm[ioa] - rm -f *~ - -include .depend - -depend: - $(CAMLDEP) *.mli *.ml > .depend diff --git a/stdlib/arg.ml b/stdlib/arg.ml deleted file mode 100644 index 3726760f49..0000000000 --- a/stdlib/arg.ml +++ /dev/null @@ -1,61 +0,0 @@ -type spec = - String of (string -> unit) - | Int of (int -> unit) - | Unit of (unit -> unit) - | Float of (float -> unit) - -exception Bad of string - -type error = - Unknown of string - | Wrong of string * string * string (* option, actual, expected *) - | Missing of string - | Message of string - -open Printf - -let stop error = - let progname = - if Array.length Sys.argv > 0 then Sys.argv.(0) else "(?)" in - begin match error with - Unknown s -> - eprintf "%s: unknown option `%s'.\n" progname s - | Missing s -> - eprintf "%s: option `%s' needs an argument.\n" progname s - | Wrong (opt, arg, expected) -> - eprintf "%s: wrong argument `%s'; option `%s' expects %s.\n" - progname arg opt expected - | Message s -> - eprintf "%s: %s.\n" progname s - end; - exit 2 - -let parse speclist anonfun = - let rec p = function - [] -> () - | s :: t -> - if String.length s >= 1 & String.get s 0 = '-' - then do_key s t - else begin try (anonfun s); p t with Bad m -> stop (Message m) end - and do_key s l = - let action = - try - List.assoc s speclist - with Not_found -> - stop (Unknown s) in - try - match (action, l) with - (Unit f, l) -> f (); p l - | (String f, arg::t) -> f arg; p t - | (Int f, arg::t) -> - begin try f (int_of_string arg) - with Failure "int_of_string" -> stop (Wrong (s, arg, "an integer")) - end; - p t - | (Float f, arg::t) -> f (float_of_string arg); p t - | (_, []) -> stop (Missing s) - with Bad m -> stop (Message m) - in - match Array.to_list Sys.argv with - [] -> () - | a::l -> p l diff --git a/stdlib/arg.mli b/stdlib/arg.mli deleted file mode 100644 index 593d5b36b6..0000000000 --- a/stdlib/arg.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* Parsing of command line arguments. *) - -(* This module provides a general mechanism for extracting options and - arguments from the command line to the program. *) - -(* Syntax of command lines: - A keyword is a character string starting with a [-]. - An option is a keyword alone or followed by an argument. - There are four types of keywords: Unit, String, Int, and Float. - Unit keywords do not take an argument. - String, Int, and Float keywords take the following word on the command line - as an argument. - Arguments not preceded by a keyword are called anonymous arguments. *) - -(* Examples ([cmd] is assumed to be the command name): - -- [cmd -flag ](a unit option) -- [cmd -int 1 ](an int option with argument [1]) -- [cmd -string foobar ](a string option with argument ["foobar"]) -- [cmd -float 12.34 ](a float option with argument [12.34]) -- [cmd 1 2 3 ](three anonymous arguments: ["1"], ["2"], and ["3"]) -- [cmd 1 2 -flag 3 -string bar 4] -- [ ](four anonymous arguments, a unit option, and -- [ ] a string option with argument ["bar"]) -*) - -type spec = - String of (string -> unit) - | Int of (int -> unit) - | Unit of (unit -> unit) - | Float of (float -> unit) - (* The concrete type describing the behavior associated - with a keyword. *) - -val parse : (string * spec) list -> (string -> unit) -> unit - (* [parse speclist anonfun] parses the command line, - calling the functions in [speclist] whenever appropriate, - and [anonfun] on anonymous arguments. - The functions are called in the same order as they appear - on the command line. - The strings in the [(string * spec) list] are keywords and must - start with a [-], else they are ignored. *) - -exception Bad of string - (* Functions in [speclist] or [anonfun] can raise [Bad] with - an error message to reject invalid arguments. *) diff --git a/stdlib/array.ml b/stdlib/array.ml deleted file mode 100644 index d539d76c60..0000000000 --- a/stdlib/array.ml +++ /dev/null @@ -1,117 +0,0 @@ -(* Array operations *) - -external length : 'a array -> int = "%array_length" -external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get" -external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set" -external new: int -> 'a -> 'a array = "make_vect" -external get: 'a array -> int -> 'a = "array_get" -external set: 'a array -> int -> 'a -> unit = "array_set" - -(***** -let get a n = - if n < 0 or n >= length a - then invalid_arg "Array.get" - else unsafe_get a n - -let set a n v = - if n < 0 or n >= length a - then invalid_arg "Array.set" - else unsafe_set a n v -*****) - -let new_matrix sx sy init = - let res = new sx [||] in - for x = 0 to pred sx do - unsafe_set res x (new sy init) - done; - res - -let copy a = - let l = length a in - if l = 0 then [||] else begin - let r = new l (unsafe_get a 0) in - for i = 1 to l-1 do - unsafe_set r i (unsafe_get a i) - done; - r - end - -let append a1 a2 = - let l1 = length a1 and l2 = length a2 in - if l1 = 0 & l2 = 0 then [||] else begin - let r = new (l1 + l2) (unsafe_get (if l1 > 0 then a1 else a2) 0) in - for i = 0 to l1 - 1 do unsafe_set r i (unsafe_get a1 i) done; - for i = 0 to l2 - 1 do unsafe_set r (i + l1) (unsafe_get a2 i) done; - r - end - -let concat_aux init al = - let size = List.fold_left (fun sz a -> sz + length a) 0 al in - let res = new size init in - let pos = ref 0 in - List.iter - (fun a -> - for i = 0 to length a - 1 do - unsafe_set res !pos (unsafe_get a i); - incr pos - done) - al; - res - -let concat al = - let rec find_init = function - [] -> [||] - | a :: rem -> - if length a > 0 then concat_aux (unsafe_get a 0) al else find_init rem - in find_init al - -let sub a ofs len = - if ofs < 0 or len < 0 or ofs + len > length a then invalid_arg "Array.sub" - else if len = 0 then [||] - else begin - let r = new len (unsafe_get a ofs) in - for i = 1 to len - 1 do unsafe_set r i (unsafe_get a (ofs + i)) done; - r - end - -let fill a ofs len v = - if ofs < 0 or len < 0 or ofs + len > length a - then invalid_arg "Array.fill" - else for i = ofs to ofs + len - 1 do unsafe_set a i v done - -let blit a1 ofs1 a2 ofs2 len = - if len < 0 or ofs1 < 0 or ofs1 + len > length a1 - or ofs2 < 0 or ofs2 + len > length a2 - then invalid_arg "Array.blit" - else - for i = 0 to len - 1 do - unsafe_set a2 (ofs2 + i) (unsafe_get a1 (ofs1 + i)) - done - -let iter f a = - for i = 0 to length a - 1 do f(unsafe_get a i) done - -let map f a = - let l = length a in - if l = 0 then [||] else begin - let r = new l (f(unsafe_get a 0)) in - for i = 1 to l - 1 do - unsafe_set r i (f(unsafe_get a i)) - done; - r - end - -let to_list a = - let len = length a in - let rec tolist i = - if i >= len then [] else unsafe_get a i :: tolist(i+1) in - tolist 0 - -let of_list = function - [] -> [||] - | hd::tl -> - let a = new (List.length tl + 1) hd in - let rec fill i = function - [] -> a - | hd::tl -> unsafe_set a i hd; fill (i+1) tl in - fill 1 tl diff --git a/stdlib/array.mli b/stdlib/array.mli deleted file mode 100644 index e0d9983d7d..0000000000 --- a/stdlib/array.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* Array operations *) - -external length : 'a array -> int = "%array_length" - -external get: 'a array -> int -> 'a = "array_get" -external set: 'a array -> int -> 'a -> unit = "array_set" -external new: int -> 'a -> 'a array = "make_vect" -val new_matrix: int -> int -> 'a -> 'a array array -val append: 'a array -> 'a array -> 'a array -val concat: 'a array list -> 'a array -val sub: 'a array -> int -> int -> 'a array -val copy: 'a array -> 'a array -val fill: 'a array -> int -> int -> 'a -> unit -val blit: 'a array -> int -> 'a array -> int -> int -> unit -val iter: ('a -> 'b) -> 'a array -> unit -val map: ('a -> 'b) -> 'a array -> 'b array -val to_list: 'a array -> 'a list -val of_list: 'a list -> 'a array - -external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get" -external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set" - diff --git a/stdlib/baltree.ml b/stdlib/baltree.ml deleted file mode 100644 index 6ecf9cf626..0000000000 --- a/stdlib/baltree.ml +++ /dev/null @@ -1,193 +0,0 @@ -(* Weight-balanced binary trees. - These are binary trees such that one child of a node has at most N times - as many elements as the other child. We take N=3. *) - -type 'a t = Empty | Node of 'a t * 'a * 'a t * int - (* The type of trees containing elements of type ['a]. - [Empty] is the empty tree (containing no elements). *) - -type 'a contents = Nothing | Something of 'a - (* Used with the functions [modify] and [List.split], to represent - the presence or the absence of an element in a tree. *) - -(* Compute the size (number of nodes and leaves) of a tree. *) - -let size = function - Empty -> 1 - | Node(_, _, _, s) -> s - -(* Creates a new node with left son l, value x and right son r. - l and r must be balanced and size l / size r must be between 1/N and N. - Inline expansion of size for better speed. *) - -let new l x r = - let sl = match l with Empty -> 0 | Node(_,_,_,s) -> s in - let sr = match r with Empty -> 0 | Node(_,_,_,s) -> s in - Node(l, x, r, sl + sr + 1) - -(* Same as new, but performs rebalancing if necessary. - Assumes l and r balanced, and size l / size r "reasonable" - (between 1/N^2 and N^2 ???). - Inline expansion of new for better speed in the most frequent case - where no rebalancing is required. *) - -let bal l x r = - let sl = match l with Empty -> 0 | Node(_,_,_,s) -> s in - let sr = match r with Empty -> 0 | Node(_,_,_,s) -> s in - if sl > 3 * sr then begin - match l with - Empty -> invalid_arg "Baltree.bal" - | Node(ll, lv, lr, _) -> - if size ll >= size lr then - new ll lv (new lr x r) - else begin - match lr with - Empty -> invalid_arg "Baltree.bal" - | Node(lrl, lrv, lrr, _)-> - new (new ll lv lrl) lrv (new lrr x r) - end - end else if sr > 3 * sl then begin - match r with - Empty -> invalid_arg "Baltree.bal" - | Node(rl, rv, rr, _) -> - if size rr >= size rl then - new (new l x rl) rv rr - else begin - match rl with - Empty -> invalid_arg "Baltree.bal" - | Node(rll, rlv, rlr, _) -> - new (new l x rll) rlv (new rlr rv rr) - end - end else - Node(l, x, r, sl + sr + 1) - -(* Same as bal, but rebalance regardless of the original ratio - size l / size r *) - -let rec join l x r = - match bal l x r with - Empty -> invalid_arg "Baltree.join" - | Node(l', x', r', _) as t' -> - let sl = size l' and sr = size r' in - if sl > 3 * sr or sr > 3 * sl then join l' x' r' else t' - -(* Merge two trees l and r into one. - All elements of l must precede the elements of r. - Assumes size l / size r between 1/N and N. *) - -let rec merge t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> - bal l1 v1 (bal (merge r1 l2) v2 r2) - -(* Same as merge, but does not assume anything about l and r. *) - -let rec concat t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> - join l1 v1 (join (concat r1 l2) v2 r2) - -(* Insertion *) - -let add searchpred x t = - let rec add = function - Empty -> - Node(Empty, x, Empty, 1) - | Node(l, v, r, _) as t -> - let c = searchpred v in - if c == 0 then t else - if c < 0 then bal (add l) v r else bal l v (add r) - in add t - -(* Membership *) - -let contains searchpred t = - let rec contains = function - Empty -> false - | Node(l, v, r, _) -> - let c = searchpred v in - if c == 0 then true else - if c < 0 then contains l else contains r - in contains t - -(* Search *) - -let find searchpred t = - let rec find = function - Empty -> - raise Not_found - | Node(l, v, r, _) -> - let c = searchpred v in - if c == 0 then v else - if c < 0 then find l else find r - in find t - -(* Deletion *) - -let remove searchpred t = - let rec remove = function - Empty -> - Empty - | Node(l, v, r, _) -> - let c = searchpred v in - if c == 0 then merge l r else - if c < 0 then bal (remove l) v r else bal l v (remove r) - in remove t - -(* Modification *) - -let modify searchpred modifier t = - let rec modify = function - Empty -> - begin match modifier Nothing with - Nothing -> Empty - | Something v -> Node(Empty, v, Empty, 1) - end - | Node(l, v, r, s) -> - let c = searchpred v in - if c == 0 then - begin match modifier(Something v) with - Nothing -> merge l r - | Something v' -> Node(l, v', r, s) - end - else if c < 0 then bal (modify l) v r else bal l v (modify r) - in modify t - -(* Splitting *) - -let split searchpred = - let rec split = function - Empty -> - (Empty, Nothing, Empty) - | Node(l, v, r, _) -> - let c = searchpred v in - if c == 0 then (l, Something v, r) - else if c < 0 then - let (ll, vl, rl) = split l in (ll, vl, join rl v r) - else - let (lr, vr, rr) = split r in (join l v lr, vr, rr) - in split - -(* Comparison (by lexicographic ordering of the fringes of the two trees). *) - -let compare cmp s1 s2 = - let rec compare_aux l1 l2 = - match (l1, l2) with - ([], []) -> 0 - | ([], _) -> -1 - | (_, []) -> 1 - | (Empty::t1, Empty::t2) -> - compare_aux t1 t2 - | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) -> - let c = cmp v1 v2 in - if c != 0 then c else compare_aux (r1::t1) (r2::t2) - | (Node(l1, v1, r1, _) :: t1, t2) -> - compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2 - | (t1, Node(l2, v2, r2, _) :: t2) -> - compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2) - in - compare_aux [s1] [s2] diff --git a/stdlib/baltree.mli b/stdlib/baltree.mli deleted file mode 100644 index 4e6f35efbb..0000000000 --- a/stdlib/baltree.mli +++ /dev/null @@ -1,77 +0,0 @@ -(* Basic balanced binary trees *) - -(* This module implements balanced ordered binary trees. - All operations over binary trees are applicative (no side-effects). - The [set] and [List.map] modules are based on this module. - This modules gives a more direct access to the internals of the - binary tree implementation than the [set] and [List.map] abstractions, - but is more delicate to use and not as safe. For advanced users only. *) - -type 'a t = Empty | Node of 'a t * 'a * 'a t * int - (* The type of trees containing elements of type ['a]. - [Empty] is the empty tree (containing no elements). *) - -type 'a contents = Nothing | Something of 'a - (* Used with the functions [modify] and [List.split], to represent - the presence or the absence of an element in a tree. *) - -val add: ('a -> int) -> 'a -> 'a t -> 'a t - (* [add f x t] inserts the element [x] into the tree [t]. - [f] is an ordering function: [f y] must return [0] if - [x] and [y] are equal (or equivalent), a negative integer if - [x] is smaller than [y], and a positive integer if [x] is - greater than [y]. The tree [t] is returned unchanged if - it already contains an element equivalent to [x] (that is, - an element [y] such that [f y] is [0]). - The ordering [f] must be consistent with the orderings used - to build [t] with [add], [remove], [modify] or [List.split] - operations. *) -val contains: ('a -> int) -> 'a t -> bool - (* [contains f t] checks whether [t] contains an element - satisfying [f], that is, an element [x] such - that [f x] is [0]. [f] is an ordering function with the same - constraints as for [add]. It can be coarser (identify more - elements) than the orderings used to build [t], but must be - consistent with them. *) -val find: ('a -> int) -> 'a t -> 'a - (* Same as [contains], except that [find f t] returns the element [x] - such that [f x] is [0], or raises [Not_found] if none has been - found. *) -val remove: ('a -> int) -> 'a t -> 'a t - (* [remove f t] removes one element [x] of [t] such that [f x] is [0]. - [f] is an ordering function with the same constraints as for [add]. - [t] is returned unchanged if it does not contain any element - satisfying [f]. If several elements of [t] satisfy [f], - only one is removed. *) -val modify: ('a -> int) -> ('a contents -> 'a contents) -> 'a t -> 'a t - (* General insertion/modification/deletion function. - [modify f g t] searchs [t] for an element [x] satisfying the - ordering function [f]. If one is found, [g] is applied to - [Something x]; if [g] returns [Nothing], the element [x] - is removed; if [g] returns [Something y], the element [y] - replaces [x] in the tree. (It is assumed that [x] and [y] - are equivalent, in particular, that [f y] is [0].) - If the tree does not contain any [x] satisfying [f], - [g] is applied to [Nothing]; if it returns [Nothing], - the tree is returned unchanged; if it returns [Something x], - the element [x] is inserted in the tree. (It is assumed that - [f x] is [0].) The functions [add] and [remove] are special cases - of [modify], slightly more efficient. *) -val split: ('a -> int) -> 'a t -> 'a t * 'a contents * 'a t - (* [split f t] returns a triple [(less, elt, greater)] where - [less] is a tree containing all elements [x] of [t] such that - [f x] is negative, [greater] is a tree containing all - elements [x] of [t] such that [f x] is positive, and [elt] - is [Something x] if [t] contains an element [x] such that - [f x] is [0], and [Nothing] otherwise. *) -val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - (* Compare two trees. The first argument [f] is a comparison function - over the tree elements: [f e1 e2] is zero if the elements [e1] and - [e2] are equal, negative if [e1] is smaller than [e2], - and positive if [e1] is greater than [e2]. [compare f t1 t2] - compares the fringes of [t1] and [t2] by lexicographic extension - of [f]. *) -(*--*) -val join: 'a t -> 'a -> 'a t -> 'a t -val concat: 'a t -> 'a t -> 'a t - diff --git a/stdlib/char.ml b/stdlib/char.ml deleted file mode 100644 index 348c5683c4..0000000000 --- a/stdlib/char.ml +++ /dev/null @@ -1,26 +0,0 @@ -(* Character operations *) - -external code: char -> int = "%identity" -external unsafe_chr: int -> char = "%identity" - -let chr n = - if n < 0 or n > 255 then invalid_arg "Char.chr" else unsafe_chr n - -external is_printable: char -> bool = "is_printable" - -let escaped = function - '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | c -> if is_printable c then - String.make 1 c - 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)); - s - end diff --git a/stdlib/char.mli b/stdlib/char.mli deleted file mode 100644 index 7afa37bb4d..0000000000 --- a/stdlib/char.mli +++ /dev/null @@ -1,6 +0,0 @@ -(* Character operations *) - -external code: char -> int = "%identity" -val chr: int -> char -val escaped : char -> string -external unsafe_chr: int -> char = "%identity" diff --git a/stdlib/filename.ml b/stdlib/filename.ml deleted file mode 100644 index af63af08fc..0000000000 --- a/stdlib/filename.ml +++ /dev/null @@ -1,49 +0,0 @@ -let check_suffix name suff = - String.length name >= String.length suff & - String.sub name (String.length name - String.length suff) (String.length suff) - = suff - -let chop_suffix name suff = - let n = String.length name - String.length suff in - if n < 0 then invalid_arg "chop_suffix" else String.sub name 0 n - -let current_dir_name = "." - -let concat dirname filename = - let l = String.length dirname - 1 in - if l < 0 or String.get dirname l = '/' - then dirname ^ filename - else dirname ^ "/" ^ filename - -let 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 = "../") - -let slash_pos s = - let rec pos i = - if i < 0 then raise Not_found - else if String.get s i = '/' then i - else pos (i - 1) - in pos (String.length s - 1) - -let basename name = - try - let p = slash_pos name + 1 in - String.sub name p (String.length name - p) - with Not_found -> - name - -let dirname name = - try - match slash_pos name with - 0 -> "/" - | n -> String.sub name 0 (slash_pos name) - with Not_found -> - "." - - - - - - diff --git a/stdlib/filename.mli b/stdlib/filename.mli deleted file mode 100644 index bf75f61c5f..0000000000 --- a/stdlib/filename.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Operations on file names *) - -val current_dir_name : string - (* The conventional name for the current directory - (e.g. [.] in Unix). *) -val concat : string -> string -> string - (* [concat dir file] returns a file name that designates file - [file] in directory [dir]. *) -val is_absolute : string -> bool - (* Return [true] if the file name is absolute or starts with an - explicit reference to the current directory ([./] or [../] in - Unix), and [false] if it is relative to the current directory. *) -val check_suffix : string -> string -> bool - (* [check_suffix name suff] returns [true] if the filename [name] - ends with the suffix [suff]. *) -val chop_suffix : string -> string -> string - (* [chop_suffix name suff] removes the suffix [suff] from - the filename [name]. The behavior is undefined if [name] does not - end with the suffix [suff]. *) -val basename : string -> string -val dirname : string -> string - (* Split a file name into directory name / base file name. - [concat (dirname name) (basename name)] returns a file name - which is equivalent to [name]. Moreover, after setting the - current directory to [dirname name] (with [sys__chdir]), - references to [basename name] (which is a relative file name) - designate the same file as [name] before the call to [chdir]. *) diff --git a/stdlib/format.ml b/stdlib/format.ml deleted file mode 100644 index 6ac6c247ce..0000000000 --- a/stdlib/format.ml +++ /dev/null @@ -1,471 +0,0 @@ -(* Tokens are one of the following : *) - -type pp_token = - Pp_text of string (* normal text *) - | Pp_break of int * int (* complete break *) - | Pp_tbreak of int * int (* go to next tab *) - | Pp_stab (* set a tabulation *) - | Pp_begin of int * block_type (* beginning of a block *) - | Pp_end (* end of a block *) - | Pp_tbegin of tblock (* Beginning of a tabulation block *) - | Pp_tend (* end of a tabulation block *) - | Pp_newline (* to force a newline inside a block *) - | Pp_if_newline (* to do something only if this very - line has been broken *) - -and block_type = - Pp_hbox (* Horizontal block no line breaking *) - | Pp_vbox (* Vertical block each break leads to a new line *) - | Pp_hvbox (* Horizontal-vertical block: same as vbox, except if this block - is small enough to fit on a single line *) - | Pp_hovbox (* Horizontal or Vertical block: breaks lead to new line - only when necessary to print the content of the block *) - | Pp_fits (* Internal usage: when a block fits on a single line *) - -and tblock = Pp_tbox of int list ref (* Tabulation box *) - -(* The Queue: contains all formatting elements. - elements are tuples (size,token,length), where - 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 : int; token : pp_token; length : int} - -(* Scan stack - each element is (left_total, queue element) where left_total - is the value of pp_left_total when the element has been enqueued *) -type pp_scan_elem = Scan_elem of int * pp_queue_elem -let pp_scan_stack = ref ([] : pp_scan_elem list) - -(* Formatting Stack: - used to break the lines while printing tokens. - The formatting stack contains the description of - the currently active blocks. *) -type pp_format_elem = Format_elem of block_type * int -let pp_format_stack = ref ([]:pp_format_elem list) - -let pp_tbox_stack = ref ([]:tblock list) - -(* Large value for default tokens size *) -let pp_infinity = 9999 - -(* Global variables: default initialization is - set_margin 78 - set_min_space_left 0 *) -(* value of right margin *) -let pp_margin = ref 78 - -(* Minimal space left before margin, when opening a block *) -let pp_min_space_left = ref 10 -(* maximum value of indentation: - no blocks can be opened further *) -let pp_max_indent = ref (!pp_margin - !pp_min_space_left) - -let pp_space_left = ref !pp_margin(* space remaining on the current line *) -and pp_current_indent = ref 0 (* current value of indentation *) -and pp_left_total = ref 1 (* total width of tokens already printed *) -and pp_right_total = ref 1 (* total width of tokens ever put in queue *) -and pp_curr_depth = ref 0 (* current number of opened blocks *) -and pp_max_boxes = ref 35 (* maximum number of blocks which can be - opened at the same time *) -and pp_ellipsis = ref "." (* ellipsis string *) -and pp_out_channel = ref stdout (* out_channel of the pretty_printer *) - -(* Output functions for the formatter *) -let pp_output s = output !pp_out_channel s -and pp_output_string s = output_string !pp_out_channel s -and pp_output_newline () = output_char !pp_out_channel '\n' - -(* The pretty-printer queue *) -let pp_queue = (Queue.new () : pp_queue_elem Queue.t) - -let pp_clear_queue () = - pp_left_total := 1; pp_right_total := 1; - Queue.clear pp_queue - -(* Enter a token in the pretty-printer queue *) -let pp_enqueue ({length=len} as token) = - pp_right_total := !pp_right_total + len; - Queue.add token pp_queue - -(* To output spaces *) -let blank_line = String.make 80 ' ' -let display_blanks n = - if n > 0 then - if n <= 80 then pp_output blank_line 0 n - else pp_output_string (String.make n ' ') - -(* To format a break, indenting a new line *) -let break_new_line offset width = - pp_output_newline (); - let indent = !pp_margin - width + offset in - (* Don't indent more than pp_max_indent *) - let real_indent = min !pp_max_indent indent in - pp_current_indent := real_indent; - pp_space_left := !pp_margin - !pp_current_indent; - display_blanks !pp_current_indent - -(* To force a line break inside a block: no offset is added *) -let break_line width = break_new_line 0 width - -(* To format a break that fits on the current line *) -let break_same_line width = - pp_space_left := !pp_space_left - width; - display_blanks 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_newline () = - match !pp_format_stack with - Format_elem (bl_ty, width) :: _ -> - if width > !pp_space_left then - (match bl_ty with - Pp_fits -> () | Pp_hbox -> () | _ -> break_line width) - | _ -> pp_output_newline() - -(* To skip a token, if the previous line has been broken *) -let pp_skip_token () = - (* When calling pp_skip_token the queue cannot be empty *) - match Queue.take pp_queue with - {elem_size = size; length = len} -> - pp_left_total := !pp_left_total - len; - pp_space_left := !pp_space_left + size - -(* To format a token *) -let format_pp_token size = function - - Pp_text s -> pp_space_left := !pp_space_left - size; pp_output_string s - - | Pp_begin (off,ty) -> - let insertion_point = !pp_margin - !pp_space_left in - if insertion_point > !pp_max_indent then - (* can't open a block right there ! *) - pp_force_newline () else - (* If block is rejected on the left current indentation will change *) - if size > !pp_space_left & !pp_current_indent < insertion_point then - pp_force_newline (); - let offset = !pp_space_left - off in - let bl_type = - begin match ty with - Pp_vbox -> Pp_vbox - | _ -> if size > !pp_space_left then ty else Pp_fits - end in - pp_format_stack := Format_elem (bl_type, offset) :: !pp_format_stack - - | Pp_end -> - begin match !pp_format_stack with - x::(y::l as ls) -> pp_format_stack := ls - | _ -> () (* No more block to close *) - end - - | Pp_tbegin (Pp_tbox _ as tbox) -> pp_tbox_stack := tbox :: !pp_tbox_stack - - | Pp_tend -> - begin match !pp_tbox_stack with - x::ls -> pp_tbox_stack := ls - | _ -> () (* No more tabulation block to close *) - end - - | Pp_stab -> - begin match !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 (!pp_margin - !pp_space_left) !tabs - | _ -> () (* No opened tabulation block *) - end - - | Pp_tbreak (n,off) -> - let insertion_point = !pp_margin - !pp_space_left in - begin match !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 (offset + n) else - break_new_line (tab + off) !pp_margin - | _ -> () (* No opened tabulation block *) - end - - | Pp_newline -> - begin match !pp_format_stack with - Format_elem (_,width) :: _ -> break_line width - | _ -> pp_output_newline() - end - - | Pp_if_newline -> - if !pp_current_indent != !pp_margin - !pp_space_left - then pp_skip_token () - - | Pp_break (n,off) -> - begin match !pp_format_stack with - Format_elem (ty,width) :: _ -> - begin match ty with - Pp_hovbox -> - if size > !pp_space_left then break_new_line off width else - (* break the line here leads to new indentation ? *) - if (!pp_current_indent > !pp_margin - width + off) - then break_new_line off width else break_same_line n - | Pp_hvbox -> break_new_line off width - | Pp_fits -> break_same_line n - | Pp_vbox -> break_new_line off width - | Pp_hbox -> break_same_line n - end - | _ -> () (* No opened block *) - 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 List.exists on the current line *) -let rec advance_left () = - try - match Queue.peek pp_queue with - {elem_size = size; token = tok; length = len} -> - if not (size < 0 & - (!pp_right_total - !pp_left_total <= !pp_space_left)) then - begin - Queue.take pp_queue; - format_pp_token (if size < 0 then pp_infinity else size) tok; - pp_left_total := len + !pp_left_total; - advance_left () - end - with Queue.Empty -> () - -let enqueue_advance tok = pp_enqueue tok; advance_left () - -(* To enqueue a string : try to advance *) -let enqueue_string_as n s = - enqueue_advance {elem_size = n; token = Pp_text s; length = n} - -let enqueue_string s = enqueue_string_as (String.length s) s - -(* Routines for scan stack - determine sizes of blocks *) -(* scan_stack is never empty *) -let empty_scan_stack = - [Scan_elem (-1, {elem_size = (-1); token = Pp_text ""; length = 0})] -let clear_scan_stack () = pp_scan_stack := empty_scan_stack - -(* Set size of blocks on scan stack: - if ty = true then size of break is set else size of block is set - in each case pp_scan_stack is popped *) -(* Pattern matching on scan stack is exhaustive, - since scan_stack is never empty. - Pattern matching on token in scan stack is also exhaustive, - since scan_push is used on breaks and opening of boxes *) -let set_size ty = - match !pp_scan_stack with - Scan_elem (left_tot, - ({elem_size = size; token = tok} as queue_elem)) :: t -> - (* test if scan stack contains any data that is not obsolete *) - if left_tot < !pp_left_total then clear_scan_stack () else - begin match tok with - Pp_break (_, _) | Pp_tbreak (_, _) -> - if ty then - begin - queue_elem.elem_size <- !pp_right_total + size; - pp_scan_stack := t - end - | Pp_begin (_, _) -> - if not ty then - begin - queue_elem.elem_size <- !pp_right_total + size; - pp_scan_stack := t - end - | _ -> () (* 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 b tok = - pp_enqueue tok; - if b then set_size true; - pp_scan_stack := Scan_elem (!pp_right_total,tok) :: !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 character the ellipsis -*) -let pp_open_box (indent,br_ty) = - incr pp_curr_depth; - if !pp_curr_depth < !pp_max_boxes then - (scan_push false - {elem_size = (- !pp_right_total); - token = Pp_begin (indent, br_ty); length = 0}) else - if !pp_curr_depth = !pp_max_boxes then enqueue_string !pp_ellipsis - -(* The box which is always opened *) -let pp_open_sys_box () = - incr pp_curr_depth; - scan_push false - {elem_size = (- !pp_right_total); - token = Pp_begin (0, Pp_hovbox); length = 0} - -(* close a block, setting sizes of its subblocks *) -let close_box () = - if !pp_curr_depth > 1 then - begin - if !pp_curr_depth < !pp_max_boxes then - begin - pp_enqueue {elem_size = 0; token = Pp_end; length = 0}; - set_size true; set_size false - end; - decr pp_curr_depth - end - -(* Initialize pretty-printer. *) -let pp_rinit () = - pp_clear_queue (); - clear_scan_stack(); - pp_current_indent := 0; - pp_curr_depth := 0; pp_space_left := !pp_margin; - pp_format_stack := []; - pp_tbox_stack := []; - pp_open_sys_box () - -(* Flushing pretty-printer queue. *) -let pp_flush b = - while !pp_curr_depth > 1 do - close_box () - done; - pp_right_total := pp_infinity; advance_left (); - if b then pp_output_newline (); - flush !pp_out_channel; - pp_rinit() - -(************************************************************** - - Procedures to format objects, and use boxes - - **************************************************************) - -(* To format a string *) -let print_as n s = - if !pp_curr_depth < !pp_max_boxes then (enqueue_string_as n s) - -let print_string s = print_as (String.length s) s - -(* To format an integer *) -let print_int i = print_string (string_of_int i) - -(* To format a float *) -let print_float f = print_string (string_of_float f) - -(* To format a boolean *) -let print_bool b = print_string (string_of_bool b) - -(* To format a char *) -let print_char c = print_string (String.make 1 c) - -let open_hbox () = pp_open_box (0, Pp_hbox) -and open_vbox indent = pp_open_box (indent, Pp_vbox) - -and open_hvbox indent = pp_open_box (indent, Pp_hvbox) -and open_hovbox indent = pp_open_box (indent, Pp_hovbox) - -(* Print a new line after printing all queued text - (same for print_flush but without a newline) *) -let print_newline () = pp_flush true -and print_flush () = pp_flush false - -(* To get a newline when one does not want to close the current block *) -let force_newline () = - if !pp_curr_depth < !pp_max_boxes - then enqueue_advance {elem_size = 0; token = Pp_newline; length = 0} - -(* To format something if the line has just been broken *) -let print_if_newline () = - if !pp_curr_depth < !pp_max_boxes - then enqueue_advance {elem_size = 0; token = Pp_if_newline ;length = 0} - -(* Breaks: indicate where a block may be broken. - If line is broken then offset is added to the indentation of the current - block else (the value of) width blanks are printed. - To do (?) : add a maximum width and offset value *) -let print_break (width, offset) = - if !pp_curr_depth < !pp_max_boxes then - scan_push true - {elem_size = (- !pp_right_total); token = Pp_break (width,offset); - length = width} - -let print_space () = print_break (1,0) -and print_cut () = print_break (0,0) - -let open_tbox () = - incr pp_curr_depth; - if !pp_curr_depth < !pp_max_boxes then - enqueue_advance - {elem_size = 0; - token = Pp_tbegin (Pp_tbox (ref [])); length = 0} - -(* Close a tabulation block *) -let close_tbox () = - if !pp_curr_depth > 1 then begin - if !pp_curr_depth < !pp_max_boxes then - enqueue_advance {elem_size = 0; token = Pp_tend; length = 0}; - decr pp_curr_depth end - -(* Print a tabulation break *) -let print_tbreak (width, offset) = - if !pp_curr_depth < !pp_max_boxes then - scan_push true - {elem_size = (- !pp_right_total); token = Pp_tbreak (width,offset); - length = width} - -let print_tab () = print_tbreak (0,0) - -let set_tab () = - if !pp_curr_depth < !pp_max_boxes - then enqueue_advance {elem_size = 0; token = Pp_stab; length=0} - -(************************************************************** - - Procedures to control the pretty-printer - - **************************************************************) - -(* Fit max_boxes *) -let set_max_boxes n = if n > 1 then pp_max_boxes := n - -(* To know the current maximum number of boxes allowed *) -let get_max_boxes () = !pp_max_boxes - -(* Ellipsis *) -let set_ellipsis_text s = pp_ellipsis := s -and get_ellipsis_text () = !pp_ellipsis - -(* To set the margin of pretty-formater *) -let set_margin n = - if n >= 1 then - begin - pp_margin := n; - pp_max_indent := !pp_margin - !pp_min_space_left; - pp_rinit () end - -let get_margin () = !pp_margin - -let set_min_space_left n = - if n >= 1 then - begin - pp_min_space_left := n; - pp_max_indent := !pp_margin - !pp_min_space_left; - pp_rinit () end - -let set_max_indent n = set_min_space_left (!pp_margin - n) -let get_max_indent () = !pp_max_indent - -let set_formatter_output os = pp_out_channel := os -let get_formatter_output () = !pp_out_channel - -(* Initializing formatter *) -let _ = pp_rinit() diff --git a/stdlib/format.mli b/stdlib/format.mli deleted file mode 100644 index 5d9a9ac3e2..0000000000 --- a/stdlib/format.mli +++ /dev/null @@ -1,151 +0,0 @@ -(* Pretty printing *) - -(* This module implements a pretty-printing facility to format text - within ``pretty-printing boxes''. The pretty-printer breaks lines - at specified break hints, and indents lines according to the box structure. -*) - -(* The behaviour of pretty-printing commands is unspecified - if there is no opened pretty-printing box. *) - -(*** Boxes *) -val open_vbox : int -> unit - (* [open_vbox d] opens a new pretty-printing box - with offset [d]. - This box is ``vertical'': every break hint inside this - box leads to a new line. - When a new line is printed in the box, [d] is added to the - current indentation. *) -val open_hbox : unit -> unit - (* [open_hbox ()] opens a new pretty-printing box. - This box is ``horizontal'': the line is not List.split in this box - (new lines may still occur inside boxes nested deeper). *) -val open_hvbox : int -> unit - (* [open_hovbox d] opens a new pretty-printing box - with offset [d]. - This box is ``horizontal-vertical'': it behaves as an - ``horizontal'' box if it fits on a single line, - otherwise it behaves as a ``vertical'' box. - When a new line is printed in the box, [d] is added to the - current indentation. *) -val open_hovbox : int -> unit - (* [open_hovbox d] opens a new pretty-printing box - with offset [d]. - This box is ``horizontal or vertical'': break hints - inside this box may lead to a new line, if there is no more room - on the line to print the remainder of the box. - When a new line is printed in the box, [d] is added to the - current indentation. *) -val close_box : unit -> unit - (* Close the most recently opened pretty-printing box. *) - -(*** Formatting functions *) -val print_string : string -> unit - (* [print_string str] prints [str] in the current box. *) -val print_as : int -> string -> unit - (* [print_as len str] prints [str] in the - current box. The pretty-printer formats [str] as if - it were of length [len]. *) -val print_int : int -> unit - (* Print an integer in the current box. *) -val print_float : float -> unit - (* Print a floating point number in the current box. *) -val print_char : char -> unit - (* Print a character in the current box. *) -val print_bool : bool -> unit - (* Print an boolean in the current box. *) - -(*** Break hints *) -val print_break : int * int -> unit - (* Insert a break hint in a pretty-printing box. - [print_break (nspaces, offset)] indicates that the line may - be List.split (a newline character is printed) at this point, - if the contents of the current box does not fit on one line. - If the line is List.split at that point, [offset] is added to - the current indentation. If the line is not List.split, - [nspaces] spaces are printed. *) -val print_cut : unit -> unit - (* [print_cut ()] is equivalent to [print_break (0,0)]. - This allows line splitting at the current point, without printing - spaces or adding indentation. *) -val print_space : unit -> unit - (* [print_space ()] is equivalent to [print_break (1,0)]. - This either prints one space or splits the line at that point. *) -val force_newline : unit -> unit - (* Force a newline in the current box. *) - -val print_flush : unit -> unit - (* Flush the pretty printer: all opened boxes are closed, - and all pending text is displayed. *) -val print_newline : unit -> unit - (* Equivalent to [print_flush] followed by a new line. *) - -val print_if_newline : unit -> unit - (* If the preceding line has not been List.split, the next - formatting command is ignored. *) - -(*** Tabulations *) -val open_tbox : unit -> unit - (* Open a tabulation box. *) -val close_tbox : unit -> unit - (* Close the most recently opened tabulation box. *) -val print_tbreak : int * int -> unit - (* Break hint in a tabulation box. - [print_tbreak (spaces, offset)] moves the insertion point to - the next tabulation ([spaces] being added to this position). - Nothing occurs if insertion point is already on a - tabulation mark. - If there is no next tabulation on the line, then a newline - is printed and the insertion point moves to the first - tabulation of the box. - If a new line is printed, [offset] is added to the current - indentation. *) -val set_tab : unit -> unit - (* Set a tabulation mark at the current insertion point. *) -val print_tab : unit -> unit - (* [print_tab ()] is equivalent to [print_tbreak (0,0)]. *) - -(*** Margin *) -val set_margin : int -> unit - (* [set_margin d] sets the val of the right margin - to [d] (in characters): this val is used to detect line - overflows that leads to List.split lines. - Nothing happens if [d] is not greater than 1. *) -val get_margin : unit -> int - (* Return the position of the right margin. *) - -(*** Maximum indentation limit *) -val set_max_indent : int -> unit - (* [set_max_indent d] sets the val of the maximum - indentation limit to [d] (in characters): - once this limit is reached, boxes are rejected to the left, - if they do not fit on the current line. - Nothing happens if [d] is not greater than 1. *) -val get_max_indent : unit -> int - (* Return the val of the maximum indentation limit (in - characters). *) - -(*** Formatting depth: maximum number of boxes allowed before ellipsis *) -val set_max_boxes : int -> unit - (* [set_max_boxes max] sets the maximum number - of boxes simultaneously opened. - Material inside boxes nested deeper is printed as an - ellipsis (more precisely as the text returned by - [get_ellipsis_text]). - Nothing happens if [max] is not greater than 1. *) -val get_max_boxes : unit -> int - (* Return the maximum number of boxes allowed before ellipsis. *) - -(*** Ellipsis *) -val set_ellipsis_text : string -> unit - (* Set the text of the ellipsis printed when too many boxes - are opened (a single dot, [.], by default). *) -val get_ellipsis_text : unit -> string - (* Return the text of the ellipsis. *) - -(*** Redirecting formatter output *) -val set_formatter_output : out_channel -> unit - (* Redirect the pretty-printer output to the given channel. *) -val get_formatter_output : unit -> out_channel - (* Return the channel connected to the pretty-printer. *) - diff --git a/stdlib/gc.ml b/stdlib/gc.ml deleted file mode 100644 index 78065fdd87..0000000000 --- a/stdlib/gc.ml +++ /dev/null @@ -1,47 +0,0 @@ -type stat = { - minor_words : int; - promoted_words : int; - major_words : int; - minor_collections : int; - major_collections : int; - heap_size : int; - heap_chunks : int; - live_words : int; - live_blocks : int; - free_words : int; - free_blocks : int; - largest_free : int; - fragments : int -} - -type control = { - mutable minor_heap_size : int; - mutable major_heap_increment : int; - mutable space_overhead : int; - mutable verbose : bool -} - -external stat : unit -> stat = "gc_stat" -external get : unit -> control = "gc_get" -external set : control -> unit = "gc_set" -external minor : unit -> unit = "gc_minor" -external major : unit -> unit = "gc_major" -external full_major : unit -> unit = "gc_full_major" - -open Printf - -let print_stat c = - let st = stat () in - fprintf c "minor_words: %d\n" st.minor_words; - fprintf c "promoted_words: %d\n" st.promoted_words; - fprintf c "major_words: %d\n" st.major_words; - fprintf c "minor_collections: %d\n" st.minor_collections; - fprintf c "major_collections: %d\n" st.major_collections; - fprintf c "heap_size: %d\n" st.heap_size; - fprintf c "heap_chunks: %d\n" st.heap_chunks; - fprintf c "live_words: %d\n" st.live_words; - fprintf c "live_blocks: %d\n" st.live_blocks; - fprintf c "free_words: %d\n" st.free_words; - fprintf c "free_blocks: %d\n" st.free_blocks; - fprintf c "largest_free: %d\n" st.largest_free; - fprintf c "fragments: %d\n" st.fragments diff --git a/stdlib/gc.mli b/stdlib/gc.mli deleted file mode 100644 index 80ab5e4e94..0000000000 --- a/stdlib/gc.mli +++ /dev/null @@ -1,93 +0,0 @@ -(* Memory management control and statistics. *) - -type stat = { - minor_words : int; - promoted_words : int; - major_words : int; - minor_collections : int; - major_collections : int; - heap_size : int; - heap_chunks : int; - live_words : int; - live_blocks : int; - free_words : int; - free_blocks : int; - largest_free : int; - fragments : int -} - (* The memory management counters are returned in a [stat] record. - All the numbers are computed since the start of the program. - The fields of this record are: -- [minor_words] Number of words allocated in the minor heap. -- [promoted_words] Number of words allocated in the minor heap that - survived a minor collection and were moved to the major heap. -- [major_words] Number of words allocated in the major heap, including - the promoted words. -- [minor_collections] Number of minor collections. -- [major_collections] Number of major collection cycles, not counting - the current cycle. -- [heap_size] Total number of words in the major heap. -- [heap_chunks] Number of times the major heap size was increased. -- [live_words] Number of words of live data in the major heap, including - the header words. -- [live_blocks] Number of live objects in the major heap. -- [free_words] Number of words in the free list. -- [free_blocks] Number of objects in the free list. -- [largest_free] Size (in words) of the largest object in the free list. -- [fragments] Number of wasted words due to fragmentation. These are - 1-words free blocks placed between two live objects. They - cannot be inserted in the free list, thus they are not available - for allocation. - -- The total amount of memory allocated by the program is (in words) - [minor_words + major_words - promoted_words]. Multiply by - the word size (4 on a 32-bit machine, 8 on a 64-bit machine) to get - the number of bytes. - *) - -type control = { - mutable minor_heap_size : int; - mutable major_heap_increment : int; - mutable space_overhead : int; - mutable verbose : bool -} - - (* The GC parameters are given as a [control] record. The fields are: -- [minor_heap_size] The size (in words) of the minor heap. Changing - this parameter will trigger a minor collection. -- [major_heap_increment] The minimum number of words to add to the - major heap when increasing it. -- [space_overhead] The major GC speed is computed from this parameter. - This is the percentage of heap space that will be "wasted" - because the GC does not immediatly collect unreachable - objects. The GC will work more (use more CPU time and collect - objects more eagerly) if [space_overhead] is smaller. - The computation of the GC speed assumes that the amount - of live data is constant. -- [verbose] This flag controls the GC messages on standard error output. - *) - -external stat : unit -> stat = "gc_stat" - (* Return the current values of the memory management counters in a - [stat] record. *) -val print_stat : out_channel -> unit - (* Print the current values of the memory management counters (in - human-readable form) into the channel argument. *) -external get : unit -> control = "gc_get" - (* Return the current values of the GC parameters in a [control] record. *) -external set : control -> unit = "gc_set" - (* [set r] changes the GC parameters according to the [control] record [r]. - The normal usage is: - [ - let r = Gc.get () in (* Get the current parameters. *) - r.verbose <- true; (* Change some of them. *) - Gc.set r (* Set the new values. *) - ] - *) -external minor : unit -> unit = "gc_minor" - (* Trigger a minor collection. *) -external major : unit -> unit = "gc_major" - (* Finish the current major collection cycle. *) -external full_major : unit -> unit = "gc_full_major" - (* Finish the current major collection cycle and perform a complete - new cycle. This will collect all currently unreachable objects. *) diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml deleted file mode 100644 index f7cbda3ff2..0000000000 --- a/stdlib/hashtbl.ml +++ /dev/null @@ -1,95 +0,0 @@ -(* 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. *) - -type ('a, 'b) t = - { mutable max_len: int; (* max length of a bucket *) - mutable data: ('a, 'b) bucketlist array } (* the buckets *) - -and ('a, 'b) bucketlist = - Empty - | Cons of 'a * 'b * ('a, 'b) bucketlist - -let new initial_size = - { max_len = 2; data = Array.new 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.new (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 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" - -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 - -let remove h key = - let rec remove_bucket = function - Empty -> - Empty - | 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) - -let find h key = - match h.data.((hash_param 10 100 key) mod (Array.length h.data)) with - Empty -> raise Not_found - | Cons(k1, d1, rest1) -> - if key = k1 then d1 else - match rest1 with - Empty -> raise Not_found - | Cons(k2, d2, rest2) -> - if key = k2 then d2 else - match rest2 with - Empty -> raise Not_found - | Cons(k3, d3, rest3) -> - if key = k3 then d3 else begin - let rec find = function - Empty -> - raise Not_found - | Cons(k, d, rest) -> - if 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 k = key then d :: find_in_bucket rest else find_in_bucket rest in - find_in_bucket h.data.((hash_param 10 100 key) mod (Array.length h.data)) - -let iter f h = - let len = Array.length h.data in - for i = 0 to Array.length h.data - 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 - do_bucket h.data.(i) - done - -let hash x = hash_param 50 500 x diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli deleted file mode 100644 index 5054970f8c..0000000000 --- a/stdlib/hashtbl.mli +++ /dev/null @@ -1,67 +0,0 @@ -(* Hash tables and hash functions *) - -(* Hash tables are hashed association tables, with in-place modification. *) - -type ('a, 'b) t - (* The type of hash tables from type ['a] to type ['b]. *) - -val new : int -> ('a,'b) t - (* [new n] creates a new, empty hash table, with initial size [n]. - The table grows as needed, so [n] is just an initial guess. - Better results are said to be achieved when [n] is a prime - number. *) - -val clear : ('a, 'b) t -> unit - (* Empty a hash table. *) - -val add : ('a, 'b) t -> 'a -> 'b -> unit - (* [add tbl x y] adds a binding of [x] to [y] in table [tbl]. - Previous bindings for [x] are not removed, but simply - hidden. That is, after performing [remove tbl x], the previous - binding for [x], if any, is restored. - (This is the semantics of association lists.) *) - -val find : ('a, 'b) t -> 'a -> 'b - (* [find tbl x] returns the current binding of [x] in [tbl], - or raises [Not_found] if no such binding exists. *) - -val find_all : ('a, 'b) t -> 'a -> 'b list - (* [find_all tbl x] returns the list of all data associated with [x] - in [tbl]. The current binding is returned first, then the previous - bindings, in reverse order of introduction in the table. *) - -val remove : ('a, 'b) t -> 'a -> unit - (* [remove tbl x] removes the current binding of [x] in [tbl], - restoring the previous binding if it exists. - It does nothing if [x] is not bound in [tbl]. *) - -val iter : ('a -> 'b -> 'c) -> ('a, 'b) t -> unit - (* [iter f tbl] applies [f] to all bindings in table [tbl], - discarding all the results. - [f] receives the key as first argument, and the associated val - as second argument. The order in which the bindings are passed to - [f] is unpredictable. Each binding is presented exactly once - to [f]. *) - -(*** The polymorphic hash primitive *) - -val hash : 'a -> int - (* [hash x] associates a positive integer to any val of - any type. It is guaranteed that - if [x = y], then [hash x = hash y]. - Moreover, [hash] always terminates, even on cyclic - structures. *) - -external hash_param : int -> int -> 'a -> int = "hash_univ_param" - (* [hash_param n m x] computes a hash val for [x], with the - same properties as for [hash]. The two extra parameters [n] and - [m] give more precise control over hashing. Hashing performs a - depth-first, right-to-left traversal of the structure [x], stopping - after [n] meaningful nodes were encountered, or [m] nodes, - meaningful or not, were encountered. Meaningful nodes are: integers; - floating-point numbers; strings; characters; booleans; and constant - constructors. Larger vals of [m] and [n] means that more - nodes are taken into account to compute the final hash - val, and therefore collisions are less likely to happen. - However, hashing takes longer. The parameters [m] and [n] - govern the tradeoff between accuracy and speed. *) diff --git a/stdlib/header.c b/stdlib/header.c deleted file mode 100644 index aba20e62a1..0000000000 --- a/stdlib/header.c +++ /dev/null @@ -1,11 +0,0 @@ -char * runtime_name = "cslrun"; -char * errmsg = "Cannot exec cslrun.\n"; - -int main(argc, argv) - int argc; - char ** argv; -{ - execvp(runtime_name, argv); - write(2, errmsg, sizeof(errmsg)-1); - return 2; -} diff --git a/stdlib/lexing.ml b/stdlib/lexing.ml deleted file mode 100644 index 07bb7b5df5..0000000000 --- a/stdlib/lexing.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* The run-time library for lexers generated by camllex *) - -type lexbuf = - { refill_buff : lexbuf -> unit; - lex_buffer : string; - mutable lex_abs_pos : int; - mutable lex_start_pos : int; - mutable lex_curr_pos : int; - mutable lex_last_pos : int; - mutable lex_last_action : lexbuf -> Obj.t } - -let lex_aux_buffer = String.create 1024 - -let lex_refill read_fun lexbuf = - let read = - read_fun lex_aux_buffer 1024 in - let n = - if read > 0 - then read - else (String.unsafe_set lex_aux_buffer 0 '\000'; 1) in - String.unsafe_blit lexbuf.lex_buffer n lexbuf.lex_buffer 0 (2048 - n); - String.unsafe_blit lex_aux_buffer 0 lexbuf.lex_buffer (2048 - n) n; - lexbuf.lex_abs_pos <- lexbuf.lex_abs_pos + n; - lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - n; - lexbuf.lex_start_pos <- lexbuf.lex_start_pos - n; - lexbuf.lex_last_pos <- lexbuf.lex_last_pos - n; - if lexbuf.lex_start_pos < 0 then failwith "lexing: token too long" - -let dummy_action x = failwith "lexing: empty token" - -let from_function f = - { refill_buff = lex_refill f; - lex_buffer = String.create 2048; - lex_abs_pos = - 2048; - lex_start_pos = 2048; - lex_curr_pos = 2048; - lex_last_pos = 2048; - lex_last_action = dummy_action } - -let from_channel ic = - from_function (fun buf n -> input ic buf 0 n) - -let from_string s = - { refill_buff = - (fun lexbuf -> lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - 1); - lex_buffer = s ^ "\000"; - lex_abs_pos = 0; - lex_start_pos = 0; - lex_curr_pos = 0; - lex_last_pos = 0; - lex_last_action = dummy_action } - -external get_next_char : lexbuf -> char = "get_next_char" - -let lexeme lexbuf = - let len = lexbuf.lex_curr_pos - lexbuf.lex_start_pos in - let s = String.create len in - String.unsafe_blit lexbuf.lex_buffer lexbuf.lex_start_pos s 0 len; s - -let lexeme_char lexbuf i = - String.get lexbuf.lex_buffer (lexbuf.lex_start_pos + i) - -let start_lexing lexbuf = - lexbuf.lex_start_pos <- lexbuf.lex_curr_pos; - lexbuf.lex_last_action <- dummy_action - -let backtrack lexbuf = - lexbuf.lex_curr_pos <- lexbuf.lex_last_pos; - Obj.magic(lexbuf.lex_last_action lexbuf) - -let lexeme_start lexbuf = - lexbuf.lex_abs_pos + lexbuf.lex_start_pos -and lexeme_end lexbuf = - lexbuf.lex_abs_pos + lexbuf.lex_curr_pos - diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli deleted file mode 100644 index 1585da1f19..0000000000 --- a/stdlib/lexing.mli +++ /dev/null @@ -1,68 +0,0 @@ -(* The run-time library for lexers generated by camllex *) - -(*** Lexer buffers *) - -type lexbuf = - { refill_buff : lexbuf -> unit; - lex_buffer : string; - mutable lex_abs_pos : int; - mutable lex_start_pos : int; - mutable lex_curr_pos : int; - mutable lex_last_pos : int; - mutable lex_last_action : lexbuf -> Obj.t } - (* The type of lexer buffers. A lexer buffer is the argument passed - to the scanning functions defined by the generated scanners. - The lexer buffer holds the current state of the scanner, plus - a function to refill the buffer from the input. *) - -val from_channel : in_channel -> lexbuf - (* Create a lexer buffer on the given input channel. - [create_lexer_channel inchan] returns a lexer buffer which reads - from the input channel [inchan], at the current reading position. *) -val from_string : string -> lexbuf - (* Create a lexer buffer which reads from - the given string. Reading starts from the first character in - the string. An end-of-input condition is generated when the - end of the string is reached. *) -val from_function : (string -> int -> int) -> lexbuf - (* Create a lexer buffer with the given function as its reading method. - When the scanner needs more characters, it will call the given - function, giving it a character string [s] and a character - count [n]. The function should put [n] characters or less in [s], - starting at character number 0, and return the number of characters - provided. A return value of 0 means end of input. *) - -(*** Functions for lexer semantic actions *) - - (* The following functions can be called from the semantic actions - of lexer definitions (the ML code enclosed in braces that - computes the value returned by lexing functions). They give - access to the character string matched by the regular expression - associated with the semantic action. These functions must be - applied to the argument [lexbuf], which, in the code generated by - camllex, is bound to the lexer buffer passed to the parsing - function. *) - -val lexeme : lexbuf -> string - (* [get_lexeme lexbuf] returns the string matched by - the regular expression. *) -val lexeme_char : lexbuf -> int -> char - (* [get_lexeme_char lexbuf i] returns character number [i] in - the matched string. *) -val lexeme_start : lexbuf -> int - (* [get_lexeme_start lexbuf] returns the position in the input stream - of the first character of the matched string. The first character - of the stream has position 0. *) -val lexeme_end : lexbuf -> int - (* [get_lexeme_end lexbuf] returns the position in the input stream - of the character following the last character of the matched - string. The first character of the stream has position 0. *) - -(*--*) - -(* The following definitions are used by the generated scanners only. - They are not intended to be used by user programs. *) - -val start_lexing : lexbuf -> unit -external get_next_char : lexbuf -> char = "get_next_char" -val backtrack : lexbuf -> 'a diff --git a/stdlib/list.ml b/stdlib/list.ml deleted file mode 100644 index 3b6cdb4402..0000000000 --- a/stdlib/list.ml +++ /dev/null @@ -1,104 +0,0 @@ -(* List operations *) - -let rec length = function - [] -> 0 - | a::l -> 1 + length l - -let hd = function - [] -> failwith "hd" - | a::l -> a - -let tl = function - [] -> failwith "tl" - | a::l -> l - -let rec rev_append accu = function - [] -> accu - | a::l -> rev_append (a :: accu) l - -let rev l = rev_append [] l - -let rec flatten = function - [] -> [] - | l::r -> l @ flatten r - -let rec map f = function - [] -> [] - | a::l -> let r = f a in r :: map f l - -(* let rec map f = function - [] -> [] - | a::l -> f a :: map f l *) - -let rec iter f = function - [] -> () - | a::l -> f a; iter f l - - -let rec fold_left f accu l = - match l with - [] -> accu - | a::l -> fold_left f (f accu a) l - -let rec fold_right f l accu = - match l with - [] -> accu - | a::l -> f a (fold_right f l accu) - -let rec map2 f l1 l2 = - match (l1, l2) with - ([], []) -> [] - | (a1::l1, a2::l2) -> f a1 a2 :: map2 f l1 l2 - | (_, _) -> invalid_arg "List.map2" - -let rec iter2 f l1 l2 = - match (l1, l2) with - ([], []) -> () - | (a1::l1, a2::l2) -> f a1 a2; iter2 f l1 l2 - | (_, _) -> invalid_arg "List.iter2" - -let rec fold_left2 f accu l1 l2 = - match (l1, l2) with - ([], []) -> accu - | (a1::l1, a2::l2) -> fold_left2 f (f accu a1 a2) l1 l2 - | (_, _) -> invalid_arg "List.fold_left2" - -let rec fold_right2 f l1 l2 accu = - match (l1, l2) with - ([], []) -> accu - | (a1::l1, a2::l2) -> f a1 a2 (fold_right2 f l1 l2 accu) - | (_, _) -> invalid_arg "List.fold_right2" - -let rec for_all p = function - [] -> true - | a::l -> p a & for_all p l - -let rec exists p = function - [] -> false - | a::l -> p a or exists p l - -let rec mem x = function - [] -> false - | a::l -> a = x or mem x l - -let rec assoc x = function - [] -> raise Not_found - | (a,b)::l -> if a = x then b else assoc x l - -let rec mem_assoc x = function - [] -> false - | (a,b)::l -> a = x or mem_assoc x l - -let rec assq x = function - [] -> raise Not_found - | (a,b)::l -> if a == x then b else assq x l - -let rec split = function - [] -> ([], []) - | (x,y)::l -> - let (rx, ry) = split l in (x::rx, y::ry) - -let rec combine = function - ([], []) -> [] - | (a1::l1, a2::l2) -> (a1, a2) :: combine(l1, l2) - | (_, _) -> invalid_arg "List.combine" diff --git a/stdlib/list.mli b/stdlib/list.mli deleted file mode 100644 index 00d0cc469f..0000000000 --- a/stdlib/list.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* List operations *) - -val length : 'a list -> int -val hd : 'a list -> 'a -val tl : 'a list -> 'a list -val rev : 'a list -> 'a list -val flatten : 'a list list -> 'a list -val iter : ('a -> 'b) -> 'a list -> unit -val map : ('a -> 'b) -> 'a list -> 'b list -val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a -val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b -val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list -val iter2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> unit -val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a -val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c -val for_all : ('a -> bool) -> 'a list -> bool -val exists : ('a -> bool) -> 'a list -> bool -val mem : 'a -> 'a list -> bool -val assoc : 'a -> ('a * 'b) list -> 'b -val mem_assoc : 'a -> ('a * 'b) list -> bool -val assq : 'a -> ('a * 'b) list -> 'b -val split : ('a * 'b) list -> 'a list * 'b list -val combine : 'a list * 'b list -> ('a * 'b) list - diff --git a/stdlib/map.ml b/stdlib/map.ml deleted file mode 100644 index 40ebdfaef5..0000000000 --- a/stdlib/map.ml +++ /dev/null @@ -1,97 +0,0 @@ -module type OrderedType = - sig - type t - val compare: t -> t -> int - end - -module type S = - sig - type key - type 'a t - val empty: 'a t - val add: key -> 'a -> 'a t -> 'a t - val find: key -> 'a t -> 'a - val iter: (key -> 'a -> 'b) -> 'a t -> unit - val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - end - -module Make(Ord: OrderedType) = struct - - type key = Ord.t - - type 'a t = - Empty - | Node of 'a t * key * 'a * 'a t * int - - let empty = Empty - - let height = function - Empty -> 0 - | Node(_,_,_,_,h) -> h - - let new l x d r = - let hl = height l and hr = height r in - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - let bal l x d r = - let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in - if hl > hr + 2 then begin - match l with - Empty -> invalid_arg "Set.bal" - | Node(ll, lv, ld, lr, _) -> - if height ll >= height lr then - new ll lv ld (new lr x d r) - else begin - match lr with - Empty -> invalid_arg "Set.bal" - | Node(lrl, lrv, lrd, lrr, _)-> - new (new ll lv ld lrl) lrv lrd (new lrr x d r) - end - end else if hr > hl + 2 then begin - match r with - Empty -> invalid_arg "Set.bal" - | Node(rl, rv, rd, rr, _) -> - if height rr >= height rl then - new (new l x d rl) rv rd rr - else begin - match rl with - Empty -> invalid_arg "Set.bal" - | Node(rll, rlv, rld, rlr, _) -> - new (new l x d rll) rlv rld (new rlr rv rd rr) - end - end else - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - let rec add x data = function - Empty -> - Node(Empty, x, data, Empty, 1) - | Node(l, v, d, r, h) as t -> - let c = Ord.compare x v in - if c = 0 then - Node(l, x, data, r, h) - else if c < 0 then - bal (add x data l) v d r - else - bal l v d (add x data r) - - let rec find x = function - Empty -> - raise Not_found - | Node(l, v, d, r, _) -> - let c = Ord.compare x v in - if c = 0 then d - else find x (if c < 0 then l else r) - - let rec iter f = function - Empty -> () - | Node(l, v, d, r, _) -> - iter f l; f v d; iter f r - - let rec fold f m accu = - match m with - Empty -> accu - | Node(l, v, d, r, _) -> - fold f l (f v d (fold f r accu)) - -end diff --git a/stdlib/map.mli b/stdlib/map.mli deleted file mode 100644 index 38e2e85e7b..0000000000 --- a/stdlib/map.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* Maps over ordered types *) - -module type OrderedType = - sig - type t - val compare: t -> t -> int - end - -module type S = - sig - type key - type 'a t - val empty: 'a t - val add: key -> 'a -> 'a t -> 'a t - val find: key -> 'a t -> 'a - val iter: (key -> 'a -> 'b) -> 'a t -> unit - val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - end - -module Make(Ord: OrderedType): (S with key = Ord.t) diff --git a/stdlib/obj.ml b/stdlib/obj.ml deleted file mode 100644 index c31e6c3ab0..0000000000 --- a/stdlib/obj.ml +++ /dev/null @@ -1,13 +0,0 @@ -(* Operations on internal representations of values *) - -type t - -external repr : 'a -> t = "%identity" -external magic : 'a -> 'b = "%identity" -external is_block : t -> bool = "obj_is_block" -external tag : t -> int = "%tagof" -external size : t -> int = "%array_length" -external field : t -> int -> t = "%array_unsafe_get" -external set_field : t -> int -> t -> unit = "%array_unsafe_set" -external new_block : int -> int -> t = "obj_block" -external update : t -> t -> unit = "%update" diff --git a/stdlib/obj.mli b/stdlib/obj.mli deleted file mode 100644 index c31e6c3ab0..0000000000 --- a/stdlib/obj.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* Operations on internal representations of values *) - -type t - -external repr : 'a -> t = "%identity" -external magic : 'a -> 'b = "%identity" -external is_block : t -> bool = "obj_is_block" -external tag : t -> int = "%tagof" -external size : t -> int = "%array_length" -external field : t -> int -> t = "%array_unsafe_get" -external set_field : t -> int -> t -> unit = "%array_unsafe_set" -external new_block : int -> int -> t = "obj_block" -external update : t -> t -> unit = "%update" diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml deleted file mode 100644 index 0ddf431e79..0000000000 --- a/stdlib/parsing.ml +++ /dev/null @@ -1,148 +0,0 @@ -(* The parsing engine *) - -type parse_tables = - { actions : (unit -> Obj.t) array; - transl : int array; - lhs : string; - len : string; - defred : string; - dgoto : string; - sindex : string; - rindex : string; - gindex : string; - tablesize : int; - table : string; - check : string } - -exception YYexit of Obj.t -exception Parse_error - -open Lexing - -(* Internal interface to the parsing engine *) - -type parser_env = - { mutable s_stack : int array; (* States *) - mutable v_stack : Obj.t array; (* Semantic attributes *) - mutable symb_start_stack : int array; (* Start positions *) - mutable symb_end_stack : int array; (* End positions *) - mutable stacksize : int; (* Size of the stacks *) - mutable curr_char : int; (* Last token read *) - mutable lval : Obj.t; (* Its semantic attribute *) - mutable symb_start : int; (* Start pos. of the current symbol*) - mutable symb_end : int; (* End pos. of the current symbol *) - mutable asp : int; (* The stack pointer for attributes *) - mutable rule_len : int; (* Number of rhs items in the rule *) - mutable rule_number : int; (* Rule number to reduce by *) - mutable sp : int; (* Saved sp for parse_engine *) - mutable state : int } (* Saved state for parse_engine *) - -type parser_input = - Start - | Token_read - | Stacks_grown_1 - | Stacks_grown_2 - | Semantic_action_computed - -type parser_output = - Read_token - | Raise_parse_error - | Grow_stacks_1 - | Grow_stacks_2 - | Compute_semantic_action - -external parse_engine : - parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output - = "parse_engine" - -let env = - { s_stack = Array.new 100 0; - v_stack = Array.new 100 (Obj.repr ()); - symb_start_stack = Array.new 100 0; - symb_end_stack = Array.new 100 0; - stacksize = 100; - curr_char = 0; - lval = Obj.repr (); - symb_start = 0; - symb_end = 0; - asp = 0; - rule_len = 0; - rule_number = 0; - sp = 0; - state = 0 } - -let grow_stacks() = - let oldsize = env.stacksize in - let newsize = oldsize * 2 in - let new_s = Array.new newsize 0 - and new_v = Array.new newsize (Obj.repr ()) - and new_start = Array.new newsize 0 - and new_end = Array.new newsize 0 in - Array.blit env.s_stack 0 new_s 0 oldsize; - env.s_stack <- new_s; - Array.blit env.v_stack 0 new_v 0 oldsize; - env.v_stack <- new_v; - Array.blit env.symb_start_stack 0 new_start 0 oldsize; - env.symb_start_stack <- new_start; - Array.blit env.symb_end_stack 0 new_end 0 oldsize; - env.symb_end_stack <- new_end; - env.stacksize <- newsize - -let clear_parser() = - Array.fill env.v_stack 0 env.stacksize (Obj.repr ()); - env.lval <- Obj.repr () - -let current_lookahead_fun = ref (fun (x: Obj.t) -> false) - -let yyparse tables start lexer lexbuf = - let rec loop cmd arg = - match parse_engine tables env cmd arg with - Read_token -> - let t = Obj.repr(lexer lexbuf) in - env.symb_start <- lexbuf.lex_abs_pos + lexbuf.lex_start_pos; - env.symb_end <- lexbuf.lex_abs_pos + lexbuf.lex_curr_pos; - loop Token_read t - | Raise_parse_error -> - raise Parse_error - | Compute_semantic_action -> - loop Semantic_action_computed (tables.actions.(env.rule_number) ()) - | Grow_stacks_1 -> - grow_stacks(); loop Stacks_grown_1 (Obj.repr ()) - | Grow_stacks_2 -> - grow_stacks(); loop Stacks_grown_2 (Obj.repr ()) in - let init_asp = env.asp - and init_sp = env.sp - and init_state = env.state - and init_curr_char = env.curr_char in - env.curr_char <- start; - try - loop Start (Obj.repr ()) - with exn -> - let curr_char = env.curr_char in - env.asp <- init_asp; - env.sp <- init_sp; - env.state <- init_state; - env.curr_char <- init_curr_char; - match exn with - YYexit v -> - Obj.magic v - | _ -> - current_lookahead_fun := - (fun tok -> tables.transl.(Obj.tag tok) = curr_char); - raise exn - -let peek_val n = - Obj.magic env.v_stack.(env.asp - n) - -let symbol_start () = - env.symb_start_stack.(env.asp - env.rule_len + 1) -let symbol_end () = - env.symb_end_stack.(env.asp) - -let rhs_start n = - env.symb_start_stack.(env.asp - (env.rule_len - n)) -let rhs_end n = - env.symb_end_stack.(env.asp - (env.rule_len - n)) - -let is_current_lookahead tok = - (!current_lookahead_fun)(Obj.repr tok) diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli deleted file mode 100644 index 9f5fbaffb3..0000000000 --- a/stdlib/parsing.mli +++ /dev/null @@ -1,51 +0,0 @@ -(* The run-time library for parsers generated by camlyacc *) - -val symbol_start : unit -> int -val symbol_end : unit -> int - (* [symbol_start] and [symbol_end] are to be called in the action part - of a grammar rule only. They return the position of the string that - matches the left-hand side of the rule: [symbol_start()] returns - the position of the first character; [symbol_end()] returns the - position of the last character, plus one. The first character - in a file is at position 0. *) -val rhs_start: int -> int -val rhs_end: int -> int - (* Same as [symbol_start] and [symbol_end] above, but return then - position of the string matching the [n]th item on the - right-hand side of the rule, where [n] is the integer parameter - to [lhs_start] and [lhs_end]. [n] is 1 for the leftmost item. *) -val clear_parser : unit -> unit - (* Empty the parser stack. Call it just after a parsing function - has returned, to remove all pointers from the parser stack - to structures that were built by semantic actions during parsing. - This is optional, but lowers the memory requirements of the - programs. *) - -exception Parse_error - (* Raised when a parser encounters a syntax error. *) - -(*--*) - -(* The following definitions are used by the generated parsers only. - They are not intended to be used by user programs. *) - -type parse_tables = - { actions : (unit -> Obj.t) array; - transl : int array; - lhs : string; - len : string; - defred : string; - dgoto : string; - sindex : string; - rindex : string; - gindex : string; - tablesize : int; - table : string; - check : string } - -exception YYexit of Obj.t - -val yyparse : - parse_tables -> int -> (Lexing.lexbuf -> 'a) -> Lexing.lexbuf -> 'b -val peek_val : int -> 'a -val is_current_lookahead: 'a -> bool diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml deleted file mode 100644 index e406db952b..0000000000 --- a/stdlib/pervasives.ml +++ /dev/null @@ -1,278 +0,0 @@ -(* Exceptions *) - -external raise : exn -> 'a = "%raise" - -let failwith s = raise(Failure s) -let invalid_arg s = raise(Invalid_argument s) - -exception Exit - -(* Comparisons *) - -external (=) : 'a -> 'a -> bool = "%equal" -external (<>) : 'a -> 'a -> bool = "%notequal" -external (<) : 'a -> 'a -> bool = "%lessthan" -external (>) : 'a -> 'a -> bool = "%greaterthan" -external (<=) : 'a -> 'a -> bool = "%lessequal" -external (>=) : 'a -> 'a -> bool = "%greaterequal" -external compare: 'a -> 'a -> int = "compare" - -let min x y = if x <= y then x else y -let max x y = if x >= y then x else y - -external (==) : 'a -> 'a -> bool = "%eq" -external (!=) : 'a -> 'a -> bool = "%noteq" - -(* Boolean operations *) - -external not : bool -> bool = "%boolnot" -external (&) : bool -> bool -> bool = "%sequand" -external (or) : bool -> bool -> bool = "%sequor" - -(* Integer operations *) - -external (~-) : int -> int = "%negint" -external succ : int -> int = "%succint" -external pred : int -> int = "%predint" -external (+) : int -> int -> int = "%addint" -external (-) : int -> int -> int = "%subint" -external ( * ) : int -> int -> int = "%mulint" -external (/) : int -> int -> int = "%divint" -external (mod) : int -> int -> int = "%modint" - -let abs x = if x >= 0 then x else -x - -external (land) : int -> int -> int = "%andint" -external (lor) : int -> int -> int = "%orint" -external (lxor) : int -> int -> int = "%xorint" - -let lnot x = x lxor (-1) - -external (lsl) : int -> int -> int = "%lslint" -external (lsr) : int -> int -> int = "%lsrint" -external (asr) : int -> int -> int = "%asrint" - -(* Floating-point operations *) - -external (~-.) : float -> float = "neg_float" -external (+.) : float -> float -> float = "add_float" -external (-.) : float -> float -> float = "sub_float" -external ( *. ) : float -> float -> float = "mul_float" -external (/.) : float -> float -> float = "div_float" -external ( ** ) : float -> float -> float = "power_float" -external exp : float -> float = "exp_float" -external log : float -> float = "log_float" -external sqrt : float -> float = "sqrt_float" -external sin : float -> float = "sin_float" -external cos : float -> float = "cos_float" -external tan : float -> float = "tan_float" -external asin : float -> float = "asin_float" -external acos : float -> float = "acos_float" -external atan : float -> float = "atan_float" -external atan2 : float -> float -> float = "atan2_float" - -let abs_float f = if f >= 0.0 then f else -. f - -external float : int -> float = "float_of_int" -external truncate : float -> int = "int_of_float" - -(* String operations -- more in module String *) - -external string_length : string -> int = "ml_string_length" -external string_create: int -> string = "create_string" -external string_blit : string -> int -> string -> int -> int -> unit - = "blit_string" - -let (^) s1 s2 = - let l1 = string_length s1 and l2 = string_length s2 in - let s = string_create (l1 + l2) in - string_blit s1 0 s 0 l1; - string_blit s2 0 s l1 l2; - s - -(* Pair operations *) - -external fst : 'a * 'b -> 'a = "%field0" -external snd : 'a * 'b -> 'b = "%field1" - -(* String conversion functions *) - -external format_int: string -> int -> string = "format_int" -external format_float: string -> float -> string = "format_float" - -let string_of_bool b = - if b then "true" else "false" - -let string_of_int n = - format_int "%d" n - -external int_of_string : string -> int = "int_of_string" - -let string_of_float f = - format_float "%.12g" f - -external float_of_string : string -> float = "float_of_string" - -(* List operations -- more in module List *) - -let rec (@) l1 l2 = - match l1 with - [] -> l2 - | hd :: tl -> hd :: (tl @ l2) - -(* I/O operations *) - -type in_channel -type out_channel - -external open_descriptor_out: int -> out_channel = "open_descriptor" -external open_descriptor_in: int -> in_channel = "open_descriptor" - -let stdin = open_descriptor_in 0 -let stdout = open_descriptor_out 1 -let stderr = open_descriptor_out 2 - -(* General output functions *) - -type open_flag = - Open_rdonly | Open_wronly | Open_rdwr - | Open_append | Open_creat | Open_trunc | Open_excl - | Open_binary | Open_text - -external open_desc: string -> open_flag list -> int -> int = "sys_open" - -let open_out_gen mode perm name = - open_descriptor_out(open_desc name mode perm) - -let open_out name = - open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name - -let open_out_bin name = - open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name - -external flush : out_channel -> unit = "flush" - -external unsafe_output : out_channel -> string -> int -> int -> unit = "output" - -external output_char : out_channel -> char -> unit = "output_char" - -let output_string oc s = - unsafe_output oc s 0 (string_length s) - -let output oc s ofs len = - if ofs < 0 or ofs + len > string_length s - then invalid_arg "output" - else unsafe_output oc s ofs len - -external output_byte : out_channel -> int -> unit = "output_char" -external output_binary_int : out_channel -> int -> unit = "output_int" -external output_value : out_channel -> 'a -> unit = "output_value" -external output_compact_value : out_channel -> 'a -> unit = "output_value" -external seek_out : out_channel -> int -> unit = "seek_out" -external pos_out : out_channel -> int = "pos_out" -external size_out : out_channel -> int = "channel_size" -external close_out : out_channel -> unit = "close_out" - -(* General input functions *) - -let open_in_gen mode perm name = - open_descriptor_in(open_desc name mode perm) - -let open_in name = - open_in_gen [Open_rdonly; Open_text] 0 name - -let open_in_bin name = - open_in_gen [Open_rdonly; Open_binary] 0 name - -external input_char : in_channel -> char = "input_char" - -external unsafe_input : in_channel -> string -> int -> int -> int = "input" - -let input ic s ofs len = - if ofs < 0 or ofs + len > string_length s - then invalid_arg "input" - else unsafe_input ic s ofs len - -let rec unsafe_really_input ic s ofs len = - if len <= 0 then () else begin - let r = unsafe_input ic s ofs len in - if r = 0 - then raise End_of_file - else unsafe_really_input ic s (ofs+r) (len-r) - end - -let really_input ic s ofs len = - if ofs < 0 or ofs + len > string_length s - then invalid_arg "really_input" - else unsafe_really_input ic s ofs len - -external input_scan_line : in_channel -> int = "input_scan_line" - -let rec input_line chan = - let n = input_scan_line chan in - if n = 0 then (* n = 0: we are at EOF *) - raise End_of_file - else if n > 0 then begin (* n > 0: newline found in buffer *) - let res = string_create (n-1) in - unsafe_input chan res 0 (n-1); - input_char chan; (* skip the newline *) - res - end else begin (* n < 0: newline not found *) - let beg = string_create (-n) in - unsafe_input chan beg 0 (-n); - try - beg ^ input_line chan - with End_of_file -> - beg - end - -external input_byte : in_channel -> int = "input_char" -external input_binary_int : in_channel -> int = "input_int" -external input_value : in_channel -> 'a = "input_value" -external seek_in : in_channel -> int -> unit = "seek_in" -external pos_in : in_channel -> int = "pos_in" -external in_channel_length : in_channel -> int = "channel_size" -external close_in : in_channel -> unit = "close_in" - -(* Output functions on standard output *) - -let print_char c = output_char stdout c -let print_string s = output_string stdout s -let print_int i = output_string stdout (string_of_int i) -let print_float f = output_string stdout (string_of_float f) -let print_endline s = output_string stdout s; output_char stdout '\n' -let print_newline () = output_char stdout '\n'; flush stdout - -(* Output functions on standard error *) - -let prerr_char c = output_char stderr c -let prerr_string s = output_string stderr s -let prerr_int i = output_string stderr (string_of_int i) -let prerr_float f = output_string stderr (string_of_float f) -let prerr_endline s = - output_string stderr s; output_char stderr '\n'; flush stderr -let prerr_newline () = output_char stderr '\n'; flush stderr - -(* Input functions on standard input *) - -let read_line () = flush stdout; input_line stdin -let read_int () = int_of_string(read_line()) -let read_float () = float_of_string(read_line()) - -(* References *) - -type 'a ref = { mutable contents: 'a } -external ref: 'a -> 'a ref = "%makeblock" -external (!): 'a ref -> 'a = "%field0" -external (:=): 'a ref -> 'a -> unit = "%setfield0" -external incr: int ref -> unit = "%incr" -external decr: int ref -> unit = "%decr" - -(* Miscellaneous *) - -external sys_exit : int -> 'a = "sys_exit" - -let exit retcode = - flush stdout; flush stderr; sys_exit retcode - -type 'a option = None | Some of 'a diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli deleted file mode 100644 index 3d5a1d6c76..0000000000 --- a/stdlib/pervasives.mli +++ /dev/null @@ -1,204 +0,0 @@ -(* The initially opened module *) - -(* Predefined in the compiler *) - -(*** -type int -type char -type string -type float -type bool -type unit = () -type exn -type 'a array -type 'a list = [] | :: of 'a * 'a list -type ('a, 'b, 'c) format -exception Out_of_memory -exception Invalid_argument of string -exception Failure of string -exception Not_found -exception Sys_error of string -exception End_of_file -exception Division_by_zero -***) - -(* Exceptions *) - -external raise : exn -> 'a = "%raise" -val failwith: string -> 'a -val invalid_arg: string -> 'a - -exception Exit - -(* Comparisons *) - -external (=) : 'a -> 'a -> bool = "%equal" -external (<>) : 'a -> 'a -> bool = "%notequal" -external (<) : 'a -> 'a -> bool = "%lessthan" -external (>) : 'a -> 'a -> bool = "%greaterthan" -external (<=) : 'a -> 'a -> bool = "%lessequal" -external (>=) : 'a -> 'a -> bool = "%greaterequal" -external compare: 'a -> 'a -> int = "compare" -val min: 'a -> 'a -> 'a -val max: 'a -> 'a -> 'a -external (==) : 'a -> 'a -> bool = "%eq" -external (!=) : 'a -> 'a -> bool = "%noteq" - -(* Boolean operations *) - -external not : bool -> bool = "%boolnot" -external (&) : bool -> bool -> bool = "%sequand" -external (or) : bool -> bool -> bool = "%sequor" - -(* Integer operations *) - -external (~-) : int -> int = "%negint" -external succ : int -> int = "%succint" -external pred : int -> int = "%predint" -external (+) : int -> int -> int = "%addint" -external (-) : int -> int -> int = "%subint" -external ( * ) : int -> int -> int = "%mulint" -external (/) : int -> int -> int = "%divint" -external (mod) : int -> int -> int = "%modint" -val abs : int -> int -external (land) : int -> int -> int = "%andint" -external (lor) : int -> int -> int = "%orint" -external (lxor) : int -> int -> int = "%xorint" -val lnot: int -> int -external (lsl) : int -> int -> int = "%lslint" -external (lsr) : int -> int -> int = "%lsrint" -external (asr) : int -> int -> int = "%asrint" - -(* Floating-point operations *) - -external (~-.) : float -> float = "neg_float" -external (+.) : float -> float -> float = "add_float" -external (-.) : float -> float -> float = "sub_float" -external ( *. ) : float -> float -> float = "mul_float" -external (/.) : float -> float -> float = "div_float" -external ( ** ) : float -> float -> float = "power_float" -external exp : float -> float = "exp_float" -external log : float -> float = "log_float" -external sqrt : float -> float = "sqrt_float" -external sin : float -> float = "sin_float" -external cos : float -> float = "cos_float" -external tan : float -> float = "tan_float" -external asin : float -> float = "asin_float" -external acos : float -> float = "acos_float" -external atan : float -> float = "atan_float" -external atan2 : float -> float -> float = "atan2_float" -val abs_float : float -> float -external float : int -> float = "float_of_int" -external truncate : float -> int = "int_of_float" - -(* String operations -- more in module String *) - -val (^) : string -> string -> string - -(* Pair operations *) - -external fst : 'a * 'b -> 'a = "%field0" -external snd : 'a * 'b -> 'b = "%field1" - -(* String conversion functions *) - -val string_of_bool : bool -> string -val string_of_int : int -> string -external int_of_string : string -> int = "int_of_string" -val string_of_float : float -> string -external float_of_string : string -> float = "float_of_string" - -(* List operations -- more in module List *) - -val (@) : 'a list -> 'a list -> 'a list - -(* I/O operations *) - -type in_channel -type out_channel - -val stdin : in_channel -val stdout : out_channel -val stderr : out_channel - -(* Output functions on standard output *) - -val print_char : char -> unit -val print_string : string -> unit -val print_int : int -> unit -val print_float : float -> unit -val print_endline : string -> unit -val print_newline : unit -> unit - -(* Output functions on standard error *) - -val prerr_char : char -> unit -val prerr_string : string -> unit -val prerr_int : int -> unit -val prerr_float : float -> unit -val prerr_endline : string -> unit -val prerr_newline : unit -> unit - -(* Input functions on standard input *) - -val read_line : unit -> string -val read_int : unit -> int -val read_float : unit -> float - -(* General output functions *) - -type open_flag = - Open_rdonly | Open_wronly | Open_rdwr - | Open_append | Open_creat | Open_trunc | Open_excl - | Open_binary | Open_text - -val open_out : string -> out_channel -val open_out_bin : string -> out_channel -val open_out_gen : open_flag list -> int -> string -> out_channel -external flush : out_channel -> unit = "flush" -external output_char : out_channel -> char -> unit = "output_char" -val output_string : out_channel -> string -> unit -val output : out_channel -> string -> int -> int -> unit -external output_byte : out_channel -> int -> unit = "output_char" -external output_binary_int : out_channel -> int -> unit = "output_int" -external output_value : out_channel -> 'a -> unit = "output_value" -external output_compact_value : out_channel -> 'a -> unit = "output_value" -external seek_out : out_channel -> int -> unit = "seek_out" -external pos_out : out_channel -> int = "pos_out" -external size_out : out_channel -> int = "channel_size" -external close_out : out_channel -> unit = "close_out" - -(* General input functions *) -val open_in : string -> in_channel -val open_in_bin : string -> in_channel -val open_in_gen : open_flag list -> int -> string -> in_channel -external input_char : in_channel -> char = "input_char" -val input_line : in_channel -> string -val input : in_channel -> string -> int -> int -> int -val really_input : in_channel -> string -> int -> int -> unit -external input_byte : in_channel -> int = "input_char" -external input_binary_int : in_channel -> int = "input_int" -external input_value : in_channel -> 'a = "input_value" -external seek_in : in_channel -> int -> unit = "seek_in" -external pos_in : in_channel -> int = "pos_in" -external in_channel_length : in_channel -> int = "channel_size" -external close_in : in_channel -> unit = "close_in" - -(* References *) - -type 'a ref = { mutable contents: 'a } -external ref: 'a -> 'a ref = "%makeblock" -external (!): 'a ref -> 'a = "%field0" -external (:=): 'a ref -> 'a -> unit = "%setfield0" -external incr: int ref -> unit = "%incr" -external decr: int ref -> unit = "%decr" - -(* Miscellaneous *) - -val exit : int -> 'a - -type 'a option = None | Some of 'a - -(**** For system use, not for the casual user ****) - -val unsafe_really_input: in_channel -> string -> int -> int -> unit diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml deleted file mode 100644 index 7404513286..0000000000 --- a/stdlib/printexc.ml +++ /dev/null @@ -1,43 +0,0 @@ -let print_exn = function - Out_of_memory -> - prerr_string "Out of memory\n" - | Match_failure(file, first_char, last_char) -> - prerr_string "Pattern matching failed, file "; - prerr_string file; - prerr_string ", chars "; prerr_int first_char; - prerr_char '-'; prerr_int last_char; prerr_char '\n' - | x -> - prerr_string "Uncaught exception: "; - prerr_string (Obj.magic(Obj.field (Obj.field (Obj.repr x) 0) 0)); - if Obj.size (Obj.repr x) > 1 then begin - prerr_char '('; - for i = 1 to Obj.size (Obj.repr x) - 1 do - if i > 1 then prerr_string ", "; - let arg = Obj.field (Obj.repr x) i in - if not (Obj.is_block arg) then - prerr_int (Obj.magic arg : int) - else if Obj.tag arg = 253 then begin - prerr_char '"'; - prerr_string (Obj.magic arg : string); - prerr_char '"' - end else - prerr_char '_' - done; - prerr_char ')' - end; - prerr_char '\n' - -let print fct arg = - try - fct arg - with x -> - print_exn x; - raise x - -let catch fct arg = - try - fct arg - with x -> - flush stdout; - print_exn x; - exit 2 diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli deleted file mode 100644 index 0b56bd2a83..0000000000 --- a/stdlib/printexc.mli +++ /dev/null @@ -1,14 +0,0 @@ -(* A catch-all exception handler *) - -val catch: ('a -> 'b) -> 'a -> 'b - (* [Printexc.catch fn x] applies [fn] to [x] and returns the result. - If the evaluation of [fn x] raises any exception, the - name of the exception is printed on standard error output, - and the programs aborts with exit code 2. - Typical use is [Printexc.catch main ()], where [main], with type - [unit->unit], is the entry point of a standalone program, to catch - and print stray exceptions. *) - -val print: ('a -> 'b) -> 'a -> 'b - (* Same as [catch], but re-raise the stray exception after - printing it, instead of aborting the program. *) diff --git a/stdlib/printf.ml b/stdlib/printf.ml deleted file mode 100644 index 34f0b54385..0000000000 --- a/stdlib/printf.ml +++ /dev/null @@ -1,152 +0,0 @@ -external format_int: string -> int -> string = "format_int" -external format_float: string -> float -> string = "format_float" - -let fprintf outchan format = - let format = (Obj.magic format : string) in - let rec doprn i = - if i >= String.length format then - Obj.magic () - else begin - let c = String.unsafe_get format i in - if c <> '%' then begin - output_char outchan c; - doprn (succ i) - end else begin - let j = skip_args (succ i) in - match String.unsafe_get format j with - '%' -> - output_char outchan '%'; - doprn (succ j) - | 's' -> - Obj.magic(fun s -> - if j <= i+1 then - output_string outchan s - else begin - let p = - try - int_of_string (String.sub format (i+1) (j-i-1)) - with _ -> - invalid_arg "fprintf: bad %s format" in - if p > 0 & String.length s < p then begin - output_string outchan - (String.make (p - String.length s) ' '); - output_string outchan s - end else if p < 0 & String.length s < -p then begin - output_string outchan s; - output_string outchan - (String.make (-p - String.length s) ' ') - end else - output_string outchan s - end; - doprn (succ j)) - | 'c' -> - Obj.magic(fun c -> - output_char outchan c; - doprn (succ j)) - | 'd' | 'o' | 'x' | 'X' | 'u' -> - Obj.magic(fun n -> - output_string outchan - (format_int (String.sub format i (j-i+1)) n); - doprn (succ j)) - | 'f' | 'e' | 'E' | 'g' | 'G' -> - Obj.magic(fun f -> - output_string outchan - (format_float (String.sub format i (j-i+1)) f); - doprn (succ j)) - | 'b' -> - Obj.magic(fun b -> - output_string outchan (string_of_bool b); - doprn (succ j)) - | 'a' -> - Obj.magic(fun printer arg -> - printer outchan arg; - doprn(succ j)) - | 't' -> - Obj.magic(fun printer -> - printer outchan; - doprn(succ j)) - | c -> - invalid_arg ("fprintf: unknown format") - end - end - - and skip_args j = - match String.unsafe_get format j with - '0' .. '9' | ' ' | '.' | '-' -> skip_args (succ j) - | c -> j - - in doprn 0 - -let printf fmt = fprintf stdout fmt -and eprintf fmt = fprintf stderr fmt - -let sprintf format = - let format = (Obj.magic format : string) in - let res = ref [] in - let rec doprn start i = - if i >= String.length format then begin - if i > start then res := String.sub format start (i-start) :: !res; - Obj.magic(String.concat "" (List.rev !res)) - end else - if String.unsafe_get format i <> '%' then - doprn start (i+1) - else begin - if i > start then res := String.sub format start (i-start) :: !res; - let j = skip_args (succ i) in - match String.unsafe_get format j with - '%' -> - doprn j (succ j) - | 's' -> - Obj.magic(fun s -> - if j <= i+1 then - res := s :: !res - else begin - let p = - try - int_of_string (String.sub format (i+1) (j-i-1)) - with _ -> - invalid_arg "fprintf: bad %s format" in - if p > 0 & String.length s < p then begin - res := String.make (p - String.length s) ' ' :: !res; - res := s :: !res - end else if p < 0 & String.length s < -p then begin - res := s :: !res; - res := String.make (-p - String.length s) ' ' :: !res - end else - res := s :: !res - end; - doprn (succ j) (succ j)) - | 'c' -> - Obj.magic(fun c -> - res := String.make 1 c :: !res; - doprn (succ j) (succ j)) - | 'd' | 'o' | 'x' | 'X' | 'u' -> - Obj.magic(fun n -> - res := format_int (String.sub format i (j-i+1)) n :: !res; - doprn (succ j) (succ j)) - | 'f' | 'e' | 'E' | 'g' | 'G' -> - Obj.magic(fun f -> - res := format_float (String.sub format i (j-i+1)) f :: !res; - doprn (succ j) (succ j)) - | 'b' -> - Obj.magic(fun b -> - res := string_of_bool b :: !res; - doprn (succ j) (succ j)) - | 'a' -> - Obj.magic(fun printer arg -> - res := printer () arg :: !res; - doprn (succ j) (succ j)) - | 't' -> - Obj.magic(fun printer -> - res := printer () :: !res; - doprn (succ j) (succ j)) - | c -> - invalid_arg ("sprintf: unknown format") - end - - and skip_args j = - match String.unsafe_get format j with - '0' .. '9' | ' ' | '.' | '-' -> skip_args (succ j) - | c -> j - - in doprn 0 0 diff --git a/stdlib/printf.mli b/stdlib/printf.mli deleted file mode 100644 index a46718d7fd..0000000000 --- a/stdlib/printf.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* Formatting printing functions *) - -val fprintf: out_channel -> ('a, out_channel, unit) format -> 'a - (* [fprintf outchan format arg1 ... argN] formats the arguments - [arg1] to [argN] according to the format string [format], - and outputs the resulting string on the channel [outchan]. - The format is a character string which contains two types of - objects: plain characters, which are simply copied to the - output channel, and conversion specifications, each of which - causes conversion and printing of one argument. - Conversion specifications consist in the [%] character, followed - by optional flags and field widths, followed by one conversion - character. The conversion characters and their meanings are: -- [d] or [i]: convert an integer argument to signed decimal -- [u]: convert an integer argument to unsigned decimal -- [x]: convert an integer argument to unsigned hexadecimal, - using lowercase letters. -- [X]: convert an integer argument to unsigned hexadecimal, - using uppercase letters. -- [s]: insert a string argument -- [c]: insert a character argument -- [f]: convert a floating-point argument to decimal notation, - in the style [dddd.ddd] -- [e] or [E]: convert a floating-point argument to decimal notation, - in the style [d.ddd e+-dd] (mantissa and exponent) -- [g] or [G]: convert a floating-point argument to decimal notation, - in style [f] or [e], [E] (whichever is more compact) -- [b]: convert a boolean argument to the string [true] or [false] -- [a]: user-defined printer. Takes two arguments and apply the first - one to [outchan] (the current output channel) and to the second - argument. The first argument must therefore have type - [out_channel -> 'b -> unit] and the second ['b]. - The output produced by the function is therefore inserted - in the output of [fprintf] at the current point. -- [t]: same as [%a], but takes only one argument (with type - [out_channel -> unit]) and apply it to [outchan]. -- Refer to the C library [printf] function for the meaning of - flags and field width specifiers. *) - -val printf: ('a, out_channel, unit) format -> 'a - (* Same as [fprintf], but output on [std_out]. *) - -val eprintf: ('a, out_channel, unit) format -> 'a - (* Same as [fprintf], but output on [std_err]. *) - -val sprintf: ('a, unit, string) format -> 'a - (* Same as [printf], but return the result of formatting in a - string. *) diff --git a/stdlib/queue.ml b/stdlib/queue.ml deleted file mode 100644 index 977a26338c..0000000000 --- a/stdlib/queue.ml +++ /dev/null @@ -1,58 +0,0 @@ -exception Empty - -type 'a queue_cell = - Nil - | Cons of 'a * 'a queue_cell ref - -type 'a t = - { mutable head: 'a queue_cell; - mutable tail: 'a queue_cell } - -let new () = - { head = Nil; tail = Nil } - -let clear q = - q.head <- Nil; q.tail <- Nil - -let add x q = - match q.tail with - Nil -> (* if tail = Nil then head = Nil *) - let c = Cons(x, ref Nil) in - q.head <- c; q.tail <- c - | Cons(_, newtailref) -> - let c = Cons(x, ref Nil) in - newtailref := c; - q.tail <- c - -let peek q = - match q.head with - Nil -> - raise Empty - | Cons(x, _) -> - x - -let take q = - match q.head with - Nil -> - raise Empty - | Cons(x, rest) -> - q.head <- !rest; - begin match !rest with - Nil -> q.tail <- Nil - | _ -> () - end; - x - -let rec length_aux = function - Nil -> 0 - | Cons(_, rest) -> succ (length_aux !rest) - -let length q = length_aux q.head - -let rec iter_aux f = function - Nil -> - () - | Cons(x, rest) -> - f x; iter_aux f !rest - -let iter f q = iter_aux f q.head diff --git a/stdlib/queue.mli b/stdlib/queue.mli deleted file mode 100644 index 297e81afa0..0000000000 --- a/stdlib/queue.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Queues *) - -(* This module implements queues (FIFOs), with in-place modification. *) - -type 'a t - (* The type of queues containing elements of type ['a]. *) - -exception Empty - (* Raised when [take] is applied to an empty queue. *) - -val new: unit -> 'a t - (* Return a new queue, initially empty. *) -val add: 'a -> 'a t -> unit - (* [add x q] adds the element [x] at the end of the queue [q]. *) -val take: 'a t -> 'a - (* [take q] removes and returns the first element in queue [q], - or raises [Empty] if the queue is empty. *) -val peek: 'a t -> 'a - (* [peek q] returns the first element in queue [q], without removing - it from the queue, or raises [Empty] if the queue is empty. *) -val clear : 'a t -> unit - (* Discard all elements from a queue. *) -val length: 'a t -> int - (* Return the number of elements in a queue. *) -val iter: ('a -> 'b) -> 'a t -> unit - (* [iter f q] applies [f] in turn to all elements of [q], from the - least recently entered to the most recently entered. - The queue itself is unchanged. *) diff --git a/stdlib/set.ml b/stdlib/set.ml deleted file mode 100644 index 84a8a942c8..0000000000 --- a/stdlib/set.ml +++ /dev/null @@ -1,226 +0,0 @@ -(* Sets over ordered types *) - -module type OrderedType = - sig - type t - val compare: t -> t -> int - end - -module type S = - sig - type elt - type t - val empty: t - val is_empty: t -> bool - val mem: elt -> t -> bool - val add: elt -> t -> t - val remove: elt -> t -> t - val union: t -> t -> t - val inter: t -> t -> t - val diff: t -> t -> t - val compare: t -> t -> int - val equal: t -> t -> bool - val iter: (elt -> 'a) -> t -> unit - val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a - val elements: t -> elt list - val choose: t -> elt - end - -module Make(Ord: OrderedType): (S with elt = Ord.t) = - struct - type elt = Ord.t - type t = Empty | Node of t * elt * t * int - - (* Sets are represented by balanced binary trees (the heights of the - children differ by at most 2 *) - - let height = function - Empty -> 0 - | Node(_, _, _, h) -> h - - (* Creates a new node with left son l, value x and right son r. - l and r must be balanced and | height l - height r | <= 2. - Inline expansion of height for better speed. *) - - let new l x r = - let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in - Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1)) - - (* Same as new, but performs one step of rebalancing if necessary. - Assumes l and r balanced. - Inline expansion of new for better speed in the most frequent case - where no rebalancing is required. *) - - let bal l x r = - let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in - if hl > hr + 2 then begin - match l with - Empty -> invalid_arg "Set.bal" - | Node(ll, lv, lr, _) -> - if height ll >= height lr then - new ll lv (new lr x r) - else begin - match lr with - Empty -> invalid_arg "Set.bal" - | Node(lrl, lrv, lrr, _)-> - new (new ll lv lrl) lrv (new lrr x r) - end - end else if hr > hl + 2 then begin - match r with - Empty -> invalid_arg "Set.bal" - | Node(rl, rv, rr, _) -> - if height rr >= height rl then - new (new l x rl) rv rr - else begin - match rl with - Empty -> invalid_arg "Set.bal" - | Node(rll, rlv, rlr, _) -> - new (new l x rll) rlv (new rlr rv rr) - end - end else - Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1)) - - (* Same as bal, but repeat rebalancing until the final result - is balanced. *) - - let rec join l x r = - match bal l x r with - Empty -> invalid_arg "Set.join" - | Node(l', x', r', _) as t' -> - let d = height l' - height r' in - if d < -2 or d > 2 then join l' x' r' else t' - - (* Merge two trees l and r into one. - All elements of l must precede the elements of r. - Assumes | height l - height r | <= 2. *) - - let rec merge t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> - bal l1 v1 (bal (merge r1 l2) v2 r2) - - (* Same as merge, but does not assume anything about l and r. *) - - let rec concat t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> - join l1 v1 (join (concat r1 l2) v2 r2) - - (* Splitting *) - - let rec split x = function - Empty -> - (Empty, None, Empty) - | Node(l, v, r, _) -> - let c = Ord.compare x v in - if c = 0 then (l, Some v, r) - else if c < 0 then - let (ll, vl, rl) = split x l in (ll, vl, join rl v r) - else - let (lr, vr, rr) = split x r in (join l v lr, vr, rr) - - (* Implementation of the set operations *) - - let empty = Empty - - let is_empty = function Empty -> true | _ -> false - - let rec mem x = function - Empty -> false - | Node(l, v, r, _) -> - let c = Ord.compare x v in - if c = 0 then true else - if c < 0 then mem x l else mem x r - - let rec add x = function - Empty -> Node(Empty, x, Empty, 1) - | Node(l, v, r, _) as t -> - let c = Ord.compare x v in - if c = 0 then t else - if c < 0 then bal (add x l) v r else bal l v (add x r) - - let rec remove x = function - Empty -> Empty - | Node(l, v, r, _) -> - let c = Ord.compare x v in - if c = 0 then merge l r else - if c < 0 then bal (remove x l) v r else bal l v (remove x r) - - let rec union s1 s2 = - match (s1, s2) with - (Empty, t2) -> t2 - | (t1, Empty) -> t1 - | (Node(l1, v1, r1, _), t2) -> - let (l2, _, r2) = split v1 t2 in - join (union l1 l2) v1 (union r1 r2) - - let rec inter s1 s2 = - match (s1, s2) with - (Empty, t2) -> Empty - | (t1, Empty) -> Empty - | (Node(l1, v1, r1, _), t2) -> - match split v1 t2 with - (l2, None, r2) -> - concat (inter l1 l2) (inter r1 r2) - | (l2, Some _, r2) -> - join (inter l1 l2) v1 (inter r1 r2) - - let rec diff s1 s2 = - match (s1, s2) with - (Empty, t2) -> Empty - | (t1, Empty) -> t1 - | (Node(l1, v1, r1, _), t2) -> - match split v1 t2 with - (l2, None, r2) -> - join (diff l1 l2) v1 (diff r1 r2) - | (l2, Some _, r2) -> - concat (diff l1 l2) (diff r1 r2) - - let rec compare_aux l1 l2 = - match (l1, l2) with - ([], []) -> 0 - | ([], _) -> -1 - | (_, []) -> 1 - | (Empty :: t1, Empty :: t2) -> - compare_aux t1 t2 - | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) -> - let c = Ord.compare v1 v2 in - if c <> 0 then c else compare_aux (r1::t1) (r2::t2) - | (Node(l1, v1, r1, _) :: t1, t2) -> - compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2 - | (t1, Node(l2, v2, r2, _) :: t2) -> - compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2) - - let compare s1 s2 = - compare_aux [s1] [s2] - - let equal s1 s2 = - compare s1 s2 = 0 - - let rec iter f = function - Empty -> () - | Node(l, v, r, _) -> iter f l; f v; iter f r - - let rec fold f s accu = - match s with - Empty -> accu - | Node(l, v, r, _) -> fold f l (f v (fold f r accu)) - - let rec elements_aux accu = function - Empty -> accu - | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l - - let elements s = - elements_aux [] s - - let rec choose = function - Empty -> raise Not_found - | Node(Empty, v, r, _) -> v - | Node(l, v, r, _) -> choose l - end diff --git a/stdlib/set.mli b/stdlib/set.mli deleted file mode 100644 index dff78105ae..0000000000 --- a/stdlib/set.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Sets over ordered types *) - -module type OrderedType = - sig - type t - val compare: t -> t -> int - end - -module type S = - sig - type elt - type t - val empty: t - val is_empty: t -> bool - val mem: elt -> t -> bool - val add: elt -> t -> t - val remove: elt -> t -> t - val union: t -> t -> t - val inter: t -> t -> t - val diff: t -> t -> t - val compare: t -> t -> int - val equal: t -> t -> bool - val iter: (elt -> 'a) -> t -> unit - val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a - val elements: t -> elt list - val choose: t -> elt - end - -module Make(Ord: OrderedType): (S with elt = Ord.t) diff --git a/stdlib/sort.ml b/stdlib/sort.ml deleted file mode 100644 index 1b694bfffa..0000000000 --- a/stdlib/sort.ml +++ /dev/null @@ -1,28 +0,0 @@ -(* Merging and sorting *) - -let rec merge order l1 l2 = - match l1 with - [] -> l2 - | h1 :: t1 -> - match l2 with - [] -> l1 - | h2 :: t2 -> - if order h1 h2 - then h1 :: merge order t1 l2 - else h2 :: merge order l1 t2 - -let list order l = - let rec initlist = function - [] -> [] - | [e] -> [[e]] - | e1::e2::rest -> - (if order e1 e2 then [e1;e2] else [e2;e1]) :: initlist rest in - let rec merge2 = function - l1::l2::rest -> merge order l1 l2 :: merge2 rest - | x -> x in - let rec mergeall = function - [] -> [] - | [l] -> l - | llist -> mergeall (merge2 llist) in - mergeall(initlist l) - diff --git a/stdlib/sort.mli b/stdlib/sort.mli deleted file mode 100644 index 545a0fad73..0000000000 --- a/stdlib/sort.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* Sorting and merging lists *) - -val list : ('a -> 'a -> bool) -> 'a list -> 'a list - (* Sort a list in increasing order according to an ordering predicate. - The predicate should return [true] if its first argument is - less than or equal to its second argument. *) - -val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list - (* Merge two lists according to the given predicate. - Assuming the two argument lists are sorted according to the - predicate, [merge] returns a sorted list containing the elements - from the two lists. The behavior is undefined if the two - argument lists were not sorted. *) diff --git a/stdlib/stack.ml b/stdlib/stack.ml deleted file mode 100644 index 8b1710cdd3..0000000000 --- a/stdlib/stack.ml +++ /dev/null @@ -1,18 +0,0 @@ -type 'a t = { mutable c : 'a list } - -exception Empty - -let new () = { c = [] } - -let clear s = s.c <- [] - -let push x s = s.c <- x :: s.c - -let pop s = - match s.c with - hd::tl -> s.c <- tl; hd - | [] -> raise Empty - -let length s = List.length s.c - -let iter f s = List.iter f s.c diff --git a/stdlib/stack.mli b/stdlib/stack.mli deleted file mode 100644 index a1133edcce..0000000000 --- a/stdlib/stack.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Stacks *) - -(* This modl implements stacks (LIFOs), with in-place modification. *) - -type 'a t - (* The type of stacks containing elements of type ['a]. *) - -exception Empty - (* Raised when [pop] is applied to an empty stack. *) - -val new: unit -> 'a t - (* Return a new stack, initially empty. *) -val push: 'a -> 'a t -> unit - (* [push x s] adds the element [x] at the top of stack [s]. *) -val pop: 'a t -> 'a - (* [pop s] removes and returns the topmost element in stack [s], - or raises [Empty] if the stack is empty. *) -val clear : 'a t -> unit - (* Discard all elements from a stack. *) -val length: 'a t -> int - (* Return the number of elements in a stack. *) -val iter: ('a -> 'b) -> 'a t -> unit - (* [iter f s] applies [f] in turn to all elements of [s], from the - element at the top of the stack to the element at the - bottom of the stack. The stack itself is unchanged. *) diff --git a/stdlib/string.ml b/stdlib/string.ml deleted file mode 100644 index d26ff55a55..0000000000 --- a/stdlib/string.ml +++ /dev/null @@ -1,113 +0,0 @@ -(* String operations *) - -external length : string -> int = "ml_string_length" -external create: int -> string = "create_string" -external unsafe_get : string -> int -> char = "%string_unsafe_get" -external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" -external get : string -> int -> char = "string_get" -external set : string -> int -> char -> unit = "string_set" -external unsafe_blit : string -> int -> string -> int -> int -> unit - = "blit_string" -external unsafe_fill : string -> int -> int -> char -> unit = "fill_string" - -(****** -let get s n = - if n < 0 or n >= length s - then invalid_arg "String.get" - else unsafe_get s n - -let set s n c = - if n < 0 or n >= length s - then invalid_arg "String.set" - else unsafe_set s n c -*******) - -let make n c = - let s = create n in - unsafe_fill s 0 n c; - s - -let copy s = - let len = length s in - let r = create len in - unsafe_blit s 0 r 0 len; - r - -let sub s ofs len = - if ofs < 0 or len < 0 or ofs + len > length s - then invalid_arg "String.sub" - else begin - let r = create len in - unsafe_blit s ofs r 0 len; - r - end - -let fill s ofs len c = - if ofs < 0 or len < 0 or ofs + len > length s - then invalid_arg "String.fill" - else unsafe_fill s ofs len c - -let blit s1 ofs1 s2 ofs2 len = - if len < 0 or ofs1 < 0 or ofs1 + len > length s1 - or ofs2 < 0 or ofs2 + len > length s2 - then invalid_arg "String.blit" - else unsafe_blit s1 ofs1 s2 ofs2 len - -let concat sep l = - match l with - [] -> "" - | hd :: tl -> - let num = ref 0 and len = ref 0 in - List.iter (fun s -> incr num; len := !len + length s) l; - let r = create (!len + length sep * (!num - 1)) in - unsafe_blit hd 0 r 0 (length hd); - let pos = ref(length hd) in - List.iter - (fun s -> - unsafe_blit sep 0 r !pos (length sep); - pos := !pos + length sep; - unsafe_blit s 0 r !pos (length s); - pos := !pos + length s) - tl; - r - -external is_printable: char -> bool = "is_printable" - -let escaped s = - let n = ref 0 in - for i = 0 to length s - 1 do - n := !n + - (match unsafe_get s i with - '"' | '\\' | '\n' | '\t' -> 2 - | c -> if is_printable c then 1 else 4) - done; - if !n = length s then s else begin - let s' = create !n in - n := 0; - for i = 0 to length s - 1 do - begin - match unsafe_get s i with - ('"' | '\\') as c -> - unsafe_set s' !n '\\'; incr n; unsafe_set s' !n c - | '\n' -> - unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'n' - | '\t' -> - unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 't' - | c -> - if is_printable c then - unsafe_set s' !n c - else begin - let a = Char.code c in - unsafe_set s' !n '\\'; - incr n; - unsafe_set s' !n (Char.unsafe_chr (48 + a / 100)); - incr n; - unsafe_set s' !n (Char.unsafe_chr (48 + (a / 10) mod 10)); - incr n; - unsafe_set s' !n (Char.unsafe_chr (48 + a mod 10)) - end - end; - incr n - done; - s' - end diff --git a/stdlib/string.mli b/stdlib/string.mli deleted file mode 100644 index ddf2df1bda..0000000000 --- a/stdlib/string.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* String operations *) - -external length : string -> int = "ml_string_length" - -external get : string -> int -> char = "string_get" -external set : string -> int -> char -> unit = "string_set" - -external create : int -> string = "create_string" -val make : int -> char -> string -val copy : string -> string -val sub : string -> int -> int -> string - -val fill : string -> int -> int -> char -> unit -val blit : string -> int -> string -> int -> int -> unit - -val concat : string -> string list -> string - -val escaped: string -> string - -external unsafe_get : string -> int -> char = "%string_unsafe_get" -external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" -external unsafe_blit : string -> int -> string -> int -> int -> unit - = "blit_string" -external unsafe_fill : string -> int -> int -> char -> unit = "fill_string" - - diff --git a/stdlib/sys.ml b/stdlib/sys.ml deleted file mode 100644 index 79a40d9b3a..0000000000 --- a/stdlib/sys.ml +++ /dev/null @@ -1,46 +0,0 @@ -(* System interface *) - -external get_argv: unit -> string array = "sys_get_argv" - -let argv = get_argv() - -external file_exists: string -> bool = "sys_file_exists" -external remove: string -> unit = "sys_remove" -external getenv: string -> string = "sys_getenv" -external command: string -> int = "sys_system_command" -external chdir: string -> unit = "sys_chdir" - -type signal_behavior = - Signal_default - | Signal_ignore - | Signal_handle of (int -> unit) - -external signal: int -> signal_behavior -> unit = "install_signal_handler" - -let sigabrt = -1 -let sigalrm = -2 -let sigfpe = -3 -let sighup = -4 -let sigill = -5 -let sigint = -6 -let sigkill = -7 -let sigpipe = -8 -let sigquit = -9 -let sigsegv = -10 -let sigterm = -11 -let sigusr1 = -12 -let sigusr2 = -13 -let sigchld = -14 -let sigcont = -15 -let sigstop = -16 -let sigtstp = -17 -let sigttin = -18 -let sigttou = -19 - -exception Break - -let catch_break on = - if on then - signal sigint (Signal_handle(fun _ -> raise Break)) - else - signal sigint Signal_default diff --git a/stdlib/sys.mli b/stdlib/sys.mli deleted file mode 100644 index 0466ba5917..0000000000 --- a/stdlib/sys.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* System interface *) - -val argv: string array -external file_exists: string -> bool = "sys_file_exists" -external remove: string -> unit = "sys_remove" -external getenv: string -> string = "sys_getenv" -external command: string -> int = "sys_system_command" -external chdir: string -> unit = "sys_chdir" - -type signal_behavior = - Signal_default - | Signal_ignore - | Signal_handle of (int -> unit) - -external signal: int -> signal_behavior -> unit = "install_signal_handler" - -val sigabrt: int -val sigalrm: int -val sigfpe: int -val sighup: int -val sigill: int -val sigint: int -val sigkill: int -val sigpipe: int -val sigquit: int -val sigsegv: int -val sigterm: int -val sigusr1: int -val sigusr2: int -val sigchld: int -val sigcont: int -val sigstop: int -val sigtstp: int -val sigttin: int -val sigttou: int - -exception Break - -val catch_break: bool -> unit |