Ekdohibs/camlboot
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Make ocamllex work with miniml

Browse Source
This commit is contained in:
Nathanaël Courant 2021-02-12 15:41:29 +01:00
parent 0903b729ca
commit f4fc51c0b4
9 changed files with 702 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
miniml/compiler/compile.scm
View File

@ -72,8 +72,8 @@
MUTABLE OF OPEN REC SIG STRUCT TO TRY TYPE VAL WHEN WHILE WITH
EOF STRING LIDENT UIDENT INT
(right: MINUSGT)
(left: BAR)
(left: AS)
(left: BAR)
(nonassoc: annot_prec)
(nonassoc: LET MATCH)
(right: SEMICOLON)
@ -244,6 +244,9 @@
(nonempty_variance type_ignore) : '()
(QUOTE type_ignore) : '()
(longident_field type_ignore) : '()
(QUESTION type_ignore) : '()
(TILDE type_ignore) : '()
(COLON type_ignore) : '()
(LPAREN type_ignore RPAREN type_ignore) : '())
(type_count_stars
@ -255,6 +258,9 @@
(type_count_arrows
( ) : 0
(QUESTION type_count_arrows) : $2
(TILDE type_count_arrows) : $2
(COLON type_count_arrows) : $2
(MINUSGT type_count_arrows) : (+ 1 $2)
(longident_field type_count_arrows) : $2
(QUOTE type_count_arrows) : $2

5
miniml/interp/arg.ml
View File

@ -268,11 +268,12 @@ let parse_and_expand_argv_dynamic_aux allow_expand current argv speclist anonfun
let parse_and_expand_argv_dynamic current argv speclist anonfun errmsg =
parse_and_expand_argv_dynamic_aux true current argv speclist anonfun errmsg
let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg =
let current1 = current
let parse_argv_dynamic ?(current=current1) argv speclist anonfun errmsg =
parse_and_expand_argv_dynamic_aux false current (ref argv) speclist anonfun errmsg
let parse_argv ?(current=current) argv speclist anonfun errmsg =
let parse_argv ?(current=current1) argv speclist anonfun errmsg =
parse_argv_dynamic ~current:current argv (ref speclist) anonfun errmsg

13
miniml/interp/format.ml
View File

@ -6,8 +6,8 @@ type formatter_functions = {
let error msg =
print_string msg; print_string "\n"; failwith msg
let mkprintf is_format ff fmt cont =
let out_string = ff.out_string in
let mkprintf is_format print_fun ff fmt cont =
let out_string = print_fun ff in
let rec loop i =
let j = ref i in
while !j < String.length fmt && fmt.[!j] <> '%' && (not is_format || fmt.[!j] <> '@') do
@ -47,10 +47,11 @@ let mkprintf is_format ff fmt cont =
in
loop 0
let printf fmt = mkprintf true { out_string = print_string } fmt (fun () -> ())
let fprintf ff fmt = mkprintf true ff fmt (fun () -> ())
let eprintf fmt = mkprintf true { out_string = print_err } fmt (fun () -> ())
let kbprintf k b fmt = mkprintf true { out_string = Buffer.add_string b } fmt (fun () -> k b)
let getff ff = ff.out_string
let printf fmt = mkprintf true getff { out_string = print_string } fmt (fun () -> ())
let fprintf ff fmt = mkprintf true getff ff fmt (fun () -> ())
let eprintf fmt = mkprintf true getff { out_string = print_err } fmt (fun () -> ())
let kbprintf k b fmt = mkprintf true getff { out_string = Buffer.add_string b } fmt (fun () -> k b)
let bprintf b fmt = kbprintf (fun _ -> ()) b fmt
let kprintf k fmt = kbprintf (fun b -> k (Buffer.contents b)) (Buffer.create 16) fmt
let ksprintf = kprintf

18
miniml/interp/genfilelex.sh Executable file
View File

@ -0,0 +1,18 @@
#!/usr/bin/env bash
files=( int64.ml nativeint.ml seq.ml char.ml bytes.ml string.ml digest.ml marshal.ml array.ml list.ml stack.ml hashtbl.ml map.ml set.ml buffer.ml format.ml printf.ml arg.ml gc.ml filename.ml lexing.ml parsing.ml ../../ocaml-src/lex/cset.ml ../../ocaml-src/lex/syntax.ml ../../ocaml-src/lex/parser.ml ../../ocaml-src/lex/lexer.ml ../../ocaml-src/lex/table.ml ../../ocaml-src/lex/lexgen.ml ../../ocaml-src/lex/compact.ml ../../ocaml-src/lex/common.ml ../../ocaml-src/lex/output.ml ../../ocaml-src/lex/outputbis.ml ../../ocaml-src/lex/main.ml )
modules=( Int64 Nativeint Seq Char Bytes String Digest Marshal Array List Stack Hashtbl Map Set Buffer Format Printf Arg Gc Filename Lexing Parsing Cset Syntax Parser Lexer Table Lexgen Compact Common Output Outputbis Main )
out=outlex.ml
cat std.ml > $out
for i in "${!files[@]}"; do
f=${files[$i]}
m=${modules[$i]}
echo "module $m = struct" >> $out
echo "# 1 \"$f\"" >> $out
cat $f >> $out
echo "# $(($(wc -l < $out) + 2)) \"$out\"" >> $out
echo "end" >> $out
echo >> $out
done
camlboot_path_esc=$(realpath "$(dirname "$0")"/../.. | sed 's_/_\\/_g')
sed -i "s#%CAMLBOOT_PATH%#$camlboot_path_esc#" $out
sed -i "s/lexbuf.Lexing.refill_buff/Lexing.refill_buff/" $out

596
miniml/interp/hashtbl.ml
View File

@ -1,5 +1,595 @@
external seeded_hash_param : int -> int -> int -> 'a -> int = "caml_hash"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* Hash tables *)
external seeded_hash_param :
int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
external old_hash_param :
int -> int -> 'a -> int = "caml_hash_univ_param" [@@noalloc]
let find t x = List.assoc x t
let mem t x = List.mem_assoc x t
let hash x = seeded_hash_param 10 100 0 x
let hash_param n1 n2 x = seeded_hash_param n1 n2 0 x
let seeded_hash seed x = seeded_hash_param 10 100 seed x
(* We do dynamic hashing, and resize the table and rehash the elements
when buckets become too long. *)
type ('a, 'b) t =
{ mutable size: int; (* number of entries *)
mutable data: ('a, 'b) bucketlist array; (* the buckets *)
mutable seed: int; (* for randomization *)
mutable initial_size: int; (* initial array size *)
}
and ('a, 'b) bucketlist =
Empty
| Cons of { mutable key: 'a;
mutable kdata: 'b;
mutable next: ('a, 'b) bucketlist }
(* The sign of initial_size encodes the fact that a traversal is
ongoing or not.
This disables the efficient in place implementation of resizing.
*)
let ongoing_traversal h =
Obj.size (Obj.repr h) < 4 (* compatibility with old hash tables *)
|| h.initial_size < 0
let flip_ongoing_traversal h =
h.initial_size <- - h.initial_size
(* To pick random seeds if requested *)
let randomized_default =
let params =
try Sys.getenv "OCAMLRUNPARAM" with Not_found ->
try Sys.getenv "CAMLRUNPARAM" with Not_found -> "" in
String.contains params 'R'
let randomized = ref randomized_default
let randomize () = randomized := true
let is_randomized () = !randomized
let prng = 0 (* lazy (Random.State.make_self_init()) *)
(* Creating a fresh, empty table *)
let rec power_2_above x n =
if x >= n then x
else if x * 2 > Sys.max_array_length then x
else power_2_above (x * 2) n
let create ?(random = !randomized) initial_size =
let s = power_2_above 16 initial_size in
let seed = (* if random then Random.State.bits (Lazy.force prng) else 0 in *) 0 in
{ initial_size = s; size = 0; seed = seed; data = Array.make s Empty }
let clear h =
h.size <- 0;
let len = Array.length h.data in
for i = 0 to len - 1 do
h.data.(i) <- Empty
done
let reset h =
let len = Array.length h.data in
if Obj.size (Obj.repr h) < 4 (* compatibility with old hash tables *)
|| len = abs h.initial_size then
clear h
else begin
h.size <- 0;
h.data <- Array.make (abs h.initial_size) Empty
end
let copy_bucketlist = function
| Empty -> Empty
| Cons {key; kdata; next} ->
let rec loop prec = function
| Empty -> ()
| Cons {key; kdata; next} ->
let r = Cons {key; kdata; next} in
begin match prec with
| Empty -> assert false
| Cons prec -> prec.next <- r
end;
loop r next
in
let r = Cons {key; kdata; next} in
loop r next;
r
let copy h = { h with data = Array.map copy_bucketlist h.data }
let length h = h.size
let resize indexfun h =
let odata = h.data in
let osize = Array.length odata in
let nsize = osize * 2 in
if nsize < Sys.max_array_length then begin
let ndata = Array.make nsize Empty in
let ndata_tail = Array.make nsize Empty in
let inplace = not (ongoing_traversal h) in
h.data <- ndata; (* so that indexfun sees the new bucket count *)
let rec insert_bucket = function
| Empty -> ()
| Cons {key; kdata; next} as cell ->
let cell =
if inplace then cell
else Cons {key; kdata; next = Empty}
in
let nidx = indexfun h key in
begin match ndata_tail.(nidx) with
| Empty -> ndata.(nidx) <- cell;
| Cons tail -> tail.next <- cell;
end;
ndata_tail.(nidx) <- cell;
insert_bucket next
in
for i = 0 to osize - 1 do
insert_bucket odata.(i)
done;
if inplace then
for i = 0 to nsize - 1 do
match ndata_tail.(i) with
| Empty -> ()
| Cons tail -> tail.next <- Empty
done;
end
let key_index h key =
(* compatibility with old hash tables *)
if Obj.size (Obj.repr h) >= 3
then (seeded_hash_param 10 100 h.seed key) land (Array.length h.data - 1)
else (old_hash_param 10 100 key) mod (Array.length h.data)
let add h key data =
let i = key_index h key in
let bucket = Cons{key; kdata=data; next=h.data.(i)} in
h.data.(i) <- bucket;
h.size <- h.size + 1;
if h.size > Array.length h.data lsl 1 then resize key_index h
let rec remove_bucket h i key prec = function
| Empty ->
()
| (Cons {key=k; next}) as c ->
if compare k key = 0
then begin
h.size <- h.size - 1;
match prec with
| Empty -> h.data.(i) <- next
| Cons c -> c.next <- next
end
else remove_bucket h i key c next
let remove h key =
let i = key_index h key in
remove_bucket h i key Empty h.data.(i)
let rec find_rec key = function
| Empty ->
raise Not_found
| Cons{key=k; kdata; next} ->
if compare key k = 0 then kdata else find_rec key next
let find h key =
match h.data.(key_index h key) with
| Empty -> raise Not_found
| Cons{key=k1; kdata=d1; next=next1} ->
if compare key k1 = 0 then d1 else
match next1 with
| Empty -> raise Not_found
| Cons{key=k2; kdata=d2; next=next2} ->
if compare key k2 = 0 then d2 else
match next2 with
| Empty -> raise Not_found
| Cons{key=k3; kdata=d3; next=next3} ->
if compare key k3 = 0 then d3 else find_rec key next3
let rec find_rec_opt key = function
| Empty ->
None
| Cons{key=k; kdata; next} ->
if compare key k = 0 then Some kdata else find_rec_opt key next
let find_opt h key =
match h.data.(key_index h key) with
| Empty -> None
| Cons{key=k1; kdata=d1; next=next1} ->
if compare key k1 = 0 then Some d1 else
match next1 with
| Empty -> None
| Cons{key=k2; kdata=d2; next=next2} ->
if compare key k2 = 0 then Some d2 else
match next2 with
| Empty -> None
| Cons{key=k3; kdata=d3; next=next3} ->
if compare key k3 = 0 then Some d3 else find_rec_opt key next3
let find_all h key =
let rec find_in_bucket = function
| Empty ->
[]
| Cons{key=k; kdata; next} ->
if compare k key = 0
then kdata :: find_in_bucket next
else find_in_bucket next in
find_in_bucket h.data.(key_index h key)
let rec replace_bucket key data = function
| Empty ->
true
| Cons ({key=k; next} as slot) ->
if compare k key = 0
then (slot.key <- key; slot.kdata <- data; false)
else replace_bucket key data next
let replace h key data =
let i = key_index h key in
let l = h.data.(i) in
if replace_bucket key data l then begin
h.data.(i) <- Cons{key; kdata=data; next=l};
h.size <- h.size + 1;
if h.size > Array.length h.data lsl 1 then resize key_index h
end
let mem h key =
let rec mem_in_bucket = function
| Empty ->
false
| Cons{key=k; next} ->
compare k key = 0 || mem_in_bucket next in
mem_in_bucket h.data.(key_index h key)
let iter f h =
let rec do_bucket = function
| Empty ->
()
| Cons{key; kdata; next} ->
f key kdata; do_bucket next in
let old_trav = ongoing_traversal h in
if not old_trav then flip_ongoing_traversal h;
try
let d = h.data in
for i = 0 to Array.length d - 1 do
do_bucket d.(i)
done;
if not old_trav then flip_ongoing_traversal h;
with exn when not old_trav ->
flip_ongoing_traversal h;
raise exn
let rec filter_map_inplace_bucket f h i prec = function
| Empty ->
begin match prec with
| Empty -> h.data.(i) <- Empty
| Cons c -> c.next <- Empty
end
| (Cons ({key; kdata; next} as c)) as slot ->
begin match f key kdata with
| None ->
h.size <- h.size - 1;
filter_map_inplace_bucket f h i prec next
| Some kdata ->
begin match prec with
| Empty -> h.data.(i) <- slot
| Cons c -> c.next <- slot
end;
c.kdata <- kdata;
filter_map_inplace_bucket f h i slot next
end
let filter_map_inplace f h =
let d = h.data in
let old_trav = ongoing_traversal h in
if not old_trav then flip_ongoing_traversal h;
try
for i = 0 to Array.length d - 1 do
filter_map_inplace_bucket f h i Empty h.data.(i)
done
with exn when not old_trav ->
flip_ongoing_traversal h;
raise exn
let fold f h init =
let rec do_bucket b accu =
match b with
Empty ->
accu
| Cons{key; kdata; next} ->
do_bucket next (f key kdata accu) in
let old_trav = ongoing_traversal h in
if not old_trav then flip_ongoing_traversal h;
try
let d = h.data in
let accu = ref init in
for i = 0 to Array.length d - 1 do
accu := do_bucket d.(i) !accu
done;
if not old_trav then flip_ongoing_traversal h;
!accu
with exn when not old_trav ->
flip_ongoing_traversal h;
raise exn
type statistics = {
num_bindings: int;
num_buckets: int;
max_bucket_length: int;
bucket_histogram: int array
}
let rec bucket_length accu = function
| Empty -> accu
| Cons{next} -> bucket_length (accu + 1) next
let stats h =
let mbl =
Array.fold_left (fun m b -> max m (bucket_length 0 b)) 0 h.data in
let histo = Array.make (mbl + 1) 0 in
Array.iter
(fun b ->
let l = bucket_length 0 b in
histo.(l) <- histo.(l) + 1)
h.data;
{ num_bindings = h.size;
num_buckets = Array.length h.data;
max_bucket_length = mbl;
bucket_histogram = histo }
(** {6 Iterators} *)
let to_seq tbl =
(* capture current array, so that even if the table is resized we
keep iterating on the same array *)
let tbl_data = tbl.data in
(* state: index * next bucket to traverse *)
let rec aux i buck () = match buck with
| Empty ->
if i = Array.length tbl_data
then Seq.Nil
else aux(i+1) tbl_data.(i) ()
| Cons {key; kdata; next} ->
Seq.Cons ((key, kdata), aux i next)
in
aux 0 Empty
let to_seq_keys m = Seq.map fst (to_seq m)
let to_seq_values m = Seq.map snd (to_seq m)
let add_seq tbl i =
Seq.iter (fun (k,v) -> add tbl k v) i
let replace_seq tbl i =
Seq.iter (fun (k,v) -> replace tbl k v) i
let of_seq i =
let tbl = create 16 in
replace_seq tbl i;
tbl
(* Functorial interface *)
(*
module type HashedType =
sig
type t
val equal: t -> t -> bool
val hash: t -> int
end
module type SeededHashedType =
sig
type t
val equal: t -> t -> bool
val hash: int -> t -> int
end
module type S =
sig
type key
type 'a t
val create: int -> 'a t
val clear : 'a t -> unit
val reset : 'a t -> unit
val copy: 'a t -> 'a t
val add: 'a t -> key -> 'a -> unit
val remove: 'a t -> key -> unit
val find: 'a t -> key -> 'a
val find_opt: 'a t -> key -> 'a option
val find_all: 'a t -> key -> 'a list
val replace : 'a t -> key -> 'a -> unit
val mem : 'a t -> key -> bool
val iter: (key -> 'a -> unit) -> 'a t -> unit
val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit
val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val length: 'a t -> int
val stats: 'a t -> statistics
val to_seq : 'a t -> (key * 'a) Seq.t
val to_seq_keys : _ t -> key Seq.t
val to_seq_values : 'a t -> 'a Seq.t
val add_seq : 'a t -> (key * 'a) Seq.t -> unit
val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
val of_seq : (key * 'a) Seq.t -> 'a t
end
module type SeededS =
sig
type key
type 'a t
val create : ?random:bool -> int -> 'a t
val clear : 'a t -> unit
val reset : 'a t -> unit
val copy : 'a t -> 'a t
val add : 'a t -> key -> 'a -> unit
val remove : 'a t -> key -> unit
val find : 'a t -> key -> 'a
val find_opt: 'a t -> key -> 'a option
val find_all : 'a t -> key -> 'a list
val replace : 'a t -> key -> 'a -> unit
val mem : 'a t -> key -> bool
val iter : (key -> 'a -> unit) -> 'a t -> unit
val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val length : 'a t -> int
val stats: 'a t -> statistics
val to_seq : 'a t -> (key * 'a) Seq.t
val to_seq_keys : _ t -> key Seq.t
val to_seq_values : 'a t -> 'a Seq.t
val add_seq : 'a t -> (key * 'a) Seq.t -> unit
val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
val of_seq : (key * 'a) Seq.t -> 'a t
end
module MakeSeeded(H: SeededHashedType): (SeededS with type key = H.t) =
struct
type key = H.t
type 'a hashtbl = (key, 'a) t
type 'a t = 'a hashtbl
let create = create
let clear = clear
let reset = reset
let copy = copy
let key_index h key =
(H.hash h.seed key) land (Array.length h.data - 1)
let add h key data =
let i = key_index h key in
let bucket = Cons{key; data; next=h.data.(i)} in
h.data.(i) <- bucket;
h.size <- h.size + 1;
if h.size > Array.length h.data lsl 1 then resize key_index h
let rec remove_bucket h i key prec = function
| Empty ->
()
| (Cons {key=k; next}) as c ->
if H.equal k key
then begin
h.size <- h.size - 1;
match prec with
| Empty -> h.data.(i) <- next
| Cons c -> c.next <- next
end
else remove_bucket h i key c next
let remove h key =
let i = key_index h key in
remove_bucket h i key Empty h.data.(i)
let rec find_rec key = function
| Empty ->
raise Not_found
| Cons{key=k; data; next} ->
if H.equal key k then data else find_rec key next
let find h key =
match h.data.(key_index h key) with
| Empty -> raise Not_found
| Cons{key=k1; data=d1; next=next1} ->
if H.equal key k1 then d1 else
match next1 with
| Empty -> raise Not_found
| Cons{key=k2; data=d2; next=next2} ->
if H.equal key k2 then d2 else
match next2 with
| Empty -> raise Not_found
| Cons{key=k3; data=d3; next=next3} ->
if H.equal key k3 then d3 else find_rec key next3
let rec find_rec_opt key = function
| Empty ->
None
| Cons{key=k; data; next} ->
if H.equal key k then Some data else find_rec_opt key next
let find_opt h key =
match h.data.(key_index h key) with
| Empty -> None
| Cons{key=k1; data=d1; next=next1} ->
if H.equal key k1 then Some d1 else
match next1 with
| Empty -> None
| Cons{key=k2; data=d2; next=next2} ->
if H.equal key k2 then Some d2 else
match next2 with
| Empty -> None
| Cons{key=k3; data=d3; next=next3} ->
if H.equal key k3 then Some d3 else find_rec_opt key next3
let find_all h key =
let rec find_in_bucket = function
| Empty ->
[]
| Cons{key=k; data=d; next} ->
if H.equal k key
then d :: find_in_bucket next
else find_in_bucket next in
find_in_bucket h.data.(key_index h key)
let rec replace_bucket key data = function
| Empty ->
true
| Cons ({key=k; next} as slot) ->
if H.equal k key
then (slot.key <- key; slot.data <- data; false)
else replace_bucket key data next
let replace h key data =
let i = key_index h key in
let l = h.data.(i) in
if replace_bucket key data l then begin
h.data.(i) <- Cons{key; data; next=l};
h.size <- h.size + 1;
if h.size > Array.length h.data lsl 1 then resize key_index h
end
let mem h key =
let rec mem_in_bucket = function
| Empty ->
false
| Cons{key=k; next} ->
H.equal k key || mem_in_bucket next in
mem_in_bucket h.data.(key_index h key)
let iter = iter
let filter_map_inplace = filter_map_inplace
let fold = fold
let length = length
let stats = stats
let to_seq = to_seq
let to_seq_keys = to_seq_keys
let to_seq_values = to_seq_values
let add_seq = add_seq
let replace_seq = replace_seq
let of_seq = of_seq
end
module Make(H: HashedType): (S with type key = H.t) =
struct
include MakeSeeded(struct
type t = H.t
let equal = H.equal
let hash (_seed: int) x = H.hash x
end)
let create sz = create ~random:false sz
end
*)

12
miniml/interp/printf.ml
View File

@ -1,7 +1,11 @@
let printf fmt = Format.(mkprintf false { out_string = print_string } fmt (fun () -> ()))
let fprintf ff fmt = Format.(mkprintf false ff fmt (fun () -> ()))
let eprintf fmt = Format.(mkprintf false { out_string = print_err } fmt (fun () -> ()))
let kbprintf k b fmt = Format.(mkprintf false { out_string = Buffer.add_string b } fmt (fun () -> k b))
let getff ff = ff.Format.out_string
let getoc oc = output_string oc
let printf fmt = Format.(mkprintf false getoc stdout fmt (fun () -> ()))
let fprintf ff fmt = Format.(mkprintf false getoc ff fmt (fun () -> ()))
let eprintf fmt = Format.(mkprintf false getoc stderr fmt (fun () -> ()))
let kbprintf k b fmt = Format.(mkprintf false getff { out_string = Buffer.add_string b } fmt (fun () -> k b))
let bprintf b fmt = kbprintf (fun _ -> ()) b fmt
let kprintf k fmt = kbprintf (fun b -> k (Buffer.contents b)) (Buffer.create 16) fmt
let ksprintf = kprintf

56
miniml/interp/stack.ml Normal file
View File

@ -0,0 +1,56 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
type 'a t = { mutable c : 'a list; mutable len : int; }
exception Empty
let create () = { c = []; len = 0; }
let clear s = s.c <- []; s.len <- 0
let copy s = { c = s.c; len = s.len; }
let push x s = s.c <- x :: s.c; s.len <- s.len + 1
let pop s =
match s.c with
| hd::tl -> s.c <- tl; s.len <- s.len - 1; hd
| [] -> raise Empty
let top s =
match s.c with
| hd::_ -> hd
| [] -> raise Empty
let is_empty s = (s.c = [])
let length s = s.len
let iter f s = List.iter f s.c
let fold f acc s = List.fold_left f acc s.c
(** {6 Iterators} *)
let to_seq s = List.to_seq s.c
let add_seq q i = Seq.iter (fun x -> push x q) i
let of_seq g =
let s = create() in
add_seq s g;
s

9
miniml/interp/std.ml
View File

@ -41,6 +41,8 @@ let min_int = max_int + 1
let min x y = if x <= y then x else y
let max x y = if x >= y then x else y
let abs x = if x < 0 then -x else x
type bool = false | true
type 'a ref = { mutable contents : 'a }
type ('a, 'b) result = Ok of 'a | Error of 'b
@ -161,6 +163,7 @@ let open_out_bin name =
open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 438 (* 0o666 *) name
external close_in : in_channel -> unit = "caml_ml_close_channel"
let close_in_noerr ic = try close_in ic with _ -> ()
external flush : out_channel -> unit = "caml_ml_flush"
external close_out_channel : out_channel -> unit = "caml_ml_close_channel"
let close_out oc = flush oc; close_out_channel oc
@ -184,6 +187,8 @@ let output_string oc s =
unsafe_output_string oc s 0 (string_length s)
let print_string s = output_string stdout s; flush stdout
let print_newline () = print_string "\n"
let print_endline s = print_string s; print_newline ()
let print_err s = output_string stderr s; flush stderr
external unsafe_input : in_channel -> bytes -> int -> int -> int
@ -230,6 +235,7 @@ module Sys = struct
with Not_found -> None
let max_string_length = (1 lsl 57) - 9
let max_array_length = (1 lsl 54) - 1
let word_size = 8
external get_argv: unit -> string * string array = "caml_sys_get_argv"
@ -242,6 +248,9 @@ module Sys = struct
external getcwd: unit -> string = "caml_sys_getcwd"
external rename : string -> string -> unit = "caml_sys_rename"
external remove: string -> unit = "caml_sys_remove"
let os_type = ""
let ocaml_version = "camlboot"
end

2
ocaml-src

@ -1 +1 @@
Subproject commit 5f0e7b9b65357d6cd5d8e51e4b53957c7ac10d8e
Subproject commit 24db971eea8dbf9a5ec3f5526cf171a320d8388c