diff options
Diffstat (limited to 'stdlib')
45 files changed, 3289 insertions, 0 deletions
diff --git a/stdlib/.depend b/stdlib/.depend new file mode 100644 index 000000000..f988c3da9 --- /dev/null +++ b/stdlib/.depend @@ -0,0 +1,28 @@ +baltree.cmi: list.cmi +format.cmi: list.cmi +gc.cmi: +lexing.cmi: obj.cmi +parsing.cmi: lexing.cmi obj.cmi +pervasives.cmi: sys.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 +baltree.cmo: baltree.cmi baltree.cmi list.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 +obj.cmo: obj.cmi +parsing.cmo: parsing.cmi array.cmi lexing.cmi obj.cmi +pervasives.cmo: pervasives.cmi sys.cmi +printexc.cmo: printexc.cmi obj.cmi +printf.cmo: printf.cmi string.cmi obj.cmi +queue.cmo: queue.cmi +set.cmo: set.cmi baltree.cmi +sort.cmo: sort.cmi +stack.cmo: stack.cmi list.cmi +string.cmo: string.cmi char.cmi string.cmi +sys.cmo: sys.cmi diff --git a/stdlib/Makefile b/stdlib/Makefile new file mode 100644 index 000000000..a00cd82b9 --- /dev/null +++ b/stdlib/Makefile @@ -0,0 +1,55 @@ +include ../Makefile.config + +COMPILER=../camlc +CAMLC=../boot/camlrun $(COMPILER) +CAMLDEP=../tools/camldep + +OBJS=pervasives.cmo string.cmo char.cmo list.cmo array.cmo sys.cmo \ + hashtbl.cmo sort.cmo filename.cmo obj.cmo lexing.cmo parsing.cmo \ + baltree.cmo set.cmo stack.cmo queue.cmo \ + printf.cmo format.cmo arg.cmo printexc.cmo gc.cmo + +all: stdlib.cma header.exe + +install: + cp stdlib.cma *.cmi *.mli header.exe $(LIBDIR) + +stdlib.cma: $(OBJS) + $(CAMLC) -a -o stdlib.cma $(OBJS) + +header.exe: header.c ../Makefile.config + if $(SHARPBANGSCRIPTS); \ + then echo "#!$(BINDIR)/cslrun" > header.exe; \ + else $(CC) $(CCCOMPOPTS) $(CCLINKOPTS) header.c -o header.exe; \ + strip header.exe; fi + +pervasives.cmi: pervasives.mli + $(CAMLC) -nopervasives -c pervasives.mli + +pervasives.cmo: pervasives.ml + $(CAMLC) -nopervasives -c pervasives.ml + +sys.cmi: sys.mli + $(CAMLC) -nopervasives -c sys.mli + +.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 new file mode 100644 index 000000000..3726760f4 --- /dev/null +++ b/stdlib/arg.ml @@ -0,0 +1,61 @@ +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 new file mode 100644 index 000000000..593d5b36b --- /dev/null +++ b/stdlib/arg.mli @@ -0,0 +1,46 @@ +(* 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 new file mode 100644 index 000000000..aa156bef9 --- /dev/null +++ b/stdlib/array.ml @@ -0,0 +1,99 @@ +(* Array operations *) + +external length : 'a array -> int = "%array_length" +external unsafe_get: 'a array -> int -> 'a = "%array_get" +external unsafe_set: 'a array -> int -> 'a -> unit = "%array_set" +external new: int -> 'a -> 'a array = "make_vect" + +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 concat_aux a1 a2 l1 l2 init = + let r = new (l1 + l2) init 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 a1 i) done; + r + +let concat 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 a1 i) done; + r + end + +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 new file mode 100644 index 000000000..add7a92ca --- /dev/null +++ b/stdlib/array.mli @@ -0,0 +1,21 @@ +(* Array operations *) + +val length : 'a array -> int = "%array_length" + +val get: 'a array -> int -> 'a +val set: 'a array -> int -> 'a -> unit +val new: int -> 'a -> 'a array = "make_vect" +val new_matrix: int -> int -> 'a -> 'a array array +val concat: 'a array -> 'a array -> '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 + +val unsafe_get: 'a array -> int -> 'a = "%array_get" +val unsafe_set: 'a array -> int -> 'a -> unit = "%array_set" + diff --git a/stdlib/baltree.ml b/stdlib/baltree.ml new file mode 100644 index 000000000..7c61a8f54 --- /dev/null +++ b/stdlib/baltree.ml @@ -0,0 +1,193 @@ +(* 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, val 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 new file mode 100644 index 000000000..4e6f35efb --- /dev/null +++ b/stdlib/baltree.mli @@ -0,0 +1,77 @@ +(* 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 new file mode 100644 index 000000000..348c5683c --- /dev/null +++ b/stdlib/char.ml @@ -0,0 +1,26 @@ +(* 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 new file mode 100644 index 000000000..40791c94b --- /dev/null +++ b/stdlib/char.mli @@ -0,0 +1,6 @@ +(* Character operations *) + +val code: char -> int = "%identity" +val chr: int -> char +val escaped : char -> string +val unsafe_chr: int -> char = "%identity" diff --git a/stdlib/filename.ml b/stdlib/filename.ml new file mode 100644 index 000000000..af63af08f --- /dev/null +++ b/stdlib/filename.ml @@ -0,0 +1,49 @@ +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 new file mode 100644 index 000000000..bf75f61c5 --- /dev/null +++ b/stdlib/filename.mli @@ -0,0 +1,27 @@ +(* 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 new file mode 100644 index 000000000..ca631fdd2 --- /dev/null +++ b/stdlib/format.ml @@ -0,0 +1,471 @@ +(* 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 val 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 val for default tokens size *) +let pp_infinity = 9999 + +(* Global variables: default initialization is + set_margin 78 + set_min_space_left 0 *) +(* val 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 val 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 val 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 val of) width blanks are printed. + To do (?) : add a maximum width and offset val *) +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 new file mode 100644 index 000000000..5d9a9ac3e --- /dev/null +++ b/stdlib/format.mli @@ -0,0 +1,151 @@ +(* 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 new file mode 100644 index 000000000..78065fdd8 --- /dev/null +++ b/stdlib/gc.ml @@ -0,0 +1,47 @@ +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 new file mode 100644 index 000000000..b77b0e286 --- /dev/null +++ b/stdlib/gc.mli @@ -0,0 +1,93 @@ +(* 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. + *) + +val 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. *) +val get : unit -> control = "gc_get" + (* Return the current values of the GC parameters in a [control] record. *) +val 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. *) + ] + *) +val minor : unit -> unit = "gc_minor" + (* Trigger a minor collection. *) +val major : unit -> unit = "gc_major" + (* Finish the current major collection cycle. *) +val 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 new file mode 100644 index 000000000..f7cbda3ff --- /dev/null +++ b/stdlib/hashtbl.ml @@ -0,0 +1,95 @@ +(* 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 new file mode 100644 index 000000000..fd32f6a36 --- /dev/null +++ b/stdlib/hashtbl.mli @@ -0,0 +1,67 @@ +(* 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. *) + +val 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 new file mode 100644 index 000000000..aba20e62a --- /dev/null +++ b/stdlib/header.c @@ -0,0 +1,11 @@ +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 new file mode 100644 index 000000000..07bb7b5df --- /dev/null +++ b/stdlib/lexing.ml @@ -0,0 +1,75 @@ +(* 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 new file mode 100644 index 000000000..6e224c4fc --- /dev/null +++ b/stdlib/lexing.mli @@ -0,0 +1,68 @@ +(* 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 +val get_next_char : lexbuf -> char = "get_next_char" +val backtrack : lexbuf -> 'a diff --git a/stdlib/list.ml b/stdlib/list.ml new file mode 100644 index 000000000..3b6cdb440 --- /dev/null +++ b/stdlib/list.ml @@ -0,0 +1,104 @@ +(* 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 new file mode 100644 index 000000000..00d0cc469 --- /dev/null +++ b/stdlib/list.mli @@ -0,0 +1,24 @@ +(* 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/obj.ml b/stdlib/obj.ml new file mode 100644 index 000000000..b4c131ad4 --- /dev/null +++ b/stdlib/obj.ml @@ -0,0 +1,13 @@ +(* 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_get" +external set_field : t -> int -> t -> unit = "%array_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 new file mode 100644 index 000000000..9509c2b8a --- /dev/null +++ b/stdlib/obj.mli @@ -0,0 +1,13 @@ +(* Operations on internal representations of values *) + +type t + +val repr : 'a -> t = "%identity" +val magic : 'a -> 'b = "%identity" +val is_block : t -> bool = "obj_is_block" +val tag : t -> int = "%tagof" +val size : t -> int = "%array_length" +val field : t -> int -> t = "%array_get" +val set_field : t -> int -> t -> unit = "%array_set" +val new_block : int -> int -> t = "obj_block" +val update : t -> t -> unit = "%update" diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml new file mode 100644 index 000000000..0ddf431e7 --- /dev/null +++ b/stdlib/parsing.ml @@ -0,0 +1,148 @@ +(* 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 new file mode 100644 index 000000000..9f5fbaffb --- /dev/null +++ b/stdlib/parsing.mli @@ -0,0 +1,51 @@ +(* 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 new file mode 100644 index 000000000..bc1014158 --- /dev/null +++ b/stdlib/pervasives.ml @@ -0,0 +1,273 @@ +(* 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 *) + +open Sys + +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 new file mode 100644 index 000000000..ff40c49d1 --- /dev/null +++ b/stdlib/pervasives.mli @@ -0,0 +1,198 @@ +(* 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 *) + +val raise : exn -> 'a = "%raise" +val failwith: string -> 'a +val invalid_arg: string -> 'a + +exception Exit + +(* Comparisons *) + +val (=) : 'a -> 'a -> bool = "%equal" +val (<>) : 'a -> 'a -> bool = "%notequal" +val (<) : 'a -> 'a -> bool = "%lessthan" +val (>) : 'a -> 'a -> bool = "%greaterthan" +val (<=) : 'a -> 'a -> bool = "%lessequal" +val (>=) : 'a -> 'a -> bool = "%greaterequal" +val compare: 'a -> 'a -> int = "compare" +val min: 'a -> 'a -> 'a +val max: 'a -> 'a -> 'a +val (==) : 'a -> 'a -> bool = "%eq" +val (!=) : 'a -> 'a -> bool = "%noteq" + +(* Boolean operations *) + +val not : bool -> bool = "%boolnot" +val (&) : bool -> bool -> bool = "%sequand" +val (or) : bool -> bool -> bool = "%sequor" + +(* Integer operations *) + +val (~-) : int -> int = "%negint" +val succ : int -> int = "%succint" +val pred : int -> int = "%predint" +val (+) : int -> int -> int = "%addint" +val (-) : int -> int -> int = "%subint" +val ( * ) : int -> int -> int = "%mulint" +val (/) : int -> int -> int = "%divint" +val (mod) : int -> int -> int = "%modint" +val abs : int -> int +val (land) : int -> int -> int = "%andint" +val (lor) : int -> int -> int = "%orint" +val (lxor) : int -> int -> int = "%xorint" +val lnot: int -> int +val (lsl) : int -> int -> int = "%lslint" +val (lsr) : int -> int -> int = "%lsrint" +val (asr) : int -> int -> int = "%asrint" + +(* Floating-point operations *) + +val (~-.) : float -> float = "neg_float" +val (+.) : float -> float -> float = "add_float" +val (-.) : float -> float -> float = "sub_float" +val ( *. ) : float -> float -> float = "mul_float" +val (/.) : float -> float -> float = "div_float" +val ( ** ) : float -> float -> float = "power_float" +val exp : float -> float = "exp_float" +val log : float -> float = "log_float" +val sqrt : float -> float = "sqrt_float" +val sin : float -> float = "sin_float" +val cos : float -> float = "cos_float" +val tan : float -> float = "tan_float" +val asin : float -> float = "asin_float" +val acos : float -> float = "acos_float" +val atan : float -> float = "atan_float" +val atan2 : float -> float -> float = "atan2_float" +val abs_float : float -> float +val float : int -> float = "float_of_int" +val truncate : float -> int = "int_of_float" + +(* String operations -- more in module String *) + +val (^) : string -> string -> string + +(* Pair operations *) + +val fst : 'a * 'b -> 'a = "%field0" +val snd : 'a * 'b -> 'b = "%field1" + +(* String conversion functions *) + +val string_of_bool : bool -> string +val string_of_int : int -> string +val int_of_string : string -> int = "int_of_string" +val string_of_float : float -> string +val 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 *) +val open_out : string -> out_channel +val open_out_bin : string -> out_channel +val open_out_gen : Sys.open_flag list -> int -> string -> out_channel +val flush : out_channel -> unit = "flush" +val output_char : out_channel -> char -> unit = "output_char" +val output_string : out_channel -> string -> unit +val output : out_channel -> string -> int -> int -> unit +val output_byte : out_channel -> int -> unit = "output_char" +val output_binary_int : out_channel -> int -> unit = "output_int" +val output_value : out_channel -> 'a -> unit = "output_value" +val output_compact_value : out_channel -> 'a -> unit = "output_value" +val seek_out : out_channel -> int -> unit = "seek_out" +val pos_out : out_channel -> int = "pos_out" +val size_out : out_channel -> int = "channel_size" +val 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 : Sys.open_flag list -> int -> string -> in_channel +val 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 +val input_byte : in_channel -> int = "input_char" +val input_binary_int : in_channel -> int = "input_int" +val input_value : in_channel -> 'a = "input_value" +val seek_in : in_channel -> int -> unit = "seek_in" +val pos_in : in_channel -> int = "pos_in" +val in_channel_length : in_channel -> int = "channel_size" +val close_in : in_channel -> unit = "close_in" + +(* References *) + +type 'a ref = { mutable contents: 'a } +val ref: 'a -> 'a ref = "%makeblock" +val (!): 'a ref -> 'a = "%field0" +val (:=): 'a ref -> 'a -> unit = "%setfield0" +val incr: int ref -> unit = "%incr" +val 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 new file mode 100644 index 000000000..740451328 --- /dev/null +++ b/stdlib/printexc.ml @@ -0,0 +1,43 @@ +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 new file mode 100644 index 000000000..0b56bd2a8 --- /dev/null +++ b/stdlib/printexc.mli @@ -0,0 +1,14 @@ +(* 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 new file mode 100644 index 000000000..e13c2a600 --- /dev/null +++ b/stdlib/printf.ml @@ -0,0 +1,86 @@ +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 + match String.get format i with + '%' -> + let j = skip_args (succ i) in + begin match String.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(doint i j) + | 'f' | 'e' | 'E' | 'g' | 'G' -> + Obj.magic(dofloat i 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 + | c -> output_char outchan c; doprn (succ i) + + and skip_args j = + match String.get format j with + '0' .. '9' | ' ' | '.' | '-' -> skip_args (succ j) + | c -> j + + and doint i j n = + let len = j-i in + let fmt = String.create (len+2) in + String.blit format i fmt 0 len; + String.set fmt len 'l'; + String.set fmt (len+1) (String.get format j); + output_string outchan (format_int fmt n); + doprn (succ j) + + and dofloat i j f = + output_string outchan (format_float (String.sub format i (j-i+1)) f); + doprn (succ j) + + in doprn 0 + +let printf fmt = fprintf stdout fmt +and eprintf fmt = fprintf stderr fmt + diff --git a/stdlib/printf.mli b/stdlib/printf.mli new file mode 100644 index 000000000..943f97209 --- /dev/null +++ b/stdlib/printf.mli @@ -0,0 +1,45 @@ +(* 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]. *) + diff --git a/stdlib/queue.ml b/stdlib/queue.ml new file mode 100644 index 000000000..977a26338 --- /dev/null +++ b/stdlib/queue.ml @@ -0,0 +1,58 @@ +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 new file mode 100644 index 000000000..297e81afa --- /dev/null +++ b/stdlib/queue.mli @@ -0,0 +1,28 @@ +(* 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 new file mode 100644 index 000000000..404056308 --- /dev/null +++ b/stdlib/set.ml @@ -0,0 +1,99 @@ +(* 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 + end + +module Make(Ord: OrderedType): (S with elt = Ord.t) = + struct + open Baltree + type elt = Ord.t + type t = elt Baltree.t + + let empty = Empty + + let is_empty = function Empty -> true | _ -> false + + let mem x s = + Baltree.contains (Ord.compare x) s + + let add x s = + Baltree.add (Ord.compare x) x s + + let remove x s = + Baltree.remove (Ord.compare x) s + + let rec union s1 s2 = + match (s1, s2) with + (Empty, t2) -> t2 + | (t1, Empty) -> t1 + | (Node(l1, v1, r1, _), t2) -> + let (l2, _, r2) = Baltree.split (Ord.compare v1) t2 in + Baltree.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 Baltree.split (Ord.compare v1) t2 with + (l2, Nothing, r2) -> + Baltree.concat (inter l1 l2) (inter r1 r2) + | (l2, Something _, r2) -> + Baltree.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 Baltree.split (Ord.compare v1) t2 with + (l2, Nothing, r2) -> + Baltree.join (diff l1 l2) v1 (diff r1 r2) + | (l2, Something _, r2) -> + Baltree.concat (diff l1 l2) (diff r1 r2) + + let compare s1 s2 = + Baltree.compare Ord.compare 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 + + end diff --git a/stdlib/set.mli b/stdlib/set.mli new file mode 100644 index 000000000..4cf37425a --- /dev/null +++ b/stdlib/set.mli @@ -0,0 +1,28 @@ +(* 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 + end + +module Make(Ord: OrderedType): (S with elt = Ord.t) diff --git a/stdlib/sort.ml b/stdlib/sort.ml new file mode 100644 index 000000000..1b694bfff --- /dev/null +++ b/stdlib/sort.ml @@ -0,0 +1,28 @@ +(* 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 new file mode 100644 index 000000000..545a0fad7 --- /dev/null +++ b/stdlib/sort.mli @@ -0,0 +1,13 @@ +(* 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 new file mode 100644 index 000000000..8b1710cdd --- /dev/null +++ b/stdlib/stack.ml @@ -0,0 +1,18 @@ +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 new file mode 100644 index 000000000..a1133edcc --- /dev/null +++ b/stdlib/stack.mli @@ -0,0 +1,25 @@ +(* 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 new file mode 100644 index 000000000..eeb5676a7 --- /dev/null +++ b/stdlib/string.ml @@ -0,0 +1,93 @@ +(* String operations *) + +external length : string -> int = "ml_string_length" +external create: int -> string = "create_string" +external unsafe_get : string -> int -> char = "%string_get" +external unsafe_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 + + +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 new file mode 100644 index 000000000..6dd586f86 --- /dev/null +++ b/stdlib/string.mli @@ -0,0 +1,24 @@ +(* String operations *) + +val length : string -> int = "ml_string_length" + +val get : string -> int -> char +val set : string -> int -> char -> unit + +val 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 escaped: string -> string + +val unsafe_get : string -> int -> char = "%string_get" +val unsafe_set : string -> int -> char -> unit = "%string_set" +val unsafe_blit : string -> int -> string -> int -> int -> unit + = "blit_string" +val unsafe_fill : string -> int -> int -> char -> unit = "fill_string" + + diff --git a/stdlib/sys.ml b/stdlib/sys.ml new file mode 100644 index 000000000..b6172e418 --- /dev/null +++ b/stdlib/sys.ml @@ -0,0 +1,52 @@ +(* System interface *) + +type open_flag = + Open_rdonly | Open_wronly | Open_rdwr + | Open_append | Open_creat | Open_trunc | Open_excl + | Open_binary | Open_text + +external get_argv: unit -> string array = "sys_get_argv" + +let argv = get_argv() + +external remove: string -> unit = "sys_remove" +external getenv: string -> string = "sys_getenv" +external open_desc: string -> open_flag list -> int -> int = "sys_open" +external close_desc: int -> unit = "sys_close" +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 new file mode 100644 index 000000000..b6332a14a --- /dev/null +++ b/stdlib/sys.mli @@ -0,0 +1,45 @@ +(* System interface *) + +type open_flag = + Open_rdonly | Open_wronly | Open_rdwr + | Open_append | Open_creat | Open_trunc | Open_excl + | Open_binary | Open_text + +val argv: string array +val remove: string -> unit = "sys_remove" +val getenv: string -> string = "sys_getenv" +val open_desc: string -> open_flag list -> int -> int = "sys_open" +val close_desc: int -> unit = "sys_close" +val command: string -> int = "sys_system_command" +val chdir: string -> unit = "sys_chdir" + +type signal_behavior = + Signal_default + | Signal_ignore + | Signal_handle of (int -> unit) + +val 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 |