diff options
Diffstat (limited to 'ocaml-binary-annot/stdlib')
100 files changed, 18357 insertions, 0 deletions
diff --git a/ocaml-binary-annot/stdlib/.cvsignore b/ocaml-binary-annot/stdlib/.cvsignore new file mode 100644 index 0000000000..6aa0cd421b --- /dev/null +++ b/ocaml-binary-annot/stdlib/.cvsignore @@ -0,0 +1,7 @@ +camlheader +camlheader_ur +labelled-* +caml +*.annot +sys.ml +*.a diff --git a/ocaml-binary-annot/stdlib/.depend b/ocaml-binary-annot/stdlib/.depend new file mode 100644 index 0000000000..0267136b71 --- /dev/null +++ b/ocaml-binary-annot/stdlib/.depend @@ -0,0 +1,248 @@ +arg.cmi: +array.cmi: +arrayLabels.cmi: +buffer.cmi: +callback.cmi: +camlinternalLazy.cmi: +camlinternalMod.cmi: obj.cmi +camlinternalOO.cmi: obj.cmi +char.cmi: +complex.cmi: +digest.cmi: +filename.cmi: +format.cmi: pervasives.cmi buffer.cmi +gc.cmi: +genlex.cmi: stream.cmi +hashtbl.cmi: +int32.cmi: +int64.cmi: +lazy.cmi: +lexing.cmi: +list.cmi: +listLabels.cmi: +map.cmi: +marshal.cmi: +moreLabels.cmi: set.cmi map.cmi hashtbl.cmi +nativeint.cmi: +obj.cmi: int32.cmi +oo.cmi: camlinternalOO.cmi +parsing.cmi: obj.cmi lexing.cmi +pervasives.cmi: +printexc.cmi: +printf.cmi: obj.cmi buffer.cmi +queue.cmi: +random.cmi: nativeint.cmi int64.cmi int32.cmi +scanf.cmi: pervasives.cmi +set.cmi: +sort.cmi: +stack.cmi: +stdLabels.cmi: +stream.cmi: +string.cmi: +stringLabels.cmi: +sys.cmi: +weak.cmi: hashtbl.cmi +arg.cmo: sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi arg.cmi +arg.cmx: sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx arg.cmi +array.cmo: array.cmi +array.cmx: array.cmi +arrayLabels.cmo: array.cmi arrayLabels.cmi +arrayLabels.cmx: array.cmx arrayLabels.cmi +buffer.cmo: sys.cmi string.cmi buffer.cmi +buffer.cmx: sys.cmx string.cmx buffer.cmi +callback.cmo: obj.cmi callback.cmi +callback.cmx: obj.cmx callback.cmi +camlinternalLazy.cmo: obj.cmi camlinternalLazy.cmi +camlinternalLazy.cmx: obj.cmx camlinternalLazy.cmi +camlinternalMod.cmo: obj.cmi camlinternalOO.cmi array.cmi camlinternalMod.cmi +camlinternalMod.cmx: obj.cmx camlinternalOO.cmx array.cmx camlinternalMod.cmi +camlinternalOO.cmo: sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \ + array.cmi camlinternalOO.cmi +camlinternalOO.cmx: sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \ + array.cmx camlinternalOO.cmi +char.cmo: char.cmi +char.cmx: char.cmi +complex.cmo: complex.cmi +complex.cmx: complex.cmi +digest.cmo: string.cmi printf.cmi digest.cmi +digest.cmx: string.cmx printf.cmx digest.cmi +filename.cmo: sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \ + filename.cmi +filename.cmx: sys.cmx string.cmx random.cmx printf.cmx buffer.cmx \ + filename.cmi +format.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi buffer.cmi \ + format.cmi +format.cmx: string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx buffer.cmx \ + format.cmi +gc.cmo: sys.cmi printf.cmi gc.cmi +gc.cmx: sys.cmx printf.cmx gc.cmi +genlex.cmo: string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi +genlex.cmx: string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx genlex.cmi +hashtbl.cmo: sys.cmi array.cmi hashtbl.cmi +hashtbl.cmx: sys.cmx array.cmx hashtbl.cmi +int32.cmo: pervasives.cmi int32.cmi +int32.cmx: pervasives.cmx int32.cmi +int64.cmo: pervasives.cmi int64.cmi +int64.cmx: pervasives.cmx int64.cmi +lazy.cmo: obj.cmi camlinternalLazy.cmi lazy.cmi +lazy.cmx: obj.cmx camlinternalLazy.cmx lazy.cmi +lexing.cmo: sys.cmi string.cmi array.cmi lexing.cmi +lexing.cmx: sys.cmx string.cmx array.cmx lexing.cmi +list.cmo: list.cmi +list.cmx: list.cmi +listLabels.cmo: list.cmi listLabels.cmi +listLabels.cmx: list.cmx listLabels.cmi +map.cmo: map.cmi +map.cmx: map.cmi +marshal.cmo: string.cmi marshal.cmi +marshal.cmx: string.cmx marshal.cmi +moreLabels.cmo: set.cmi map.cmi hashtbl.cmi moreLabels.cmi +moreLabels.cmx: set.cmx map.cmx hashtbl.cmx moreLabels.cmi +nativeint.cmo: sys.cmi pervasives.cmi nativeint.cmi +nativeint.cmx: sys.cmx pervasives.cmx nativeint.cmi +obj.cmo: marshal.cmi int32.cmi array.cmi obj.cmi +obj.cmx: marshal.cmx int32.cmx array.cmx obj.cmi +oo.cmo: camlinternalOO.cmi oo.cmi +oo.cmx: camlinternalOO.cmx oo.cmi +parsing.cmo: obj.cmi lexing.cmi array.cmi parsing.cmi +parsing.cmx: obj.cmx lexing.cmx array.cmx parsing.cmi +pervasives.cmo: pervasives.cmi +pervasives.cmx: pervasives.cmi +printexc.cmo: printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi +printexc.cmx: printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi +printf.cmo: string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \ + array.cmi printf.cmi +printf.cmx: string.cmx pervasives.cmx obj.cmx list.cmx char.cmx buffer.cmx \ + array.cmx printf.cmi +queue.cmo: obj.cmi queue.cmi +queue.cmx: obj.cmx queue.cmi +random.cmo: string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ + digest.cmi char.cmi array.cmi random.cmi +random.cmx: string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \ + digest.cmx char.cmx array.cmx random.cmi +scanf.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi hashtbl.cmi \ + buffer.cmi array.cmi scanf.cmi +scanf.cmx: string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx hashtbl.cmx \ + buffer.cmx array.cmx scanf.cmi +set.cmo: set.cmi +set.cmx: set.cmi +sort.cmo: array.cmi sort.cmi +sort.cmx: array.cmx sort.cmi +stack.cmo: list.cmi stack.cmi +stack.cmx: list.cmx stack.cmi +stdLabels.cmo: stringLabels.cmi listLabels.cmi arrayLabels.cmi stdLabels.cmi +stdLabels.cmx: stringLabels.cmx listLabels.cmx arrayLabels.cmx stdLabels.cmi +std_exit.cmo: +std_exit.cmx: +stream.cmo: string.cmi obj.cmi list.cmi lazy.cmi stream.cmi +stream.cmx: string.cmx obj.cmx list.cmx lazy.cmx stream.cmi +string.cmo: pervasives.cmi list.cmi char.cmi string.cmi +string.cmx: pervasives.cmx list.cmx char.cmx string.cmi +stringLabels.cmo: string.cmi stringLabels.cmi +stringLabels.cmx: string.cmx stringLabels.cmi +sys.cmo: sys.cmi +sys.cmx: sys.cmi +weak.cmo: sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi +weak.cmx: sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi +arg.cmo: sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi arg.cmi +arg.p.cmx: sys.p.cmx string.p.cmx printf.p.cmx list.p.cmx buffer.p.cmx array.p.cmx arg.cmi +array.cmo: array.cmi +array.p.cmx: array.cmi +arrayLabels.cmo: array.cmi arrayLabels.cmi +arrayLabels.p.cmx: array.p.cmx arrayLabels.cmi +buffer.cmo: sys.cmi string.cmi buffer.cmi +buffer.p.cmx: sys.p.cmx string.p.cmx buffer.cmi +callback.cmo: obj.cmi callback.cmi +callback.p.cmx: obj.p.cmx callback.cmi +camlinternalLazy.cmo: obj.cmi camlinternalLazy.cmi +camlinternalLazy.p.cmx: obj.p.cmx camlinternalLazy.cmi +camlinternalMod.cmo: obj.cmi camlinternalOO.cmi array.cmi camlinternalMod.cmi +camlinternalMod.p.cmx: obj.p.cmx camlinternalOO.p.cmx array.p.cmx camlinternalMod.cmi +camlinternalOO.cmo: sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \ + array.cmi camlinternalOO.cmi +camlinternalOO.p.cmx: sys.p.cmx string.p.cmx obj.p.cmx map.p.cmx list.p.cmx char.p.cmx \ + array.p.cmx camlinternalOO.cmi +char.cmo: char.cmi +char.p.cmx: char.cmi +complex.cmo: complex.cmi +complex.p.cmx: complex.cmi +digest.cmo: string.cmi printf.cmi digest.cmi +digest.p.cmx: string.p.cmx printf.p.cmx digest.cmi +filename.cmo: sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \ + filename.cmi +filename.p.cmx: sys.p.cmx string.p.cmx random.p.cmx printf.p.cmx buffer.p.cmx \ + filename.cmi +format.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi buffer.cmi \ + format.cmi +format.p.cmx: string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx buffer.p.cmx \ + format.cmi +gc.cmo: sys.cmi printf.cmi gc.cmi +gc.p.cmx: sys.p.cmx printf.p.cmx gc.cmi +genlex.cmo: string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi +genlex.p.cmx: string.p.cmx stream.p.cmx list.p.cmx hashtbl.p.cmx char.p.cmx genlex.cmi +hashtbl.cmo: sys.cmi array.cmi hashtbl.cmi +hashtbl.p.cmx: sys.p.cmx array.p.cmx hashtbl.cmi +int32.cmo: pervasives.cmi int32.cmi +int32.p.cmx: pervasives.p.cmx int32.cmi +int64.cmo: pervasives.cmi int64.cmi +int64.p.cmx: pervasives.p.cmx int64.cmi +lazy.cmo: obj.cmi camlinternalLazy.cmi lazy.cmi +lazy.p.cmx: obj.p.cmx camlinternalLazy.p.cmx lazy.cmi +lexing.cmo: sys.cmi string.cmi array.cmi lexing.cmi +lexing.p.cmx: sys.p.cmx string.p.cmx array.p.cmx lexing.cmi +list.cmo: list.cmi +list.p.cmx: list.cmi +listLabels.cmo: list.cmi listLabels.cmi +listLabels.p.cmx: list.p.cmx listLabels.cmi +map.cmo: map.cmi +map.p.cmx: map.cmi +marshal.cmo: string.cmi marshal.cmi +marshal.p.cmx: string.p.cmx marshal.cmi +moreLabels.cmo: set.cmi map.cmi hashtbl.cmi moreLabels.cmi +moreLabels.p.cmx: set.p.cmx map.p.cmx hashtbl.p.cmx moreLabels.cmi +nativeint.cmo: sys.cmi pervasives.cmi nativeint.cmi +nativeint.p.cmx: sys.p.cmx pervasives.p.cmx nativeint.cmi +obj.cmo: marshal.cmi int32.cmi array.cmi obj.cmi +obj.p.cmx: marshal.p.cmx int32.p.cmx array.p.cmx obj.cmi +oo.cmo: camlinternalOO.cmi oo.cmi +oo.p.cmx: camlinternalOO.p.cmx oo.cmi +parsing.cmo: obj.cmi lexing.cmi array.cmi parsing.cmi +parsing.p.cmx: obj.p.cmx lexing.p.cmx array.p.cmx parsing.cmi +pervasives.cmo: pervasives.cmi +pervasives.p.cmx: pervasives.cmi +printexc.cmo: printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi +printexc.p.cmx: printf.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx printexc.cmi +printf.cmo: string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \ + array.cmi printf.cmi +printf.p.cmx: string.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx \ + array.p.cmx printf.cmi +queue.cmo: obj.cmi queue.cmi +queue.p.cmx: obj.p.cmx queue.cmi +random.cmo: string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ + digest.cmi char.cmi array.cmi random.cmi +random.p.cmx: string.p.cmx pervasives.p.cmx nativeint.p.cmx int64.p.cmx int32.p.cmx \ + digest.p.cmx char.p.cmx array.p.cmx random.cmi +scanf.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi hashtbl.cmi \ + buffer.cmi array.cmi scanf.cmi +scanf.p.cmx: string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx hashtbl.p.cmx \ + buffer.p.cmx array.p.cmx scanf.cmi +set.cmo: set.cmi +set.p.cmx: set.cmi +sort.cmo: array.cmi sort.cmi +sort.p.cmx: array.p.cmx sort.cmi +stack.cmo: list.cmi stack.cmi +stack.p.cmx: list.p.cmx stack.cmi +stdLabels.cmo: stringLabels.cmi listLabels.cmi arrayLabels.cmi stdLabels.cmi +stdLabels.p.cmx: stringLabels.p.cmx listLabels.p.cmx arrayLabels.p.cmx stdLabels.cmi +std_exit.cmo: +std_exit.p.cmx: +stream.cmo: string.cmi obj.cmi list.cmi lazy.cmi stream.cmi +stream.p.cmx: string.p.cmx obj.p.cmx list.p.cmx lazy.p.cmx stream.cmi +string.cmo: pervasives.cmi list.cmi char.cmi string.cmi +string.p.cmx: pervasives.p.cmx list.p.cmx char.p.cmx string.cmi +stringLabels.cmo: string.cmi stringLabels.cmi +stringLabels.p.cmx: string.p.cmx stringLabels.cmi +sys.cmo: sys.cmi +sys.p.cmx: sys.cmi +weak.cmo: sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi +weak.p.cmx: sys.p.cmx obj.p.cmx hashtbl.p.cmx array.p.cmx weak.cmi diff --git a/ocaml-binary-annot/stdlib/Compflags b/ocaml-binary-annot/stdlib/Compflags new file mode 100755 index 0000000000..862a1c4e1e --- /dev/null +++ b/ocaml-binary-annot/stdlib/Compflags @@ -0,0 +1,27 @@ +#!/bin/sh +######################################################################### +# # +# Objective Caml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../LICENSE. # +# # +######################################################################### + +# $Id$ + +case $1 in + pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';; + camlinternalOO.cmi) echo ' -nopervasives';; + camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';; + scanf.cmx|scanf.p.cmx) echo ' -inline 9';; + arrayLabels.cm[ox]|arrayLabels.p.cmx) echo ' -nolabels';; + listLabels.cm[ox]|listLabels.p.cmx) echo ' -nolabels';; + stringLabels.cm[ox]|stringLabels.p.cmx) echo ' -nolabels';; + moreLabels.cm[ox]|moreLabels.p.cmx) echo ' -nolabels';; + *) echo ' ';; +esac diff --git a/ocaml-binary-annot/stdlib/Makefile b/ocaml-binary-annot/stdlib/Makefile new file mode 100644 index 0000000000..874dcf6f9e --- /dev/null +++ b/ocaml-binary-annot/stdlib/Makefile @@ -0,0 +1,59 @@ +######################################################################### +# # +# Objective Caml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../LICENSE. # +# # +######################################################################### + +# $Id$ + +include Makefile.shared + +allopt: stdlib.cmxa std_exit.cmx allopt-$(PROFILING) + +allopt-noprof: + +allopt-prof: stdlib.p.cmxa std_exit.p.cmx + rm -f std_exit.p.cmi + +installopt: installopt-default installopt-$(PROFILING) + +installopt-default: + cp stdlib.cmxa stdlib.a std_exit.o *.cmx $(LIBDIR) + cd $(LIBDIR); $(RANLIB) stdlib.a + +installopt-noprof: + rm -f $(LIBDIR)/stdlib.p.cmxa; ln -s stdlib.cmxa $(LIBDIR)/stdlib.p.cmxa + rm -f $(LIBDIR)/stdlib.p.a; ln -s stdlib.a $(LIBDIR)/stdlib.p.a + rm -f $(LIBDIR)/std_exit.p.cmx; \ + ln -s std_exit.cmx $(LIBDIR)/std_exit.p.cmx + rm -f $(LIBDIR)/std_exit.p.o; ln -s std_exit.o $(LIBDIR)/std_exit.p.o + +installopt-prof: + cp stdlib.p.cmxa stdlib.p.a std_exit.p.cmx std_exit.p.o $(LIBDIR) + cd $(LIBDIR); $(RANLIB) stdlib.p.a + +stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx) + $(CAMLOPT) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx) + +camlheader camlheader_ur: header.c ../config/Makefile + if $(SHARPBANGSCRIPTS); then \ + echo '#!$(BINDIR)/ocamlrun' > camlheader && \ + echo '#!' | tr -d '\012' > camlheader_ur; \ + else \ + $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \ + -DRUNTIME_NAME='"$(BINDIR)/ocamlrun"' \ + header.c -o tmpheader$(EXE) && \ + strip tmpheader$(EXE) && \ + mv tmpheader$(EXE) camlheader && \ + cp camlheader camlheader_ur; \ + fi + +.PHONY: all allopt allopt-noprof allopt-prof install installopt +.PHONY: installopt-default installopt-noprof installopt-prof clean depend diff --git a/ocaml-binary-annot/stdlib/Makefile.nt b/ocaml-binary-annot/stdlib/Makefile.nt new file mode 100644 index 0000000000..995a0c3fd6 --- /dev/null +++ b/ocaml-binary-annot/stdlib/Makefile.nt @@ -0,0 +1,31 @@ +######################################################################### +# # +# Objective Caml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../LICENSE. # +# # +######################################################################### + +# $Id$ + +include Makefile.shared + +allopt: stdlib.cmxa std_exit.cmx + +installopt: + cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(LIBDIR) + +camlheader camlheader_ur: headernt.c ../config/Makefile + $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun headernt.c + $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS) + rm -f camlheader.exe + mv tmpheader.exe camlheader + cp camlheader camlheader_ur + +# TODO: do not call flexlink to build tmpheader.exe (we don't need +# the export table) diff --git a/ocaml-binary-annot/stdlib/Makefile.shared b/ocaml-binary-annot/stdlib/Makefile.shared new file mode 100755 index 0000000000..64087dc9c3 --- /dev/null +++ b/ocaml-binary-annot/stdlib/Makefile.shared @@ -0,0 +1,97 @@ +######################################################################### +# # +# Objective Caml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../LICENSE. # +# # +######################################################################### + +# $Id$ + +include ../config/Makefile +RUNTIME=../boot/ocamlrun +COMPILER=../ocamlc +CAMLC=$(RUNTIME) $(COMPILER) +COMPFLAGS=-strict-sequence -g -warn-error A -nostdlib +OPTCOMPILER=../ocamlopt +CAMLOPT=$(RUNTIME) $(OPTCOMPILER) +OPTCOMPFLAGS=-warn-error A -nostdlib -g +CAMLDEP=../boot/ocamlrun ../tools/ocamldep + +OBJS=pervasives.cmo $(OTHERS) +OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \ + hashtbl.cmo sort.cmo marshal.cmo obj.cmo \ + int32.cmo int64.cmo nativeint.cmo \ + lexing.cmo parsing.cmo \ + set.cmo map.cmo stack.cmo queue.cmo \ + camlinternalLazy.cmo lazy.cmo stream.cmo \ + buffer.cmo printf.cmo format.cmo scanf.cmo \ + arg.cmo printexc.cmo gc.cmo \ + digest.cmo random.cmo callback.cmo \ + camlinternalOO.cmo oo.cmo camlinternalMod.cmo \ + genlex.cmo weak.cmo \ + filename.cmo complex.cmo \ + arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo + +all: stdlib.cma std_exit.cmo camlheader camlheader_ur + +install: + cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur $(LIBDIR) + +stdlib.cma: $(OBJS) + $(CAMLC) -a -o stdlib.cma $(OBJS) + +stdlib.cmxa: $(OBJS:.cmo=.cmx) + $(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx) + +sys.ml: sys.mlp ../VERSION + sed -e "s|%%VERSION%%|`sed -e 1q ../VERSION`|" sys.mlp >sys.ml + +clean:: + rm -f sys.ml + +clean:: + rm -f camlheader camlheader_ur + +.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx + +.mli.cmi: + $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< + +.ml.cmo: + $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< + +.ml.cmx: + $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -c $< + +.ml.p.cmx: + $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -p -c -o $*.p.cmx $< + +# Dependencies on the compiler +$(OBJS) std_exit.cmo: $(COMPILER) +$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER) +$(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER) +$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER) + +# Dependencies on Pervasives (not tracked by ocamldep) +$(OBJS) std_exit.cmo: pervasives.cmi +$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi +$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi +$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi +$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx +$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx + +clean:: + rm -f *.cm* *.$(O) *.$(A) + rm -f *~ + +include .depend + +depend: + $(CAMLDEP) *.mli *.ml > .depend + $(CAMLDEP) *.ml | sed -e 's/\.cmx/.p.cmx/g' >>.depend diff --git a/ocaml-binary-annot/stdlib/StdlibModules b/ocaml-binary-annot/stdlib/StdlibModules new file mode 100644 index 0000000000..4f689f8c4a --- /dev/null +++ b/ocaml-binary-annot/stdlib/StdlibModules @@ -0,0 +1,49 @@ +# This file lists all standard library modules. -*- Makefile -*- +# It is used in particular to know what to expunge in toplevels. +# $Id$ + +STDLIB_MODULES=\ + arg \ + array \ + arrayLabels \ + buffer \ + callback \ + camlinternalLazy \ + camlinternalMod \ + camlinternalOO \ + char \ + complex \ + digest \ + filename \ + format \ + gc \ + genlex \ + hashtbl \ + int32 \ + int64 \ + lazy \ + lexing \ + list \ + listLabels \ + map \ + marshal \ + moreLabels \ + nativeint \ + obj \ + oo \ + parsing \ + pervasives \ + printexc \ + printf \ + queue \ + random \ + scanf \ + set \ + sort \ + stack \ + stdLabels \ + stream \ + string \ + stringLabels \ + sys \ + weak diff --git a/ocaml-binary-annot/stdlib/arg.ml b/ocaml-binary-annot/stdlib/arg.ml new file mode 100644 index 0000000000..009e203753 --- /dev/null +++ b/ocaml-binary-annot/stdlib/arg.ml @@ -0,0 +1,252 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +type key = string +type doc = string +type usage_msg = string +type anon_fun = (string -> unit) + +type spec = + | Unit of (unit -> unit) (* Call the function with unit argument *) + | Bool of (bool -> unit) (* Call the function with a bool argument *) + | Set of bool ref (* Set the reference to true *) + | Clear of bool ref (* Set the reference to false *) + | String of (string -> unit) (* Call the function with a string argument *) + | Set_string of string ref (* Set the reference to the string argument *) + | Int of (int -> unit) (* Call the function with an int argument *) + | Set_int of int ref (* Set the reference to the int argument *) + | Float of (float -> unit) (* Call the function with a float argument *) + | Set_float of float ref (* Set the reference to the float argument *) + | Tuple of spec list (* Take several arguments according to the + spec list *) + | Symbol of string list * (string -> unit) + (* Take one of the symbols as argument and + call the function with the symbol. *) + | Rest of (string -> unit) (* Stop interpreting keywords and call the + function with each remaining argument *) + +exception Bad of string +exception Help of string + +type error = + | Unknown of string + | Wrong of string * string * string (* option, actual, expected *) + | Missing of string + | Message of string + +exception Stop of error;; (* used internally *) + +open Printf + +let rec assoc3 x l = + match l with + | [] -> raise Not_found + | (y1, y2, y3) :: t when y1 = x -> y2 + | _ :: t -> assoc3 x t +;; + +let make_symlist prefix sep suffix l = + match l with + | [] -> "<none>" + | h::t -> (List.fold_left (fun x y -> x ^ sep ^ y) (prefix ^ h) t) ^ suffix +;; + +let print_spec buf (key, spec, doc) = + match spec with + | Symbol (l, _) -> bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l) + doc + | _ -> bprintf buf " %s %s\n" key doc +;; + +let help_action () = raise (Stop (Unknown "-help"));; + +let add_help speclist = + let add1 = + try ignore (assoc3 "-help" speclist); [] + with Not_found -> + ["-help", Unit help_action, " Display this list of options"] + and add2 = + try ignore (assoc3 "--help" speclist); [] + with Not_found -> + ["--help", Unit help_action, " Display this list of options"] + in + speclist @ (add1 @ add2) +;; + +let usage_b buf speclist errmsg = + bprintf buf "%s\n" errmsg; + List.iter (print_spec buf) (add_help speclist); +;; + +let usage speclist errmsg = + let b = Buffer.create 200 in + usage_b b speclist errmsg; + eprintf "%s" (Buffer.contents b); +;; + +let current = ref 0;; + +let parse_argv ?(current=current) argv speclist anonfun errmsg = + let l = Array.length argv in + let b = Buffer.create 200 in + let initpos = !current in + let stop error = + let progname = if initpos < l then argv.(initpos) else "(?)" in + begin match error with + | Unknown "-help" -> () + | Unknown "--help" -> () + | Unknown s -> + bprintf b "%s: unknown option `%s'.\n" progname s + | Missing s -> + bprintf b "%s: option `%s' needs an argument.\n" progname s + | Wrong (opt, arg, expected) -> + bprintf b "%s: wrong argument `%s'; option `%s' expects %s.\n" + progname arg opt expected + | Message s -> + bprintf b "%s: %s.\n" progname s + end; + usage_b b speclist errmsg; + if error = Unknown "-help" || error = Unknown "--help" + then raise (Help (Buffer.contents b)) + else raise (Bad (Buffer.contents b)) + in + incr current; + while !current < l do + let s = argv.(!current) in + if String.length s >= 1 && String.get s 0 = '-' then begin + let action = + try assoc3 s speclist + with Not_found -> stop (Unknown s) + in + begin try + let rec treat_action = function + | Unit f -> f (); + | Bool f when !current + 1 < l -> + let arg = argv.(!current + 1) in + begin try f (bool_of_string arg) + with Invalid_argument "bool_of_string" -> + raise (Stop (Wrong (s, arg, "a boolean"))) + end; + incr current; + | Set r -> r := true; + | Clear r -> r := false; + | String f when !current + 1 < l -> + f argv.(!current + 1); + incr current; + | Symbol (symb, f) when !current + 1 < l -> + let arg = argv.(!current + 1) in + if List.mem arg symb then begin + f argv.(!current + 1); + incr current; + end else begin + raise (Stop (Wrong (s, arg, "one of: " + ^ (make_symlist "" " " "" symb)))) + end + | Set_string r when !current + 1 < l -> + r := argv.(!current + 1); + incr current; + | Int f when !current + 1 < l -> + let arg = argv.(!current + 1) in + begin try f (int_of_string arg) + with Failure "int_of_string" -> + raise (Stop (Wrong (s, arg, "an integer"))) + end; + incr current; + | Set_int r when !current + 1 < l -> + let arg = argv.(!current + 1) in + begin try r := (int_of_string arg) + with Failure "int_of_string" -> + raise (Stop (Wrong (s, arg, "an integer"))) + end; + incr current; + | Float f when !current + 1 < l -> + let arg = argv.(!current + 1) in + begin try f (float_of_string arg); + with Failure "float_of_string" -> + raise (Stop (Wrong (s, arg, "a float"))) + end; + incr current; + | Set_float r when !current + 1 < l -> + let arg = argv.(!current + 1) in + begin try r := (float_of_string arg); + with Failure "float_of_string" -> + raise (Stop (Wrong (s, arg, "a float"))) + end; + incr current; + | Tuple specs -> + List.iter treat_action specs; + | Rest f -> + while !current < l - 1 do + f argv.(!current + 1); + incr current; + done; + | _ -> raise (Stop (Missing s)) + in + treat_action action + with Bad m -> stop (Message m); + | Stop e -> stop e; + end; + incr current; + end else begin + (try anonfun s with Bad m -> stop (Message m)); + incr current; + end; + done; +;; + +let parse l f msg = + try + parse_argv Sys.argv l f msg; + with + | Bad msg -> eprintf "%s" msg; exit 2; + | Help msg -> printf "%s" msg; exit 0; +;; + +let rec second_word s = + let len = String.length s in + let rec loop n = + if n >= len then len + else if s.[n] = ' ' then loop (n+1) + else n + in + try loop (String.index s ' ') + with Not_found -> len +;; + +let max_arg_len cur (kwd, spec, doc) = + match spec with + | Symbol _ -> max cur (String.length kwd) + | _ -> max cur (String.length kwd + second_word doc) +;; + +let add_padding len ksd = + match ksd with + | (kwd, (Symbol (l, _) as spec), msg) -> + let cutcol = second_word msg in + let spaces = String.make (len - cutcol + 3) ' ' in + (kwd, spec, "\n" ^ spaces ^ msg) + | (kwd, spec, msg) -> + let cutcol = second_word msg in + let spaces = String.make (len - String.length kwd - cutcol) ' ' in + let prefix = String.sub msg 0 cutcol in + let suffix = String.sub msg cutcol (String.length msg - cutcol) in + (kwd, spec, prefix ^ spaces ^ suffix) +;; + +let align speclist = + let completed = add_help speclist in + let len = List.fold_left max_arg_len 0 completed in + List.map (add_padding len) completed +;; diff --git a/ocaml-binary-annot/stdlib/arg.mli b/ocaml-binary-annot/stdlib/arg.mli new file mode 100644 index 0000000000..4e5ed08d1c --- /dev/null +++ b/ocaml-binary-annot/stdlib/arg.mli @@ -0,0 +1,135 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** 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. + The types of keywords are: [Unit], [Bool], [Set], [Clear], + [String], [Set_string], [Int], [Set_int], [Float], [Set_float], + [Tuple], [Symbol], and [Rest]. + [Unit], [Set] and [Clear] keywords take no argument. A [Rest] + keyword takes the remaining of the command line as arguments. + Every other keyword takes the following word on the command line + as 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 a b c ](three anonymous arguments: ["a"], ["b"], and ["c"]) +- [cmd a b -- c d ](two anonymous arguments and a rest option with + two arguments) +*) + +type spec = + | Unit of (unit -> unit) (** Call the function with unit argument *) + | Bool of (bool -> unit) (** Call the function with a bool argument *) + | Set of bool ref (** Set the reference to true *) + | Clear of bool ref (** Set the reference to false *) + | String of (string -> unit) (** Call the function with a string argument *) + | Set_string of string ref (** Set the reference to the string argument *) + | Int of (int -> unit) (** Call the function with an int argument *) + | Set_int of int ref (** Set the reference to the int argument *) + | Float of (float -> unit) (** Call the function with a float argument *) + | Set_float of float ref (** Set the reference to the float argument *) + | Tuple of spec list (** Take several arguments according to the + spec list *) + | Symbol of string list * (string -> unit) + (** Take one of the symbols as argument and + call the function with the symbol *) + | Rest of (string -> unit) (** Stop interpreting keywords and call the + function with each remaining argument *) +(** The concrete type describing the behavior associated + with a keyword. *) + +type key = string +type doc = string +type usage_msg = string +type anon_fun = (string -> unit) + +val parse : + (key * spec * doc) list -> anon_fun -> usage_msg -> unit +(** [Arg.parse speclist anon_fun usage_msg] parses the command line. + [speclist] is a list of triples [(key, spec, doc)]. + [key] is the option keyword, it must start with a ['-'] character. + [spec] gives the option type and the function to call when this option + is found on the command line. + [doc] is a one-line description of this option. + [anon_fun] is called on anonymous arguments. + The functions in [spec] and [anon_fun] are called in the same order + as their arguments appear on the command line. + + If an error occurs, [Arg.parse] exits the program, after printing + an error message as follows: +- The reason for the error: unknown option, invalid or missing argument, etc. +- [usage_msg] +- The list of options, each followed by the corresponding [doc] string. + + For the user to be able to specify anonymous arguments starting with a + [-], include for example [("-", String anon_fun, doc)] in [speclist]. + + By default, [parse] recognizes two unit options, [-help] and [--help], + which will display [usage_msg] and the list of options, and exit + the program. You can override this behaviour by specifying your + own [-help] and [--help] options in [speclist]. +*) + +val parse_argv : ?current: int ref -> string array -> + (key * spec * doc) list -> anon_fun -> usage_msg -> unit +(** [Arg.parse_argv ~current args speclist anon_fun usage_msg] parses + the array [args] as if it were the command line. It uses and updates + the value of [~current] (if given), or [Arg.current]. You must set + it before calling [parse_argv]. The initial value of [current] + is the index of the program name (argument 0) in the array. + If an error occurs, [Arg.parse_argv] raises [Arg.Bad] with + the error message as argument. If option [-help] or [--help] is + given, [Arg.parse_argv] raises [Arg.Help] with the help message + as argument. +*) + +exception Help of string +(** Raised by [Arg.parse_argv] when the user asks for help. *) + +exception Bad of string +(** Functions in [spec] or [anon_fun] can raise [Arg.Bad] with an error + message to reject invalid arguments. + [Arg.Bad] is also raised by [Arg.parse_argv] in case of an error. *) + +val usage : (key * spec * doc) list -> usage_msg -> unit +(** [Arg.usage speclist usage_msg] prints an error message including + the list of valid options. This is the same message that + {!Arg.parse} prints in case of error. + [speclist] and [usage_msg] are the same as for [Arg.parse]. *) + +val align: (key * spec * doc) list -> (key * spec * doc) list;; +(** Align the documentation strings by inserting spaces at the first + space, according to the length of the keyword. Use a + space as the first character in a doc string if you want to + align the whole string. The doc strings corresponding to + [Symbol] arguments are aligned on the next line. *) + +val current : int ref +(** Position (in {!Sys.argv}) of the argument being processed. You can + change this value, e.g. to force {!Arg.parse} to skip some arguments. + {!Arg.parse} uses the initial value of {!Arg.current} as the index of + argument 0 (the program name) and starts parsing arguments + at the next element. *) diff --git a/ocaml-binary-annot/stdlib/array.ml b/ocaml-binary-annot/stdlib/array.ml new file mode 100644 index 0000000000..d1cbd65576 --- /dev/null +++ b/ocaml-binary-annot/stdlib/array.ml @@ -0,0 +1,280 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Array operations *) + +external length : 'a array -> int = "%array_length" +external get: 'a array -> int -> 'a = "%array_safe_get" +external set: 'a array -> int -> 'a -> unit = "%array_safe_set" +external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get" +external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set" +external make: int -> 'a -> 'a array = "caml_make_vect" +external create: int -> 'a -> 'a array = "caml_make_vect" + +let init l f = + if l = 0 then [||] else + let res = create l (f 0) in + for i = 1 to pred l do + unsafe_set res i (f i) + done; + res + +let make_matrix sx sy init = + let res = create sx [||] in + for x = 0 to pred sx do + unsafe_set res x (create sy init) + done; + res + +let create_matrix = make_matrix + +let copy a = + let l = length a in + if l = 0 then [||] else begin + let res = create l (unsafe_get a 0) in + for i = 1 to pred l do + unsafe_set res i (unsafe_get a i) + done; + res + end + +let append a1 a2 = + let l1 = length a1 and l2 = length a2 in + if l1 = 0 && l2 = 0 then [||] else begin + let r = create (l1 + l2) (unsafe_get (if l1 > 0 then a1 else a2) 0) in + for i = 0 to l1 - 1 do unsafe_set r i (unsafe_get a1 i) done; + for i = 0 to l2 - 1 do unsafe_set r (i + l1) (unsafe_get a2 i) done; + r + end + +let concat_aux init al = + let rec size accu = function + | [] -> accu + | h::t -> size (accu + length h) t + in + let res = create (size 0 al) init in + let rec fill pos = function + | [] -> () + | h::t -> + for i = 0 to length h - 1 do + unsafe_set res (pos + i) (unsafe_get h i); + done; + fill (pos + length h) t; + in + fill 0 al; + res +;; + +let concat al = + let rec find_init aa = + match aa with + | [] -> [||] + | a :: rem -> + if length a > 0 then concat_aux (unsafe_get a 0) aa else find_init rem + in find_init al + +let sub a ofs len = + if ofs < 0 || len < 0 || ofs > length a - len then invalid_arg "Array.sub" + else if len = 0 then [||] + else begin + let r = create 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 || len < 0 || ofs > length a - len + 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 || ofs1 < 0 || ofs1 > length a1 - len + || ofs2 < 0 || ofs2 > length a2 - len + then invalid_arg "Array.blit" + else if ofs1 < ofs2 then + (* Top-down copy *) + for i = len - 1 downto 0 do + unsafe_set a2 (ofs2 + i) (unsafe_get a1 (ofs1 + i)) + done + else + (* Bottom-up copy *) + 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 = create 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 iteri f a = + for i = 0 to length a - 1 do f i (unsafe_get a i) done + +let mapi f a = + let l = length a in + if l = 0 then [||] else begin + let r = create l (f 0 (unsafe_get a 0)) in + for i = 1 to l - 1 do + unsafe_set r i (f i (unsafe_get a i)) + done; + r + end + +let to_list a = + let rec tolist i res = + if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in + tolist (length a - 1) [] + +(* Cannot use List.length here because the List module depends on Array. *) +let rec list_length accu = function + | [] -> accu + | h::t -> list_length (succ accu) t +;; + +let of_list = function + [] -> [||] + | hd::tl as l -> + let a = create (list_length 0 l) hd in + let rec fill i = function + [] -> a + | hd::tl -> unsafe_set a i hd; fill (i+1) tl in + fill 1 tl + +let fold_left f x a = + let r = ref x in + for i = 0 to length a - 1 do + r := f !r (unsafe_get a i) + done; + !r + +let fold_right f a x = + let r = ref x in + for i = length a - 1 downto 0 do + r := f (unsafe_get a i) !r + done; + !r + +exception Bottom of int;; +let sort cmp a = + let maxson l i = + let i31 = i+i+i+1 in + let x = ref i31 in + if i31+2 < l then begin + if cmp (get a i31) (get a (i31+1)) < 0 then x := i31+1; + if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2; + !x + end else + if i31+1 < l && cmp (get a i31) (get a (i31+1)) < 0 + then i31+1 + else if i31 < l then i31 else raise (Bottom i) + in + let rec trickledown l i e = + let j = maxson l i in + if cmp (get a j) e > 0 then begin + set a i (get a j); + trickledown l j e; + end else begin + set a i e; + end; + in + let rec trickle l i e = try trickledown l i e with Bottom i -> set a i e in + let rec bubbledown l i = + let j = maxson l i in + set a i (get a j); + bubbledown l j + in + let bubble l i = try bubbledown l i with Bottom i -> i in + let rec trickleup i e = + let father = (i - 1) / 3 in + assert (i <> father); + if cmp (get a father) e < 0 then begin + set a i (get a father); + if father > 0 then trickleup father e else set a 0 e; + end else begin + set a i e; + end; + in + let l = length a in + for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done; + for i = l - 1 downto 2 do + let e = (get a i) in + set a i (get a 0); + trickleup (bubble i 0) e; + done; + if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e); +;; + +let cutoff = 5;; +let stable_sort cmp a = + let merge src1ofs src1len src2 src2ofs src2len dst dstofs = + let src1r = src1ofs + src1len and src2r = src2ofs + src2len in + let rec loop i1 s1 i2 s2 d = + if cmp s1 s2 <= 0 then begin + set dst d s1; + let i1 = i1 + 1 in + if i1 < src1r then + loop i1 (get a i1) i2 s2 (d + 1) + else + blit src2 i2 dst (d + 1) (src2r - i2) + end else begin + set dst d s2; + let i2 = i2 + 1 in + if i2 < src2r then + loop i1 s1 i2 (get src2 i2) (d + 1) + else + blit a i1 dst (d + 1) (src1r - i1) + end + in loop src1ofs (get a src1ofs) src2ofs (get src2 src2ofs) dstofs; + in + let isortto srcofs dst dstofs len = + for i = 0 to len - 1 do + let e = (get a (srcofs + i)) in + let j = ref (dstofs + i - 1) in + while (!j >= dstofs && cmp (get dst !j) e > 0) do + set dst (!j + 1) (get dst !j); + decr j; + done; + set dst (!j + 1) e; + done; + in + let rec sortto srcofs dst dstofs len = + if len <= cutoff then isortto srcofs dst dstofs len else begin + let l1 = len / 2 in + let l2 = len - l1 in + sortto (srcofs + l1) dst (dstofs + l1) l2; + sortto srcofs a (srcofs + l2) l1; + merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; + end; + in + let l = length a in + if l <= cutoff then isortto 0 a 0 l else begin + let l1 = l / 2 in + let l2 = l - l1 in + let t = make l2 (get a 0) in + sortto l1 t 0 l2; + sortto 0 a l2 l1; + merge l2 l1 t 0 l2 a 0; + end; +;; + +let fast_sort = stable_sort;; diff --git a/ocaml-binary-annot/stdlib/array.mli b/ocaml-binary-annot/stdlib/array.mli new file mode 100644 index 0000000000..9fb74b06eb --- /dev/null +++ b/ocaml-binary-annot/stdlib/array.mli @@ -0,0 +1,205 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Array operations. *) + +external length : 'a array -> int = "%array_length" +(** Return the length (number of elements) of the given array. *) + +external get : 'a array -> int -> 'a = "%array_safe_get" +(** [Array.get a n] returns the element number [n] of array [a]. + The first element has number 0. + The last element has number [Array.length a - 1]. + You can also write [a.(n)] instead of [Array.get a n]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [(Array.length a - 1)]. *) + +external set : 'a array -> int -> 'a -> unit = "%array_safe_set" +(** [Array.set a n x] modifies array [a] in place, replacing + element number [n] with [x]. + You can also write [a.(n) <- x] instead of [Array.set a n x]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [Array.length a - 1]. *) + +external make : int -> 'a -> 'a array = "caml_make_vect" +(** [Array.make n x] returns a fresh array of length [n], + initialized with [x]. + All the elements of this new array are initially + physically equal to [x] (in the sense of the [==] predicate). + Consequently, if [x] is mutable, it is shared among all elements + of the array, and modifying [x] through one of the array entries + will modify all other entries at the same time. + + Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. + If the value of [x] is a floating-point number, then the maximum + size is only [Sys.max_array_length / 2].*) + +external create : int -> 'a -> 'a array = "caml_make_vect" +(** @deprecated [Array.create] is an alias for {!Array.make}. *) + +val init : int -> (int -> 'a) -> 'a array +(** [Array.init n f] returns a fresh array of length [n], + with element number [i] initialized to the result of [f i]. + In other terms, [Array.init n f] tabulates the results of [f] + applied to the integers [0] to [n-1]. + + Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. + If the return type of [f] is [float], then the maximum + size is only [Sys.max_array_length / 2].*) + +val make_matrix : int -> int -> 'a -> 'a array array +(** [Array.make_matrix dimx dimy e] returns a two-dimensional array + (an array of arrays) with first dimension [dimx] and + second dimension [dimy]. All the elements of this new matrix + are initially physically equal to [e]. + The element ([x,y]) of a matrix [m] is accessed + with the notation [m.(x).(y)]. + + Raise [Invalid_argument] if [dimx] or [dimy] is negative or + greater than [Sys.max_array_length]. + If the value of [e] is a floating-point number, then the maximum + size is only [Sys.max_array_length / 2]. *) + +val create_matrix : int -> int -> 'a -> 'a array array +(** @deprecated [Array.create_matrix] is an alias for {!Array.make_matrix}. *) + +val append : 'a array -> 'a array -> 'a array +(** [Array.append v1 v2] returns a fresh array containing the + concatenation of the arrays [v1] and [v2]. *) + +val concat : 'a array list -> 'a array +(** Same as [Array.append], but concatenates a list of arrays. *) + +val sub : 'a array -> int -> int -> 'a array +(** [Array.sub a start len] returns a fresh array of length [len], + containing the elements number [start] to [start + len - 1] + of array [a]. + + Raise [Invalid_argument "Array.sub"] if [start] and [len] do not + designate a valid subarray of [a]; that is, if + [start < 0], or [len < 0], or [start + len > Array.length a]. *) + +val copy : 'a array -> 'a array +(** [Array.copy a] returns a copy of [a], that is, a fresh array + containing the same elements as [a]. *) + +val fill : 'a array -> int -> int -> 'a -> unit +(** [Array.fill a ofs len x] modifies the array [a] in place, + storing [x] in elements number [ofs] to [ofs + len - 1]. + + Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not + designate a valid subarray of [a]. *) + +val blit : 'a array -> int -> 'a array -> int -> int -> unit +(** [Array.blit v1 o1 v2 o2 len] copies [len] elements + from array [v1], starting at element number [o1], to array [v2], + starting at element number [o2]. It works correctly even if + [v1] and [v2] are the same array, and the source and + destination chunks overlap. + + Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not + designate a valid subarray of [v1], or if [o2] and [len] do not + designate a valid subarray of [v2]. *) + +val to_list : 'a array -> 'a list +(** [Array.to_list a] returns the list of all the elements of [a]. *) + +val of_list : 'a list -> 'a array +(** [Array.of_list l] returns a fresh array containing the elements + of [l]. *) + +val iter : ('a -> unit) -> 'a array -> unit +(** [Array.iter f a] applies function [f] in turn to all + the elements of [a]. It is equivalent to + [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *) + +val map : ('a -> 'b) -> 'a array -> 'b array +(** [Array.map f a] applies function [f] to all the elements of [a], + and builds an array with the results returned by [f]: + [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *) + +val iteri : (int -> 'a -> unit) -> 'a array -> unit +(** Same as {!Array.iter}, but the + function is applied to the index of the element as first argument, + and the element itself as second argument. *) + +val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array +(** Same as {!Array.map}, but the + function is applied to the index of the element as first argument, + and the element itself as second argument. *) + +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a +(** [Array.fold_left f x a] computes + [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], + where [n] is the length of the array [a]. *) + +val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a +(** [Array.fold_right f a x] computes + [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], + where [n] is the length of the array [a]. *) + + +(** {6 Sorting} *) + + +val sort : ('a -> 'a -> int) -> 'a array -> unit +(** Sort an array in increasing order according to a comparison + function. The comparison function must return 0 if its arguments + compare as equal, a positive integer if the first is greater, + and a negative integer if the first is smaller (see below for a + complete specification). For example, {!Pervasives.compare} is + a suitable comparison function, provided there are no floating-point + NaN values in the data. After calling [Array.sort], the + array is sorted in place in increasing order. + [Array.sort] is guaranteed to run in constant heap space + and (at most) logarithmic stack space. + + The current implementation uses Heap Sort. It runs in constant + stack space. + + Specification of the comparison function: + Let [a] be the array and [cmp] the comparison function. The following + must be true for all x, y, z in a : +- [cmp x y] > 0 if and only if [cmp y x] < 0 +- if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 + + When [Array.sort] returns, [a] contains the same elements as before, + reordered in such a way that for all i and j valid indices of [a] : +- [cmp a.(i) a.(j)] >= 0 if and only if i >= j +*) + +val stable_sort : ('a -> 'a -> int) -> 'a array -> unit +(** Same as {!Array.sort}, but the sorting algorithm is stable (i.e. + elements that compare equal are kept in their original order) and + not guaranteed to run in constant heap space. + + The current implementation uses Merge Sort. It uses [n/2] + words of heap space, where [n] is the length of the array. + It is usually faster than the current implementation of {!Array.sort}. +*) + +val fast_sort : ('a -> 'a -> int) -> 'a array -> unit +(** Same as {!Array.sort} or {!Array.stable_sort}, whichever is faster + on typical input. +*) + + +(**/**) +(** {6 Undocumented functions} *) + +external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" +external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" diff --git a/ocaml-binary-annot/stdlib/arrayLabels.ml b/ocaml-binary-annot/stdlib/arrayLabels.ml new file mode 100644 index 0000000000..fed0ad1c2c --- /dev/null +++ b/ocaml-binary-annot/stdlib/arrayLabels.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Module [ArrayLabels]: labelled Array module *) + +include Array diff --git a/ocaml-binary-annot/stdlib/arrayLabels.mli b/ocaml-binary-annot/stdlib/arrayLabels.mli new file mode 100644 index 0000000000..f45f70c6de --- /dev/null +++ b/ocaml-binary-annot/stdlib/arrayLabels.mli @@ -0,0 +1,209 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Array operations. *) + +external length : 'a array -> int = "%array_length" +(** Return the length (number of elements) of the given array. *) + +external get : 'a array -> int -> 'a = "%array_safe_get" +(** [Array.get a n] returns the element number [n] of array [a]. + The first element has number 0. + The last element has number [Array.length a - 1]. + You can also write [a.(n)] instead of [Array.get a n]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [(Array.length a - 1)]. *) + +external set : 'a array -> int -> 'a -> unit = "%array_safe_set" +(** [Array.set a n x] modifies array [a] in place, replacing + element number [n] with [x]. + You can also write [a.(n) <- x] instead of [Array.set a n x]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [Array.length a - 1]. *) + +external make : int -> 'a -> 'a array = "caml_make_vect" +(** [Array.make n x] returns a fresh array of length [n], + initialized with [x]. + All the elements of this new array are initially + physically equal to [x] (in the sense of the [==] predicate). + Consequently, if [x] is mutable, it is shared among all elements + of the array, and modifying [x] through one of the array entries + will modify all other entries at the same time. + + Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. + If the value of [x] is a floating-point number, then the maximum + size is only [Sys.max_array_length / 2].*) + +external create : int -> 'a -> 'a array = "caml_make_vect" +(** @deprecated [Array.create] is an alias for {!ArrayLabels.make}. *) + +val init : int -> f:(int -> 'a) -> 'a array +(** [Array.init n f] returns a fresh array of length [n], + with element number [i] initialized to the result of [f i]. + In other terms, [Array.init n f] tabulates the results of [f] + applied to the integers [0] to [n-1]. + + Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. + If the return type of [f] is [float], then the maximum + size is only [Sys.max_array_length / 2].*) + +val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array +(** [Array.make_matrix dimx dimy e] returns a two-dimensional array + (an array of arrays) with first dimension [dimx] and + second dimension [dimy]. All the elements of this new matrix + are initially physically equal to [e]. + The element ([x,y]) of a matrix [m] is accessed + with the notation [m.(x).(y)]. + + Raise [Invalid_argument] if [dimx] or [dimy] is negative or + greater than [Sys.max_array_length]. + If the value of [e] is a floating-point number, then the maximum + size is only [Sys.max_array_length / 2]. *) + +val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array +(** @deprecated [Array.create_matrix] is an alias for + {!ArrayLabels.make_matrix}. *) + +val append : 'a array -> 'a array -> 'a array +(** [Array.append v1 v2] returns a fresh array containing the + concatenation of the arrays [v1] and [v2]. *) + +val concat : 'a array list -> 'a array +(** Same as [Array.append], but concatenates a list of arrays. *) + +val sub : 'a array -> pos:int -> len:int -> 'a array +(** [Array.sub a start len] returns a fresh array of length [len], + containing the elements number [start] to [start + len - 1] + of array [a]. + + Raise [Invalid_argument "Array.sub"] if [start] and [len] do not + designate a valid subarray of [a]; that is, if + [start < 0], or [len < 0], or [start + len > Array.length a]. *) + +val copy : 'a array -> 'a array +(** [Array.copy a] returns a copy of [a], that is, a fresh array + containing the same elements as [a]. *) + +val fill : 'a array -> pos:int -> len:int -> 'a -> unit +(** [Array.fill a ofs len x] modifies the array [a] in place, + storing [x] in elements number [ofs] to [ofs + len - 1]. + + Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not + designate a valid subarray of [a]. *) + +val blit : + src:'a array -> src_pos:int -> dst:'a array -> dst_pos:int -> len:int -> + unit +(** [Array.blit v1 o1 v2 o2 len] copies [len] elements + from array [v1], starting at element number [o1], to array [v2], + starting at element number [o2]. It works correctly even if + [v1] and [v2] are the same array, and the source and + destination chunks overlap. + + Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not + designate a valid subarray of [v1], or if [o2] and [len] do not + designate a valid subarray of [v2]. *) + +val to_list : 'a array -> 'a list +(** [Array.to_list a] returns the list of all the elements of [a]. *) + +val of_list : 'a list -> 'a array +(** [Array.of_list l] returns a fresh array containing the elements + of [l]. *) + +val iter : f:('a -> unit) -> 'a array -> unit +(** [Array.iter f a] applies function [f] in turn to all + the elements of [a]. It is equivalent to + [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *) + +val map : f:('a -> 'b) -> 'a array -> 'b array +(** [Array.map f a] applies function [f] to all the elements of [a], + and builds an array with the results returned by [f]: + [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *) + +val iteri : f:(int -> 'a -> unit) -> 'a array -> unit +(** Same as {!ArrayLabels.iter}, but the + function is applied to the index of the element as first argument, + and the element itself as second argument. *) + +val mapi : f:(int -> 'a -> 'b) -> 'a array -> 'b array +(** Same as {!ArrayLabels.map}, but the + function is applied to the index of the element as first argument, + and the element itself as second argument. *) + +val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a +(** [Array.fold_left f x a] computes + [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], + where [n] is the length of the array [a]. *) + +val fold_right : f:('b -> 'a -> 'a) -> 'b array -> init:'a -> 'a +(** [Array.fold_right f a x] computes + [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], + where [n] is the length of the array [a]. *) + + +(** {6 Sorting} *) + + +val sort : cmp:('a -> 'a -> int) -> 'a array -> unit +(** Sort an array in increasing order according to a comparison + function. The comparison function must return 0 if its arguments + compare as equal, a positive integer if the first is greater, + and a negative integer if the first is smaller (see below for a + complete specification). For example, {!Pervasives.compare} is + a suitable comparison function, provided there are no floating-point + NaN values in the data. After calling [Array.sort], the + array is sorted in place in increasing order. + [Array.sort] is guaranteed to run in constant heap space + and (at most) logarithmic stack space. + + The current implementation uses Heap Sort. It runs in constant + stack space. + + Specification of the comparison function: + Let [a] be the array and [cmp] the comparison function. The following + must be true for all x, y, z in a : +- [cmp x y] > 0 if and only if [cmp y x] < 0 +- if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 + + When [Array.sort] returns, [a] contains the same elements as before, + reordered in such a way that for all i and j valid indices of [a] : +- [cmp a.(i) a.(j)] >= 0 if and only if i >= j +*) + +val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit +(** Same as {!ArrayLabels.sort}, but the sorting algorithm is stable (i.e. + elements that compare equal are kept in their original order) and + not guaranteed to run in constant heap space. + + The current implementation uses Merge Sort. It uses [n/2] + words of heap space, where [n] is the length of the array. + It is usually faster than the current implementation of {!ArrayLabels.sort}. +*) + +val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit +(** Same as {!Array.sort} or {!Array.stable_sort}, whichever is faster + on typical input. +*) + + +(**/**) + +(** {6 Undocumented functions} *) + +external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" +external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" diff --git a/ocaml-binary-annot/stdlib/buffer.ml b/ocaml-binary-annot/stdlib/buffer.ml new file mode 100644 index 0000000000..9327aaefb5 --- /dev/null +++ b/ocaml-binary-annot/stdlib/buffer.ml @@ -0,0 +1,183 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Extensible buffers *) + +type t = + {mutable buffer : string; + mutable position : int; + mutable length : int; + initial_buffer : string} + +let create n = + let n = if n < 1 then 1 else n in + let n = if n > Sys.max_string_length then Sys.max_string_length else n in + let s = String.create n in + {buffer = s; position = 0; length = n; initial_buffer = s} + +let contents b = String.sub b.buffer 0 b.position + +let sub b ofs len = + if ofs < 0 || len < 0 || ofs > b.position - len + then invalid_arg "Buffer.sub" + else begin + let r = String.create len in + String.blit b.buffer ofs r 0 len; + r + end +;; + +let blit src srcoff dst dstoff len = + if len < 0 || srcoff < 0 || srcoff > src.position - len + || dstoff < 0 || dstoff > (String.length dst) - len + then invalid_arg "Buffer.blit" + else + String.blit src.buffer srcoff dst dstoff len +;; + +let nth b ofs = + if ofs < 0 || ofs >= b.position then + invalid_arg "Buffer.nth" + else String.get b.buffer ofs +;; + +let length b = b.position + +let clear b = b.position <- 0 + +let reset b = + b.position <- 0; b.buffer <- b.initial_buffer; + b.length <- String.length b.buffer + +let resize b more = + let len = b.length in + let new_len = ref len in + while b.position + more > !new_len do new_len := 2 * !new_len done; + if !new_len > Sys.max_string_length then begin + if b.position + more <= Sys.max_string_length + then new_len := Sys.max_string_length + else failwith "Buffer.add: cannot grow buffer" + end; + let new_buffer = String.create !new_len in + String.blit b.buffer 0 new_buffer 0 b.position; + b.buffer <- new_buffer; + b.length <- !new_len + +let add_char b c = + let pos = b.position in + if pos >= b.length then resize b 1; + b.buffer.[pos] <- c; + b.position <- pos + 1 + +let add_substring b s offset len = + if offset < 0 || len < 0 || offset > String.length s - len + then invalid_arg "Buffer.add_substring"; + let new_position = b.position + len in + if new_position > b.length then resize b len; + String.blit s offset b.buffer b.position len; + b.position <- new_position + +let add_string b s = + let len = String.length s in + let new_position = b.position + len in + if new_position > b.length then resize b len; + String.blit s 0 b.buffer b.position len; + b.position <- new_position + +let add_buffer b bs = + add_substring b bs.buffer 0 bs.position + +let add_channel b ic len = + if len < 0 || len > Sys.max_string_length then (* PR#5004 *) + invalid_arg "Buffer.add_channel"; + if b.position + len > b.length then resize b len; + really_input ic b.buffer b.position len; + b.position <- b.position + len + +let output_buffer oc b = + output oc b.buffer 0 b.position + +let closing = function + | '(' -> ')' + | '{' -> '}' + | _ -> assert false;; + +(* opening and closing: open and close characters, typically ( and ) + k: balance of opening and closing chars + s: the string where we are searching + start: the index where we start the search. *) +let advance_to_closing opening closing k s start = + let rec advance k i lim = + if i >= lim then raise Not_found else + if s.[i] = opening then advance (k + 1) (i + 1) lim else + if s.[i] = closing then + if k = 0 then i else advance (k - 1) (i + 1) lim + else advance k (i + 1) lim in + advance k start (String.length s);; + +let advance_to_non_alpha s start = + let rec advance i lim = + if i >= lim then lim else + match s.[i] with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | + 'é'|'à'|'á'|'è'|'ù'|'â'|'ê'| + 'î'|'ô'|'û'|'ë'|'ï'|'ü'|'ç'| + 'É'|'À'|'Á'|'È'|'Ù'|'Â'|'Ê'| + 'Î'|'Ô'|'Û'|'Ë'|'Ï'|'Ü'|'Ç' -> + advance (i + 1) lim + | _ -> i in + advance start (String.length s);; + +(* We are just at the beginning of an ident in s, starting at start. *) +let find_ident s start lim = + if start >= lim then raise Not_found else + match s.[start] with + (* Parenthesized ident ? *) + | '(' | '{' as c -> + let new_start = start + 1 in + let stop = advance_to_closing c (closing c) 0 s new_start in + String.sub s new_start (stop - start - 1), stop + 1 + (* Regular ident *) + | _ -> + let stop = advance_to_non_alpha s (start + 1) in + String.sub s start (stop - start), stop;; + +(* Substitute $ident, $(ident), or ${ident} in s, + according to the function mapping f. *) +let add_substitute b f s = + let lim = String.length s in + let rec subst previous i = + if i < lim then begin + match s.[i] with + | '$' as current when previous = '\\' -> + add_char b current; + subst ' ' (i + 1) + | '$' -> + let j = i + 1 in + let ident, next_i = find_ident s j lim in + add_string b (f ident); + subst ' ' next_i + | current when previous == '\\' -> + add_char b '\\'; + add_char b current; + subst ' ' (i + 1) + | '\\' as current -> + subst current (i + 1) + | current -> + add_char b current; + subst current (i + 1) + end else + if previous = '\\' then add_char b previous in + subst ' ' 0;; diff --git a/ocaml-binary-annot/stdlib/buffer.mli b/ocaml-binary-annot/stdlib/buffer.mli new file mode 100644 index 0000000000..efe2e9ea2e --- /dev/null +++ b/ocaml-binary-annot/stdlib/buffer.mli @@ -0,0 +1,117 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Extensible string buffers. + + This module implements string buffers that automatically expand + as necessary. It provides accumulative concatenation of strings + in quasi-linear time (instead of quadratic time when strings are + concatenated pairwise). +*) + +type t +(** The abstract type of buffers. *) + +val create : int -> t +(** [create n] returns a fresh buffer, initially empty. + The [n] parameter is the initial size of the internal string + that holds the buffer contents. That string is automatically + reallocated when more than [n] characters are stored in the buffer, + but shrinks back to [n] characters when [reset] is called. + For best performance, [n] should be of the same order of magnitude + as the number of characters that are expected to be stored in + the buffer (for instance, 80 for a buffer that holds one output + line). Nothing bad will happen if the buffer grows beyond that + limit, however. In doubt, take [n = 16] for instance. + If [n] is not between 1 and {!Sys.max_string_length}, it will + be clipped to that interval. *) + +val contents : t -> string +(** Return a copy of the current contents of the buffer. + The buffer itself is unchanged. *) + +val sub : t -> int -> int -> string +(** [Buffer.sub b off len] returns (a copy of) the substring of the +current contents of the buffer [b] starting at offset [off] of length +[len] bytes. May raise [Invalid_argument] if out of bounds request. The +buffer itself is unaffected. *) + +val blit : t -> int -> string -> int -> int -> unit +(** [Buffer.blit src srcoff dst dstoff len] copies [len] characters from + the current contents of the buffer [src], starting at offset [srcoff] + to string [dst], starting at character [dstoff]. + + Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid + substring of [src], or if [dstoff] and [len] do not designate a valid + substring of [dst]. + @since 3.11.2 +*) + +val nth : t -> int -> char +(** get the n-th character of the buffer. Raise [Invalid_argument] if +index out of bounds *) + +val length : t -> int +(** Return the number of characters currently contained in the buffer. *) + +val clear : t -> unit +(** Empty the buffer. *) + +val reset : t -> unit +(** Empty the buffer and deallocate the internal string holding the + buffer contents, replacing it with the initial internal string + of length [n] that was allocated by {!Buffer.create} [n]. + For long-lived buffers that may have grown a lot, [reset] allows + faster reclamation of the space used by the buffer. *) + +val add_char : t -> char -> unit +(** [add_char b c] appends the character [c] at the end of the buffer [b]. *) + +val add_string : t -> string -> unit +(** [add_string b s] appends the string [s] at the end of the buffer [b]. *) + +val add_substring : t -> string -> int -> int -> unit +(** [add_substring b s ofs len] takes [len] characters from offset + [ofs] in string [s] and appends them at the end of the buffer [b]. *) + +val add_substitute : t -> (string -> string) -> string -> unit +(** [add_substitute b f s] appends the string pattern [s] at the end + of the buffer [b] with substitution. + The substitution process looks for variables into + the pattern and substitutes each variable name by its value, as + obtained by applying the mapping [f] to the variable name. Inside the + string pattern, a variable name immediately follows a non-escaped + [$] character and is one of the following: + - a non empty sequence of alphanumeric or [_] characters, + - an arbitrary sequence of characters enclosed by a pair of + matching parentheses or curly brackets. + An escaped [$] character is a [$] that immediately follows a backslash + character; it then stands for a plain [$]. + Raise [Not_found] if the closing character of a parenthesized variable + cannot be found. *) + +val add_buffer : t -> t -> unit +(** [add_buffer b1 b2] appends the current contents of buffer [b2] + at the end of buffer [b1]. [b2] is not modified. *) + +val add_channel : t -> in_channel -> int -> unit +(** [add_channel b ic n] reads exactly [n] character from the + input channel [ic] and stores them at the end of buffer [b]. + Raise [End_of_file] if the channel contains fewer than [n] + characters. *) + +val output_buffer : out_channel -> t -> unit +(** [output_buffer oc b] writes the current contents of buffer [b] + on the output channel [oc]. *) diff --git a/ocaml-binary-annot/stdlib/callback.ml b/ocaml-binary-annot/stdlib/callback.ml new file mode 100644 index 0000000000..819f9d3f40 --- /dev/null +++ b/ocaml-binary-annot/stdlib/callback.ml @@ -0,0 +1,25 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Registering Caml values with the C runtime for later callbacks *) + +external register_named_value : string -> Obj.t -> unit + = "caml_register_named_value" + +let register name v = + register_named_value name (Obj.repr v) + +let register_exception name (exn : exn) = + register_named_value name (Obj.field (Obj.repr exn) 0) diff --git a/ocaml-binary-annot/stdlib/callback.mli b/ocaml-binary-annot/stdlib/callback.mli new file mode 100644 index 0000000000..ba2ab7ecb7 --- /dev/null +++ b/ocaml-binary-annot/stdlib/callback.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Registering Caml values with the C runtime. + + This module allows Caml values to be registered with the C runtime + under a symbolic name, so that C code can later call back registered + Caml functions, or raise registered Caml exceptions. +*) + +val register : string -> 'a -> unit +(** [Callback.register n v] registers the value [v] under + the name [n]. C code can later retrieve a handle to [v] + by calling [caml_named_value(n)]. *) + +val register_exception : string -> exn -> unit +(** [Callback.register_exception n exn] registers the + exception contained in the exception value [exn] + under the name [n]. C code can later retrieve a handle to + the exception by calling [caml_named_value(n)]. The exception + value thus obtained is suitable for passign as first argument + to [raise_constant] or [raise_with_arg]. *) diff --git a/ocaml-binary-annot/stdlib/camlinternalLazy.ml b/ocaml-binary-annot/stdlib/camlinternalLazy.ml new file mode 100644 index 0000000000..46cf42788a --- /dev/null +++ b/ocaml-binary-annot/stdlib/camlinternalLazy.ml @@ -0,0 +1,64 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Internals of forcing lazy values. *) + +exception Undefined;; + +let raise_undefined = Obj.repr (fun () -> raise Undefined);; + +(* Assume [blk] is a block with tag lazy *) +let force_lazy_block (blk : 'arg lazy_t) = + let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in + Obj.set_field (Obj.repr blk) 0 raise_undefined; + try + let result = closure () in + Obj.set_field (Obj.repr blk) 0 (Obj.repr result); (* do set_field BEFORE set_tag *) + Obj.set_tag (Obj.repr blk) Obj.forward_tag; + result + with e -> + Obj.set_field (Obj.repr blk) 0 (Obj.repr (fun () -> raise e)); + raise e +;; + +(* Assume [blk] is a block with tag lazy *) +let force_val_lazy_block (blk : 'arg lazy_t) = + let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in + Obj.set_field (Obj.repr blk) 0 raise_undefined; + let result = closure () in + Obj.set_field (Obj.repr blk) 0 (Obj.repr result); (* do set_field BEFORE set_tag *) + Obj.set_tag (Obj.repr blk) (Obj.forward_tag); + result +;; + +(* [force] is not used, since [Lazy.force] is declared as a primitive + whose code inlines the tag tests of its argument. This function is + here for the sake of completeness, and for debugging purpose. *) + +let force (lzv : 'arg lazy_t) = + let x = Obj.repr lzv in + let t = Obj.tag x in + if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else + if t <> Obj.lazy_tag then (Obj.obj x : 'arg) + else force_lazy_block lzv +;; + +let force_val (lzv : 'arg lazy_t) = + let x = Obj.repr lzv in + let t = Obj.tag x in + if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else + if t <> Obj.lazy_tag then (Obj.obj x : 'arg) + else force_val_lazy_block lzv +;; diff --git a/ocaml-binary-annot/stdlib/camlinternalLazy.mli b/ocaml-binary-annot/stdlib/camlinternalLazy.mli new file mode 100644 index 0000000000..37b707d4f9 --- /dev/null +++ b/ocaml-binary-annot/stdlib/camlinternalLazy.mli @@ -0,0 +1,25 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Internals of forcing lazy values *) + +exception Undefined;; + +val force_lazy_block : 'a lazy_t -> 'a ;; + +val force_val_lazy_block : 'a lazy_t -> 'a ;; + +val force : 'a lazy_t -> 'a ;; +val force_val : 'a lazy_t -> 'a ;; diff --git a/ocaml-binary-annot/stdlib/camlinternalMod.ml b/ocaml-binary-annot/stdlib/camlinternalMod.ml new file mode 100644 index 0000000000..12a77cc8fb --- /dev/null +++ b/ocaml-binary-annot/stdlib/camlinternalMod.ml @@ -0,0 +1,68 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2004 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +type shape = + | Function + | Lazy + | Class + | Module of shape array + +let rec init_mod loc shape = + match shape with + | Function -> + let pad1 = 1 and pad2 = 2 and pad3 = 3 and pad4 = 4 + and pad5 = 5 and pad6 = 6 and pad7 = 7 and pad8 = 8 in + Obj.repr(fun _ -> + ignore pad1; ignore pad2; ignore pad3; ignore pad4; + ignore pad5; ignore pad6; ignore pad7; ignore pad8; + raise (Undefined_recursive_module loc)) + | Lazy -> + Obj.repr (lazy (raise (Undefined_recursive_module loc))) + | Class -> + Obj.repr (CamlinternalOO.dummy_class loc) + | Module comps -> + Obj.repr (Array.map (init_mod loc) comps) + +let overwrite o n = + assert (Obj.size o >= Obj.size n); + for i = 0 to Obj.size n - 1 do + Obj.set_field o i (Obj.field n i) + done + +let rec update_mod shape o n = + match shape with + | Function -> + if Obj.tag n = Obj.closure_tag && Obj.size n <= Obj.size o + then begin overwrite o n; Obj.truncate o (Obj.size n) (* PR #4008 *) end + else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x)) + | Lazy -> + if Obj.tag n = Obj.lazy_tag then + Obj.set_field o 0 (Obj.field n 0) + else if Obj.tag n = Obj.forward_tag then begin (* PR#4316 *) + Obj.set_tag o Obj.forward_tag; + Obj.set_field o 0 (Obj.field n 0) + end else begin + (* forwarding pointer was shortcut by GC *) + Obj.set_tag o Obj.forward_tag; + Obj.set_field o 0 n + end + | Class -> + assert (Obj.tag n = 0 && Obj.size n = 4); + overwrite o n + | Module comps -> + assert (Obj.tag n = 0 && Obj.size n >= Array.length comps); + for i = 0 to Array.length comps - 1 do + update_mod comps.(i) (Obj.field o i) (Obj.field n i) + done diff --git a/ocaml-binary-annot/stdlib/camlinternalMod.mli b/ocaml-binary-annot/stdlib/camlinternalMod.mli new file mode 100644 index 0000000000..74bf28db28 --- /dev/null +++ b/ocaml-binary-annot/stdlib/camlinternalMod.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2004 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +type shape = + | Function + | Lazy + | Class + | Module of shape array + +val init_mod: string * int * int -> shape -> Obj.t +val update_mod: shape -> Obj.t -> Obj.t -> unit diff --git a/ocaml-binary-annot/stdlib/camlinternalOO.ml b/ocaml-binary-annot/stdlib/camlinternalOO.ml new file mode 100644 index 0000000000..2ffa71c0a2 --- /dev/null +++ b/ocaml-binary-annot/stdlib/camlinternalOO.ml @@ -0,0 +1,588 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Obj + +(**** Object representation ****) + +let last_id = ref 0 +let new_id () = + let id = !last_id in incr last_id; id + +let set_id o id = + let id0 = !id in + Array.unsafe_set (Obj.magic o : int array) 1 id0; + id := id0 + 1 + +(**** Object copy ****) + +let copy o = + let o = (Obj.obj (Obj.dup (Obj.repr o))) in + set_id o last_id; + o + +(**** Compression options ****) +(* Parameters *) +type params = { + mutable compact_table : bool; + mutable copy_parent : bool; + mutable clean_when_copying : bool; + mutable retry_count : int; + mutable bucket_small_size : int + } + +let params = { + compact_table = true; + copy_parent = true; + clean_when_copying = true; + retry_count = 3; + bucket_small_size = 16 +} + +(**** Parameters ****) + +let step = Sys.word_size / 16 +let initial_object_size = 2 + +(**** Items ****) + +type item = DummyA | DummyB | DummyC of int + +let dummy_item = (magic () : item) + +(**** Types ****) + +type tag +type label = int +type closure = item +type t = DummyA | DummyB | DummyC of int +type obj = t array +external ret : (obj -> 'a) -> closure = "%identity" + +(**** Labels ****) + +let public_method_label s : tag = + let accu = ref 0 in + for i = 0 to String.length s - 1 do + accu := 223 * !accu + Char.code s.[i] + done; + (* reduce to 31 bits *) + accu := !accu land (1 lsl 31 - 1); + (* make it signed for 64 bits architectures *) + let tag = if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu in + (* Printf.eprintf "%s = %d\n" s tag; flush stderr; *) + magic tag + +(**** Sparse array ****) + +module Vars = Map.Make(struct type t = string let compare = compare end) +type vars = int Vars.t + +module Meths = Map.Make(struct type t = string let compare = compare end) +type meths = label Meths.t +module Labs = Map.Make(struct type t = label let compare = compare end) +type labs = bool Labs.t + +(* The compiler assumes that the first field of this structure is [size]. *) +type table = + { mutable size: int; + mutable methods: closure array; + mutable methods_by_name: meths; + mutable methods_by_label: labs; + mutable previous_states: + (meths * labs * (label * item) list * vars * + label list * string list) list; + mutable hidden_meths: (label * item) list; + mutable vars: vars; + mutable initializers: (obj -> unit) list } + +let dummy_table = + { methods = [| dummy_item |]; + methods_by_name = Meths.empty; + methods_by_label = Labs.empty; + previous_states = []; + hidden_meths = []; + vars = Vars.empty; + initializers = []; + size = 0 } + +let table_count = ref 0 + +(* dummy_met should be a pointer, so use an atom *) +let dummy_met : item = obj (Obj.new_block 0 0) +(* if debugging is needed, this could be a good idea: *) +(* let dummy_met () = failwith "Undefined method" *) + +let rec fit_size n = + if n <= 2 then n else + fit_size ((n+1)/2) * 2 + +let new_table pub_labels = + incr table_count; + let len = Array.length pub_labels in + let methods = Array.create (len*2+2) dummy_met in + methods.(0) <- magic len; + methods.(1) <- magic (fit_size len * Sys.word_size / 8 - 1); + for i = 0 to len - 1 do methods.(i*2+3) <- magic pub_labels.(i) done; + { methods = methods; + methods_by_name = Meths.empty; + methods_by_label = Labs.empty; + previous_states = []; + hidden_meths = []; + vars = Vars.empty; + initializers = []; + size = initial_object_size } + +let resize array new_size = + let old_size = Array.length array.methods in + if new_size > old_size then begin + let new_buck = Array.create new_size dummy_met in + Array.blit array.methods 0 new_buck 0 old_size; + array.methods <- new_buck + end + +let put array label element = + resize array (label + 1); + array.methods.(label) <- element + +(**** Classes ****) + +let method_count = ref 0 +let inst_var_count = ref 0 + +(* type t *) +type meth = item + +let new_method table = + let index = Array.length table.methods in + resize table (index + 1); + index + +let get_method_label table name = + try + Meths.find name table.methods_by_name + with Not_found -> + let label = new_method table in + table.methods_by_name <- Meths.add name label table.methods_by_name; + table.methods_by_label <- Labs.add label true table.methods_by_label; + label + +let get_method_labels table names = + Array.map (get_method_label table) names + +let set_method table label element = + incr method_count; + if Labs.find label table.methods_by_label then + put table label element + else + table.hidden_meths <- (label, element) :: table.hidden_meths + +let get_method table label = + try List.assoc label table.hidden_meths + with Not_found -> table.methods.(label) + +let to_list arr = + if arr == magic 0 then [] else Array.to_list arr + +let narrow table vars virt_meths concr_meths = + let vars = to_list vars + and virt_meths = to_list virt_meths + and concr_meths = to_list concr_meths in + let virt_meth_labs = List.map (get_method_label table) virt_meths in + let concr_meth_labs = List.map (get_method_label table) concr_meths in + table.previous_states <- + (table.methods_by_name, table.methods_by_label, table.hidden_meths, + table.vars, virt_meth_labs, vars) + :: table.previous_states; + table.vars <- + Vars.fold + (fun lab info tvars -> + if List.mem lab vars then Vars.add lab info tvars else tvars) + table.vars Vars.empty; + let by_name = ref Meths.empty in + let by_label = ref Labs.empty in + List.iter2 + (fun met label -> + by_name := Meths.add met label !by_name; + by_label := + Labs.add label + (try Labs.find label table.methods_by_label with Not_found -> true) + !by_label) + concr_meths concr_meth_labs; + List.iter2 + (fun met label -> + by_name := Meths.add met label !by_name; + by_label := Labs.add label false !by_label) + virt_meths virt_meth_labs; + table.methods_by_name <- !by_name; + table.methods_by_label <- !by_label; + table.hidden_meths <- + List.fold_right + (fun ((lab, _) as met) hm -> + if List.mem lab virt_meth_labs then hm else met::hm) + table.hidden_meths + [] + +let widen table = + let (by_name, by_label, saved_hidden_meths, saved_vars, virt_meths, vars) = + List.hd table.previous_states + in + table.previous_states <- List.tl table.previous_states; + table.vars <- + List.fold_left + (fun s v -> Vars.add v (Vars.find v table.vars) s) + saved_vars vars; + table.methods_by_name <- by_name; + table.methods_by_label <- by_label; + table.hidden_meths <- + List.fold_right + (fun ((lab, _) as met) hm -> + if List.mem lab virt_meths then hm else met::hm) + table.hidden_meths + saved_hidden_meths + +let new_slot table = + let index = table.size in + table.size <- index + 1; + index + +let new_variable table name = + try Vars.find name table.vars + with Not_found -> + let index = new_slot table in + if name <> "" then table.vars <- Vars.add name index table.vars; + index + +let to_array arr = + if arr = Obj.magic 0 then [||] else arr + +let new_methods_variables table meths vals = + let meths = to_array meths in + let nmeths = Array.length meths and nvals = Array.length vals in + let res = Array.create (nmeths + nvals) 0 in + for i = 0 to nmeths - 1 do + res.(i) <- get_method_label table meths.(i) + done; + for i = 0 to nvals - 1 do + res.(i+nmeths) <- new_variable table vals.(i) + done; + res + +let get_variable table name = + try Vars.find name table.vars with Not_found -> assert false + +let get_variables table names = + Array.map (get_variable table) names + +let add_initializer table f = + table.initializers <- f::table.initializers + +(* +module Keys = Map.Make(struct type t = tag array let compare = compare end) +let key_map = ref Keys.empty +let get_key tags : item = + try magic (Keys.find tags !key_map : tag array) + with Not_found -> + key_map := Keys.add tags tags !key_map; + magic tags +*) + +let create_table public_methods = + if public_methods == magic 0 then new_table [||] else + (* [public_methods] must be in ascending order for bytecode *) + let tags = Array.map public_method_label public_methods in + let table = new_table tags in + Array.iteri + (fun i met -> + let lab = i*2+2 in + table.methods_by_name <- Meths.add met lab table.methods_by_name; + table.methods_by_label <- Labs.add lab true table.methods_by_label) + public_methods; + table + +let init_class table = + inst_var_count := !inst_var_count + table.size - 1; + table.initializers <- List.rev table.initializers; + resize table (3 + magic table.methods.(1) * 16 / Sys.word_size) + +let inherits cla vals virt_meths concr_meths (_, super, _, env) top = + narrow cla vals virt_meths concr_meths; + let init = + if top then super cla env else Obj.repr (super cla) in + widen cla; + Array.concat + [[| repr init |]; + magic (Array.map (get_variable cla) (to_array vals) : int array); + Array.map + (fun nm -> repr (get_method cla (get_method_label cla nm) : closure)) + (to_array concr_meths) ] + +let make_class pub_meths class_init = + let table = create_table pub_meths in + let env_init = class_init table in + init_class table; + (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0) + +type init_table = { mutable env_init: t; mutable class_init: table -> t } + +let make_class_store pub_meths class_init init_table = + let table = create_table pub_meths in + let env_init = class_init table in + init_class table; + init_table.class_init <- class_init; + init_table.env_init <- env_init + +let dummy_class loc = + let undef = fun _ -> raise (Undefined_recursive_module loc) in + (Obj.magic undef, undef, undef, Obj.repr 0) + +(**** Objects ****) + +let create_object table = + (* XXX Appel de [obj_block] *) + let obj = Obj.new_block Obj.object_tag table.size in + (* XXX Appel de [caml_modify] *) + Obj.set_field obj 0 (Obj.repr table.methods); + set_id obj last_id; + (Obj.obj obj) + +let create_object_opt obj_0 table = + if (Obj.magic obj_0 : bool) then obj_0 else begin + (* XXX Appel de [obj_block] *) + let obj = Obj.new_block Obj.object_tag table.size in + (* XXX Appel de [caml_modify] *) + Obj.set_field obj 0 (Obj.repr table.methods); + set_id obj last_id; + (Obj.obj obj) + end + +let rec iter_f obj = + function + [] -> () + | f::l -> f obj; iter_f obj l + +let run_initializers obj table = + let inits = table.initializers in + if inits <> [] then + iter_f obj inits + +let run_initializers_opt obj_0 obj table = + if (Obj.magic obj_0 : bool) then obj else begin + let inits = table.initializers in + if inits <> [] then iter_f obj inits; + obj + end + +let create_object_and_run_initializers obj_0 table = + if (Obj.magic obj_0 : bool) then obj_0 else begin + let obj = create_object table in + run_initializers obj table; + obj + end + +(* Equivalent primitive below +let sendself obj lab = + (magic obj : (obj -> t) array array).(0).(lab) obj +*) +external send : obj -> tag -> 'a = "%send" +external sendcache : obj -> tag -> t -> int -> 'a = "%sendcache" +external sendself : obj -> label -> 'a = "%sendself" +external get_public_method : obj -> tag -> closure + = "caml_get_public_method" "noalloc" + +(**** table collection access ****) + +type tables = Empty | Cons of closure * tables * tables +type mut_tables = + {key: closure; mutable data: tables; mutable next: tables} +external mut : tables -> mut_tables = "%identity" + +let build_path n keys tables = + let res = Cons (Obj.magic 0, Empty, Empty) in + let r = ref res in + for i = 0 to n do + r := Cons (keys.(i), !r, Empty) + done; + tables.data <- !r; + res + +let rec lookup_keys i keys tables = + if i < 0 then tables else + let key = keys.(i) in + let rec lookup_key tables = + if tables.key == key then lookup_keys (i-1) keys tables.data else + if tables.next <> Empty then lookup_key (mut tables.next) else + let next = Cons (key, Empty, Empty) in + tables.next <- next; + build_path (i-1) keys (mut next) + in + lookup_key (mut tables) + +let lookup_tables root keys = + let root = mut root in + if root.data <> Empty then + lookup_keys (Array.length keys - 1) keys root.data + else + build_path (Array.length keys - 1) keys root + +(**** builtin methods ****) + +let get_const x = ret (fun obj -> x) +let get_var n = ret (fun obj -> Array.unsafe_get obj n) +let get_env e n = + ret (fun obj -> + Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n) +let get_meth n = ret (fun obj -> sendself obj n) +let set_var n = ret (fun obj x -> Array.unsafe_set obj n x) +let app_const f x = ret (fun obj -> f x) +let app_var f n = ret (fun obj -> f (Array.unsafe_get obj n)) +let app_env f e n = + ret (fun obj -> + f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n)) +let app_meth f n = ret (fun obj -> f (sendself obj n)) +let app_const_const f x y = ret (fun obj -> f x y) +let app_const_var f x n = ret (fun obj -> f x (Array.unsafe_get obj n)) +let app_const_meth f x n = ret (fun obj -> f x (sendself obj n)) +let app_var_const f n x = ret (fun obj -> f (Array.unsafe_get obj n) x) +let app_meth_const f n x = ret (fun obj -> f (sendself obj n) x) +let app_const_env f x e n = + ret (fun obj -> + f x (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n)) +let app_env_const f e n x = + ret (fun obj -> + f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n) x) +let meth_app_const n x = ret (fun obj -> (sendself obj n : _ -> _) x) +let meth_app_var n m = + ret (fun obj -> (sendself obj n : _ -> _) (Array.unsafe_get obj m)) +let meth_app_env n e m = + ret (fun obj -> (sendself obj n : _ -> _) + (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) m)) +let meth_app_meth n m = + ret (fun obj -> (sendself obj n : _ -> _) (sendself obj m)) +let send_const m x c = + ret (fun obj -> sendcache x m (Array.unsafe_get obj 0) c) +let send_var m n c = + ret (fun obj -> + sendcache (Obj.magic (Array.unsafe_get obj n) : obj) m + (Array.unsafe_get obj 0) c) +let send_env m e n c = + ret (fun obj -> + sendcache + (Obj.magic (Array.unsafe_get + (Obj.magic (Array.unsafe_get obj e) : obj) n) : obj) + m (Array.unsafe_get obj 0) c) +let send_meth m n c = + ret (fun obj -> + sendcache (sendself obj n) m (Array.unsafe_get obj 0) c) +let new_cache table = + let n = new_method table in + let n = + if n mod 2 = 0 || n > 2 + magic table.methods.(1) * 16 / Sys.word_size + then n else new_method table + in + table.methods.(n) <- Obj.magic 0; + n + +type impl = + GetConst + | GetVar + | GetEnv + | GetMeth + | SetVar + | AppConst + | AppVar + | AppEnv + | AppMeth + | AppConstConst + | AppConstVar + | AppConstEnv + | AppConstMeth + | AppVarConst + | AppEnvConst + | AppMethConst + | MethAppConst + | MethAppVar + | MethAppEnv + | MethAppMeth + | SendConst + | SendVar + | SendEnv + | SendMeth + | Closure of closure + +let method_impl table i arr = + let next () = incr i; magic arr.(!i) in + match next() with + GetConst -> let x : t = next() in get_const x + | GetVar -> let n = next() in get_var n + | GetEnv -> let e = next() and n = next() in get_env e n + | GetMeth -> let n = next() in get_meth n + | SetVar -> let n = next() in set_var n + | AppConst -> let f = next() and x = next() in app_const f x + | AppVar -> let f = next() and n = next () in app_var f n + | AppEnv -> + let f = next() and e = next() and n = next() in app_env f e n + | AppMeth -> let f = next() and n = next () in app_meth f n + | AppConstConst -> + let f = next() and x = next() and y = next() in app_const_const f x y + | AppConstVar -> + let f = next() and x = next() and n = next() in app_const_var f x n + | AppConstEnv -> + let f = next() and x = next() and e = next () and n = next() in + app_const_env f x e n + | AppConstMeth -> + let f = next() and x = next() and n = next() in app_const_meth f x n + | AppVarConst -> + let f = next() and n = next() and x = next() in app_var_const f n x + | AppEnvConst -> + let f = next() and e = next () and n = next() and x = next() in + app_env_const f e n x + | AppMethConst -> + let f = next() and n = next() and x = next() in app_meth_const f n x + | MethAppConst -> + let n = next() and x = next() in meth_app_const n x + | MethAppVar -> + let n = next() and m = next() in meth_app_var n m + | MethAppEnv -> + let n = next() and e = next() and m = next() in meth_app_env n e m + | MethAppMeth -> + let n = next() and m = next() in meth_app_meth n m + | SendConst -> + let m = next() and x = next() in send_const m x (new_cache table) + | SendVar -> + let m = next() and n = next () in send_var m n (new_cache table) + | SendEnv -> + let m = next() and e = next() and n = next() in + send_env m e n (new_cache table) + | SendMeth -> + let m = next() and n = next () in send_meth m n (new_cache table) + | Closure _ as clo -> magic clo + +let set_methods table methods = + let len = Array.length methods and i = ref 0 in + while !i < len do + let label = methods.(!i) and clo = method_impl table i methods in + set_method table label clo; + incr i + done + +(**** Statistics ****) + +type stats = + { classes: int; methods: int; inst_vars: int; } + +let stats () = + { classes = !table_count; + methods = !method_count; inst_vars = !inst_var_count; } diff --git a/ocaml-binary-annot/stdlib/camlinternalOO.mli b/ocaml-binary-annot/stdlib/camlinternalOO.mli new file mode 100644 index 0000000000..d2aeea319b --- /dev/null +++ b/ocaml-binary-annot/stdlib/camlinternalOO.mli @@ -0,0 +1,153 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jerome Vouillon, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Run-time support for objects and classes. + All functions in this module are for system use only, not for the + casual user. *) + +(** {6 Classes} *) + +type tag +type label +type table +type meth +type t +type obj +type closure +val public_method_label : string -> tag +val new_method : table -> label +val new_variable : table -> string -> int +val new_methods_variables : + table -> string array -> string array -> label array +val get_variable : table -> string -> int +val get_variables : table -> string array -> int array +val get_method_label : table -> string -> label +val get_method_labels : table -> string array -> label array +val get_method : table -> label -> meth +val set_method : table -> label -> meth -> unit +val set_methods : table -> label array -> unit +val narrow : table -> string array -> string array -> string array -> unit +val widen : table -> unit +val add_initializer : table -> (obj -> unit) -> unit +val dummy_table : table +val create_table : string array -> table +val init_class : table -> unit +val inherits : + table -> string array -> string array -> string array -> + (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t array +val make_class : + string array -> (table -> Obj.t -> t) -> + (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t) +type init_table +val make_class_store : + string array -> (table -> t) -> init_table -> unit +val dummy_class : + string * int * int -> + (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t) + +(** {6 Objects} *) + +val copy : (< .. > as 'a) -> 'a +val create_object : table -> obj +val create_object_opt : obj -> table -> obj +val run_initializers : obj -> table -> unit +val run_initializers_opt : obj -> obj -> table -> obj +val create_object_and_run_initializers : obj -> table -> obj +external send : obj -> tag -> t = "%send" +external sendcache : obj -> tag -> t -> int -> t = "%sendcache" +external sendself : obj -> label -> t = "%sendself" +external get_public_method : obj -> tag -> closure + = "caml_get_public_method" "noalloc" + +(** {6 Table cache} *) + +type tables +val lookup_tables : tables -> closure array -> tables + +(** {6 Builtins to reduce code size} *) + +(* +val get_const : t -> closure +val get_var : int -> closure +val get_env : int -> int -> closure +val get_meth : label -> closure +val set_var : int -> closure +val app_const : (t -> t) -> t -> closure +val app_var : (t -> t) -> int -> closure +val app_env : (t -> t) -> int -> int -> closure +val app_meth : (t -> t) -> label -> closure +val app_const_const : (t -> t -> t) -> t -> t -> closure +val app_const_var : (t -> t -> t) -> t -> int -> closure +val app_const_env : (t -> t -> t) -> t -> int -> int -> closure +val app_const_meth : (t -> t -> t) -> t -> label -> closure +val app_var_const : (t -> t -> t) -> int -> t -> closure +val app_env_const : (t -> t -> t) -> int -> int -> t -> closure +val app_meth_const : (t -> t -> t) -> label -> t -> closure +val meth_app_const : label -> t -> closure +val meth_app_var : label -> int -> closure +val meth_app_env : label -> int -> int -> closure +val meth_app_meth : label -> label -> closure +val send_const : tag -> obj -> int -> closure +val send_var : tag -> int -> int -> closure +val send_env : tag -> int -> int -> int -> closure +val send_meth : tag -> label -> int -> closure +*) + +type impl = + GetConst + | GetVar + | GetEnv + | GetMeth + | SetVar + | AppConst + | AppVar + | AppEnv + | AppMeth + | AppConstConst + | AppConstVar + | AppConstEnv + | AppConstMeth + | AppVarConst + | AppEnvConst + | AppMethConst + | MethAppConst + | MethAppVar + | MethAppEnv + | MethAppMeth + | SendConst + | SendVar + | SendEnv + | SendMeth + | Closure of closure + +(** {6 Parameters} *) + +(* currently disabled *) +type params = + { mutable compact_table : bool; + mutable copy_parent : bool; + mutable clean_when_copying : bool; + mutable retry_count : int; + mutable bucket_small_size : int } + +val params : params + +(** {6 Statistics} *) + +type stats = + { classes : int; + methods : int; + inst_vars : int } +val stats : unit -> stats diff --git a/ocaml-binary-annot/stdlib/char.ml b/ocaml-binary-annot/stdlib/char.ml new file mode 100644 index 0000000000..28a1bcc46c --- /dev/null +++ b/ocaml-binary-annot/stdlib/char.ml @@ -0,0 +1,69 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Character operations *) + +external code: char -> int = "%identity" +external unsafe_chr: int -> char = "%identity" + +let chr n = + if n < 0 || n > 255 then invalid_arg "Char.chr" else unsafe_chr n + +external is_printable: char -> bool = "caml_is_printable" + +external string_create: int -> string = "caml_create_string" +external string_unsafe_get : string -> int -> char = "%string_unsafe_get" +external string_unsafe_set : string -> int -> char -> unit + = "%string_unsafe_set" + +let escaped = function + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | c -> + if is_printable c then begin + let s = string_create 1 in + string_unsafe_set s 0 c; + s + end else begin + let n = code c in + let s = string_create 4 in + string_unsafe_set s 0 '\\'; + string_unsafe_set s 1 (unsafe_chr (48 + n / 100)); + string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10)); + string_unsafe_set s 3 (unsafe_chr (48 + n mod 10)); + s + end + +let lowercase c = + if (c >= 'A' && c <= 'Z') + || (c >= '\192' && c <= '\214') + || (c >= '\216' && c <= '\222') + then unsafe_chr(code c + 32) + else c + +let uppercase c = + if (c >= 'a' && c <= 'z') + || (c >= '\224' && c <= '\246') + || (c >= '\248' && c <= '\254') + then unsafe_chr(code c - 32) + else c + +type t = char + +let compare c1 c2 = code c1 - code c2 diff --git a/ocaml-binary-annot/stdlib/char.mli b/ocaml-binary-annot/stdlib/char.mli new file mode 100644 index 0000000000..8ab72bd9a6 --- /dev/null +++ b/ocaml-binary-annot/stdlib/char.mli @@ -0,0 +1,48 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Character operations. *) + +external code : char -> int = "%identity" +(** Return the ASCII code of the argument. *) + +val chr : int -> char +(** Return the character with the given ASCII code. + Raise [Invalid_argument "Char.chr"] if the argument is + outside the range 0--255. *) + +val escaped : char -> string +(** Return a string representing the given character, + with special characters escaped following the lexical conventions + of Objective Caml. *) + +val lowercase : char -> char +(** Convert the given character to its equivalent lowercase character. *) + +val uppercase : char -> char +(** Convert the given character to its equivalent uppercase character. *) + +type t = char +(** An alias for the type of characters. *) + +val compare: t -> t -> int +(** The comparison function for characters, with the same specification as + {!Pervasives.compare}. Along with the type [t], this function [compare] + allows the module [Char] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +(**/**) + +external unsafe_chr : int -> char = "%identity" diff --git a/ocaml-binary-annot/stdlib/complex.ml b/ocaml-binary-annot/stdlib/complex.ml new file mode 100644 index 0000000000..3c28a58b79 --- /dev/null +++ b/ocaml-binary-annot/stdlib/complex.ml @@ -0,0 +1,87 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Complex numbers *) + +type t = { re: float; im: float } + +let zero = { re = 0.0; im = 0.0 } +let one = { re = 1.0; im = 0.0 } +let i = { re = 0.0; im = 1.0 } + +let add x y = { re = x.re +. y.re; im = x.im +. y.im } + +let sub x y = { re = x.re -. y.re; im = x.im -. y.im } + +let neg x = { re = -. x.re; im = -. x.im } + +let conj x = { re = x.re; im = -. x.im } + +let mul x y = { re = x.re *. y.re -. x.im *. y.im; + im = x.re *. y.im +. x.im *. y.re } + +let div x y = + if abs_float y.re >= abs_float y.im then + let r = y.im /. y.re in + let d = y.re +. r *. y.im in + { re = (x.re +. r *. x.im) /. d; + im = (x.im -. r *. x.re) /. d } + else + let r = y.re /. y.im in + let d = y.im +. r *. y.re in + { re = (r *. x.re +. x.im) /. d; + im = (r *. x.im -. x.re) /. d } + +let inv x = div one x + +let norm2 x = x.re *. x.re +. x.im *. x.im + +let norm x = + (* Watch out for overflow in computing re^2 + im^2 *) + let r = abs_float x.re and i = abs_float x.im in + if r = 0.0 then i + else if i = 0.0 then r + else if r >= i then + let q = i /. r in r *. sqrt(1.0 +. q *. q) + else + let q = r /. i in i *. sqrt(1.0 +. q *. q) + +let arg x = atan2 x.im x.re + +let polar n a = { re = cos a *. n; im = sin a *. n } + +let sqrt x = + if x.re = 0.0 && x.im = 0.0 then { re = 0.0; im = 0.0 } + else begin + let r = abs_float x.re and i = abs_float x.im in + let w = + if r >= i then begin + let q = i /. r in + sqrt(r) *. sqrt(0.5 *. (1.0 +. sqrt(1.0 +. q *. q))) + end else begin + let q = r /. i in + sqrt(i) *. sqrt(0.5 *. (q +. sqrt(1.0 +. q *. q))) + end in + if x.re >= 0.0 + then { re = w; im = 0.5 *. x.im /. w } + else { re = 0.5 *. i /. w; im = if x.im >= 0.0 then w else -. w } + end + +let exp x = + let e = exp x.re in { re = e *. cos x.im; im = e *. sin x.im } + +let log x = { re = log (norm x); im = atan2 x.im x.re } + +let pow x y = exp (mul y (log x)) diff --git a/ocaml-binary-annot/stdlib/complex.mli b/ocaml-binary-annot/stdlib/complex.mli new file mode 100644 index 0000000000..3c3b361d27 --- /dev/null +++ b/ocaml-binary-annot/stdlib/complex.mli @@ -0,0 +1,86 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Complex numbers. + + This module provides arithmetic operations on complex numbers. + Complex numbers are represented by their real and imaginary parts + (cartesian representation). Each part is represented by a + double-precision floating-point number (type [float]). *) + +type t = { re: float; im: float } +(** The type of complex numbers. [re] is the real part and [im] the + imaginary part. *) + +val zero: t +(** The complex number [0]. *) + +val one: t +(** The complex number [1]. *) + +val i: t +(** The complex number [i]. *) + +val neg: t -> t +(** Unary negation. *) + +val conj: t -> t +(** Conjugate: given the complex [x + i.y], returns [x - i.y]. *) + +val add: t -> t -> t +(** Addition *) + +val sub: t -> t -> t +(** Subtraction *) + +val mul: t -> t -> t +(** Multiplication *) + +val inv: t -> t +(** Multiplicative inverse ([1/z]). *) + +val div: t -> t -> t +(** Division *) + +val sqrt: t -> t +(** Square root. The result [x + i.y] is such that [x > 0] or + [x = 0] and [y >= 0]. + This function has a discontinuity along the negative real axis. *) + +val norm2: t -> float +(** Norm squared: given [x + i.y], returns [x^2 + y^2]. *) + +val norm: t -> float +(** Norm: given [x + i.y], returns [sqrt(x^2 + y^2)]. *) + +val arg: t -> float +(** Argument. The argument of a complex number is the angle + in the complex plane between the positive real axis and a line + passing through zero and the number. This angle ranges from + [-pi] to [pi]. This function has a discontinuity along the + negative real axis. *) + +val polar: float -> float -> t +(** [polar norm arg] returns the complex having norm [norm] + and argument [arg]. *) + +val exp: t -> t +(** Exponentiation. [exp z] returns [e] to the [z] power. *) + +val log: t -> t +(** Natural logarithm (in base [e]). *) + +val pow: t -> t -> t +(** Power function. [pow z1 z2] returns [z1] to the [z2] power. *) diff --git a/ocaml-binary-annot/stdlib/digest.ml b/ocaml-binary-annot/stdlib/digest.ml new file mode 100644 index 0000000000..78a45d54ee --- /dev/null +++ b/ocaml-binary-annot/stdlib/digest.ml @@ -0,0 +1,51 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Message digest (MD5) *) + +type t = string + +external unsafe_string: string -> int -> int -> t = "caml_md5_string" +external channel: in_channel -> int -> t = "caml_md5_chan" + +let string str = + unsafe_string str 0 (String.length str) + +let substring str ofs len = + if ofs < 0 || len < 0 || ofs > String.length str - len + then invalid_arg "Digest.substring" + else unsafe_string str ofs len + +let file filename = + let ic = open_in_bin filename in + let d = channel ic (-1) in + close_in ic; + d + +let output chan digest = + output chan digest 0 16 + +let input chan = + let digest = String.create 16 in + really_input chan digest 0 16; + digest + +let to_hex d = + let result = String.create 32 in + for i = 0 to 15 do + String.blit (Printf.sprintf "%02x" (int_of_char d.[i])) 0 result (2*i) 2; + done; + result +;; diff --git a/ocaml-binary-annot/stdlib/digest.mli b/ocaml-binary-annot/stdlib/digest.mli new file mode 100644 index 0000000000..981bd02fc3 --- /dev/null +++ b/ocaml-binary-annot/stdlib/digest.mli @@ -0,0 +1,53 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** MD5 message digest. + + This module provides functions to compute 128-bit ``digests'' of + arbitrary-length strings or files. The digests are of cryptographic + quality: it is very hard, given a digest, to forge a string having + that digest. The algorithm used is MD5. +*) + +type t = string +(** The type of digests: 16-character strings. *) + +val string : string -> t +(** Return the digest of the given string. *) + +val substring : string -> int -> int -> t +(** [Digest.substring s ofs len] returns the digest of the substring + of [s] starting at character number [ofs] and containing [len] + characters. *) + +external channel : in_channel -> int -> t = "caml_md5_chan" +(** If [len] is nonnegative, [Digest.channel ic len] reads [len] + characters from channel [ic] and returns their digest, or raises + [End_of_file] if end-of-file is reached before [len] characters + are read. If [len] is negative, [Digest.channel ic len] reads + all characters from [ic] until end-of-file is reached and return + their digest. *) + +val file : string -> t +(** Return the digest of the file whose name is given. *) + +val output : out_channel -> t -> unit +(** Write a digest on the given output channel. *) + +val input : in_channel -> t +(** Read a digest from the given input channel. *) + +val to_hex : t -> string +(** Return the printable hexadecimal representation of the given digest. *) diff --git a/ocaml-binary-annot/stdlib/filename.ml b/ocaml-binary-annot/stdlib/filename.ml new file mode 100644 index 0000000000..e11f1e3304 --- /dev/null +++ b/ocaml-binary-annot/stdlib/filename.ml @@ -0,0 +1,220 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy and Damien Doligez, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +let generic_quote quotequote s = + let l = String.length s in + let b = Buffer.create (l + 20) in + Buffer.add_char b '\''; + for i = 0 to l - 1 do + if s.[i] = '\'' + then Buffer.add_string b quotequote + else Buffer.add_char b s.[i] + done; + Buffer.add_char b '\''; + Buffer.contents b + +let generic_basename rindex_dir_sep current_dir_name name = + let raw_name = + try + let p = rindex_dir_sep name + 1 in + String.sub name p (String.length name - p) + with Not_found -> + name + in + if raw_name = "" then current_dir_name else raw_name + +let generic_dirname rindex_dir_sep current_dir_name dir_sep name = + try + match rindex_dir_sep name with + 0 -> dir_sep + | n -> String.sub name 0 n + with Not_found -> + current_dir_name + +module Unix = struct + let current_dir_name = "." + let parent_dir_name = ".." + let dir_sep = "/" + let is_dir_sep s i = s.[i] = '/' + let rindex_dir_sep s = String.rindex s '/' + let is_relative n = String.length n < 1 || n.[0] <> '/';; + let is_implicit n = + is_relative n + && (String.length n < 2 || String.sub n 0 2 <> "./") + && (String.length n < 3 || String.sub n 0 3 <> "../") + 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 temp_dir_name = + try Sys.getenv "TMPDIR" with Not_found -> "/tmp" + let quote = generic_quote "'\\''" + let basename = generic_basename rindex_dir_sep current_dir_name + let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep +end + +module Win32 = struct + let current_dir_name = "." + let parent_dir_name = ".." + let dir_sep = "\\" + let is_dir_sep s i = let c = s.[i] in c = '/' || c = '\\' || c = ':' + let rindex_dir_sep s = + let rec pos i = + if i < 0 then raise Not_found + else if is_dir_sep s i then i + else pos (i - 1) + in pos (String.length s - 1) + let is_relative n = + (String.length n < 1 || n.[0] <> '/') + && (String.length n < 1 || n.[0] <> '\\') + && (String.length n < 2 || n.[1] <> ':') + let is_implicit n = + is_relative n + && (String.length n < 2 || String.sub n 0 2 <> "./") + && (String.length n < 2 || String.sub n 0 2 <> ".\\") + && (String.length n < 3 || String.sub n 0 3 <> "../") + && (String.length n < 3 || String.sub n 0 3 <> "..\\") + let check_suffix name suff = + String.length name >= String.length suff && + (let s = String.sub name (String.length name - String.length suff) + (String.length suff) in + String.lowercase s = String.lowercase suff) + let temp_dir_name = + try Sys.getenv "TEMP" with Not_found -> "." + let quote s = + let l = String.length s in + let b = Buffer.create (l + 20) in + Buffer.add_char b '\"'; + let rec loop i = + if i = l then Buffer.add_char b '\"' else + match s.[i] with + | '\"' -> loop_bs 0 i; + | '\\' -> loop_bs 0 i; + | c -> Buffer.add_char b c; loop (i+1); + and loop_bs n i = + if i = l then begin + Buffer.add_char b '\"'; + add_bs n; + end else begin + match s.[i] with + | '\"' -> add_bs (2*n+1); Buffer.add_char b '\"'; loop (i+1); + | '\\' -> loop_bs (n+1) (i+1); + | c -> add_bs n; loop i + end + and add_bs n = for j = 1 to n do Buffer.add_char b '\\'; done + in + loop 0; + Buffer.contents b + let has_drive s = + let is_letter = function + | 'A' .. 'Z' | 'a' .. 'z' -> true + | _ -> false + in + String.length s >= 2 && is_letter s.[0] && s.[1] = ':' + let drive_and_path s = + if has_drive s + then (String.sub s 0 2, String.sub s 2 (String.length s - 2)) + else ("", s) + let dirname s = + let (drive, path) = drive_and_path s in + let dir = generic_dirname rindex_dir_sep current_dir_name dir_sep path in + drive ^ dir + let basename s = + let (drive, path) = drive_and_path s in + generic_basename rindex_dir_sep current_dir_name path +end + +module Cygwin = struct + let current_dir_name = "." + let parent_dir_name = ".." + let dir_sep = "/" + let is_dir_sep = Win32.is_dir_sep + let rindex_dir_sep = Win32.rindex_dir_sep + let is_relative = Win32.is_relative + let is_implicit = Win32.is_implicit + let check_suffix = Win32.check_suffix + let temp_dir_name = Unix.temp_dir_name + let quote = Unix.quote + let basename = generic_basename rindex_dir_sep current_dir_name + let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep +end + +let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep, rindex_dir_sep, + is_relative, is_implicit, check_suffix, temp_dir_name, quote, basename, + dirname) = + match Sys.os_type with + "Unix" -> + (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep, + Unix.is_dir_sep, Unix.rindex_dir_sep, + Unix.is_relative, Unix.is_implicit, Unix.check_suffix, + Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname) + | "Win32" -> + (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep, + Win32.is_dir_sep, Win32.rindex_dir_sep, + Win32.is_relative, Win32.is_implicit, Win32.check_suffix, + Win32.temp_dir_name, Win32.quote, Win32.basename, Win32.dirname) + | "Cygwin" -> + (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep, + Cygwin.is_dir_sep, Cygwin.rindex_dir_sep, + Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix, + Cygwin.temp_dir_name, Cygwin.quote, Cygwin.basename, Cygwin.dirname) + | _ -> assert false + +let concat dirname filename = + let l = String.length dirname in + if l = 0 || is_dir_sep dirname (l-1) + then dirname ^ filename + else dirname ^ dir_sep ^ filename + +let chop_suffix name suff = + let n = String.length name - String.length suff in + if n < 0 then invalid_arg "Filename.chop_suffix" else String.sub name 0 n + +let chop_extension name = + let rec search_dot i = + if i < 0 || is_dir_sep name i then invalid_arg "Filename.chop_extension" + else if name.[i] = '.' then String.sub name 0 i + else search_dot (i - 1) in + search_dot (String.length name - 1) + +external open_desc: string -> open_flag list -> int -> int = "caml_sys_open" +external close_desc: int -> unit = "caml_sys_close" + +let prng = Random.State.make_self_init ();; + +let temp_file_name temp_dir prefix suffix = + let rnd = (Random.State.bits prng) land 0xFFFFFF in + concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix) +;; + +let temp_file ?(temp_dir=temp_dir_name) prefix suffix = + let rec try_name counter = + let name = temp_file_name temp_dir prefix suffix in + try + close_desc(open_desc name [Open_wronly; Open_creat; Open_excl] 0o600); + name + with Sys_error _ as e -> + if counter >= 1000 then raise e else try_name (counter + 1) + in try_name 0 + +let open_temp_file ?(mode = [Open_text]) ?(temp_dir=temp_dir_name) prefix suffix = + let rec try_name counter = + let name = temp_file_name temp_dir prefix suffix in + try + (name, + open_out_gen (Open_wronly::Open_creat::Open_excl::mode) 0o600 name) + with Sys_error _ as e -> + if counter >= 1000 then raise e else try_name (counter + 1) + in try_name 0 diff --git a/ocaml-binary-annot/stdlib/filename.mli b/ocaml-binary-annot/stdlib/filename.mli new file mode 100644 index 0000000000..e43f19ccf2 --- /dev/null +++ b/ocaml-binary-annot/stdlib/filename.mli @@ -0,0 +1,116 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Operations on file names. *) + +val current_dir_name : string +(** The conventional name for the current directory (e.g. [.] in Unix). *) + +val parent_dir_name : string +(** The conventional name for the parent of the current directory + (e.g. [..] in Unix). *) + +val dir_sep : string +(** The directory separator (e.g. [/] in Unix). @since 3.11.2 *) + +val concat : string -> string -> string +(** [concat dir file] returns a file name that designates file + [file] in directory [dir]. *) + +val is_relative : string -> bool +(** Return [true] if the file name is relative to the current + directory, [false] if it is absolute (i.e. in Unix, starts + with [/]). *) + +val is_implicit : string -> bool +(** Return [true] if the file name is relative and does not start + with an explicit reference to the current directory ([./] or + [../] in Unix), [false] if it starts with an explicit reference + to the root directory or 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 chop_extension : string -> string +(** Return the given file name without its extension. The extension + is the shortest suffix starting with a period and not including + a directory separator, [.xyz] for instance. + + Raise [Invalid_argument] if the given name does not contain + an extension. *) + +val basename : 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 {!Sys.chdir}. + + The result is not specified if the argument is not a valid file name + (for example, under Unix if there is a NUL character in the string). *) + +val dirname : string -> string +(** See {!Filename.basename}. *) + +val temp_file : ?temp_dir: string -> string -> string -> string +(** [temp_file prefix suffix] returns the name of a + fresh temporary file in the temporary directory. + The base name of the temporary file is formed by concatenating + [prefix], then a suitably chosen integer number, then [suffix]. + The optional argument [temp_dir] indicates the temporary directory + to use, defaulting to {!Filename.temp_dir_name}. + The temporary file is created empty, with permissions [0o600] + (readable and writable only by the file owner). The file is + guaranteed to be different from any other file that existed when + [temp_file] was called. + @before 3.11.2 no ?temp_dir optional argument +*) + +val open_temp_file : + ?mode: open_flag list -> ?temp_dir: string -> string -> string -> string * out_channel +(** Same as {!Filename.temp_file}, but returns both the name of a fresh + temporary file, and an output channel opened (atomically) on + this file. This function is more secure than [temp_file]: there + is no risk that the temporary file will be modified (e.g. replaced + by a symbolic link) before the program opens it. The optional argument + [mode] is a list of additional flags to control the opening of the file. + It can contain one or several of [Open_append], [Open_binary], + and [Open_text]. The default is [[Open_text]] (open in text mode). + @before 3.11.2 no ?temp_dir optional argument +*) + +val temp_dir_name : string +(** The name of the temporary directory: + Under Unix, the value of the [TMPDIR] environment variable, or "/tmp" + if the variable is not set. + Under Windows, the value of the [TEMP] environment variable, or "." + if the variable is not set. + @since 3.09.1 +*) + +val quote : string -> string +(** Return a quoted version of a file name, suitable for use as + one argument in a command line, escaping all meta-characters. + Warning: under Windows, the output is only suitable for use + with programs that follow the standard Windows quoting + conventions. + *) diff --git a/ocaml-binary-annot/stdlib/format.ml b/ocaml-binary-annot/stdlib/format.ml new file mode 100644 index 0000000000..a8d6ec9e14 --- /dev/null +++ b/ocaml-binary-annot/stdlib/format.ml @@ -0,0 +1,1342 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Pierre Weis, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* A pretty-printing facility and definition of formatters for ``parallel'' + (i.e. unrelated or independent) pretty-printing on multiple out channels. *) + +(************************************************************** + + Data structures definitions. + + **************************************************************) + +type size;; + +external size_of_int : int -> size = "%identity" +;; +external int_of_size : size -> int = "%identity" +;; + +(* 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 tabulation *) +| 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 *) +| Pp_open_tag of string (* opening a tag name *) +| Pp_close_tag (* closing the most recently opened tag *) + +and tag = string + +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_box (* Horizontal or Indent block: breaks lead to new line + only when necessary to print the content of the block, or + when it leads to a new indentation of the current line *) +| 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 : size; + token : pp_token; + length : int; +} +;; + +(* Scan stack: + each element is (left_total, queue element) where left_total + is the value of pp_left_total when the element has been enqueued. *) +type pp_scan_elem = Scan_elem of int * pp_queue_elem;; + +(* 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;; + +(* General purpose queues, used in the formatter. *) +type 'a queue_elem = + | Nil + | Cons of 'a queue_cell + +and 'a queue_cell = { + mutable head : 'a; + mutable tail : 'a queue_elem; +} +;; + +type 'a queue = { + mutable insert : 'a queue_elem; + mutable body : 'a queue_elem; +} +;; + +(* The formatter specific tag handling functions. *) +type formatter_tag_functions = { + mark_open_tag : tag -> string; + mark_close_tag : tag -> string; + print_open_tag : tag -> unit; + print_close_tag : tag -> unit; +} +;; + +(* A formatter with all its machinery. *) +type formatter = { + mutable pp_scan_stack : pp_scan_elem list; + mutable pp_format_stack : pp_format_elem list; + mutable pp_tbox_stack : tblock list; + mutable pp_tag_stack : tag list; + mutable pp_mark_stack : tag list; + (* Global variables: default initialization is + set_margin 78 + set_min_space_left 0. *) + (* Value of right margin. *) + mutable pp_margin : int; + (* Minimal space left before margin, when opening a block. *) + mutable pp_min_space_left : int; + (* Maximum value of indentation: + no blocks can be opened further. *) + mutable pp_max_indent : int; + (* Space remaining on the current line. *) + mutable pp_space_left : int; + (* Current value of indentation. *) + mutable pp_current_indent : int; + (* True when the line has been broken by the pretty-printer. *) + mutable pp_is_new_line : bool; + (* Total width of tokens already printed. *) + mutable pp_left_total : int; + (* Total width of tokens ever put in queue. *) + mutable pp_right_total : int; + (* Current number of opened blocks. *) + mutable pp_curr_depth : int; + (* Maximum number of blocks which can be simultaneously opened. *) + mutable pp_max_boxes : int; + (* Ellipsis string. *) + mutable pp_ellipsis : string; + (* Output function. *) + mutable pp_output_function : string -> int -> int -> unit; + (* Flushing function. *) + mutable pp_flush_function : unit -> unit; + (* Output of new lines. *) + mutable pp_output_newline : unit -> unit; + (* Output of indentation spaces. *) + mutable pp_output_spaces : int -> unit; + (* Are tags printed ? *) + mutable pp_print_tags : bool; + (* Are tags marked ? *) + mutable pp_mark_tags : bool; + (* Find opening and closing markers of tags. *) + mutable pp_mark_open_tag : tag -> string; + mutable pp_mark_close_tag : tag -> string; + mutable pp_print_open_tag : tag -> unit; + mutable pp_print_close_tag : tag -> unit; + (* The pretty-printer queue. *) + mutable pp_queue : pp_queue_elem queue; +} +;; + +(************************************************************** + + Auxilliaries and basic functions. + + **************************************************************) + + +(* Queues auxilliaries. *) +let make_queue () = { insert = Nil; body = Nil; };; + +let clear_queue q = q.insert <- Nil; q.body <- Nil;; + +let add_queue x q = + let c = Cons { head = x; tail = Nil; } in + match q with + | { insert = Cons cell } -> + q.insert <- c; cell.tail <- c + (* Invariant: when insert is Nil body should be Nil. *) + | _ -> q.insert <- c; q.body <- c;; + +exception Empty_queue;; + +let peek_queue = function + | { body = Cons { head = x; }; } -> x + | _ -> raise Empty_queue +;; + +let take_queue = function + | { body = Cons { head = x; tail = tl; }; } as q -> + q.body <- tl; + if tl = Nil then q.insert <- Nil; (* Maintain the invariant. *) + x + | _ -> raise Empty_queue +;; + +(* Enter a token in the pretty-printer queue. *) +let pp_enqueue state ({length = len} as token) = + state.pp_right_total <- state.pp_right_total + len; + add_queue token state.pp_queue +;; + +let pp_clear_queue state = + state.pp_left_total <- 1; state.pp_right_total <- 1; + clear_queue state.pp_queue +;; + +(* Pp_infinity: large value for default tokens size. + + Pp_infinity is documented as being greater than 1e10; to avoid + confusion about the word ``greater'', we choose pp_infinity greater + than 1e10 + 1; for correct handling of tests in the algorithm, + pp_infinity must be even one more than 1e10 + 1; let's stand on the + safe side by choosing 1.e10+10. + + Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is + the minimal upper bound for integers; now that max_int is defined, + this limit could also be defined as max_int - 1. + + However, before setting pp_infinity to something around max_int, we + must carefully double-check all the integer arithmetic operations + that involve pp_infinity, since any overflow would wreck havoc the + pretty-printing algorithm's invariants. Given that this arithmetic + correctness check is difficult and error prone and given that 1e10 + + 1 is in practice large enough, there is no need to attempt to set + pp_infinity to the theoretically maximum limit. It is not worth the + burden ! *) + +let pp_infinity = 1000000010;; + +(* Output functions for the formatter. *) +let pp_output_string state s = state.pp_output_function s 0 (String.length s) +and pp_output_newline state = state.pp_output_newline () +and pp_display_blanks state n = state.pp_output_spaces n +;; + +(* To format a break, indenting a new line. *) +let break_new_line state offset width = + pp_output_newline state; + state.pp_is_new_line <- true; + let indent = state.pp_margin - width + offset in + (* Don't indent more than pp_max_indent. *) + let real_indent = min state.pp_max_indent indent in + state.pp_current_indent <- real_indent; + state.pp_space_left <- state.pp_margin - state.pp_current_indent; + pp_display_blanks state state.pp_current_indent +;; + +(* To force a line break inside a block: no offset is added. *) +let break_line state width = break_new_line state 0 width;; + +(* To format a break that fits on the current line. *) +let break_same_line state width = + state.pp_space_left <- state.pp_space_left - width; + pp_display_blanks state width +;; + +(* To indent no more than pp_max_indent, if one tries to open a block + beyond pp_max_indent, then the block is rejected on the left + by simulating a break. *) +let pp_force_break_line state = + match state.pp_format_stack with + | Format_elem (bl_ty, width) :: _ -> + if width > state.pp_space_left then + (match bl_ty with + | Pp_fits -> () | Pp_hbox -> () + | _ -> break_line state width) + | _ -> pp_output_newline state +;; + +(* To skip a token, if the previous line has been broken. *) +let pp_skip_token state = + (* When calling pp_skip_token the queue cannot be empty. *) + match take_queue state.pp_queue with + | { elem_size = size; length = len; } -> + state.pp_left_total <- state.pp_left_total - len; + state.pp_space_left <- state.pp_space_left + int_of_size size +;; + +(************************************************************** + + The main pretty printing functions. + + **************************************************************) + +(* To format a token. *) +let format_pp_token state size = function + + | Pp_text s -> + state.pp_space_left <- state.pp_space_left - size; + pp_output_string state s; + state.pp_is_new_line <- false + + | Pp_begin (off, ty) -> + let insertion_point = state.pp_margin - state.pp_space_left in + if insertion_point > state.pp_max_indent then + (* can't open a block right there. *) + begin pp_force_break_line state end; + let offset = state.pp_space_left - off in + let bl_type = + begin match ty with + | Pp_vbox -> Pp_vbox + | _ -> if size > state.pp_space_left then ty else Pp_fits + end in + state.pp_format_stack <- + Format_elem (bl_type, offset) :: state.pp_format_stack + + | Pp_end -> + begin match state.pp_format_stack with + | x :: (y :: l as ls) -> state.pp_format_stack <- ls + | _ -> () (* No more block to close. *) + end + + | Pp_tbegin (Pp_tbox _ as tbox) -> + state.pp_tbox_stack <- tbox :: state.pp_tbox_stack + + | Pp_tend -> + begin match state.pp_tbox_stack with + | x :: ls -> state.pp_tbox_stack <- ls + | _ -> () (* No more tabulation block to close. *) + end + + | Pp_stab -> + begin match state.pp_tbox_stack with + | Pp_tbox tabs :: _ -> + let rec add_tab n = function + | [] -> [n] + | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in + tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs + | _ -> () (* No opened tabulation block. *) + end + + | Pp_tbreak (n, off) -> + let insertion_point = state.pp_margin - state.pp_space_left in + begin match state.pp_tbox_stack with + | Pp_tbox tabs :: _ -> + let rec find n = function + | x :: l -> if x >= n then x else find n l + | [] -> raise Not_found in + let tab = + match !tabs with + | x :: l -> + begin + try find insertion_point !tabs with + | Not_found -> x + end + | _ -> insertion_point in + let offset = tab - insertion_point in + if offset >= 0 + then break_same_line state (offset + n) + else break_new_line state (tab + off) state.pp_margin + | _ -> () (* No opened tabulation block. *) + end + + | Pp_newline -> + begin match state.pp_format_stack with + | Format_elem (_, width) :: _ -> break_line state width + | _ -> pp_output_newline state + end + + | Pp_if_newline -> + if state.pp_current_indent != state.pp_margin - state.pp_space_left + then pp_skip_token state + + | Pp_break (n, off) -> + begin match state.pp_format_stack with + | Format_elem (ty, width) :: _ -> + begin match ty with + | Pp_hovbox -> + if size > state.pp_space_left + then break_new_line state off width + else break_same_line state n + | Pp_box -> + (* Have the line just been broken here ? *) + if state.pp_is_new_line then break_same_line state n else + if size > state.pp_space_left + then break_new_line state off width else + (* break the line here leads to new indentation ? *) + if state.pp_current_indent > state.pp_margin - width + off + then break_new_line state off width + else break_same_line state n + | Pp_hvbox -> break_new_line state off width + | Pp_fits -> break_same_line state n + | Pp_vbox -> break_new_line state off width + | Pp_hbox -> break_same_line state n + end + | _ -> () (* No opened block. *) + end + + | Pp_open_tag tag_name -> + let marker = state.pp_mark_open_tag tag_name in + pp_output_string state marker; + state.pp_mark_stack <- tag_name :: state.pp_mark_stack + + | Pp_close_tag -> + begin match state.pp_mark_stack with + | tag_name :: tags -> + let marker = state.pp_mark_close_tag tag_name in + pp_output_string state marker; + state.pp_mark_stack <- tags + | _ -> () (* No more tag to close. *) + end +;; + +(* Print if token size is known or printing is delayed. + Size is known when not negative. + Printing is delayed when the text waiting in the queue requires + more room to format than exists on the current line. + + Note: [advance_loop] must be tail recursive to prevent stack overflows. *) +let rec advance_loop state = + match peek_queue state.pp_queue with + | {elem_size = size; token = tok; length = len} -> + let size = int_of_size size in + if not + (size < 0 && + (state.pp_right_total - state.pp_left_total < state.pp_space_left)) + then begin + ignore (take_queue state.pp_queue); + format_pp_token state (if size < 0 then pp_infinity else size) tok; + state.pp_left_total <- len + state.pp_left_total; + advance_loop state + end +;; + +let advance_left state = + try advance_loop state with + | Empty_queue -> () +;; + +let enqueue_advance state tok = pp_enqueue state tok; advance_left state;; + +(* To enqueue a string : try to advance. *) +let make_queue_elem size tok len = + { elem_size = size; token = tok; length = len; };; + +let enqueue_string_as state size s = + let len = int_of_size size in + enqueue_advance state (make_queue_elem size (Pp_text s) len) +;; + +let enqueue_string state s = + let len = String.length s in + enqueue_string_as state (size_of_int len) s +;; + +(* Routines for scan stack + determine sizes of blocks. *) + +(* The scan_stack is never empty. *) +let scan_stack_bottom = + let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text "") 0 in + [Scan_elem (-1, q_elem)] +;; + +(* 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. *) +let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom;; + +(* 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 state ty = + match state.pp_scan_stack with + | Scan_elem + (left_tot, + ({elem_size = size; token = tok} as queue_elem)) :: t -> + let size = int_of_size size in + (* test if scan stack contains any data that is not obsolete. *) + if left_tot < state.pp_left_total then clear_scan_stack state else + begin match tok with + | Pp_break (_, _) | Pp_tbreak (_, _) -> + if ty then + begin + queue_elem.elem_size <- size_of_int (state.pp_right_total + size); + state.pp_scan_stack <- t + end + | Pp_begin (_, _) -> + if not ty then + begin + queue_elem.elem_size <- size_of_int (state.pp_right_total + size); + state.pp_scan_stack <- t + end + | _ -> () (* scan_push is only used for breaks and boxes. *) + end + | _ -> () (* scan_stack is never empty. *) +;; + +(* Push a token on scan stack. If b is true set_size is called. *) +let scan_push state b tok = + pp_enqueue state tok; + if b then set_size state true; + state.pp_scan_stack <- + Scan_elem (state.pp_right_total, tok) :: state.pp_scan_stack +;; + +(* To open a new block : + the user may set the depth bound pp_max_boxes + any text nested deeper is printed as the ellipsis string. *) +let pp_open_box_gen state indent br_ty = + state.pp_curr_depth <- state.pp_curr_depth + 1; + if state.pp_curr_depth < state.pp_max_boxes then + let elem = + make_queue_elem + (size_of_int (- state.pp_right_total)) + (Pp_begin (indent, br_ty)) + 0 in + scan_push state false elem else + if state.pp_curr_depth = state.pp_max_boxes + then enqueue_string state state.pp_ellipsis +;; + +(* The box which is always opened. *) +let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox;; + +(* Close a block, setting sizes of its sub blocks. *) +let pp_close_box state () = + if state.pp_curr_depth > 1 then + begin + if state.pp_curr_depth < state.pp_max_boxes then + begin + pp_enqueue state + { elem_size = size_of_int 0; token = Pp_end; length = 0; }; + set_size state true; set_size state false + end; + state.pp_curr_depth <- state.pp_curr_depth - 1; + end +;; + +(* Open a tag, pushing it on the tag stack. *) +let pp_open_tag state tag_name = + if state.pp_print_tags then + begin + state.pp_tag_stack <- tag_name :: state.pp_tag_stack; + state.pp_print_open_tag tag_name + end; + if state.pp_mark_tags then + pp_enqueue state { + elem_size = size_of_int 0; + token = Pp_open_tag tag_name; + length = 0; + } +;; + +(* Close a tag, popping it from the tag stack. *) +let pp_close_tag state () = + if state.pp_mark_tags then + pp_enqueue state { + elem_size = size_of_int 0; + token = Pp_close_tag; + length = 0; + }; + if state.pp_print_tags then + begin + match state.pp_tag_stack with + | tag_name :: tags -> + state.pp_print_close_tag tag_name; + state.pp_tag_stack <- tags + | _ -> () (* No more tag to close. *) + end +;; + +let pp_set_print_tags state b = state.pp_print_tags <- b;; +let pp_set_mark_tags state b = state.pp_mark_tags <- b;; +let pp_get_print_tags state () = state.pp_print_tags;; +let pp_get_mark_tags state () = state.pp_mark_tags;; +let pp_set_tags state b = pp_set_print_tags state b; pp_set_mark_tags state b;; + +let pp_get_formatter_tag_functions state () = { + mark_open_tag = state.pp_mark_open_tag; + mark_close_tag = state.pp_mark_close_tag; + print_open_tag = state.pp_print_open_tag; + print_close_tag = state.pp_print_close_tag; +} +;; + +let pp_set_formatter_tag_functions state { + mark_open_tag = mot; + mark_close_tag = mct; + print_open_tag = pot; + print_close_tag = pct; + } = + state.pp_mark_open_tag <- mot; + state.pp_mark_close_tag <- mct; + state.pp_print_open_tag <- pot; + state.pp_print_close_tag <- pct +;; + +(* Initialize pretty-printer. *) +let pp_rinit state = + pp_clear_queue state; + clear_scan_stack state; + state.pp_format_stack <- []; + state.pp_tbox_stack <- []; + state.pp_tag_stack <- []; + state.pp_mark_stack <- []; + state.pp_current_indent <- 0; + state.pp_curr_depth <- 0; + state.pp_space_left <- state.pp_margin; + pp_open_sys_box state;; + +(* Flushing pretty-printer queue. *) +let pp_flush_queue state b = + while state.pp_curr_depth > 1 do + pp_close_box state () + done; + state.pp_right_total <- pp_infinity; + advance_left state; + if b then pp_output_newline state; + pp_rinit state +;; + +(************************************************************** + + Procedures to format objects, and use boxes + + **************************************************************) + +(* To format a string. *) +let pp_print_as_size state size s = + if state.pp_curr_depth < state.pp_max_boxes + then enqueue_string_as state size s +;; + +let pp_print_as state isize s = + pp_print_as_size state (size_of_int isize) s +;; + +let pp_print_string state s = + pp_print_as state (String.length s) s +;; + +(* To format an integer. *) +let pp_print_int state i = pp_print_string state (string_of_int i);; + +(* To format a float. *) +let pp_print_float state f = pp_print_string state (string_of_float f);; + +(* To format a boolean. *) +let pp_print_bool state b = pp_print_string state (string_of_bool b);; + +(* To format a char. *) +let pp_print_char state c = + let s = String.create 1 in + s.[0] <- c; + pp_print_as state 1 s +;; + +(* Opening boxes. *) +let pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox +and pp_open_vbox state indent = pp_open_box_gen state indent Pp_vbox + +and pp_open_hvbox state indent = pp_open_box_gen state indent Pp_hvbox +and pp_open_hovbox state indent = pp_open_box_gen state indent Pp_hovbox +and pp_open_box state indent = pp_open_box_gen state indent Pp_box;; + +(* Print a new line after printing all queued text + (same for print_flush but without a newline). *) +let pp_print_newline state () = + pp_flush_queue state true; state.pp_flush_function () +and pp_print_flush state () = + pp_flush_queue state false; state.pp_flush_function ();; + +(* To get a newline when one does not want to close the current block. *) +let pp_force_newline state () = + if state.pp_curr_depth < state.pp_max_boxes then + enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0) +;; + +(* To format something if the line has just been broken. *) +let pp_print_if_newline state () = + if state.pp_curr_depth < state.pp_max_boxes then + enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 0) +;; + +(* Breaks: indicate where a block may be broken. + If line is broken then offset is added to the indentation of the current + block else (the value of) width blanks are printed. + To do (?) : add a maximum width and offset value. *) +let pp_print_break state width offset = + if state.pp_curr_depth < state.pp_max_boxes then + let elem = + make_queue_elem + (size_of_int (- state.pp_right_total)) + (Pp_break (width, offset)) + width in + scan_push state true elem +;; + +let pp_print_space state () = pp_print_break state 1 0 +and pp_print_cut state () = pp_print_break state 0 0 +;; + +(* Tabulation boxes. *) +let pp_open_tbox state () = + state.pp_curr_depth <- state.pp_curr_depth + 1; + if state.pp_curr_depth < state.pp_max_boxes then + let elem = + make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0 in + enqueue_advance state elem +;; + +(* Close a tabulation block. *) +let pp_close_tbox state () = + if state.pp_curr_depth > 1 then + begin + if state.pp_curr_depth < state.pp_max_boxes then + let elem = make_queue_elem (size_of_int 0) Pp_tend 0 in + enqueue_advance state elem; + state.pp_curr_depth <- state.pp_curr_depth - 1 + end +;; + +(* Print a tabulation break. *) +let pp_print_tbreak state width offset = + if state.pp_curr_depth < state.pp_max_boxes then + let elem = + make_queue_elem + (size_of_int (- state.pp_right_total)) + (Pp_tbreak (width, offset)) + width in + scan_push state true elem +;; + +let pp_print_tab state () = pp_print_tbreak state 0 0;; + +let pp_set_tab state () = + if state.pp_curr_depth < state.pp_max_boxes then + let elem = + make_queue_elem (size_of_int 0) Pp_stab 0 in + enqueue_advance state elem +;; + +(************************************************************** + + Procedures to control the pretty-printers + + **************************************************************) + +(* Fit max_boxes. *) +let pp_set_max_boxes state n = if n > 1 then state.pp_max_boxes <- n;; + +(* To know the current maximum number of boxes allowed. *) +let pp_get_max_boxes state () = state.pp_max_boxes;; + +let pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes;; + +(* Ellipsis. *) +let pp_set_ellipsis_text state s = state.pp_ellipsis <- s +and pp_get_ellipsis_text state () = state.pp_ellipsis +;; + +(* To set the margin of pretty-printer. *) +let pp_limit n = + if n < pp_infinity then n else pred pp_infinity +;; + +let pp_set_min_space_left state n = + if n >= 1 then + let n = pp_limit n in + state.pp_min_space_left <- n; + state.pp_max_indent <- state.pp_margin - state.pp_min_space_left; + pp_rinit state +;; + +(* Initially, we have : + pp_max_indent = pp_margin - pp_min_space_left, and + pp_space_left = pp_margin. *) +let pp_set_max_indent state n = + pp_set_min_space_left state (state.pp_margin - n) +;; +let pp_get_max_indent state () = state.pp_max_indent;; + +let pp_set_margin state n = + if n >= 1 then + let n = pp_limit n in + state.pp_margin <- n; + let new_max_indent = + (* Try to maintain max_indent to its actual value. *) + if state.pp_max_indent <= state.pp_margin + then state.pp_max_indent else + (* If possible maintain pp_min_space_left to its actual value, + if this leads to a too small max_indent, take half of the + new margin, if it is greater than 1. *) + max (max (state.pp_margin - state.pp_min_space_left) + (state.pp_margin / 2)) 1 in + (* Rebuild invariants. *) + pp_set_max_indent state new_max_indent +;; + +let pp_get_margin state () = state.pp_margin;; + +let pp_set_formatter_output_functions state f g = + state.pp_output_function <- f; state.pp_flush_function <- g;; +let pp_get_formatter_output_functions state () = + (state.pp_output_function, state.pp_flush_function) +;; + +let pp_set_all_formatter_output_functions state + ~out:f ~flush:g ~newline:h ~spaces:i = + pp_set_formatter_output_functions state f g; + state.pp_output_newline <- h; + state.pp_output_spaces <- i; +;; +let pp_get_all_formatter_output_functions state () = + (state.pp_output_function, state.pp_flush_function, + state.pp_output_newline, state.pp_output_spaces) +;; + +(* Default function to output new lines. *) +let display_newline state () = state.pp_output_function "\n" 0 1;; + +(* Default function to output spaces. *) +let blank_line = String.make 80 ' ';; +let rec display_blanks state n = + if n > 0 then + if n <= 80 then state.pp_output_function blank_line 0 n else + begin + state.pp_output_function blank_line 0 80; + display_blanks state (n - 80) + end +;; + +let pp_set_formatter_out_channel state os = + state.pp_output_function <- output os; + state.pp_flush_function <- (fun () -> flush os); + state.pp_output_newline <- display_newline state; + state.pp_output_spaces <- display_blanks state; +;; + +(************************************************************** + + Creation of specific formatters + + **************************************************************) + +let default_pp_mark_open_tag s = "<" ^ s ^ ">";; +let default_pp_mark_close_tag s = "</" ^ s ^ ">";; + +let default_pp_print_open_tag s = ();; +let default_pp_print_close_tag = default_pp_print_open_tag;; + +let pp_make_formatter f g h i = + (* The initial state of the formatter contains a dummy box. *) + let pp_q = make_queue () in + let sys_tok = + make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in + add_queue sys_tok pp_q; + let sys_scan_stack = + (Scan_elem (1, sys_tok)) :: scan_stack_bottom in + { + pp_scan_stack = sys_scan_stack; + pp_format_stack = []; + pp_tbox_stack = []; + pp_tag_stack = []; + pp_mark_stack = []; + pp_margin = 78; + pp_min_space_left = 10; + pp_max_indent = 78 - 10; + pp_space_left = 78; + pp_current_indent = 0; + pp_is_new_line = true; + pp_left_total = 1; + pp_right_total = 1; + pp_curr_depth = 1; + pp_max_boxes = max_int; + pp_ellipsis = "."; + pp_output_function = f; + pp_flush_function = g; + pp_output_newline = h; + pp_output_spaces = i; + pp_print_tags = false; + pp_mark_tags = false; + pp_mark_open_tag = default_pp_mark_open_tag; + pp_mark_close_tag = default_pp_mark_close_tag; + pp_print_open_tag = default_pp_print_open_tag; + pp_print_close_tag = default_pp_print_close_tag; + pp_queue = pp_q; + } +;; + +(* Make a formatter with default functions to output spaces and new lines. *) +let make_formatter output flush = + let ppf = pp_make_formatter output flush ignore ignore in + ppf.pp_output_newline <- display_newline ppf; + ppf.pp_output_spaces <- display_blanks ppf; + ppf +;; + +let formatter_of_out_channel oc = + make_formatter (output oc) (fun () -> flush oc) +;; + +let formatter_of_buffer b = + make_formatter (Buffer.add_substring b) ignore +;; + +let stdbuf = Buffer.create 512;; + +(* Predefined formatters. *) +let std_formatter = formatter_of_out_channel Pervasives.stdout +and err_formatter = formatter_of_out_channel Pervasives.stderr +and str_formatter = formatter_of_buffer stdbuf +;; + +let flush_str_formatter () = + pp_flush_queue str_formatter false; + let s = Buffer.contents stdbuf in + Buffer.reset stdbuf; + s +;; + +(************************************************************** + + Basic functions on the standard formatter + + **************************************************************) + +let open_hbox = pp_open_hbox std_formatter +and open_vbox = pp_open_vbox std_formatter +and open_hvbox = pp_open_hvbox std_formatter +and open_hovbox = pp_open_hovbox std_formatter +and open_box = pp_open_box std_formatter +and close_box = pp_close_box std_formatter +and open_tag = pp_open_tag std_formatter +and close_tag = pp_close_tag std_formatter +and print_as = pp_print_as std_formatter +and print_string = pp_print_string std_formatter +and print_int = pp_print_int std_formatter +and print_float = pp_print_float std_formatter +and print_char = pp_print_char std_formatter +and print_bool = pp_print_bool std_formatter +and print_break = pp_print_break std_formatter +and print_cut = pp_print_cut std_formatter +and print_space = pp_print_space std_formatter +and force_newline = pp_force_newline std_formatter +and print_flush = pp_print_flush std_formatter +and print_newline = pp_print_newline std_formatter +and print_if_newline = pp_print_if_newline std_formatter + +and open_tbox = pp_open_tbox std_formatter +and close_tbox = pp_close_tbox std_formatter +and print_tbreak = pp_print_tbreak std_formatter + +and set_tab = pp_set_tab std_formatter +and print_tab = pp_print_tab std_formatter + +and set_margin = pp_set_margin std_formatter +and get_margin = pp_get_margin std_formatter + +and set_max_indent = pp_set_max_indent std_formatter +and get_max_indent = pp_get_max_indent std_formatter + +and set_max_boxes = pp_set_max_boxes std_formatter +and get_max_boxes = pp_get_max_boxes std_formatter +and over_max_boxes = pp_over_max_boxes std_formatter + +and set_ellipsis_text = pp_set_ellipsis_text std_formatter +and get_ellipsis_text = pp_get_ellipsis_text std_formatter + +and set_formatter_out_channel = + pp_set_formatter_out_channel std_formatter + +and set_formatter_output_functions = + pp_set_formatter_output_functions std_formatter +and get_formatter_output_functions = + pp_get_formatter_output_functions std_formatter + +and set_all_formatter_output_functions = + pp_set_all_formatter_output_functions std_formatter +and get_all_formatter_output_functions = + pp_get_all_formatter_output_functions std_formatter + +and set_formatter_tag_functions = + pp_set_formatter_tag_functions std_formatter +and get_formatter_tag_functions = + pp_get_formatter_tag_functions std_formatter +and set_print_tags = + pp_set_print_tags std_formatter +and get_print_tags = + pp_get_print_tags std_formatter +and set_mark_tags = + pp_set_mark_tags std_formatter +and get_mark_tags = + pp_get_mark_tags std_formatter +and set_tags = + pp_set_tags std_formatter +;; + + +(************************************************************** + + Printf implementation. + + **************************************************************) + +module Sformat = Printf.CamlinternalPr.Sformat;; +module Tformat = Printf.CamlinternalPr.Tformat;; + +(* Error messages when processing formats. *) + +(* Trailer: giving up at character number ... *) +let giving_up mess fmt i = + "fprintf: " ^ mess ^ " ``" ^ Sformat.to_string fmt ^ "'', \ + giving up at character number " ^ string_of_int i ^ + (if i < Sformat.length fmt + then " (" ^ String.make 1 (Sformat.get fmt i) ^ ")." + else String.make 1 '.') +;; + +(* When an invalid format deserves a special error explanation. *) +let format_invalid_arg mess fmt i = invalid_arg (giving_up mess fmt i);; + +(* Standard invalid format. *) +let invalid_format fmt i = format_invalid_arg "bad format" fmt i;; + +(* Cannot find a valid integer into that format. *) +let invalid_integer fmt i = + invalid_arg (giving_up "bad integer specification" fmt i);; + +(* Finding an integer out of a sub-string of the format. *) +let format_int_of_string fmt i s = + let sz = + try int_of_string s with + | Failure s -> invalid_integer fmt i in + size_of_int sz +;; + +(* Getting strings out of buffers. *) +let get_buffer_out b = + let s = Buffer.contents b in + Buffer.reset b; + s +;; + +(* [ppf] is supposed to be a pretty-printer that outputs to buffer [b]: + to extract the contents of [ppf] as a string we flush [ppf] and get the + string out of [b]. *) +let string_out b ppf = + pp_flush_queue ppf false; + get_buffer_out b +;; + +(* Applies [printer] to a formatter that outputs on a fresh buffer, + then returns the resulting material. *) +let exstring printer arg = + let b = Buffer.create 512 in + let ppf = formatter_of_buffer b in + printer ppf arg; + string_out b ppf +;; + +(* To turn out a character accumulator into the proper string result. *) +let implode_rev s0 = function + | [] -> s0 + | l -> String.concat "" (List.rev (s0 :: l)) +;; + +(* [mkprintf] is the printf-like function generator: given the + - [to_s] flag that tells if we are printing into a string, + - the [get_out] function that has to be called to get a [ppf] function to + output onto, + it generates a [kprintf] function that takes as arguments a [k] + continuation function to be called at the end of formatting, + and a printing format string to print the rest of the arguments + according to the format string. + Regular [fprintf]-like functions of this module are obtained via partial + applications of [mkprintf]. *) +let mkprintf to_s get_out = + + let rec kprintf k fmt = + + let len = Sformat.length fmt in + + let kpr fmt v = + let ppf = get_out fmt in + let print_as = ref None in + let pp_print_as_char c = + match !print_as with + | None -> pp_print_char ppf c + | Some size -> + pp_print_as_size ppf size (String.make 1 c); + print_as := None + and pp_print_as_string s = + match !print_as with + | None -> pp_print_string ppf s + | Some size -> + pp_print_as_size ppf size s; + print_as := None in + + let rec doprn n i = + if i >= len then Obj.magic (k ppf) else + match Sformat.get fmt i with + | '%' -> + Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m + | '@' -> + let i = succ i in + if i >= len then invalid_format fmt i else + begin match Sformat.get fmt i with + | '[' -> + do_pp_open_box ppf n (succ i) + | ']' -> + pp_close_box ppf (); + doprn n (succ i) + | '{' -> + do_pp_open_tag ppf n (succ i) + | '}' -> + pp_close_tag ppf (); + doprn n (succ i) + | ' ' -> + pp_print_space ppf (); + doprn n (succ i) + | ',' -> + pp_print_cut ppf (); + doprn n (succ i) + | '?' -> + pp_print_flush ppf (); + doprn n (succ i) + | '.' -> + pp_print_newline ppf (); + doprn n (succ i) + | '\n' -> + pp_force_newline ppf (); + doprn n (succ i) + | ';' -> + do_pp_break ppf n (succ i) + | '<' -> + let got_size size n i = + print_as := Some size; + doprn n (skip_gt i) in + get_int n (succ i) got_size + | '@' as c -> + pp_print_as_char c; + doprn n (succ i) + | c -> invalid_format fmt i + end + | c -> + pp_print_as_char c; + doprn n (succ i) + + and cont_s n s i = + pp_print_as_string s; doprn n i + and cont_a n printer arg i = + if to_s then + pp_print_as_string ((Obj.magic printer : unit -> _ -> string) () arg) + else + printer ppf arg; + doprn n i + and cont_t n printer i = + if to_s then + pp_print_as_string ((Obj.magic printer : unit -> string) ()) + else + printer ppf; + doprn n i + and cont_f n i = + pp_print_flush ppf (); doprn n i + and cont_m n sfmt i = + kprintf (Obj.magic (fun _ -> doprn n i)) sfmt + + and get_int n i c = + if i >= len then invalid_integer fmt i else + match Sformat.get fmt i with + | ' ' -> get_int n (succ i) c + | '%' -> + let cont_s n s i = c (format_int_of_string fmt i s) n i + and cont_a n printer arg i = invalid_integer fmt i + and cont_t n printer i = invalid_integer fmt i + and cont_f n i = invalid_integer fmt i + and cont_m n sfmt i = invalid_integer fmt i in + Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m + | _ -> + let rec get j = + if j >= len then invalid_integer fmt j else + match Sformat.get fmt j with + | '0' .. '9' | '-' -> get (succ j) + | _ -> + let size = + if j = i then size_of_int 0 else + let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in + format_int_of_string fmt j s in + c size n j in + get i + + and skip_gt i = + if i >= len then invalid_format fmt i else + match Sformat.get fmt i with + | ' ' -> skip_gt (succ i) + | '>' -> succ i + | _ -> invalid_format fmt i + + and get_box_kind i = + if i >= len then Pp_box, i else + match Sformat.get fmt i with + | 'h' -> + let i = succ i in + if i >= len then Pp_hbox, i else + begin match Sformat.get fmt i with + | 'o' -> + let i = succ i in + if i >= len then format_invalid_arg "bad box format" fmt i else + begin match Sformat.get fmt i with + | 'v' -> Pp_hovbox, succ i + | c -> + format_invalid_arg + ("bad box name ho" ^ String.make 1 c) fmt i + end + | 'v' -> Pp_hvbox, succ i + | c -> Pp_hbox, i + end + | 'b' -> Pp_box, succ i + | 'v' -> Pp_vbox, succ i + | _ -> Pp_box, i + + and get_tag_name n i c = + let rec get accu n i j = + if j >= len then + c (implode_rev + (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) + accu) + n j else + match Sformat.get fmt j with + | '>' -> + c (implode_rev + (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) + accu) + n j + | '%' -> + let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in + let cont_s n s i = get (s :: s0 :: accu) n i i + and cont_a n printer arg i = + let s = + if to_s + then (Obj.magic printer : unit -> _ -> string) () arg + else exstring printer arg in + get (s :: s0 :: accu) n i i + and cont_t n printer i = + let s = + if to_s + then (Obj.magic printer : unit -> string) () + else exstring (fun ppf () -> printer ppf) () in + get (s :: s0 :: accu) n i i + and cont_f n i = + format_invalid_arg "bad tag name specification" fmt i + and cont_m n sfmt i = + format_invalid_arg "bad tag name specification" fmt i in + Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m + | c -> get accu n i (succ j) in + get [] n i i + + and do_pp_break ppf n i = + if i >= len then begin pp_print_space ppf (); doprn n i end else + match Sformat.get fmt i with + | '<' -> + let rec got_nspaces nspaces n i = + get_int n i (got_offset nspaces) + and got_offset nspaces offset n i = + pp_print_break ppf (int_of_size nspaces) (int_of_size offset); + doprn n (skip_gt i) in + get_int n (succ i) got_nspaces + | c -> pp_print_space ppf (); doprn n i + + and do_pp_open_box ppf n i = + if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else + match Sformat.get fmt i with + | '<' -> + let kind, i = get_box_kind (succ i) in + let got_size size n i = + pp_open_box_gen ppf (int_of_size size) kind; + doprn n (skip_gt i) in + get_int n i got_size + | c -> pp_open_box_gen ppf 0 Pp_box; doprn n i + + and do_pp_open_tag ppf n i = + if i >= len then begin pp_open_tag ppf ""; doprn n i end else + match Sformat.get fmt i with + | '<' -> + let got_name tag_name n i = + pp_open_tag ppf tag_name; + doprn n (skip_gt i) in + get_tag_name n (succ i) got_name + | c -> pp_open_tag ppf ""; doprn n i in + + doprn (Sformat.index_of_int 0) 0 in + + Tformat.kapr kpr fmt in + + kprintf +;; + +(************************************************************** + + Defining [fprintf] and various flavors of [fprintf]. + + **************************************************************) + +let kfprintf k ppf = mkprintf false (fun _ -> ppf) k;; +let ikfprintf k ppf = Tformat.kapr (fun _ _ -> Obj.magic (k ppf));; + +let fprintf ppf = kfprintf ignore ppf;; +let ifprintf ppf = ikfprintf ignore ppf;; +let printf fmt = fprintf std_formatter fmt;; +let eprintf fmt = fprintf err_formatter fmt;; + +let ksprintf k = + let b = Buffer.create 512 in + let k ppf = k (string_out b ppf) in + mkprintf true (fun _ -> formatter_of_buffer b) k +;; + +let sprintf fmt = ksprintf (fun s -> s) fmt;; + +(************************************************************** + + Deprecated stuff. + + **************************************************************) + +let kbprintf k b = + mkprintf false (fun _ -> formatter_of_buffer b) k +;; + +(* Deprecated error prone function bprintf. *) +let bprintf b = + let k ppf = pp_flush_queue ppf false in + kbprintf k b +;; + +(* Deprecated alias for ksprintf. *) +let kprintf = ksprintf;; + +at_exit print_flush +;; diff --git a/ocaml-binary-annot/stdlib/format.mli b/ocaml-binary-annot/stdlib/format.mli new file mode 100644 index 0000000000..38123900aa --- /dev/null +++ b/ocaml-binary-annot/stdlib/format.mli @@ -0,0 +1,699 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Pierre Weis, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** 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. + + For a gentle introduction to the basics of pretty-printing using + [Format], read + {{:http://caml.inria.fr/resources/doc/guides/format.html}http://caml.inria.fr/resources/doc/guides/format.html}. + + You may consider this module as providing an extension to the + [printf] facility to provide automatic line breaking. The addition of + pretty-printing annotations to your regular [printf] formats gives you + fancy indentation and line breaks. + Pretty-printing annotations are described below in the documentation of + the function {!Format.fprintf}. + + You may also use the explicit box management and printing functions + provided by this module. This style is more basic but more verbose + than the [fprintf] concise formats. + + For instance, the sequence + [open_box 0; print_string "x ="; print_space (); + print_int 1; close_box (); print_newline ()] + that prints [x = 1] within a pretty-printing box, can be + abbreviated as [printf "@[%s@ %i@]@." "x =" 1], or even shorter + [printf "@[x =@ %i@]@." 1]. + + Rule of thumb for casual users of this library: + - use simple boxes (as obtained by [open_box 0]); + - use simple break hints (as obtained by [print_cut ()] that outputs a + simple break hint, or by [print_space ()] that outputs a space + indicating a break hint); + - once a box is opened, display its material with basic printing + functions (e. g. [print_int] and [print_string]); + - when the material for a box has been printed, call [close_box ()] to + close the box; + - at the end of your routine, flush the pretty-printer to display all the + remaining material, e.g. evaluate [print_newline ()]. + + The behaviour of pretty-printing commands is unspecified + if there is no opened pretty-printing box. Each box opened via + one of the [open_] functions below must be closed using [close_box] + for proper formatting. Otherwise, some of the material printed in the + boxes may not be output, or may be formatted incorrectly. + + In case of interactive use, the system closes all opened boxes and + flushes all pending text (as with the [print_newline] function) + after each phrase. Each phrase is therefore executed in the initial + state of the pretty-printer. + + Warning: the material output by the following functions is delayed + in the pretty-printer queue in order to compute the proper line + breaking. Hence, you should not mix calls to the printing functions + of the basic I/O system with calls to the functions of this module: + this could result in some strange output seemingly unrelated with + the evaluation order of printing commands. +*) + +(** {6 Boxes} *) + +val open_box : int -> unit;; +(** [open_box d] opens a new pretty-printing box + with offset [d]. + This box is the general purpose pretty-printing box. + Material in this box is displayed ``horizontal or vertical'': + break hints inside the box may lead to a new line, if there + is no more room on the line to print the remainder of the box, + or if a new line may lead to a new indentation + (demonstrating the indentation of the box). + When a new line is printed in the box, [d] is added to the + current indentation. *) + +val close_box : unit -> unit;; +(** Closes the most recently opened pretty-printing box. *) + +(** {6 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;; +(** Prints an integer in the current box. *) + +val print_float : float -> unit;; +(** Prints a floating point number in the current box. *) + +val print_char : char -> unit;; +(** Prints a character in the current box. *) + +val print_bool : bool -> unit;; +(** Prints a boolean in the current box. *) + +(** {6 Break hints} *) + +val print_space : unit -> unit;; +(** [print_space ()] is used to separate items (typically to print + a space between two words). + It indicates that the line may be split at this + point. It either prints one space or splits the line. + It is equivalent to [print_break 1 0]. *) + +val print_cut : unit -> unit;; +(** [print_cut ()] is used to mark a good break position. + It indicates that the line may be split at this + point. It either prints nothing or splits the line. + This allows line splitting at the current + point, without printing spaces or adding indentation. + It is equivalent to [print_break 0 0]. *) + +val print_break : int -> int -> unit;; +(** Inserts a break hint in a pretty-printing box. + [print_break nspaces offset] indicates that the line may + be split (a newline character is printed) at this point, + if the contents of the current box does not fit on the + current line. + If the line is split at that point, [offset] is added to + the current indentation. If the line is not split, + [nspaces] spaces are printed. *) + +val print_flush : unit -> unit;; +(** Flushes 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 force_newline : unit -> unit;; +(** Forces a newline in the current box. Not the normal way of + pretty-printing, you should prefer break hints. *) + +val print_if_newline : unit -> unit;; +(** Executes the next formatting command if the preceding line + has just been split. Otherwise, ignore the next formatting + command. *) + +(** {6 Margin} *) + +val set_margin : int -> unit;; +(** [set_margin d] sets the value of the right margin + to [d] (in characters): this value is used to detect line + overflows that leads to split lines. + Nothing happens if [d] is smaller than 2. + If [d] is too large, the right margin is set to the maximum + admissible value (which is greater than [10^10]). *) + +val get_margin : unit -> int;; +(** Returns the position of the right margin. *) + +(** {6 Maximum indentation limit} *) + +val set_max_indent : int -> unit;; +(** [set_max_indent d] sets the value 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 smaller than 2. + If [d] is too large, the limit is set to the maximum + admissible value (which is greater than [10^10]). *) + +val get_max_indent : unit -> int;; +(** Return the value of the maximum indentation limit (in characters). *) + +(** {6 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 smaller than 2. *) + +val get_max_boxes : unit -> int;; +(** Returns the maximum number of boxes allowed before ellipsis. *) + +val over_max_boxes : unit -> bool;; +(** Tests if the maximum number of boxes allowed have already been opened. *) + +(** {6 Advanced formatting} *) + +val open_hbox : unit -> unit;; +(** [open_hbox ()] opens a new pretty-printing box. + This box is ``horizontal'': the line is not split in this box + (new lines may still occur inside boxes nested deeper). *) + +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_hvbox : int -> unit;; +(** [open_hvbox 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. *) + +(** {6 Tabulations} *) + +val open_tbox : unit -> unit;; +(** Opens a tabulation box. *) + +val close_tbox : unit -> unit;; +(** Closes 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;; +(** Sets a tabulation mark at the current insertion point. *) + +val print_tab : unit -> unit;; +(** [print_tab ()] is equivalent to [print_tbreak 0 0]. *) + +(** {6 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. *) + +(** {6:tags Semantics Tags} *) + +type tag = string;; + +(** {i Semantics tags} (or simply {e tags}) are used to decorate printed + entities for user's defined purposes, e.g. setting font and giving size + indications for a display device, or marking delimitation of semantics + entities (e.g. HTML or TeX elements or terminal escape sequences). + + By default, those tags do not influence line breaking calculation: + the tag ``markers'' are not considered as part of the printing + material that drives line breaking (in other words, the length of + those strings is considered as zero for line breaking). + + Thus, tag handling is in some sense transparent to pretty-printing + and does not interfere with usual pretty-printing. Hence, a single + pretty printing routine can output both simple ``verbatim'' + material or richer decorated output depending on the treatment of + tags. By default, tags are not active, hence the output is not + decorated with tag information. Once [set_tags] is set to [true], + the pretty printer engine honours tags and decorates the output + accordingly. + + When a tag has been opened (or closed), it is both and successively + ``printed'' and ``marked''. Printing a tag means calling a + formatter specific function with the name of the tag as argument: + that ``tag printing'' function can then print any regular material + to the formatter (so that this material is enqueued as usual in the + formatter queue for further line-breaking computation). Marking a + tag means to output an arbitrary string (the ``tag marker''), + directly into the output device of the formatter. Hence, the + formatter specific ``tag marking'' function must return the tag + marker string associated to its tag argument. Being flushed + directly into the output device of the formatter, tag marker + strings are not considered as part of the printing material that + drives line breaking (in other words, the length of the strings + corresponding to tag markers is considered as zero for line + breaking). In addition, advanced users may take advantage of + the specificity of tag markers to be precisely output when the + pretty printer has already decided where to break the lines, and + precisely when the queue is flushed into the output device. + + In the spirit of HTML tags, the default tag marking functions + output tags enclosed in "<" and ">": hence, the opening marker of + tag [t] is ["<t>"] and the closing marker ["</t>"]. + + Default tag printing functions just do nothing. + + Tag marking and tag printing functions are user definable and can + be set by calling [set_formatter_tag_functions]. *) + +val open_tag : tag -> unit;; +(** [open_tag t] opens the tag named [t]; the [print_open_tag] + function of the formatter is called with [t] as argument; + the tag marker [mark_open_tag t] will be flushed into the output + device of the formatter. *) +val close_tag : unit -> unit;; +(** [close_tag ()] closes the most recently opened tag [t]. + In addition, the [print_close_tag] function of the formatter is called + with [t] as argument. The marker [mark_close_tag t] will be flushed + into the output device of the formatter. *) + +val set_tags : bool -> unit;; +(** [set_tags b] turns on or off the treatment of tags (default is off). *) +val set_print_tags : bool -> unit;; +val set_mark_tags : bool -> unit;; +(** [set_print_tags b] turns on or off the printing of tags, while + [set_mark_tags b] turns on or off the output of tag markers. *) +val get_print_tags : unit -> bool;; +val get_mark_tags : unit -> bool;; +(** Return the current status of tags printing and tags marking. *) + +(** {6 Redirecting the standard formatter output} *) + +val set_formatter_out_channel : Pervasives.out_channel -> unit;; +(** Redirect the pretty-printer output to the given channel. + (All the output functions of the standard formatter are set to the + default output functions printing to the given channel.) *) + +val set_formatter_output_functions : + (string -> int -> int -> unit) -> (unit -> unit) -> unit +;; +(** [set_formatter_output_functions out flush] redirects the + relevant pretty-printer output functions to the functions [out] and + [flush]. + + The [out] function performs the pretty-printer string output. It is called + with a string [s], a start position [p], and a number of characters + [n]; it is supposed to output characters [p] to [p + n - 1] of + [s]. The [flush] function is called whenever the pretty-printer is + flushed (via conversion [%!], pretty-printing indications [@?] or [@.], + or using low level function [print_flush] or [print_newline]). *) + +val get_formatter_output_functions : + unit -> (string -> int -> int -> unit) * (unit -> unit) +;; +(** Return the current output functions of the pretty-printer. *) + +(** {6:meaning Changing the meaning of standard formatter pretty printing} *) + +(** The [Format] module is versatile enough to let you completely redefine + the meaning of pretty printing: you may provide your own functions to define + how to handle indentation, line breaking, and even printing of all the + characters that have to be printed! *) + +val set_all_formatter_output_functions : + out:(string -> int -> int -> unit) -> + flush:(unit -> unit) -> + newline:(unit -> unit) -> + spaces:(int -> unit) -> + unit +;; +(** [set_all_formatter_output_functions out flush outnewline outspace] + redirects the pretty-printer output to the functions [out] and + [flush] as described in [set_formatter_output_functions]. In + addition, the pretty-printer function that outputs a newline is set + to the function [outnewline] and the function that outputs + indentation spaces is set to the function [outspace]. + + This way, you can change the meaning of indentation (which can be + something else than just printing space characters) and the + meaning of new lines opening (which can be connected to any other + action needed by the application at hand). The two functions + [outspace] and [outnewline] are normally connected to [out] and + [flush]: respective default values for [outspace] and [outnewline] + are [out (String.make n ' ') 0 n] and [out "\n" 0 1]. *) + +val get_all_formatter_output_functions : + unit -> + (string -> int -> int -> unit) * + (unit -> unit) * + (unit -> unit) * + (int -> unit) +;; +(** Return the current output functions of the pretty-printer, + including line breaking and indentation functions. Useful to record the + current setting and restore it afterwards. *) + +(** {6:tags Changing the meaning of printing semantics tags} *) + +type formatter_tag_functions = { + mark_open_tag : tag -> string; + mark_close_tag : tag -> string; + print_open_tag : tag -> unit; + print_close_tag : tag -> unit; +} +;; +(** The tag handling functions specific to a formatter: + [mark] versions are the ``tag marking'' functions that associate a string + marker to a tag in order for the pretty-printing engine to flush + those markers as 0 length tokens in the output device of the formatter. + [print] versions are the ``tag printing'' functions that can perform + regular printing when a tag is closed or opened. *) + +val set_formatter_tag_functions : + formatter_tag_functions -> unit +;; + +(** [set_formatter_tag_functions tag_funs] changes the meaning of + opening and closing tags to use the functions in [tag_funs]. + + When opening a tag name [t], the string [t] is passed to the + opening tag marking function (the [mark_open_tag] field of the + record [tag_funs]), that must return the opening tag marker for + that name. When the next call to [close_tag ()] happens, the tag + name [t] is sent back to the closing tag marking function (the + [mark_close_tag] field of record [tag_funs]), that must return a + closing tag marker for that name. + + The [print_] field of the record contains the functions that are + called at tag opening and tag closing time, to output regular + material in the pretty-printer queue. *) + +val get_formatter_tag_functions : + unit -> formatter_tag_functions +;; +(** Return the current tag functions of the pretty-printer. *) + +(** {6 Multiple formatted output} *) + +type formatter;; +(** Abstract data corresponding to a pretty-printer (also called a + formatter) and all its machinery. + + Defining new pretty-printers permits unrelated output of material in + parallel on several output channels. + All the parameters of a pretty-printer are local to this pretty-printer: + margin, maximum indentation limit, maximum number of boxes + simultaneously opened, ellipsis, and so on, are specific to + each pretty-printer and may be fixed independently. + Given a [Pervasives.out_channel] output channel [oc], a new formatter + writing to that channel is simply obtained by calling + [formatter_of_out_channel oc]. + Alternatively, the [make_formatter] function allocates a new + formatter with explicit output and flushing functions + (convenient to output material to strings for instance). +*) + +val formatter_of_out_channel : out_channel -> formatter;; +(** [formatter_of_out_channel oc] returns a new formatter that + writes to the corresponding channel [oc]. *) + +val std_formatter : formatter;; +(** The standard formatter used by the formatting functions + above. It is defined as [formatter_of_out_channel stdout]. *) + +val err_formatter : formatter;; +(** A formatter to use with formatting functions below for + output to standard error. It is defined as + [formatter_of_out_channel stderr]. *) + +val formatter_of_buffer : Buffer.t -> formatter;; +(** [formatter_of_buffer b] returns a new formatter writing to + buffer [b]. As usual, the formatter has to be flushed at + the end of pretty printing, using [pp_print_flush] or + [pp_print_newline], to display all the pending material. *) + +val stdbuf : Buffer.t;; +(** The string buffer in which [str_formatter] writes. *) + +val str_formatter : formatter;; +(** A formatter to use with formatting functions below for + output to the [stdbuf] string buffer. + [str_formatter] is defined as [formatter_of_buffer stdbuf]. *) + +val flush_str_formatter : unit -> string;; +(** Returns the material printed with [str_formatter], flushes + the formatter and resets the corresponding buffer. *) + +val make_formatter : + (string -> int -> int -> unit) -> (unit -> unit) -> formatter +;; +(** [make_formatter out flush] returns a new formatter that writes according + to the output function [out], and the flushing function [flush]. For + instance, a formatter to the [Pervasives.out_channel] [oc] is returned by + [make_formatter (Pervasives.output oc) (fun () -> Pervasives.flush oc)]. *) + +(** {6 Basic functions to use with formatters} *) + +val pp_open_hbox : formatter -> unit -> unit;; +val pp_open_vbox : formatter -> int -> unit;; +val pp_open_hvbox : formatter -> int -> unit;; +val pp_open_hovbox : formatter -> int -> unit;; +val pp_open_box : formatter -> int -> unit;; +val pp_close_box : formatter -> unit -> unit;; +val pp_open_tag : formatter -> string -> unit;; +val pp_close_tag : formatter -> unit -> unit;; +val pp_print_string : formatter -> string -> unit;; +val pp_print_as : formatter -> int -> string -> unit;; +val pp_print_int : formatter -> int -> unit;; +val pp_print_float : formatter -> float -> unit;; +val pp_print_char : formatter -> char -> unit;; +val pp_print_bool : formatter -> bool -> unit;; +val pp_print_break : formatter -> int -> int -> unit;; +val pp_print_cut : formatter -> unit -> unit;; +val pp_print_space : formatter -> unit -> unit;; +val pp_force_newline : formatter -> unit -> unit;; +val pp_print_flush : formatter -> unit -> unit;; +val pp_print_newline : formatter -> unit -> unit;; +val pp_print_if_newline : formatter -> unit -> unit;; +val pp_open_tbox : formatter -> unit -> unit;; +val pp_close_tbox : formatter -> unit -> unit;; +val pp_print_tbreak : formatter -> int -> int -> unit;; +val pp_set_tab : formatter -> unit -> unit;; +val pp_print_tab : formatter -> unit -> unit;; +val pp_set_tags : formatter -> bool -> unit;; +val pp_set_print_tags : formatter -> bool -> unit;; +val pp_set_mark_tags : formatter -> bool -> unit;; +val pp_get_print_tags : formatter -> unit -> bool;; +val pp_get_mark_tags : formatter -> unit -> bool;; +val pp_set_margin : formatter -> int -> unit;; +val pp_get_margin : formatter -> unit -> int;; +val pp_set_max_indent : formatter -> int -> unit;; +val pp_get_max_indent : formatter -> unit -> int;; +val pp_set_max_boxes : formatter -> int -> unit;; +val pp_get_max_boxes : formatter -> unit -> int;; +val pp_over_max_boxes : formatter -> unit -> bool;; +val pp_set_ellipsis_text : formatter -> string -> unit;; +val pp_get_ellipsis_text : formatter -> unit -> string;; +val pp_set_formatter_out_channel : formatter -> Pervasives.out_channel -> unit;; +val pp_set_formatter_output_functions : + formatter -> (string -> int -> int -> unit) -> (unit -> unit) -> unit +;; +val pp_get_formatter_output_functions : + formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) +;; +val pp_set_all_formatter_output_functions : + formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) -> + newline:(unit -> unit) -> spaces:(int -> unit) -> unit +;; +val pp_get_all_formatter_output_functions : + formatter -> unit -> + (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) * + (int -> unit) +;; +val pp_set_formatter_tag_functions : + formatter -> formatter_tag_functions -> unit +;; +val pp_get_formatter_tag_functions : + formatter -> unit -> formatter_tag_functions +;; +(** These functions are the basic ones: usual functions + operating on the standard formatter are defined via partial + evaluation of these primitives. For instance, + [print_string] is equal to [pp_print_string std_formatter]. *) + +(** {6 [printf] like functions for pretty-printing.} *) + +val fprintf : formatter -> ('a, formatter, unit) format -> 'a;; + +(** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN] + according to the format string [fmt], and outputs the resulting string on + the formatter [ff]. + + The format [fmt] is a character string which contains three types of + objects: plain characters and conversion specifications as specified in + the [Printf] module, and pretty-printing indications specific to the + [Format] module. + + The pretty-printing indication characters are introduced by + a [@] character, and their meanings are: + - [@\[]: open a pretty-printing box. The type and offset of the + box may be optionally specified with the following syntax: + the [<] character, followed by an optional box type indication, + then an optional integer offset, and the closing [>] character. + Box type is one of [h], [v], [hv], [b], or [hov], + which stand respectively for an horizontal box, a vertical box, + an ``horizontal-vertical'' box, or an ``horizontal or + vertical'' box ([b] standing for an ``horizontal or + vertical'' box demonstrating indentation and [hov] standing + for a regular``horizontal or vertical'' box). + For instance, [@\[<hov 2>] opens an ``horizontal or vertical'' + box with indentation 2 as obtained with [open_hovbox 2]. + For more details about boxes, see the various box opening + functions [open_*box]. + - [@\]]: close the most recently opened pretty-printing box. + - [@,]: output a good break as with [print_cut ()]. + - [@ ]: output a space, as with [print_space ()]. + - [@\n]: force a newline, as with [force_newline ()]. + - [@;]: output a good break as with [print_break]. The + [nspaces] and [offset] parameters of the break may be + optionally specified with the following syntax: + the [<] character, followed by an integer [nspaces] value, + then an integer [offset], and a closing [>] character. + If no parameters are provided, the good break defaults to a + space. + - [@?]: flush the pretty printer as with [print_flush ()]. + This is equivalent to the conversion [%!]. + - [@.]: flush the pretty printer and output a new line, as with + [print_newline ()]. + - [@<n>]: print the following item as if it were of length [n]. + Hence, [printf "@<0>%s" arg] is equivalent to [print_as 0 arg]. + If [@<n>] is not followed by a conversion specification, + then the following character of the format is printed as if + it were of length [n]. + - [@\{]: open a tag. The name of the tag may be optionally + specified with the following syntax: + the [<] character, followed by an optional string + specification, and the closing [>] character. The string + specification is any character string that does not contain the + closing character ['>']. If omitted, the tag name defaults to the + empty string. + For more details about tags, see the functions [open_tag] and + [close_tag]. + - [@\}]: close the most recently opened tag. + - [@@]: print a plain [@] character. + + Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to + [open_box (); print_string "x ="; print_space (); + print_int 1; close_box (); print_newline ()]. + It prints [x = 1] within a pretty-printing box. +*) + +val printf : ('a, formatter, unit) format -> 'a;; +(** Same as [fprintf] above, but output on [std_formatter]. *) + +val eprintf : ('a, formatter, unit) format -> 'a;; +(** Same as [fprintf] above, but output on [err_formatter]. *) + +val sprintf : ('a, unit, string) format -> 'a;; +(** Same as [printf] above, but instead of printing on a formatter, + returns a string containing the result of formatting the arguments. + Note that the pretty-printer queue is flushed at the end of {e each + call} to [sprintf]. + + In case of multiple and related calls to [sprintf] to output + material on a single string, you should consider using [fprintf] + with the predefined formatter [str_formatter] and call + [flush_str_formatter ()] to get the final result. + + Alternatively, you can use [Format.fprintf] with a formatter writing to a + buffer of your own: flushing the formatter and the buffer at the end of + pretty-printing returns the desired string. *) + +val ifprintf : formatter -> ('a, formatter, unit) format -> 'a;; +(** Same as [fprintf] above, but does not print anything. + Useful to ignore some material when conditionally printing. + @since 3.10.0 +*) + +(** Formatted output functions with continuations. *) + +val kfprintf : (formatter -> 'a) -> formatter -> + ('b, formatter, unit, 'a) format4 -> 'b +;; +(** Same as [fprintf] above, but instead of returning immediately, + passes the formatter to its first argument at the end of printing. *) + +val ikfprintf : (formatter -> 'a) -> formatter -> + ('b, formatter, unit, 'a) format4 -> 'b +;; +(** Same as [kfprintf] above, but does not print anything. + Useful to ignore some material when conditionally printing. + @since 3.12.0 +*) + +val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; +(** Same as [sprintf] above, but instead of returning the string, + passes it to the first argument. *) + +(** {6 Deprecated} *) + +val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a;; +(** Deprecated and error prone function. Do not use it. + + If you need to print to some buffer [b], you must first define a + formatter writing to [b], using [let to_b = formatter_of_buffer b]; then + use regular calls to [Format.fprintf] on formatter [to_b]. *) + +val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; +(** Deprecated name. A synonym for [ksprintf]. *) diff --git a/ocaml-binary-annot/stdlib/gc.ml b/ocaml-binary-annot/stdlib/gc.ml new file mode 100644 index 0000000000..6482ebb78b --- /dev/null +++ b/ocaml-binary-annot/stdlib/gc.ml @@ -0,0 +1,102 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +type stat = { + minor_words : float; + promoted_words : float; + major_words : float; + minor_collections : int; + major_collections : int; + heap_words : int; + heap_chunks : int; + live_words : int; + live_blocks : int; + free_words : int; + free_blocks : int; + largest_free : int; + fragments : int; + compactions : int; + top_heap_words : int; + stack_size : int; +};; + +type control = { + mutable minor_heap_size : int; + mutable major_heap_increment : int; + mutable space_overhead : int; + mutable verbose : int; + mutable max_overhead : int; + mutable stack_limit : int; + mutable allocation_policy : int; +};; + +external stat : unit -> stat = "caml_gc_stat";; +external quick_stat : unit -> stat = "caml_gc_quick_stat";; +external counters : unit -> (float * float * float) = "caml_gc_counters";; +external get : unit -> control = "caml_gc_get";; +external set : control -> unit = "caml_gc_set";; +external minor : unit -> unit = "caml_gc_minor";; +external major_slice : int -> int = "caml_gc_major_slice";; +external major : unit -> unit = "caml_gc_major";; +external full_major : unit -> unit = "caml_gc_full_major";; +external compact : unit -> unit = "caml_gc_compaction";; + +open Printf;; + +let print_stat c = + let st = stat () in + fprintf c "minor_words: %.0f\n" st.minor_words; + fprintf c "promoted_words: %.0f\n" st.promoted_words; + fprintf c "major_words: %.0f\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_words: %d\n" st.heap_words; + fprintf c "heap_chunks: %d\n" st.heap_chunks; + fprintf c "top_heap_words: %d\n" st.top_heap_words; + 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; + fprintf c "compactions: %d\n" st.compactions; +;; + +let allocated_bytes () = + let (mi, pro, ma) = counters () in + (mi +. ma -. pro) *. float_of_int (Sys.word_size / 8) +;; + +external finalise : ('a -> unit) -> 'a -> unit = "caml_final_register";; +external finalise_release : unit -> unit = "caml_final_release";; + + +type alarm = bool ref;; +type alarm_rec = {active : alarm; f : unit -> unit};; + +let rec call_alarm arec = + if !(arec.active) then begin + finalise call_alarm arec; + arec.f (); + end; +;; + +let create_alarm f = + let arec = { active = ref true; f = f } in + finalise call_alarm arec; + arec.active +;; + +let delete_alarm a = a := false;; diff --git a/ocaml-binary-annot/stdlib/gc.mli b/ocaml-binary-annot/stdlib/gc.mli new file mode 100644 index 0000000000..33e794dc14 --- /dev/null +++ b/ocaml-binary-annot/stdlib/gc.mli @@ -0,0 +1,272 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Memory management control and statistics; finalised values. *) + +type stat = + { minor_words : float; + (** Number of words allocated in the minor heap since + the program was started. This number is accurate in + byte-code programs, but only an approximation in programs + compiled to native code. *) + + promoted_words : float; + (** Number of words allocated in the minor heap that + survived a minor collection and were moved to the major heap + since the program was started. *) + + major_words : float; + (** Number of words allocated in the major heap, including + the promoted words, since the program was started. *) + + minor_collections : int; + (** Number of minor collections since the program was started. *) + + major_collections : int; + (** Number of major collection cycles completed since the program + was started. *) + + heap_words : int; + (** Total size of the major heap, in words. *) + + heap_chunks : int; + (** Number of contiguous pieces of memory that make up the major heap. *) + + live_words : int; + (** Number of words of live data in the major heap, including the header + words. *) + + live_blocks : int; + (** Number of live blocks in the major heap. *) + + free_words : int; + (** Number of words in the free list. *) + + free_blocks : int; + (** Number of blocks in the free list. *) + + largest_free : int; + (** Size (in words) of the largest block in the free list. *) + + fragments : int; + (** Number of wasted words due to fragmentation. These are + 1-words free blocks placed between two live blocks. They + are not available for allocation. *) + + compactions : int; + (** Number of heap compactions since the program was started. *) + + top_heap_words : int; + (** Maximum size reached by the major heap, in words. *) + + stack_size: int; + (** Current size of the stack, in words. @since 3.12.0 *) +} +(** The memory management counters are returned in a [stat] record. + + The total amount of memory allocated by the program since it was started + 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; + (** The size (in words) of the minor heap. Changing + this parameter will trigger a minor collection. Default: 32k. *) + + mutable major_heap_increment : int; + (** The minimum number of words to add to the + major heap when increasing it. Default: 124k. *) + + mutable space_overhead : int; + (** The major GC speed is computed from this parameter. + This is the memory that will be "wasted" because the GC does not + immediatly collect unreachable blocks. It is expressed as a + percentage of the memory used for live data. + The GC will work more (use more CPU time and collect + blocks more eagerly) if [space_overhead] is smaller. + Default: 80. *) + + mutable verbose : int; + (** This value controls the GC messages on standard error output. + It is a sum of some of the following flags, to print messages + on the corresponding events: + - [0x001] Start of major GC cycle. + - [0x002] Minor collection and major GC slice. + - [0x004] Growing and shrinking of the heap. + - [0x008] Resizing of stacks and memory manager tables. + - [0x010] Heap compaction. + - [0x020] Change of GC parameters. + - [0x040] Computation of major GC slice size. + - [0x080] Calling of finalisation functions. + - [0x100] Bytecode executable search at start-up. + - [0x200] Computation of compaction triggering condition. + Default: 0. *) + + mutable max_overhead : int; + (** Heap compaction is triggered when the estimated amount + of "wasted" memory is more than [max_overhead] percent of the + amount of live data. If [max_overhead] is set to 0, heap + compaction is triggered at the end of each major GC cycle + (this setting is intended for testing purposes only). + If [max_overhead >= 1000000], compaction is never triggered. + Default: 500. *) + + mutable stack_limit : int; + (** The maximum size of the stack (in words). This is only + relevant to the byte-code runtime, as the native code runtime + uses the operating system's stack. Default: 256k. *) + + mutable allocation_policy : int; + (** The policy used for allocating in the heap. Possible + values are 0 and 1. 0 is the next-fit policy, which is + quite fast but can result in fragmentation. 1 is the + first-fit policy, which can be slower in some cases but + can be better for programs with fragmentation problems. + Default: 0. @since 3.11.0 *) +} +(** The GC parameters are given as a [control] record. Note that + these parameters can also be initialised by setting the + OCAMLRUNPARAM environment variable. See the documentation of + ocamlrun. *) + +external stat : unit -> stat = "caml_gc_stat" +(** Return the current values of the memory management counters in a + [stat] record. This function examines every heap block to get the + statistics. *) + +external quick_stat : unit -> stat = "caml_gc_quick_stat" +(** Same as [stat] except that [live_words], [live_blocks], [free_words], + [free_blocks], [largest_free], and [fragments] are set to 0. This + function is much faster than [stat] because it does not need to go + through the heap. *) + +external counters : unit -> float * float * float = "caml_gc_counters" +(** Return [(minor_words, promoted_words, major_words)]. This function + is as fast at [quick_stat]. *) + +external get : unit -> control = "caml_gc_get" +(** Return the current values of the GC parameters in a [control] record. *) + +external set : control -> unit = "caml_gc_set" +(** [set r] changes the GC parameters according to the [control] record [r]. + The normal usage is: [Gc.set { (Gc.get()) with Gc.verbose = 0x00d }] *) + +external minor : unit -> unit = "caml_gc_minor" +(** Trigger a minor collection. *) + +external major_slice : int -> int = "caml_gc_major_slice";; +(** Do a minor collection and a slice of major collection. The argument + is the size of the slice, 0 to use the automatically-computed + slice size. In all cases, the result is the computed slice size. *) + +external major : unit -> unit = "caml_gc_major" +(** Do a minor collection and finish the current major collection cycle. *) + +external full_major : unit -> unit = "caml_gc_full_major" +(** Do a minor collection, finish the current major collection cycle, + and perform a complete new cycle. This will collect all currently + unreachable blocks. *) + +external compact : unit -> unit = "caml_gc_compaction" +(** Perform a full major collection and compact the heap. Note that heap + compaction is a lengthy operation. *) + +val print_stat : out_channel -> unit +(** Print the current values of the memory management counters (in + human-readable form) into the channel argument. *) + +val allocated_bytes : unit -> float +(** Return the total number of bytes allocated since the program was + started. It is returned as a [float] to avoid overflow problems + with [int] on 32-bit machines. *) + +val finalise : ('a -> unit) -> 'a -> unit +(** [finalise f v] registers [f] as a finalisation function for [v]. + [v] must be heap-allocated. [f] will be called with [v] as + argument at some point between the first time [v] becomes unreachable + and the time [v] is collected by the GC. Several functions can + be registered for the same value, or even several instances of the + same function. Each instance will be called once (or never, + if the program terminates before [v] becomes unreachable). + + The GC will call the finalisation functions in the order of + deallocation. When several values become unreachable at the + same time (i.e. during the same GC cycle), the finalisation + functions will be called in the reverse order of the corresponding + calls to [finalise]. If [finalise] is called in the same order + as the values are allocated, that means each value is finalised + before the values it depends upon. Of course, this becomes + false if additional dependencies are introduced by assignments. + + Anything reachable from the closure of finalisation functions + is considered reachable, so the following code will not work + as expected: + - [ let v = ... in Gc.finalise (fun x -> ...) v ] + + Instead you should write: + - [ let f = fun x -> ... ;; let v = ... in Gc.finalise f v ] + + + The [f] function can use all features of O'Caml, including + assignments that make the value reachable again. It can also + loop forever (in this case, the other + finalisation functions will not be called during the execution of f, + unless it calls [finalise_release]). + It can call [finalise] on [v] or other values to register other + functions or even itself. It can raise an exception; in this case + the exception will interrupt whatever the program was doing when + the function was called. + + + [finalise] will raise [Invalid_argument] if [v] is not + heap-allocated. Some examples of values that are not + heap-allocated are integers, constant constructors, booleans, + the empty array, the empty list, the unit value. The exact list + of what is heap-allocated or not is implementation-dependent. + Some constant values can be heap-allocated but never deallocated + during the lifetime of the program, for example a list of integer + constants; this is also implementation-dependent. + You should also be aware that compiler optimisations may duplicate + some immutable values, for example floating-point numbers when + stored into arrays, so they can be finalised and collected while + another copy is still in use by the program. + + + The results of calling {!String.make}, {!String.create}, + {!Array.make}, and {!Pervasives.ref} are guaranteed to be + heap-allocated and non-constant except when the length argument is [0]. +*) + +val finalise_release : unit -> unit;; +(** A finalisation function may call [finalise_release] to tell the + GC that it can launch the next finalisation function without waiting + for the current one to return. *) + +type alarm +(** An alarm is a piece of data that calls a user function at the end of + each major GC cycle. The following functions are provided to create + and delete alarms. *) + +val create_alarm : (unit -> unit) -> alarm +(** [create_alarm f] will arrange for [f] to be called at the end of each + major GC cycle, starting with the current cycle or the next one. + A value of type [alarm] is returned that you can + use to call [delete_alarm]. *) + +val delete_alarm : alarm -> unit +(** [delete_alarm a] will stop the calls to the function associated + to [a]. Calling [delete_alarm a] again has no effect. *) diff --git a/ocaml-binary-annot/stdlib/genlex.ml b/ocaml-binary-annot/stdlib/genlex.ml new file mode 100644 index 0000000000..6ecc2805a9 --- /dev/null +++ b/ocaml-binary-annot/stdlib/genlex.ml @@ -0,0 +1,202 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +type token = + Kwd of string + | Ident of string + | Int of int + | Float of float + | String of string + | Char of char + + +(* The string buffering machinery *) + +let initial_buffer = String.create 32 + +let buffer = ref initial_buffer +let bufpos = ref 0 + +let reset_buffer () = buffer := initial_buffer; bufpos := 0 + +let store c = + if !bufpos >= String.length !buffer then + begin + let newbuffer = String.create (2 * !bufpos) in + String.blit !buffer 0 newbuffer 0 !bufpos; buffer := newbuffer + end; + String.set !buffer !bufpos c; + incr bufpos + +let get_string () = + let s = String.sub !buffer 0 !bufpos in buffer := initial_buffer; s + +(* The lexer *) + +let make_lexer keywords = + let kwd_table = Hashtbl.create 17 in + List.iter (fun s -> Hashtbl.add kwd_table s (Kwd s)) keywords; + let ident_or_keyword id = + try Hashtbl.find kwd_table id with + Not_found -> Ident id + and keyword_or_error c = + let s = String.make 1 c in + try Hashtbl.find kwd_table s with + Not_found -> raise (Stream.Error ("Illegal character " ^ s)) + in + let rec next_token (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some (' ' | '\010' | '\013' | '\009' | '\026' | '\012') -> + Stream.junk strm__; next_token strm__ + | Some ('A'..'Z' | 'a'..'z' | '_' | '\192'..'\255' as c) -> + Stream.junk strm__; + let s = strm__ in reset_buffer (); store c; ident s + | Some + ('!' | '%' | '&' | '$' | '#' | '+' | '/' | ':' | '<' | '=' | '>' | + '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) -> + Stream.junk strm__; + let s = strm__ in reset_buffer (); store c; ident2 s + | Some ('0'..'9' as c) -> + Stream.junk strm__; + let s = strm__ in reset_buffer (); store c; number s + | Some '\'' -> + Stream.junk strm__; + let c = + try char strm__ with + Stream.Failure -> raise (Stream.Error "") + in + begin match Stream.peek strm__ with + Some '\'' -> Stream.junk strm__; Some (Char c) + | _ -> raise (Stream.Error "") + end + | Some '"' -> + Stream.junk strm__; + let s = strm__ in reset_buffer (); Some (String (string s)) + | Some '-' -> Stream.junk strm__; neg_number strm__ + | Some '(' -> Stream.junk strm__; maybe_comment strm__ + | Some c -> Stream.junk strm__; Some (keyword_or_error c) + | _ -> None + and ident (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some + ('A'..'Z' | 'a'..'z' | '\192'..'\255' | '0'..'9' | '_' | '\'' as c) -> + Stream.junk strm__; let s = strm__ in store c; ident s + | _ -> Some (ident_or_keyword (get_string ())) + and ident2 (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some + ('!' | '%' | '&' | '$' | '#' | '+' | '-' | '/' | ':' | '<' | '=' | + '>' | '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) -> + Stream.junk strm__; let s = strm__ in store c; ident2 s + | _ -> Some (ident_or_keyword (get_string ())) + and neg_number (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some ('0'..'9' as c) -> + Stream.junk strm__; + let s = strm__ in reset_buffer (); store '-'; store c; number s + | _ -> let s = strm__ in reset_buffer (); store '-'; ident2 s + and number (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some ('0'..'9' as c) -> + Stream.junk strm__; let s = strm__ in store c; number s + | Some '.' -> + Stream.junk strm__; let s = strm__ in store '.'; decimal_part s + | Some ('e' | 'E') -> + Stream.junk strm__; let s = strm__ in store 'E'; exponent_part s + | _ -> Some (Int (int_of_string (get_string ()))) + and decimal_part (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some ('0'..'9' as c) -> + Stream.junk strm__; let s = strm__ in store c; decimal_part s + | Some ('e' | 'E') -> + Stream.junk strm__; let s = strm__ in store 'E'; exponent_part s + | _ -> Some (Float (float_of_string (get_string ()))) + and exponent_part (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some ('+' | '-' as c) -> + Stream.junk strm__; let s = strm__ in store c; end_exponent_part s + | _ -> end_exponent_part strm__ + and end_exponent_part (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some ('0'..'9' as c) -> + Stream.junk strm__; let s = strm__ in store c; end_exponent_part s + | _ -> Some (Float (float_of_string (get_string ()))) + and string (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some '"' -> Stream.junk strm__; get_string () + | Some '\\' -> + Stream.junk strm__; + let c = + try escape strm__ with + Stream.Failure -> raise (Stream.Error "") + in + let s = strm__ in store c; string s + | Some c -> Stream.junk strm__; let s = strm__ in store c; string s + | _ -> raise Stream.Failure + and char (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some '\\' -> + Stream.junk strm__; + begin try escape strm__ with + Stream.Failure -> raise (Stream.Error "") + end + | Some c -> Stream.junk strm__; c + | _ -> raise Stream.Failure + and escape (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some 'n' -> Stream.junk strm__; '\n' + | Some 'r' -> Stream.junk strm__; '\r' + | Some 't' -> Stream.junk strm__; '\t' + | Some ('0'..'9' as c1) -> + Stream.junk strm__; + begin match Stream.peek strm__ with + Some ('0'..'9' as c2) -> + Stream.junk strm__; + begin match Stream.peek strm__ with + Some ('0'..'9' as c3) -> + Stream.junk strm__; + Char.chr + ((Char.code c1 - 48) * 100 + (Char.code c2 - 48) * 10 + + (Char.code c3 - 48)) + | _ -> raise (Stream.Error "") + end + | _ -> raise (Stream.Error "") + end + | Some c -> Stream.junk strm__; c + | _ -> raise Stream.Failure + and maybe_comment (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some '*' -> + Stream.junk strm__; let s = strm__ in comment s; next_token s + | _ -> Some (keyword_or_error '(') + and comment (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some '(' -> Stream.junk strm__; maybe_nested_comment strm__ + | Some '*' -> Stream.junk strm__; maybe_end_comment strm__ + | Some c -> Stream.junk strm__; comment strm__ + | _ -> raise Stream.Failure + and maybe_nested_comment (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some '*' -> Stream.junk strm__; let s = strm__ in comment s; comment s + | Some c -> Stream.junk strm__; comment strm__ + | _ -> raise Stream.Failure + and maybe_end_comment (strm__ : _ Stream.t) = + match Stream.peek strm__ with + Some ')' -> Stream.junk strm__; () + | Some '*' -> Stream.junk strm__; maybe_end_comment strm__ + | Some c -> Stream.junk strm__; comment strm__ + | _ -> raise Stream.Failure + in + fun input -> Stream.from (fun count -> next_token input) diff --git a/ocaml-binary-annot/stdlib/genlex.mli b/ocaml-binary-annot/stdlib/genlex.mli new file mode 100644 index 0000000000..93bc5f55e8 --- /dev/null +++ b/ocaml-binary-annot/stdlib/genlex.mli @@ -0,0 +1,66 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** A generic lexical analyzer. + + + This module implements a simple ``standard'' lexical analyzer, presented + as a function from character streams to token streams. It implements + roughly the lexical conventions of Caml, but is parameterized by the + set of keywords of your language. + + + Example: a lexer suitable for a desk calculator is obtained by + {[ let lexer = make_lexer ["+";"-";"*";"/";"let";"="; "("; ")"] ]} + + The associated parser would be a function from [token stream] + to, for instance, [int], and would have rules such as: + + {[ + let parse_expr = parser + [< 'Int n >] -> n + | [< 'Kwd "("; n = parse_expr; 'Kwd ")" >] -> n + | [< n1 = parse_expr; n2 = parse_remainder n1 >] -> n2 + and parse_remainder n1 = parser + [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2 + | ... + ]} +*) + +(** The type of tokens. The lexical classes are: [Int] and [Float] + for integer and floating-point numbers; [String] for + string literals, enclosed in double quotes; [Char] for + character literals, enclosed in single quotes; [Ident] for + identifiers (either sequences of letters, digits, underscores + and quotes, or sequences of ``operator characters'' such as + [+], [*], etc); and [Kwd] for keywords (either identifiers or + single ``special characters'' such as [(], [}], etc). *) +type token = + Kwd of string + | Ident of string + | Int of int + | Float of float + | String of string + | Char of char + +val make_lexer : string list -> char Stream.t -> token Stream.t +(** Construct the lexer function. The first argument is the list of + keywords. An identifier [s] is returned as [Kwd s] if [s] + belongs to this list, and as [Ident s] otherwise. + A special character [s] is returned as [Kwd s] if [s] + belongs to this list, and cause a lexical error (exception + [Parse_error]) otherwise. Blanks and newlines are skipped. + Comments delimited by [(*] and [*)] are skipped as well, + and can be nested. *) diff --git a/ocaml-binary-annot/stdlib/hashtbl.ml b/ocaml-binary-annot/stdlib/hashtbl.ml new file mode 100644 index 0000000000..bcb2c9275a --- /dev/null +++ b/ocaml-binary-annot/stdlib/hashtbl.ml @@ -0,0 +1,279 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Hash tables *) + +external hash_param : int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc" + +let hash x = hash_param 10 100 x + +(* We do dynamic hashing, and resize the table and rehash the elements + when buckets become too long. *) + +type ('a, 'b) t = + { mutable size: int; (* number of elements *) + mutable data: ('a, 'b) bucketlist array } (* the buckets *) + +and ('a, 'b) bucketlist = + Empty + | Cons of 'a * 'b * ('a, 'b) bucketlist + +let create initial_size = + let s = min (max 1 initial_size) Sys.max_array_length in + { size = 0; data = Array.make s Empty } + +let clear h = + for i = 0 to Array.length h.data - 1 do + h.data.(i) <- Empty + done; + h.size <- 0 + +let copy h = + { size = h.size; + data = Array.copy h.data } + +let length h = h.size + +let resize hashfun tbl = + let odata = tbl.data in + let osize = Array.length odata in + let nsize = min (2 * osize + 1) Sys.max_array_length in + if nsize <> osize then begin + let ndata = Array.create nsize Empty in + let rec insert_bucket = function + Empty -> () + | Cons(key, data, rest) -> + insert_bucket rest; (* preserve original order of elements *) + let nidx = (hashfun key) mod nsize in + ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in + for i = 0 to osize - 1 do + insert_bucket odata.(i) + done; + tbl.data <- ndata; + end + +let add h key info = + let i = (hash key) mod (Array.length h.data) in + let bucket = Cons(key, info, h.data.(i)) in + h.data.(i) <- bucket; + h.size <- succ h.size; + if h.size > Array.length h.data lsl 1 then resize hash h + +let remove h key = + let rec remove_bucket = function + Empty -> + Empty + | Cons(k, i, next) -> + if compare k key = 0 + then begin h.size <- pred h.size; next end + else Cons(k, i, remove_bucket next) in + let i = (hash key) mod (Array.length h.data) in + h.data.(i) <- remove_bucket h.data.(i) + +let rec find_rec key = function + Empty -> + raise Not_found + | Cons(k, d, rest) -> + if compare key k = 0 then d else find_rec key rest + +let find h key = + match h.data.((hash key) mod (Array.length h.data)) with + Empty -> raise Not_found + | Cons(k1, d1, rest1) -> + if compare key k1 = 0 then d1 else + match rest1 with + Empty -> raise Not_found + | Cons(k2, d2, rest2) -> + if compare key k2 = 0 then d2 else + match rest2 with + Empty -> raise Not_found + | Cons(k3, d3, rest3) -> + if compare key k3 = 0 then d3 else find_rec key rest3 + +let find_all h key = + let rec find_in_bucket = function + Empty -> + [] + | Cons(k, d, rest) -> + if compare k key = 0 + then d :: find_in_bucket rest + else find_in_bucket rest in + find_in_bucket h.data.((hash key) mod (Array.length h.data)) + +let replace h key info = + let rec replace_bucket = function + Empty -> + raise Not_found + | Cons(k, i, next) -> + if compare k key = 0 + then Cons(k, info, next) + else Cons(k, i, replace_bucket next) in + let i = (hash key) mod (Array.length h.data) in + let l = h.data.(i) in + try + h.data.(i) <- replace_bucket l + with Not_found -> + h.data.(i) <- Cons(key, info, l); + h.size <- succ h.size; + if h.size > Array.length h.data lsl 1 then resize hash h + +let mem h key = + let rec mem_in_bucket = function + | Empty -> + false + | Cons(k, d, rest) -> + compare k key = 0 || mem_in_bucket rest in + mem_in_bucket h.data.((hash key) mod (Array.length h.data)) + +let iter f h = + let rec do_bucket = function + Empty -> + () + | Cons(k, d, rest) -> + f k d; do_bucket rest in + let d = h.data in + for i = 0 to Array.length d - 1 do + do_bucket d.(i) + done + +let fold f h init = + let rec do_bucket b accu = + match b with + Empty -> + accu + | Cons(k, d, rest) -> + do_bucket rest (f k d accu) in + 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; + !accu + +(* Functorial interface *) + +module type HashedType = + sig + type t + val equal: t -> t -> bool + val hash: t -> int + end + +module type S = + sig + type key + type 'a t + val create: int -> 'a t + val clear: 'a t -> unit + val 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_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 fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val length: 'a t -> int + end + +module Make(H: HashedType): (S with type key = H.t) = + struct + type key = H.t + type 'a hashtbl = (key, 'a) t + type 'a t = 'a hashtbl + let create = create + let clear = clear + let copy = copy + + let safehash key = (H.hash key) land max_int + + let add h key info = + let i = (safehash key) mod (Array.length h.data) in + let bucket = Cons(key, info, h.data.(i)) in + h.data.(i) <- bucket; + h.size <- succ h.size; + if h.size > Array.length h.data lsl 1 then resize safehash h + + let remove h key = + let rec remove_bucket = function + Empty -> + Empty + | Cons(k, i, next) -> + if H.equal k key + then begin h.size <- pred h.size; next end + else Cons(k, i, remove_bucket next) in + let i = (safehash key) mod (Array.length h.data) in + h.data.(i) <- remove_bucket h.data.(i) + + let rec find_rec key = function + Empty -> + raise Not_found + | Cons(k, d, rest) -> + if H.equal key k then d else find_rec key rest + + let find h key = + match h.data.((safehash key) mod (Array.length h.data)) with + Empty -> raise Not_found + | Cons(k1, d1, rest1) -> + if H.equal key k1 then d1 else + match rest1 with + Empty -> raise Not_found + | Cons(k2, d2, rest2) -> + if H.equal key k2 then d2 else + match rest2 with + Empty -> raise Not_found + | Cons(k3, d3, rest3) -> + if H.equal key k3 then d3 else find_rec key rest3 + + let find_all h key = + let rec find_in_bucket = function + Empty -> + [] + | Cons(k, d, rest) -> + if H.equal k key + then d :: find_in_bucket rest + else find_in_bucket rest in + find_in_bucket h.data.((safehash key) mod (Array.length h.data)) + + let replace h key info = + let rec replace_bucket = function + Empty -> + raise Not_found + | Cons(k, i, next) -> + if H.equal k key + then Cons(k, info, next) + else Cons(k, i, replace_bucket next) in + let i = (safehash key) mod (Array.length h.data) in + let l = h.data.(i) in + try + h.data.(i) <- replace_bucket l + with Not_found -> + h.data.(i) <- Cons(key, info, l); + h.size <- succ h.size; + if h.size > Array.length h.data lsl 1 then resize safehash h + + let mem h key = + let rec mem_in_bucket = function + | Empty -> + false + | Cons(k, d, rest) -> + H.equal k key || mem_in_bucket rest in + mem_in_bucket h.data.((safehash key) mod (Array.length h.data)) + + let iter = iter + let fold = fold + let length = length + end diff --git a/ocaml-binary-annot/stdlib/hashtbl.mli b/ocaml-binary-annot/stdlib/hashtbl.mli new file mode 100644 index 0000000000..1bf175ad1f --- /dev/null +++ b/ocaml-binary-annot/stdlib/hashtbl.mli @@ -0,0 +1,177 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Hash tables and hash functions. + + Hash tables are hashed association tables, with in-place modification. +*) + + +(** {6 Generic interface} *) + + +type ('a, 'b) t +(** The type of hash tables from type ['a] to type ['b]. *) + +val create : int -> ('a, 'b) t +(** [Hashtbl.create n] creates a new, empty hash table, with + initial size [n]. For best results, [n] should be on the + order of the expected number of elements that will be in + the table. The table grows as needed, so [n] is just an + initial guess. *) + +val clear : ('a, 'b) t -> unit +(** Empty a hash table. *) + + +val add : ('a, 'b) t -> 'a -> 'b -> unit +(** [Hashtbl.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 {!Hashtbl.remove}[ tbl x], + the previous binding for [x], if any, is restored. + (Same behavior as with association lists.) *) + +val copy : ('a, 'b) t -> ('a, 'b) t +(** Return a copy of the given hashtable. *) + +val find : ('a, 'b) t -> 'a -> 'b +(** [Hashtbl.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 +(** [Hashtbl.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 mem : ('a, 'b) t -> 'a -> bool +(** [Hashtbl.mem tbl x] checks if [x] is bound in [tbl]. *) + +val remove : ('a, 'b) t -> 'a -> unit +(** [Hashtbl.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 replace : ('a, 'b) t -> 'a -> 'b -> unit +(** [Hashtbl.replace tbl x y] replaces the current binding of [x] + in [tbl] by a binding of [x] to [y]. If [x] is unbound in [tbl], + a binding of [x] to [y] is added to [tbl]. + This is functionally equivalent to {!Hashtbl.remove}[ tbl x] + followed by {!Hashtbl.add}[ tbl x y]. *) + +val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit +(** [Hashtbl.iter f tbl] applies [f] to all bindings in table [tbl]. + [f] receives the key as first argument, and the associated value + as second argument. Each binding is presented exactly once to [f]. + The order in which the bindings are passed to [f] is unspecified. + However, if the table contains several bindings for the same key, + they are passed to [f] in reverse order of introduction, that is, + the most recent binding is passed first. *) + +val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c +(** [Hashtbl.fold f tbl init] computes + [(f kN dN ... (f k1 d1 init)...)], + where [k1 ... kN] are the keys of all bindings in [tbl], + and [d1 ... dN] are the associated values. + Each binding is presented exactly once to [f]. + The order in which the bindings are passed to [f] is unspecified. + However, if the table contains several bindings for the same key, + they are passed to [f] in reverse order of introduction, that is, + the most recent binding is passed first. *) + + +val length : ('a, 'b) t -> int +(** [Hashtbl.length tbl] returns the number of bindings in [tbl]. + Multiple bindings are counted multiply, so [Hashtbl.length] + gives the number of times [Hashtbl.iter] calls its first argument. *) + + +(** {6 Functorial interface} *) + + +module type HashedType = + sig + type t + (** The type of the hashtable keys. *) + val equal : t -> t -> bool + (** The equality predicate used to compare keys. *) + val hash : t -> int + (** A hashing function on keys. It must be such that if two keys are + equal according to [equal], then they have identical hash values + as computed by [hash]. + Examples: suitable ([equal], [hash]) pairs for arbitrary key + types include + ([(=)], {!Hashtbl.hash}) for comparing objects by structure, + ([(fun x y -> compare x y = 0)], {!Hashtbl.hash}) + for comparing objects by structure and handling {!Pervasives.nan} + correctly, and + ([(==)], {!Hashtbl.hash}) for comparing objects by addresses + (e.g. for cyclic keys). *) + end +(** The input signature of the functor {!Hashtbl.Make}. *) + +module type S = + sig + type key + type 'a t + val create : int -> 'a t + val clear : '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_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 fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val length : 'a t -> int + end +(** The output signature of the functor {!Hashtbl.Make}. *) + +module Make (H : HashedType) : S with type key = H.t +(** Functor building an implementation of the hashtable structure. + The functor [Hashtbl.Make] returns a structure containing + a type [key] of keys and a type ['a t] of hash tables + associating data of type ['a] to keys of type [key]. + The operations perform similarly to those of the generic + interface, but use the hashing and equality functions + specified in the functor argument [H] instead of generic + equality and hashing. *) + + +(** {6 The polymorphic hash primitive} *) + + +val hash : 'a -> int +(** [Hashtbl.hash x] associates a positive integer to any value of + any type. It is guaranteed that + if [x = y] or [Pervasives.compare x y = 0], then [hash x = hash y]. + Moreover, [hash] always terminates, even on cyclic + structures. *) + +external hash_param : int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc" +(** [Hashtbl.hash_param n m x] computes a hash value 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 values of [m] and [n] means that more + nodes are taken into account to compute the final hash + value, 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/ocaml-binary-annot/stdlib/header.c b/ocaml-binary-annot/stdlib/header.c new file mode 100644 index 0000000000..eda76325a6 --- /dev/null +++ b/ocaml-binary-annot/stdlib/header.c @@ -0,0 +1,191 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1998 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +/* The launcher for bytecode executables (if #! is not working) */ + +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include "../config/s.h" +#ifdef HAS_UNISTD +#include <unistd.h> +#endif +#include <fcntl.h> +#include <sys/types.h> +#include <sys/stat.h> +#include "../byterun/mlvalues.h" +#include "../byterun/exec.h" + +char * default_runtime_path = RUNTIME_NAME; + +#ifndef MAXPATHLEN +#define MAXPATHLEN 1024 +#endif + +#ifndef S_ISREG +#define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) +#endif + +#ifndef SEEK_END +#define SEEK_END 2 +#endif + +#ifndef __CYGWIN32__ + +/* Normal Unix search path function */ + +static char * searchpath(char * name) +{ + static char fullname[MAXPATHLEN + 1]; + char * path; + char * p; + char * q; + struct stat st; + + for (p = name; *p != 0; p++) { + if (*p == '/') return name; + } + path = getenv("PATH"); + if (path == NULL) return name; + while(1) { + for (p = fullname; *path != 0 && *path != ':'; p++, path++) + if (p < fullname + MAXPATHLEN) *p = *path; + if (p != fullname && p < fullname + MAXPATHLEN) + *p++ = '/'; + for (q = name; *q != 0; p++, q++) + if (p < fullname + MAXPATHLEN) *p = *q; + *p = 0; + if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) break; + if (*path == 0) return name; + path++; + } + return fullname; +} + +#else + +/* Special version for Cygwin32: takes care of the ".exe" implicit suffix */ + +static int file_ok(char * name) +{ + int fd; + /* Cannot use stat() here because it adds ".exe" implicitly */ + fd = open(name, O_RDONLY); + if (fd == -1) return 0; + close(fd); + return 1; +} + +static char * searchpath(char * name) +{ + char * path, * fullname, * p; + + path = getenv("PATH"); + fullname = malloc(strlen(name) + (path == NULL ? 0 : strlen(path)) + 6); + /* 6 = "/" plus ".exe" plus final "\0" */ + if (fullname == NULL) return name; + /* Check for absolute path name */ + for (p = name; *p != 0; p++) { + if (*p == '/' || *p == '\\') { + if (file_ok(name)) return name; + strcpy(fullname, name); + strcat(fullname, ".exe"); + if (file_ok(fullname)) return fullname; + return name; + } + } + /* Search in path */ + if (path == NULL) return name; + while(1) { + for (p = fullname; *path != 0 && *path != ':'; p++, path++) *p = *path; + if (p != fullname) *p++ = '/'; + strcpy(p, name); + if (file_ok(fullname)) return fullname; + strcat(fullname, ".exe"); + if (file_ok(fullname)) return fullname; + if (*path == 0) break; + path++; + } + return name; +} + +#endif + +static unsigned long read_size(char * ptr) +{ + unsigned char * p = (unsigned char *) ptr; + return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) + + ((unsigned long) p[2] << 8) + p[3]; +} + +static char * read_runtime_path(int fd) +{ + char buffer[TRAILER_SIZE]; + static char runtime_path[MAXPATHLEN]; + int num_sections, i; + uint32 path_size; + long ofs; + + lseek(fd, (long) -TRAILER_SIZE, SEEK_END); + if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return NULL; + num_sections = read_size(buffer); + ofs = TRAILER_SIZE + num_sections * 8; + lseek(fd, -ofs, SEEK_END); + path_size = 0; + for (i = 0; i < num_sections; i++) { + if (read(fd, buffer, 8) < 8) return NULL; + if (buffer[0] == 'R' && buffer[1] == 'N' && + buffer[2] == 'T' && buffer[3] == 'M') { + path_size = read_size(buffer + 4); + ofs += path_size; + } else if (path_size > 0) + ofs += read_size(buffer + 4); + } + if (path_size == 0) return default_runtime_path; + if (path_size >= MAXPATHLEN) return NULL; + lseek(fd, -ofs, SEEK_END); + if (read(fd, runtime_path, path_size) != path_size) return NULL; + runtime_path[path_size - 1] = 0; + return runtime_path; +} + +static void errwrite(char * msg) +{ + write(2, msg, strlen(msg)); +} + +#ifndef O_BINARY +#define O_BINARY 0 +#endif + +int main(int argc, char ** argv) +{ + char * truename, * runtime_path; + int fd; + + truename = searchpath(argv[0]); + fd = open(truename, O_RDONLY | O_BINARY); + if (fd == -1 || (runtime_path = read_runtime_path(fd)) == NULL) { + errwrite(truename); + errwrite(" not found or is not a bytecode executable file\n"); + return 2; + } + argv[0] = truename; + execv(runtime_path, argv); + errwrite("Cannot exec "); + errwrite(runtime_path); + errwrite("\n"); + return 2; +} diff --git a/ocaml-binary-annot/stdlib/headernt.c b/ocaml-binary-annot/stdlib/headernt.c new file mode 100644 index 0000000000..c8d23ee256 --- /dev/null +++ b/ocaml-binary-annot/stdlib/headernt.c @@ -0,0 +1,175 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1998 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#define STRICT +#define WIN32_LEAN_AND_MEAN + +#include <windows.h> +#include "mlvalues.h" +#include "exec.h" + +#ifndef __MINGW32__ +#pragma comment(linker , "/entry:headerentry") +#pragma comment(linker , "/subsystem:console") +#pragma comment(lib , "kernel32") +#endif + +char * default_runtime_name = "ocamlrun"; + +static +#if _MSC_VER >= 1200 +__forceinline +#else +__inline +#endif +unsigned long read_size(const char * const ptr) +{ + const unsigned char * const p = (const unsigned char * const) ptr; + return ((unsigned long) p[0] << 24) | ((unsigned long) p[1] << 16) | + ((unsigned long) p[2] << 8) | p[3]; +} + +static __inline char * read_runtime_path(HANDLE h) +{ + char buffer[TRAILER_SIZE]; + static char runtime_path[MAX_PATH]; + DWORD nread; + int num_sections, path_size, i; + long ofs; + + if (SetFilePointer(h, -TRAILER_SIZE, NULL, FILE_END) == -1) return NULL; + if (! ReadFile(h, buffer, TRAILER_SIZE, &nread, NULL)) return NULL; + if (nread != TRAILER_SIZE) return NULL; + num_sections = read_size(buffer); + ofs = TRAILER_SIZE + num_sections * 8; + if (SetFilePointer(h, - ofs, NULL, FILE_END) == -1) return NULL; + path_size = 0; + for (i = 0; i < num_sections; i++) { + if (! ReadFile(h, buffer, 8, &nread, NULL) || nread != 8) return NULL; + if (buffer[0] == 'R' && buffer[1] == 'N' && + buffer[2] == 'T' && buffer[3] == 'M') { + path_size = read_size(buffer + 4); + ofs += path_size; + } else if (path_size > 0) + ofs += read_size(buffer + 4); + } + if (path_size == 0) return default_runtime_name; + if (path_size >= MAX_PATH) return NULL; + if (SetFilePointer(h, -ofs, NULL, FILE_END) == -1) return NULL; + if (! ReadFile(h, runtime_path, path_size, &nread, NULL)) return NULL; + if (nread != path_size) return NULL; + runtime_path[path_size - 1] = 0; + return runtime_path; +} + +static BOOL WINAPI ctrl_handler(DWORD event) +{ + if (event == CTRL_C_EVENT || event == CTRL_BREAK_EVENT) + return TRUE; /* pretend we've handled them */ + else + return FALSE; +} + +#define msg_and_length(msg) msg , (sizeof(msg) - 1) + +static __inline void __declspec(noreturn) run_runtime(char * runtime, + char * const cmdline) +{ + char path[MAX_PATH]; + STARTUPINFO stinfo; + PROCESS_INFORMATION procinfo; + DWORD retcode; + if (SearchPath(NULL, runtime, ".exe", MAX_PATH, path, &runtime) == 0) { + HANDLE errh; + DWORD numwritten; + errh = GetStdHandle(STD_ERROR_HANDLE); + WriteFile(errh, msg_and_length("Cannot exec "), &numwritten, NULL); + WriteFile(errh, runtime, strlen(runtime), &numwritten, NULL); + WriteFile(errh, msg_and_length("\r\n"), &numwritten, NULL); + ExitProcess(2); +#if _MSC_VER >= 1200 + __assume(0); /* Not reached */ +#endif + } + /* Need to ignore ctrl-C and ctrl-break, otherwise we'll die and take + the underlying OCaml program with us! */ + SetConsoleCtrlHandler(ctrl_handler, TRUE); + + stinfo.cb = sizeof(stinfo); + stinfo.lpReserved = NULL; + stinfo.lpDesktop = NULL; + stinfo.lpTitle = NULL; + stinfo.dwFlags = 0; + stinfo.cbReserved2 = 0; + stinfo.lpReserved2 = NULL; + if (!CreateProcess(path, cmdline, NULL, NULL, TRUE, 0, NULL, NULL, + &stinfo, &procinfo)) { + HANDLE errh; + DWORD numwritten; + errh = GetStdHandle(STD_ERROR_HANDLE); + WriteFile(errh, msg_and_length("Cannot exec "), &numwritten, NULL); + WriteFile(errh, runtime, strlen(runtime), &numwritten, NULL); + WriteFile(errh, msg_and_length("\r\n"), &numwritten, NULL); + ExitProcess(2); +#if _MSC_VER >= 1200 + __assume(0); /* Not reached */ +#endif + } + CloseHandle(procinfo.hThread); + WaitForSingleObject(procinfo.hProcess , INFINITE); + GetExitCodeProcess(procinfo.hProcess , &retcode); + CloseHandle(procinfo.hProcess); + ExitProcess(retcode); +#if _MSC_VER >= 1200 + __assume(0); /* Not reached */ +#endif +} + +#ifdef __MINGW32__ +int main() +#else +void __declspec(noreturn) __cdecl headerentry() +#endif +{ + char truename[MAX_PATH]; + char * cmdline = GetCommandLine(); + char * runtime_path; + HANDLE h; + + GetModuleFileName(NULL, truename, sizeof(truename)); + h = CreateFile(truename, GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE, + NULL, OPEN_EXISTING, 0, NULL); + if (h == INVALID_HANDLE_VALUE || + (runtime_path = read_runtime_path(h)) == NULL) { + HANDLE errh; + DWORD numwritten; + errh = GetStdHandle(STD_ERROR_HANDLE); + WriteFile(errh, truename, strlen(truename), &numwritten, NULL); + WriteFile(errh, msg_and_length(" not found or is not a bytecode executable file\r\n"), + &numwritten, NULL); + ExitProcess(2); +#if _MSC_VER >= 1200 + __assume(0); /* Not reached */ +#endif + } + CloseHandle(h); + run_runtime(runtime_path , cmdline); +#if _MSC_VER >= 1200 + __assume(0); /* Not reached */ +#endif +#ifdef __MINGW32__ + return 0; +#endif +} diff --git a/ocaml-binary-annot/stdlib/int32.ml b/ocaml-binary-annot/stdlib/int32.ml new file mode 100644 index 0000000000..64d525e88f --- /dev/null +++ b/ocaml-binary-annot/stdlib/int32.ml @@ -0,0 +1,54 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Module [Int32]: 32-bit integers *) + +external neg : int32 -> int32 = "%int32_neg" +external add : int32 -> int32 -> int32 = "%int32_add" +external sub : int32 -> int32 -> int32 = "%int32_sub" +external mul : int32 -> int32 -> int32 = "%int32_mul" +external div : int32 -> int32 -> int32 = "%int32_div" +external rem : int32 -> int32 -> int32 = "%int32_mod" +external logand : int32 -> int32 -> int32 = "%int32_and" +external logor : int32 -> int32 -> int32 = "%int32_or" +external logxor : int32 -> int32 -> int32 = "%int32_xor" +external shift_left : int32 -> int -> int32 = "%int32_lsl" +external shift_right : int32 -> int -> int32 = "%int32_asr" +external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" +external of_int : int -> int32 = "%int32_of_int" +external to_int : int32 -> int = "%int32_to_int" +external of_float : float -> int32 = "caml_int32_of_float" +external to_float : int32 -> float = "caml_int32_to_float" +external bits_of_float : float -> int32 = "caml_int32_bits_of_float" +external float_of_bits : int32 -> float = "caml_int32_float_of_bits" + +let zero = 0l +let one = 1l +let minus_one = -1l +let succ n = add n 1l +let pred n = sub n 1l +let abs n = if n >= 0l then n else neg n +let min_int = 0x80000000l +let max_int = 0x7FFFFFFFl +let lognot n = logxor n (-1l) + +external format : string -> int32 -> string = "caml_int32_format" +let to_string n = format "%d" n + +external of_string : string -> int32 = "caml_int32_of_string" + +type t = int32 + +let compare (x: t) (y: t) = Pervasives.compare x y diff --git a/ocaml-binary-annot/stdlib/int32.mli b/ocaml-binary-annot/stdlib/int32.mli new file mode 100644 index 0000000000..eeafb1a2fc --- /dev/null +++ b/ocaml-binary-annot/stdlib/int32.mli @@ -0,0 +1,164 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** 32-bit integers. + + This module provides operations on the type [int32] + of signed 32-bit integers. Unlike the built-in [int] type, + the type [int32] is guaranteed to be exactly 32-bit wide on all + platforms. All arithmetic operations over [int32] are taken + modulo 2{^32}. + + Performance notice: values of type [int32] occupy more memory + space than values of type [int], and arithmetic operations on + [int32] are generally slower than those on [int]. Use [int32] + only when the application requires exact 32-bit arithmetic. *) + +val zero : int32 +(** The 32-bit integer 0. *) + +val one : int32 +(** The 32-bit integer 1. *) + +val minus_one : int32 +(** The 32-bit integer -1. *) + +external neg : int32 -> int32 = "%int32_neg" +(** Unary negation. *) + +external add : int32 -> int32 -> int32 = "%int32_add" +(** Addition. *) + +external sub : int32 -> int32 -> int32 = "%int32_sub" +(** Subtraction. *) + +external mul : int32 -> int32 -> int32 = "%int32_mul" +(** Multiplication. *) + +external div : int32 -> int32 -> int32 = "%int32_div" +(** Integer division. Raise [Division_by_zero] if the second + argument is zero. This division rounds the real quotient of + its arguments towards zero, as specified for {!Pervasives.(/)}. *) + +external rem : int32 -> int32 -> int32 = "%int32_mod" +(** Integer remainder. If [y] is not zero, the result + of [Int32.rem x y] satisfies the following property: + [x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)]. + If [y = 0], [Int32.rem x y] raises [Division_by_zero]. *) + +val succ : int32 -> int32 +(** Successor. [Int32.succ x] is [Int32.add x Int32.one]. *) + +val pred : int32 -> int32 +(** Predecessor. [Int32.pred x] is [Int32.sub x Int32.one]. *) + +val abs : int32 -> int32 +(** Return the absolute value of its argument. *) + +val max_int : int32 +(** The greatest representable 32-bit integer, 2{^31} - 1. *) + +val min_int : int32 +(** The smallest representable 32-bit integer, -2{^31}. *) + + +external logand : int32 -> int32 -> int32 = "%int32_and" +(** Bitwise logical and. *) + +external logor : int32 -> int32 -> int32 = "%int32_or" +(** Bitwise logical or. *) + +external logxor : int32 -> int32 -> int32 = "%int32_xor" +(** Bitwise logical exclusive or. *) + +val lognot : int32 -> int32 +(** Bitwise logical negation *) + +external shift_left : int32 -> int -> int32 = "%int32_lsl" +(** [Int32.shift_left x y] shifts [x] to the left by [y] bits. + The result is unspecified if [y < 0] or [y >= 32]. *) + +external shift_right : int32 -> int -> int32 = "%int32_asr" +(** [Int32.shift_right x y] shifts [x] to the right by [y] bits. + This is an arithmetic shift: the sign bit of [x] is replicated + and inserted in the vacated bits. + The result is unspecified if [y < 0] or [y >= 32]. *) + +external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" +(** [Int32.shift_right_logical x y] shifts [x] to the right by [y] bits. + This is a logical shift: zeroes are inserted in the vacated bits + regardless of the sign of [x]. + The result is unspecified if [y < 0] or [y >= 32]. *) + +external of_int : int -> int32 = "%int32_of_int" +(** Convert the given integer (type [int]) to a 32-bit integer + (type [int32]). *) + +external to_int : int32 -> int = "%int32_to_int" +(** Convert the given 32-bit integer (type [int32]) to an + integer (type [int]). On 32-bit platforms, the 32-bit integer + is taken modulo 2{^31}, i.e. the high-order bit is lost + during the conversion. On 64-bit platforms, the conversion + is exact. *) + +external of_float : float -> int32 = "caml_int32_of_float" +(** Convert the given floating-point number to a 32-bit integer, + discarding the fractional part (truncate towards 0). + The result of the conversion is undefined if, after truncation, + the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. *) + +external to_float : int32 -> float = "caml_int32_to_float" +(** Convert the given 32-bit integer to a floating-point number. *) + +external of_string : string -> int32 = "caml_int32_of_string" +(** Convert the given string to a 32-bit integer. + The string is read in decimal (by default) or in hexadecimal, + octal or binary if the string begins with [0x], [0o] or [0b] + respectively. + Raise [Failure "int_of_string"] if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [int32]. *) + +val to_string : int32 -> string +(** Return the string representation of its argument, in signed decimal. *) + +external bits_of_float : float -> int32 = "caml_int32_bits_of_float" +(** Return the internal representation of the given float according + to the IEEE 754 floating-point ``single format'' bit layout. + Bit 31 of the result represents the sign of the float; + bits 30 to 23 represent the (biased) exponent; bits 22 to 0 + represent the mantissa. *) + +external float_of_bits : int32 -> float = "caml_int32_float_of_bits" +(** Return the floating-point number whose internal representation, + according to the IEEE 754 floating-point ``single format'' bit layout, + is the given [int32]. *) + +type t = int32 +(** An alias for the type of 32-bit integers. *) + +val compare: t -> t -> int +(** The comparison function for 32-bit integers, with the same specification as + {!Pervasives.compare}. Along with the type [t], this function [compare] + allows the module [Int32] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +(**/**) + +(** {6 Deprecated functions} *) + +external format : string -> int32 -> string = "caml_int32_format" +(** Do not use this deprecated function. Instead, + used {!Printf.sprintf} with a [%l...] format. *) diff --git a/ocaml-binary-annot/stdlib/int64.ml b/ocaml-binary-annot/stdlib/int64.ml new file mode 100644 index 0000000000..e916fa4e0d --- /dev/null +++ b/ocaml-binary-annot/stdlib/int64.ml @@ -0,0 +1,59 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Module [Int64]: 64-bit integers *) + +external neg : int64 -> int64 = "%int64_neg" +external add : int64 -> int64 -> int64 = "%int64_add" +external sub : int64 -> int64 -> int64 = "%int64_sub" +external mul : int64 -> int64 -> int64 = "%int64_mul" +external div : int64 -> int64 -> int64 = "%int64_div" +external rem : int64 -> int64 -> int64 = "%int64_mod" +external logand : int64 -> int64 -> int64 = "%int64_and" +external logor : int64 -> int64 -> int64 = "%int64_or" +external logxor : int64 -> int64 -> int64 = "%int64_xor" +external shift_left : int64 -> int -> int64 = "%int64_lsl" +external shift_right : int64 -> int -> int64 = "%int64_asr" +external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" +external of_int : int -> int64 = "%int64_of_int" +external to_int : int64 -> int = "%int64_to_int" +external of_float : float -> int64 = "caml_int64_of_float" +external to_float : int64 -> float = "caml_int64_to_float" +external of_int32 : int32 -> int64 = "%int64_of_int32" +external to_int32 : int64 -> int32 = "%int64_to_int32" +external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" +external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" + +let zero = 0L +let one = 1L +let minus_one = -1L +let succ n = add n 1L +let pred n = sub n 1L +let abs n = if n >= 0L then n else neg n +let min_int = 0x8000000000000000L +let max_int = 0x7FFFFFFFFFFFFFFFL +let lognot n = logxor n (-1L) + +external format : string -> int64 -> string = "caml_int64_format" +let to_string n = format "%d" n + +external of_string : string -> int64 = "caml_int64_of_string" + +external bits_of_float : float -> int64 = "caml_int64_bits_of_float" +external float_of_bits : int64 -> float = "caml_int64_float_of_bits" + +type t = int64 + +let compare (x: t) (y: t) = Pervasives.compare x y diff --git a/ocaml-binary-annot/stdlib/int64.mli b/ocaml-binary-annot/stdlib/int64.mli new file mode 100644 index 0000000000..3b641338e7 --- /dev/null +++ b/ocaml-binary-annot/stdlib/int64.mli @@ -0,0 +1,186 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** 64-bit integers. + + This module provides operations on the type [int64] of + signed 64-bit integers. Unlike the built-in [int] type, + the type [int64] is guaranteed to be exactly 64-bit wide on all + platforms. All arithmetic operations over [int64] are taken + modulo 2{^64} + + Performance notice: values of type [int64] occupy more memory + space than values of type [int], and arithmetic operations on + [int64] are generally slower than those on [int]. Use [int64] + only when the application requires exact 64-bit arithmetic. +*) + +val zero : int64 +(** The 64-bit integer 0. *) + +val one : int64 +(** The 64-bit integer 1. *) + +val minus_one : int64 +(** The 64-bit integer -1. *) + +external neg : int64 -> int64 = "%int64_neg" +(** Unary negation. *) + +external add : int64 -> int64 -> int64 = "%int64_add" +(** Addition. *) + +external sub : int64 -> int64 -> int64 = "%int64_sub" +(** Subtraction. *) + +external mul : int64 -> int64 -> int64 = "%int64_mul" +(** Multiplication. *) + +external div : int64 -> int64 -> int64 = "%int64_div" +(** Integer division. Raise [Division_by_zero] if the second + argument is zero. This division rounds the real quotient of + its arguments towards zero, as specified for {!Pervasives.(/)}. *) + +external rem : int64 -> int64 -> int64 = "%int64_mod" +(** Integer remainder. If [y] is not zero, the result + of [Int64.rem x y] satisfies the following property: + [x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)]. + If [y = 0], [Int64.rem x y] raises [Division_by_zero]. *) + +val succ : int64 -> int64 +(** Successor. [Int64.succ x] is [Int64.add x Int64.one]. *) + +val pred : int64 -> int64 +(** Predecessor. [Int64.pred x] is [Int64.sub x Int64.one]. *) + +val abs : int64 -> int64 +(** Return the absolute value of its argument. *) + +val max_int : int64 +(** The greatest representable 64-bit integer, 2{^63} - 1. *) + +val min_int : int64 +(** The smallest representable 64-bit integer, -2{^63}. *) + +external logand : int64 -> int64 -> int64 = "%int64_and" +(** Bitwise logical and. *) + +external logor : int64 -> int64 -> int64 = "%int64_or" +(** Bitwise logical or. *) + +external logxor : int64 -> int64 -> int64 = "%int64_xor" +(** Bitwise logical exclusive or. *) + +val lognot : int64 -> int64 +(** Bitwise logical negation *) + +external shift_left : int64 -> int -> int64 = "%int64_lsl" +(** [Int64.shift_left x y] shifts [x] to the left by [y] bits. + The result is unspecified if [y < 0] or [y >= 64]. *) + +external shift_right : int64 -> int -> int64 = "%int64_asr" +(** [Int64.shift_right x y] shifts [x] to the right by [y] bits. + This is an arithmetic shift: the sign bit of [x] is replicated + and inserted in the vacated bits. + The result is unspecified if [y < 0] or [y >= 64]. *) + +external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" +(** [Int64.shift_right_logical x y] shifts [x] to the right by [y] bits. + This is a logical shift: zeroes are inserted in the vacated bits + regardless of the sign of [x]. + The result is unspecified if [y < 0] or [y >= 64]. *) + +external of_int : int -> int64 = "%int64_of_int" +(** Convert the given integer (type [int]) to a 64-bit integer + (type [int64]). *) + +external to_int : int64 -> int = "%int64_to_int" +(** Convert the given 64-bit integer (type [int64]) to an + integer (type [int]). On 64-bit platforms, the 64-bit integer + is taken modulo 2{^63}, i.e. the high-order bit is lost + during the conversion. On 32-bit platforms, the 64-bit integer + is taken modulo 2{^31}, i.e. the top 33 bits are lost + during the conversion. *) + +external of_float : float -> int64 = "caml_int64_of_float" +(** Convert the given floating-point number to a 64-bit integer, + discarding the fractional part (truncate towards 0). + The result of the conversion is undefined if, after truncation, + the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. *) + +external to_float : int64 -> float = "caml_int64_to_float" +(** Convert the given 64-bit integer to a floating-point number. *) + + +external of_int32 : int32 -> int64 = "%int64_of_int32" +(** Convert the given 32-bit integer (type [int32]) + to a 64-bit integer (type [int64]). *) + +external to_int32 : int64 -> int32 = "%int64_to_int32" +(** Convert the given 64-bit integer (type [int64]) to a + 32-bit integer (type [int32]). The 64-bit integer + is taken modulo 2{^32}, i.e. the top 32 bits are lost + during the conversion. *) + +external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" +(** Convert the given native integer (type [nativeint]) + to a 64-bit integer (type [int64]). *) + +external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" +(** Convert the given 64-bit integer (type [int64]) to a + native integer. On 32-bit platforms, the 64-bit integer + is taken modulo 2{^32}. On 64-bit platforms, + the conversion is exact. *) + +external of_string : string -> int64 = "caml_int64_of_string" +(** Convert the given string to a 64-bit integer. + The string is read in decimal (by default) or in hexadecimal, + octal or binary if the string begins with [0x], [0o] or [0b] + respectively. + Raise [Failure "int_of_string"] if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [int64]. *) + +val to_string : int64 -> string +(** Return the string representation of its argument, in decimal. *) + +external bits_of_float : float -> int64 = "caml_int64_bits_of_float" +(** Return the internal representation of the given float according + to the IEEE 754 floating-point ``double format'' bit layout. + Bit 63 of the result represents the sign of the float; + bits 62 to 52 represent the (biased) exponent; bits 51 to 0 + represent the mantissa. *) + +external float_of_bits : int64 -> float = "caml_int64_float_of_bits" +(** Return the floating-point number whose internal representation, + according to the IEEE 754 floating-point ``double format'' bit layout, + is the given [int64]. *) + +type t = int64 +(** An alias for the type of 64-bit integers. *) + +val compare: t -> t -> int +(** The comparison function for 64-bit integers, with the same specification as + {!Pervasives.compare}. Along with the type [t], this function [compare] + allows the module [Int64] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +(**/**) + +(** {6 Deprecated functions} *) + +external format : string -> int64 -> string = "caml_int64_format" +(** Do not use this deprecated function. Instead, + used {!Printf.sprintf} with a [%L...] format. *) diff --git a/ocaml-binary-annot/stdlib/lazy.ml b/ocaml-binary-annot/stdlib/lazy.ml new file mode 100644 index 0000000000..b1a9cbbda3 --- /dev/null +++ b/ocaml-binary-annot/stdlib/lazy.ml @@ -0,0 +1,75 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Module [Lazy]: deferred computations *) + + +(* + WARNING: some purple magic is going on here. Do not take this file + as an example of how to program in Objective Caml. +*) + + +(* We make use of two special tags provided by the runtime: + [lazy_tag] and [forward_tag]. + + A value of type ['a Lazy.t] can be one of three things: + 1. A block of size 1 with tag [lazy_tag]. Its field is a closure of + type [unit -> 'a] that computes the value. + 2. A block of size 1 with tag [forward_tag]. Its field is the value + of type ['a] that was computed. + 3. Anything else except a float. This has type ['a] and is the value + that was computed. + Exceptions are stored in format (1). + The GC will magically change things from (2) to (3) according to its + fancy. + + We cannot use representation (3) for a [float Lazy.t] because + [caml_make_array] assumes that only a [float] value can have tag + [Double_tag]. + + We have to use the built-in type constructor [lazy_t] to + let the compiler implement the special typing and compilation + rules for the [lazy] keyword. +*) + +type 'a t = 'a lazy_t;; + +exception Undefined = CamlinternalLazy.Undefined;; + +external make_forward : 'a -> 'a lazy_t = "caml_lazy_make_forward";; + +external force : 'a t -> 'a = "%lazy_force";; + +(* let force = force;; *) + +let force_val = CamlinternalLazy.force_val;; + +let lazy_from_fun (f : unit -> 'arg) = + let x = Obj.new_block Obj.lazy_tag 1 in + Obj.set_field x 0 (Obj.repr f); + (Obj.obj x : 'arg t) +;; + +let lazy_from_val (v : 'arg) = + let t = Obj.tag (Obj.repr v) in + if t = Obj.forward_tag || t = Obj.lazy_tag || t = Obj.double_tag then begin + make_forward v + end else begin + (Obj.magic v : 'arg t) + end +;; + +let lazy_is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;; diff --git a/ocaml-binary-annot/stdlib/lazy.mli b/ocaml-binary-annot/stdlib/lazy.mli new file mode 100644 index 0000000000..3b85717f14 --- /dev/null +++ b/ocaml-binary-annot/stdlib/lazy.mli @@ -0,0 +1,76 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Deferred computations. *) + +type 'a t = 'a lazy_t;; +(** A value of type ['a Lazy.t] is a deferred computation, called + a suspension, that has a result of type ['a]. The special + expression syntax [lazy (expr)] makes a suspension of the + computation of [expr], without computing [expr] itself yet. + "Forcing" the suspension will then compute [expr] and return its + result. + + Note: [lazy_t] is the built-in type constructor used by the compiler + for the [lazy] keyword. You should not use it directly. Always use + [Lazy.t] instead. + + Note: [Lazy.force] is not thread-safe. If you use this module in + a multi-threaded program, you will need to add some locks. + + Note: if the program is compiled with the [-rectypes] option, + ill-founded recursive definitions of the form [let rec x = lazy x] + or [let rec x = lazy(lazy(...(lazy x)))] are accepted by the type-checker + and lead, when forced, to ill-formed values that trigger infinite + loops in the garbage collector and other parts of the run-time system. + Without the [-rectypes] option, such ill-founded recursive definitions + are rejected by the type-checker. +*) + + +exception Undefined;; + +external force : 'a t -> 'a = "%lazy_force";; +(* val force : 'a t -> 'a ;; *) +(** [force x] forces the suspension [x] and returns its result. + If [x] has already been forced, [Lazy.force x] returns the + same value again without recomputing it. If it raised an exception, + the same exception is raised again. + Raise [Undefined] if the forcing of [x] tries to force [x] itself + recursively. +*) + +val force_val : 'a t -> 'a;; +(** [force_val x] forces the suspension [x] and returns its + result. If [x] has already been forced, [force_val x] + returns the same value again without recomputing it. + Raise [Undefined] if the forcing of [x] tries to force [x] itself + recursively. + If the computation of [x] raises an exception, it is unspecified + whether [force_val x] raises the same exception or [Undefined]. +*) + +val lazy_from_fun : (unit -> 'a) -> 'a t;; +(** [lazy_from_fun f] is the same as [lazy (f ())] but slightly more + efficient. *) + +val lazy_from_val : 'a -> 'a t;; +(** [lazy_from_val v] returns an already-forced suspension of [v] + This is for special purposes only and should not be confused with + [lazy (v)]. *) + +val lazy_is_val : 'a t -> bool;; +(** [lazy_is_val x] returns [true] if [x] has already been forced and + did not raise an exception. *) diff --git a/ocaml-binary-annot/stdlib/lexing.ml b/ocaml-binary-annot/stdlib/lexing.ml new file mode 100644 index 0000000000..9e01415265 --- /dev/null +++ b/ocaml-binary-annot/stdlib/lexing.ml @@ -0,0 +1,239 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The run-time library for lexers generated by camllex *) + +type position = { + pos_fname : string; + pos_lnum : int; + pos_bol : int; + pos_cnum : int; +} + +let dummy_pos = { + pos_fname = ""; + pos_lnum = 0; + pos_bol = 0; + pos_cnum = -1; +} + +type lexbuf = + { refill_buff : lexbuf -> unit; + mutable lex_buffer : string; + mutable lex_buffer_len : int; + mutable lex_abs_pos : int; + mutable lex_start_pos : int; + mutable lex_curr_pos : int; + mutable lex_last_pos : int; + mutable lex_last_action : int; + mutable lex_eof_reached : bool; + mutable lex_mem : int array; + mutable lex_start_p : position; + mutable lex_curr_p : position; + } + +type lex_tables = + { lex_base: string; + lex_backtrk: string; + lex_default: string; + lex_trans: string; + lex_check: string; + lex_base_code : string; + lex_backtrk_code : string; + lex_default_code : string; + lex_trans_code : string; + lex_check_code : string; + lex_code: string;} + +external c_engine : lex_tables -> int -> lexbuf -> int = "caml_lex_engine" +external c_new_engine : lex_tables -> int -> lexbuf -> int + = "caml_new_lex_engine" + +let engine tbl state buf = + let result = c_engine tbl state buf in + if result >= 0 then begin + buf.lex_start_p <- buf.lex_curr_p; + buf.lex_curr_p <- {buf.lex_curr_p + with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos}; + end; + result +;; + +let new_engine tbl state buf = + let result = c_new_engine tbl state buf in + if result >= 0 then begin + buf.lex_start_p <- buf.lex_curr_p; + buf.lex_curr_p <- {buf.lex_curr_p + with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos}; + end; + result +;; + +let lex_refill read_fun aux_buffer lexbuf = + let read = + read_fun aux_buffer (String.length aux_buffer) in + let n = + if read > 0 + then read + else (lexbuf.lex_eof_reached <- true; 0) in + (* Current state of the buffer: + <-------|---------------------|-----------> + | junk | valid data | junk | + ^ ^ ^ ^ + 0 start_pos buffer_end String.length buffer + *) + if lexbuf.lex_buffer_len + n > String.length lexbuf.lex_buffer then begin + (* There is not enough space at the end of the buffer *) + if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n + <= String.length lexbuf.lex_buffer + then begin + (* But there is enough space if we reclaim the junk at the beginning + of the buffer *) + String.blit lexbuf.lex_buffer lexbuf.lex_start_pos + lexbuf.lex_buffer 0 + (lexbuf.lex_buffer_len - lexbuf.lex_start_pos) + end else begin + (* We must grow the buffer. Doubling its size will provide enough + space since n <= String.length aux_buffer <= String.length buffer. + Watch out for string length overflow, though. *) + let newlen = + min (2 * String.length lexbuf.lex_buffer) Sys.max_string_length in + if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n > newlen + then failwith "Lexing.lex_refill: cannot grow buffer"; + let newbuf = String.create newlen in + (* Copy the valid data to the beginning of the new buffer *) + String.blit lexbuf.lex_buffer lexbuf.lex_start_pos + newbuf 0 + (lexbuf.lex_buffer_len - lexbuf.lex_start_pos); + lexbuf.lex_buffer <- newbuf + end; + (* Reallocation or not, we have shifted the data left by + start_pos characters; update the positions *) + let s = lexbuf.lex_start_pos in + lexbuf.lex_abs_pos <- lexbuf.lex_abs_pos + s; + lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - s; + lexbuf.lex_start_pos <- 0; + lexbuf.lex_last_pos <- lexbuf.lex_last_pos - s; + lexbuf.lex_buffer_len <- lexbuf.lex_buffer_len - s ; + let t = lexbuf.lex_mem in + for i = 0 to Array.length t-1 do + let v = t.(i) in + if v >= 0 then + t.(i) <- v-s + done + end; + (* There is now enough space at the end of the buffer *) + String.blit aux_buffer 0 + lexbuf.lex_buffer lexbuf.lex_buffer_len + n; + lexbuf.lex_buffer_len <- lexbuf.lex_buffer_len + n + +let zero_pos = { + pos_fname = ""; + pos_lnum = 1; + pos_bol = 0; + pos_cnum = 0; +};; + +let from_function f = + { refill_buff = lex_refill f (String.create 512); + lex_buffer = String.create 1024; + lex_buffer_len = 0; + lex_abs_pos = 0; + lex_start_pos = 0; + lex_curr_pos = 0; + lex_last_pos = 0; + lex_last_action = 0; + lex_mem = [||]; + lex_eof_reached = false; + lex_start_p = zero_pos; + lex_curr_p = zero_pos; + } + +let from_channel ic = + from_function (fun buf n -> input ic buf 0 n) + +let from_string s = + { refill_buff = (fun lexbuf -> lexbuf.lex_eof_reached <- true); + lex_buffer = s ^ ""; + lex_buffer_len = String.length s; + lex_abs_pos = 0; + lex_start_pos = 0; + lex_curr_pos = 0; + lex_last_pos = 0; + lex_last_action = 0; + lex_mem = [||]; + lex_eof_reached = true; + lex_start_p = zero_pos; + lex_curr_p = zero_pos; + } + +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 sub_lexeme lexbuf i1 i2 = + let len = i2-i1 in + let s = String.create len in + String.unsafe_blit lexbuf.lex_buffer i1 s 0 len; + s + +let sub_lexeme_opt lexbuf i1 i2 = + if i1 >= 0 then begin + let len = i2-i1 in + let s = String.create len in + String.unsafe_blit lexbuf.lex_buffer i1 s 0 len; + Some s + end else begin + None + end + +let sub_lexeme_char lexbuf i = lexbuf.lex_buffer.[i] + +let sub_lexeme_char_opt lexbuf i = + if i >= 0 then + Some lexbuf.lex_buffer.[i] + else + None + + +let lexeme_char lexbuf i = + String.get lexbuf.lex_buffer (lexbuf.lex_start_pos + i) + +let lexeme_start lexbuf = lexbuf.lex_start_p.pos_cnum;; +let lexeme_end lexbuf = lexbuf.lex_curr_p.pos_cnum;; + +let lexeme_start_p lexbuf = lexbuf.lex_start_p;; +let lexeme_end_p lexbuf = lexbuf.lex_curr_p;; + +let new_line lexbuf = + let lcp = lexbuf.lex_curr_p in + lexbuf.lex_curr_p <- { lcp with + pos_lnum = lcp.pos_lnum + 1; + pos_bol = lcp.pos_cnum; + } +;; + + +(* Discard data left in lexer buffer. *) + +let flush_input lb = + lb.lex_curr_pos <- 0; + lb.lex_abs_pos <- 0; + lb.lex_curr_p <- {lb.lex_curr_p with pos_cnum = 0}; + lb.lex_buffer_len <- 0; +;; diff --git a/ocaml-binary-annot/stdlib/lexing.mli b/ocaml-binary-annot/stdlib/lexing.mli new file mode 100644 index 0000000000..2edb6c5df2 --- /dev/null +++ b/ocaml-binary-annot/stdlib/lexing.mli @@ -0,0 +1,173 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The run-time library for lexers generated by [ocamllex]. *) + +(** {6 Positions} *) + +type position = { + pos_fname : string; + pos_lnum : int; + pos_bol : int; + pos_cnum : int; +} +(** A value of type [position] describes a point in a source file. + [pos_fname] is the file name; [pos_lnum] is the line number; + [pos_bol] is the offset of the beginning of the line (number + of characters between the beginning of the file and the beginning + of the line); [pos_cnum] is the offset of the position (number of + characters between the beginning of the file and the position). + + See the documentation of type [lexbuf] for information about + how the lexing engine will manage positions. + *) + +val dummy_pos : position;; +(** A value of type [position], guaranteed to be different from any + valid position. + *) + + +(** {6 Lexer buffers} *) + + +type lexbuf = + { refill_buff : lexbuf -> unit; + mutable lex_buffer : string; + mutable lex_buffer_len : int; + mutable lex_abs_pos : int; + mutable lex_start_pos : int; + mutable lex_curr_pos : int; + mutable lex_last_pos : int; + mutable lex_last_action : int; + mutable lex_eof_reached : bool; + mutable lex_mem : int array; + mutable lex_start_p : position; + mutable lex_curr_p : position; + } +(** 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. + + At each token, the lexing engine will copy [lex_curr_p] to + [lex_start_p], then change the [pos_cnum] field + of [lex_curr_p] by updating it with the number of characters read + since the start of the [lexbuf]. The other fields are left + unchanged by the lexing engine. In order to keep them + accurate, they must be initialised before the first use of the + lexbuf, and updated by the relevant lexer actions (i.e. at each + end of line -- see also [new_line]). + *) + +val from_channel : in_channel -> lexbuf +(** Create a lexer buffer on the given input channel. + [Lexing.from_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. *) + + +(** {6 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 + [ocamllex], is bound to the lexer buffer passed to the parsing + function. *) + +val lexeme : lexbuf -> string +(** [Lexing.lexeme lexbuf] returns the string matched by + the regular expression. *) + +val lexeme_char : lexbuf -> int -> char +(** [Lexing.lexeme_char lexbuf i] returns character number [i] in + the matched string. *) + +val lexeme_start : lexbuf -> int +(** [Lexing.lexeme_start lexbuf] returns the offset in the + input stream of the first character of the matched string. + The first character of the stream has offset 0. *) + +val lexeme_end : lexbuf -> int +(** [Lexing.lexeme_end lexbuf] returns the offset in the input stream + of the character following the last character of the matched + string. The first character of the stream has offset 0. *) + +val lexeme_start_p : lexbuf -> position +(** Like [lexeme_start], but return a complete [position] instead + of an offset. *) + +val lexeme_end_p : lexbuf -> position +(** Like [lexeme_end], but return a complete [position] instead + of an offset. *) + +val new_line : lexbuf -> unit +(** Update the [lex_curr_p] field of the lexbuf to reflect the start + of a new line. You can call this function in the semantic action + of the rule that matches the end-of-line character. + @since 3.11.0 +*) + +(** {6 Miscellaneous functions} *) + +val flush_input : lexbuf -> unit +(** Discard the contents of the buffer and reset the current + position to 0. The next use of the lexbuf will trigger a + refill. *) + +(**/**) + +(** {6 } *) + +(** The following definitions are used by the generated scanners only. + They are not intended to be used by user programs. *) + +val sub_lexeme : lexbuf -> int -> int -> string +val sub_lexeme_opt : lexbuf -> int -> int -> string option +val sub_lexeme_char : lexbuf -> int -> char +val sub_lexeme_char_opt : lexbuf -> int -> char option + +type lex_tables = + { lex_base : string; + lex_backtrk : string; + lex_default : string; + lex_trans : string; + lex_check : string; + lex_base_code : string; + lex_backtrk_code : string; + lex_default_code : string; + lex_trans_code : string; + lex_check_code : string; + lex_code: string;} + +val engine : lex_tables -> int -> lexbuf -> int +val new_engine : lex_tables -> int -> lexbuf -> int diff --git a/ocaml-binary-annot/stdlib/list.ml b/ocaml-binary-annot/stdlib/list.ml new file mode 100644 index 0000000000..c6b1618847 --- /dev/null +++ b/ocaml-binary-annot/stdlib/list.ml @@ -0,0 +1,328 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* List operations *) + +let rec length_aux len = function + [] -> len + | a::l -> length_aux (len + 1) l + +let length l = length_aux 0 l + +let hd = function + [] -> failwith "hd" + | a::l -> a + +let tl = function + [] -> failwith "tl" + | a::l -> l + +let nth l n = + if n < 0 then invalid_arg "List.nth" else + let rec nth_aux l n = + match l with + | [] -> failwith "nth" + | a::l -> if n = 0 then a else nth_aux l (n-1) + in nth_aux l n + +let append = (@) + +let rec rev_append l1 l2 = + match l1 with + [] -> l2 + | a :: l -> rev_append l (a :: l2) + +let rev l = rev_append l [] + +let rec flatten = function + [] -> [] + | l::r -> l @ flatten r + +let concat = flatten + +let rec map f = function + [] -> [] + | a::l -> let r = f a in r :: map f l + +let rec mapi i f = function + [] -> [] + | a::l -> let r = f i a in r :: mapi (i + 1) f l + +let mapi f l = mapi 0 f l + +let rev_map f l = + let rec rmap_f accu = function + | [] -> accu + | a::l -> rmap_f (f a :: accu) l + in + rmap_f [] l +;; + +let rec iter f = function + [] -> () + | a::l -> f a; iter f l + +let rec iteri i f = function + [] -> () + | a::l -> f i a; iteri (i + 1) f l + +let iteri f l = iteri 0 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) -> let r = f a1 a2 in r :: map2 f l1 l2 + | (_, _) -> invalid_arg "List.map2" + +let rev_map2 f l1 l2 = + let rec rmap2_f accu l1 l2 = + match (l1, l2) with + | ([], []) -> accu + | (a1::l1, a2::l2) -> rmap2_f (f a1 a2 :: accu) l1 l2 + | (_, _) -> invalid_arg "List.rev_map2" + in + rmap2_f [] l1 l2 +;; + +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 || exists p l + +let rec for_all2 p l1 l2 = + match (l1, l2) with + ([], []) -> true + | (a1::l1, a2::l2) -> p a1 a2 && for_all2 p l1 l2 + | (_, _) -> invalid_arg "List.for_all2" + +let rec exists2 p l1 l2 = + match (l1, l2) with + ([], []) -> false + | (a1::l1, a2::l2) -> p a1 a2 || exists2 p l1 l2 + | (_, _) -> invalid_arg "List.exists2" + +let rec mem x = function + [] -> false + | a::l -> compare a x = 0 || mem x l + +let rec memq x = function + [] -> false + | a::l -> a == x || memq x l + +let rec assoc x = function + [] -> raise Not_found + | (a,b)::l -> if compare a x = 0 then b else 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 mem_assoc x = function + | [] -> false + | (a, b) :: l -> compare a x = 0 || mem_assoc x l + +let rec mem_assq x = function + | [] -> false + | (a, b) :: l -> a == x || mem_assq x l + +let rec remove_assoc x = function + | [] -> [] + | (a, b as pair) :: l -> + if compare a x = 0 then l else pair :: remove_assoc x l + +let rec remove_assq x = function + | [] -> [] + | (a, b as pair) :: l -> if a == x then l else pair :: remove_assq x l + +let rec find p = function + | [] -> raise Not_found + | x :: l -> if p x then x else find p l + +let find_all p = + let rec find accu = function + | [] -> rev accu + | x :: l -> if p x then find (x :: accu) l else find accu l in + find [] + +let filter = find_all + +let partition p l = + let rec part yes no = function + | [] -> (rev yes, rev no) + | x :: l -> if p x then part (x :: yes) no l else part yes (x :: no) l in + part [] [] l + +let rec split = function + [] -> ([], []) + | (x,y)::l -> + let (rx, ry) = split l in (x::rx, y::ry) + +let rec combine l1 l2 = + match (l1, l2) with + ([], []) -> [] + | (a1::l1, a2::l2) -> (a1, a2) :: combine l1 l2 + | (_, _) -> invalid_arg "List.combine" + +(** sorting *) + +let rec merge cmp l1 l2 = + match l1, l2 with + | [], l2 -> l2 + | l1, [] -> l1 + | h1 :: t1, h2 :: t2 -> + if cmp h1 h2 <= 0 + then h1 :: merge cmp t1 l2 + else h2 :: merge cmp l1 t2 +;; + +let rec chop k l = + if k = 0 then l else begin + match l with + | x::t -> chop (k-1) t + | _ -> assert false + end +;; + +let stable_sort cmp l = + let rec rev_merge l1 l2 accu = + match l1, l2 with + | [], l2 -> rev_append l2 accu + | l1, [] -> rev_append l1 accu + | h1::t1, h2::t2 -> + if cmp h1 h2 <= 0 + then rev_merge t1 l2 (h1::accu) + else rev_merge l1 t2 (h2::accu) + in + let rec rev_merge_rev l1 l2 accu = + match l1, l2 with + | [], l2 -> rev_append l2 accu + | l1, [] -> rev_append l1 accu + | h1::t1, h2::t2 -> + if cmp h1 h2 > 0 + then rev_merge_rev t1 l2 (h1::accu) + else rev_merge_rev l1 t2 (h2::accu) + in + let rec sort n l = + match n, l with + | 2, x1 :: x2 :: _ -> + if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1] + | 3, x1 :: x2 :: x3 :: _ -> + if cmp x1 x2 <= 0 then begin + if cmp x2 x3 <= 0 then [x1; x2; x3] + else if cmp x1 x3 <= 0 then [x1; x3; x2] + else [x3; x1; x2] + end else begin + if cmp x1 x3 <= 0 then [x2; x1; x3] + else if cmp x2 x3 <= 0 then [x2; x3; x1] + else [x3; x2; x1] + end + | n, l -> + let n1 = n asr 1 in + let n2 = n - n1 in + let l2 = chop n1 l in + let s1 = rev_sort n1 l in + let s2 = rev_sort n2 l2 in + rev_merge_rev s1 s2 [] + and rev_sort n l = + match n, l with + | 2, x1 :: x2 :: _ -> + if cmp x1 x2 > 0 then [x1; x2] else [x2; x1] + | 3, x1 :: x2 :: x3 :: _ -> + if cmp x1 x2 > 0 then begin + if cmp x2 x3 > 0 then [x1; x2; x3] + else if cmp x1 x3 > 0 then [x1; x3; x2] + else [x3; x1; x2] + end else begin + if cmp x1 x3 > 0 then [x2; x1; x3] + else if cmp x2 x3 > 0 then [x2; x3; x1] + else [x3; x2; x1] + end + | n, l -> + let n1 = n asr 1 in + let n2 = n - n1 in + let l2 = chop n1 l in + let s1 = sort n1 l in + let s2 = sort n2 l2 in + rev_merge s1 s2 [] + in + let len = length l in + if len < 2 then l else sort len l +;; + +let sort = stable_sort;; +let fast_sort = stable_sort;; + +(* Note: on a list of length between about 100000 (depending on the minor + heap size and the type of the list) and Sys.max_array_size, it is + actually faster to use the following, but it might also use more memory + because the argument list cannot be deallocated incrementally. + + Also, there seems to be a bug in this code or in the + implementation of obj_truncate. + +external obj_truncate : 'a array -> int -> unit = "caml_obj_truncate" + +let array_to_list_in_place a = + let l = Array.length a in + let rec loop accu n p = + if p <= 0 then accu else begin + if p = n then begin + obj_truncate a p; + loop (a.(p-1) :: accu) (n-1000) (p-1) + end else begin + loop (a.(p-1) :: accu) n (p-1) + end + end + in + loop [] (l-1000) l +;; + +let stable_sort cmp l = + let a = Array.of_list l in + Array.stable_sort cmp a; + array_to_list_in_place a +;; +*) diff --git a/ocaml-binary-annot/stdlib/list.mli b/ocaml-binary-annot/stdlib/list.mli new file mode 100644 index 0000000000..547fb13287 --- /dev/null +++ b/ocaml-binary-annot/stdlib/list.mli @@ -0,0 +1,291 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** List operations. + + Some functions are flagged as not tail-recursive. A tail-recursive + function uses constant stack space, while a non-tail-recursive function + uses stack space proportional to the length of its list argument, which + can be a problem with very long lists. When the function takes several + list arguments, an approximate formula giving stack usage (in some + unspecified constant unit) is shown in parentheses. + + The above considerations can usually be ignored if your lists are not + longer than about 10000 elements. +*) + +val length : 'a list -> int +(** Return the length (number of elements) of the given list. *) + +val hd : 'a list -> 'a +(** Return the first element of the given list. Raise + [Failure "hd"] if the list is empty. *) + +val tl : 'a list -> 'a list +(** Return the given list without its first element. Raise + [Failure "tl"] if the list is empty. *) + +val nth : 'a list -> int -> 'a +(** Return the [n]-th element of the given list. + The first element (head of the list) is at position 0. + Raise [Failure "nth"] if the list is too short. + Raise [Invalid_argument "List.nth"] if [n] is negative. *) + +val rev : 'a list -> 'a list +(** List reversal. *) + +val append : 'a list -> 'a list -> 'a list +(** Catenate two lists. Same function as the infix operator [@]. + Not tail-recursive (length of the first argument). The [@] + operator is not tail-recursive either. *) + +val rev_append : 'a list -> 'a list -> 'a list +(** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. + This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is + tail-recursive and more efficient. *) + +val concat : 'a list list -> 'a list +(** Concatenate a list of lists. The elements of the argument are all + concatenated together (in the same order) to give the result. + Not tail-recursive + (length of the argument + length of the longest sub-list). *) + +val flatten : 'a list list -> 'a list +(** Same as [concat]. Not tail-recursive + (length of the argument + length of the longest sub-list). *) + + +(** {6 Iterators} *) + + +val iter : ('a -> unit) -> 'a list -> unit +(** [List.iter f [a1; ...; an]] applies function [f] in turn to + [a1; ...; an]. It is equivalent to + [begin f a1; f a2; ...; f an; () end]. *) + +val iteri : (int -> 'a -> unit) -> 'a list -> unit +(** Same as {!List.iter}, but the + function is applied to the index of the element as first argument (counting from 0), + and the element itself as second argument. + @since 3.13.0 +*) + +val map : ('a -> 'b) -> 'a list -> 'b list +(** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], + and builds the list [[f a1; ...; f an]] + with the results returned by [f]. Not tail-recursive. *) + +val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list +(** Same as {!List.map}, but the + function is applied to the index of the element as first argument (counting from 0), + and the element itself as second argument. + @since 3.13.0 +*) + +val rev_map : ('a -> 'b) -> 'a list -> 'b list +(** [List.rev_map f l] gives the same result as + {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and + more efficient. *) + +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a +(** [List.fold_left f a [b1; ...; bn]] is + [f (... (f (f a b1) b2) ...) bn]. *) + +val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b +(** [List.fold_right f [a1; ...; an] b] is + [f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *) + + +(** {6 Iterators on two lists} *) + + +val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit +(** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn + [f a1 b1; ...; f an bn]. + Raise [Invalid_argument] if the two lists have + different lengths. *) + +val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list +(** [List.map2 f [a1; ...; an] [b1; ...; bn]] is + [[f a1 b1; ...; f an bn]]. + Raise [Invalid_argument] if the two lists have + different lengths. Not tail-recursive. *) + +val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list +(** [List.rev_map2 f l1 l2] gives the same result as + {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and + more efficient. *) + +val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a +(** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is + [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. + Raise [Invalid_argument] if the two lists have + different lengths. *) + +val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c +(** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is + [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. + Raise [Invalid_argument] if the two lists have + different lengths. Not tail-recursive. *) + + +(** {6 List scanning} *) + + +val for_all : ('a -> bool) -> 'a list -> bool +(** [for_all p [a1; ...; an]] checks if all elements of the list + satisfy the predicate [p]. That is, it returns + [(p a1) && (p a2) && ... && (p an)]. *) + +val exists : ('a -> bool) -> 'a list -> bool +(** [exists p [a1; ...; an]] checks if at least one element of + the list satisfies the predicate [p]. That is, it returns + [(p a1) || (p a2) || ... || (p an)]. *) + +val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool +(** Same as {!List.for_all}, but for a two-argument predicate. + Raise [Invalid_argument] if the two lists have + different lengths. *) + +val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool +(** Same as {!List.exists}, but for a two-argument predicate. + Raise [Invalid_argument] if the two lists have + different lengths. *) + +val mem : 'a -> 'a list -> bool +(** [mem a l] is true if and only if [a] is equal + to an element of [l]. *) + +val memq : 'a -> 'a list -> bool +(** Same as {!List.mem}, but uses physical equality instead of structural + equality to compare list elements. *) + + +(** {6 List searching} *) + + +val find : ('a -> bool) -> 'a list -> 'a +(** [find p l] returns the first element of the list [l] + that satisfies the predicate [p]. + Raise [Not_found] if there is no value that satisfies [p] in the + list [l]. *) + +val filter : ('a -> bool) -> 'a list -> 'a list +(** [filter p l] returns all the elements of the list [l] + that satisfy the predicate [p]. The order of the elements + in the input list is preserved. *) + +val find_all : ('a -> bool) -> 'a list -> 'a list +(** [find_all] is another name for {!List.filter}. *) + +val partition : ('a -> bool) -> 'a list -> 'a list * 'a list +(** [partition p l] returns a pair of lists [(l1, l2)], where + [l1] is the list of all the elements of [l] that + satisfy the predicate [p], and [l2] is the list of all the + elements of [l] that do not satisfy [p]. + The order of the elements in the input list is preserved. *) + + +(** {6 Association lists} *) + + +val assoc : 'a -> ('a * 'b) list -> 'b +(** [assoc a l] returns the value associated with key [a] in the list of + pairs [l]. That is, + [assoc a [ ...; (a,b); ...] = b] + if [(a,b)] is the leftmost binding of [a] in list [l]. + Raise [Not_found] if there is no value associated with [a] in the + list [l]. *) + +val assq : 'a -> ('a * 'b) list -> 'b +(** Same as {!List.assoc}, but uses physical equality instead of structural + equality to compare keys. *) + +val mem_assoc : 'a -> ('a * 'b) list -> bool +(** Same as {!List.assoc}, but simply return true if a binding exists, + and false if no bindings exist for the given key. *) + +val mem_assq : 'a -> ('a * 'b) list -> bool +(** Same as {!List.mem_assoc}, but uses physical equality instead of + structural equality to compare keys. *) + +val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list +(** [remove_assoc a l] returns the list of + pairs [l] without the first pair with key [a], if any. + Not tail-recursive. *) + +val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list +(** Same as {!List.remove_assoc}, but uses physical equality instead + of structural equality to compare keys. Not tail-recursive. *) + + +(** {6 Lists of pairs} *) + + +val split : ('a * 'b) list -> 'a list * 'b list +(** Transform a list of pairs into a pair of lists: + [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. + Not tail-recursive. +*) + +val combine : 'a list -> 'b list -> ('a * 'b) list +(** Transform a pair of lists into a list of pairs: + [combine [a1; ...; an] [b1; ...; bn]] is + [[(a1,b1); ...; (an,bn)]]. + Raise [Invalid_argument] if the two lists + have different lengths. Not tail-recursive. *) + + +(** {6 Sorting} *) + + +val sort : ('a -> 'a -> int) -> 'a list -> 'a list +(** Sort a list in increasing order according to a comparison + function. The comparison function must return 0 if its arguments + compare as equal, a positive integer if the first is greater, + and a negative integer if the first is smaller (see Array.sort for + a complete specification). For example, + {!Pervasives.compare} is a suitable comparison function. + The resulting list is sorted in increasing order. + [List.sort] is guaranteed to run in constant heap space + (in addition to the size of the result list) and logarithmic + stack space. + + The current implementation uses Merge Sort. It runs in constant + heap space and logarithmic stack space. +*) + +val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list +(** Same as {!List.sort}, but the sorting algorithm is guaranteed to + be stable (i.e. elements that compare equal are kept in their + original order) . + + The current implementation uses Merge Sort. It runs in constant + heap space and logarithmic stack space. +*) + +val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list +(** Same as {!List.sort} or {!List.stable_sort}, whichever is faster + on typical input. *) + +val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list +(** Merge two lists: + Assuming that [l1] and [l2] are sorted according to the + comparison function [cmp], [merge cmp l1 l2] will return a + sorted list containting all the elements of [l1] and [l2]. + If several elements compare equal, the elements of [l1] will be + before the elements of [l2]. + Not tail-recursive (sum of the lengths of the arguments). +*) diff --git a/ocaml-binary-annot/stdlib/listLabels.ml b/ocaml-binary-annot/stdlib/listLabels.ml new file mode 100644 index 0000000000..be7bddea36 --- /dev/null +++ b/ocaml-binary-annot/stdlib/listLabels.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Module [ListLabels]: labelled List module *) + +include List diff --git a/ocaml-binary-annot/stdlib/listLabels.mli b/ocaml-binary-annot/stdlib/listLabels.mli new file mode 100644 index 0000000000..94c875a6cd --- /dev/null +++ b/ocaml-binary-annot/stdlib/listLabels.mli @@ -0,0 +1,293 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** List operations. + + Some functions are flagged as not tail-recursive. A tail-recursive + function uses constant stack space, while a non-tail-recursive function + uses stack space proportional to the length of its list argument, which + can be a problem with very long lists. When the function takes several + list arguments, an approximate formula giving stack usage (in some + unspecified constant unit) is shown in parentheses. + + The above considerations can usually be ignored if your lists are not + longer than about 10000 elements. +*) + +val length : 'a list -> int +(** Return the length (number of elements) of the given list. *) + +val hd : 'a list -> 'a +(** Return the first element of the given list. Raise + [Failure "hd"] if the list is empty. *) + +val tl : 'a list -> 'a list +(** Return the given list without its first element. Raise + [Failure "tl"] if the list is empty. *) + +val nth : 'a list -> int -> 'a +(** Return the [n]-th element of the given list. + The first element (head of the list) is at position 0. + Raise [Failure "nth"] if the list is too short. + Raise [Invalid_argument "List.nth"] if [n] is negative. *) + +val rev : 'a list -> 'a list +(** List reversal. *) + +val append : 'a list -> 'a list -> 'a list +(** Catenate two lists. Same function as the infix operator [@]. + Not tail-recursive (length of the first argument). The [@] + operator is not tail-recursive either. *) + +val rev_append : 'a list -> 'a list -> 'a list +(** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. + This is equivalent to {!ListLabels.rev}[ l1 @ l2], but [rev_append] is + tail-recursive and more efficient. *) + +val concat : 'a list list -> 'a list +(** Concatenate a list of lists. The elements of the argument are all + concatenated together (in the same order) to give the result. + Not tail-recursive + (length of the argument + length of the longest sub-list). *) + +val flatten : 'a list list -> 'a list +(** Same as [concat]. Not tail-recursive + (length of the argument + length of the longest sub-list). *) + + +(** {6 Iterators} *) + + +val iter : f:('a -> unit) -> 'a list -> unit +(** [List.iter f [a1; ...; an]] applies function [f] in turn to + [a1; ...; an]. It is equivalent to + [begin f a1; f a2; ...; f an; () end]. *) + +val iteri : f:(int -> 'a -> unit) -> 'a list -> unit +(** Same as {!List.iter}, but the + function is applied to the index of the element as first argument (counting from 0), + and the element itself as second argument. + @since 3.13.0 +*) + +val map : f:('a -> 'b) -> 'a list -> 'b list +(** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], + and builds the list [[f a1; ...; f an]] + with the results returned by [f]. Not tail-recursive. *) + +val mapi : f:(int -> 'a -> 'b) -> 'a list -> 'b list +(** Same as {!List.map}, but the + function is applied to the index of the element as first argument (counting from 0), + and the element itself as second argument. + @since 3.13.0 +*) + +val rev_map : f:('a -> 'b) -> 'a list -> 'b list +(** [List.rev_map f l] gives the same result as + {!ListLabels.rev}[ (]{!ListLabels.map}[ f l)], but is tail-recursive and + more efficient. *) + +val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a +(** [List.fold_left f a [b1; ...; bn]] is + [f (... (f (f a b1) b2) ...) bn]. *) + +val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b +(** [List.fold_right f [a1; ...; an] b] is + [f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *) + + +(** {6 Iterators on two lists} *) + + +val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit +(** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn + [f a1 b1; ...; f an bn]. + Raise [Invalid_argument] if the two lists have + different lengths. *) + +val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list +(** [List.map2 f [a1; ...; an] [b1; ...; bn]] is + [[f a1 b1; ...; f an bn]]. + Raise [Invalid_argument] if the two lists have + different lengths. Not tail-recursive. *) + +val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list +(** [List.rev_map2 f l1 l2] gives the same result as + {!ListLabels.rev}[ (]{!ListLabels.map2}[ f l1 l2)], but is tail-recursive and + more efficient. *) + +val fold_left2 : + f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a +(** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is + [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. + Raise [Invalid_argument] if the two lists have + different lengths. *) + +val fold_right2 : + f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c +(** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is + [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. + Raise [Invalid_argument] if the two lists have + different lengths. Not tail-recursive. *) + + +(** {6 List scanning} *) + + +val for_all : f:('a -> bool) -> 'a list -> bool +(** [for_all p [a1; ...; an]] checks if all elements of the list + satisfy the predicate [p]. That is, it returns + [(p a1) && (p a2) && ... && (p an)]. *) + +val exists : f:('a -> bool) -> 'a list -> bool +(** [exists p [a1; ...; an]] checks if at least one element of + the list satisfies the predicate [p]. That is, it returns + [(p a1) || (p a2) || ... || (p an)]. *) + +val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool +(** Same as {!ListLabels.for_all}, but for a two-argument predicate. + Raise [Invalid_argument] if the two lists have + different lengths. *) + +val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool +(** Same as {!ListLabels.exists}, but for a two-argument predicate. + Raise [Invalid_argument] if the two lists have + different lengths. *) + +val mem : 'a -> set:'a list -> bool +(** [mem a l] is true if and only if [a] is equal + to an element of [l]. *) + +val memq : 'a -> set:'a list -> bool +(** Same as {!ListLabels.mem}, but uses physical equality instead of structural + equality to compare list elements. *) + + +(** {6 List searching} *) + + +val find : f:('a -> bool) -> 'a list -> 'a +(** [find p l] returns the first element of the list [l] + that satisfies the predicate [p]. + Raise [Not_found] if there is no value that satisfies [p] in the + list [l]. *) + +val filter : f:('a -> bool) -> 'a list -> 'a list +(** [filter p l] returns all the elements of the list [l] + that satisfy the predicate [p]. The order of the elements + in the input list is preserved. *) + +val find_all : f:('a -> bool) -> 'a list -> 'a list +(** [find_all] is another name for {!ListLabels.filter}. *) + +val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list +(** [partition p l] returns a pair of lists [(l1, l2)], where + [l1] is the list of all the elements of [l] that + satisfy the predicate [p], and [l2] is the list of all the + elements of [l] that do not satisfy [p]. + The order of the elements in the input list is preserved. *) + + +(** {6 Association lists} *) + + +val assoc : 'a -> ('a * 'b) list -> 'b +(** [assoc a l] returns the value associated with key [a] in the list of + pairs [l]. That is, + [assoc a [ ...; (a,b); ...] = b] + if [(a,b)] is the leftmost binding of [a] in list [l]. + Raise [Not_found] if there is no value associated with [a] in the + list [l]. *) + +val assq : 'a -> ('a * 'b) list -> 'b +(** Same as {!ListLabels.assoc}, but uses physical equality instead of + structural equality to compare keys. *) + +val mem_assoc : 'a -> map:('a * 'b) list -> bool +(** Same as {!ListLabels.assoc}, but simply return true if a binding exists, + and false if no bindings exist for the given key. *) + +val mem_assq : 'a -> map:('a * 'b) list -> bool +(** Same as {!ListLabels.mem_assoc}, but uses physical equality instead of + structural equality to compare keys. *) + +val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list +(** [remove_assoc a l] returns the list of + pairs [l] without the first pair with key [a], if any. + Not tail-recursive. *) + +val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list +(** Same as {!ListLabels.remove_assoc}, but uses physical equality instead + of structural equality to compare keys. Not tail-recursive. *) + + +(** {6 Lists of pairs} *) + + +val split : ('a * 'b) list -> 'a list * 'b list +(** Transform a list of pairs into a pair of lists: + [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. + Not tail-recursive. +*) + +val combine : 'a list -> 'b list -> ('a * 'b) list +(** Transform a pair of lists into a list of pairs: + [combine [a1; ...; an] [b1; ...; bn]] is + [[(a1,b1); ...; (an,bn)]]. + Raise [Invalid_argument] if the two lists + have different lengths. Not tail-recursive. *) + + +(** {6 Sorting} *) + + +val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list +(** Sort a list in increasing order according to a comparison + function. The comparison function must return 0 if its arguments + compare as equal, a positive integer if the first is greater, + and a negative integer if the first is smaller (see Array.sort for + a complete specification). For example, + {!Pervasives.compare} is a suitable comparison function. + The resulting list is sorted in increasing order. + [List.sort] is guaranteed to run in constant heap space + (in addition to the size of the result list) and logarithmic + stack space. + + The current implementation uses Merge Sort. It runs in constant + heap space and logarithmic stack space. +*) + +val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list +(** Same as {!ListLabels.sort}, but the sorting algorithm is guaranteed to + be stable (i.e. elements that compare equal are kept in their + original order) . + + The current implementation uses Merge Sort. It runs in constant + heap space and logarithmic stack space. +*) + +val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list +(** Same as {!List.sort} or {!List.stable_sort}, whichever is faster + on typical input. *) + +val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list +(** Merge two lists: + Assuming that [l1] and [l2] are sorted according to the + comparison function [cmp], [merge cmp l1 l2] will return a + sorted list containting all the elements of [l1] and [l2]. + If several elements compare equal, the elements of [l1] will be + before the elements of [l2]. + Not tail-recursive (sum of the lengths of the arguments). +*) diff --git a/ocaml-binary-annot/stdlib/map.ml b/ocaml-binary-annot/stdlib/map.ml new file mode 100644 index 0000000000..3d9597aa0e --- /dev/null +++ b/ocaml-binary-annot/stdlib/map.ml @@ -0,0 +1,314 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +module type OrderedType = + sig + type t + val compare: t -> t -> int + end + +module type S = + sig + type key + type +'a t + val empty: 'a t + val is_empty: 'a t -> bool + val mem: key -> 'a t -> bool + val add: key -> 'a -> 'a t -> 'a t + val singleton: key -> 'a -> 'a t + val remove: key -> 'a t -> 'a t + val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val iter: (key -> 'a -> unit) -> 'a t -> unit + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val for_all: (key -> 'a -> bool) -> 'a t -> bool + val exists: (key -> 'a -> bool) -> 'a t -> bool + val filter: (key -> 'a -> bool) -> 'a t -> 'a t + val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + val cardinal: 'a t -> int + val bindings: 'a t -> (key * 'a) list + val min_binding: 'a t -> (key * 'a) + val max_binding: 'a t -> (key * 'a) + val choose: 'a t -> (key * 'a) + val split: key -> 'a t -> 'a t * 'a option * 'a t + val find: key -> 'a t -> 'a + val map: ('a -> 'b) -> 'a t -> 'b t + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t + end + +module Make(Ord: OrderedType) = struct + + type key = Ord.t + + type 'a t = + Empty + | Node of 'a t * key * 'a * 'a t * int + + let height = function + Empty -> 0 + | Node(_,_,_,_,h) -> h + + let create l x d r = + let hl = height l and hr = height r in + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + + let singleton x d = Node(Empty, x, d, Empty, 1) + + let bal l x d r = + let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in + if hl > hr + 2 then begin + match l with + Empty -> invalid_arg "Map.bal" + | Node(ll, lv, ld, lr, _) -> + if height ll >= height lr then + create ll lv ld (create lr x d r) + else begin + match lr with + Empty -> invalid_arg "Map.bal" + | Node(lrl, lrv, lrd, lrr, _)-> + create (create ll lv ld lrl) lrv lrd (create lrr x d r) + end + end else if hr > hl + 2 then begin + match r with + Empty -> invalid_arg "Map.bal" + | Node(rl, rv, rd, rr, _) -> + if height rr >= height rl then + create (create l x d rl) rv rd rr + else begin + match rl with + Empty -> invalid_arg "Map.bal" + | Node(rll, rlv, rld, rlr, _) -> + create (create l x d rll) rlv rld (create rlr rv rd rr) + end + end else + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + + let empty = Empty + + let is_empty = function Empty -> true | _ -> false + + let rec add x data = function + Empty -> + Node(Empty, x, data, Empty, 1) + | Node(l, v, d, r, h) -> + let c = Ord.compare x v in + if c = 0 then + Node(l, x, data, r, h) + else if c < 0 then + bal (add x data l) v d r + else + bal l v d (add x data r) + + let rec find x = function + Empty -> + raise Not_found + | Node(l, v, d, r, _) -> + let c = Ord.compare x v in + if c = 0 then d + else find x (if c < 0 then l else r) + + let rec mem x = function + Empty -> + false + | Node(l, v, d, r, _) -> + let c = Ord.compare x v in + c = 0 || mem x (if c < 0 then l else r) + + let rec min_binding = function + Empty -> raise Not_found + | Node(Empty, x, d, r, _) -> (x, d) + | Node(l, x, d, r, _) -> min_binding l + + let rec max_binding = function + Empty -> raise Not_found + | Node(l, x, d, Empty, _) -> (x, d) + | Node(l, x, d, r, _) -> max_binding r + + let rec remove_min_binding = function + Empty -> invalid_arg "Map.remove_min_elt" + | Node(Empty, x, d, r, _) -> r + | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r + + let merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> + let (x, d) = min_binding t2 in + bal t1 x d (remove_min_binding t2) + + let rec remove x = function + Empty -> + Empty + | Node(l, v, d, r, h) -> + let c = Ord.compare x v in + if c = 0 then + merge l r + else if c < 0 then + bal (remove x l) v d r + else + bal l v d (remove x r) + + let rec iter f = function + Empty -> () + | Node(l, v, d, r, _) -> + iter f l; f v d; iter f r + + let rec map f = function + Empty -> + Empty + | Node(l, v, d, r, h) -> + let l' = map f l in + let d' = f d in + let r' = map f r in + Node(l', v, d', r', h) + + let rec mapi f = function + Empty -> + Empty + | Node(l, v, d, r, h) -> + let l' = mapi f l in + let d' = f v d in + let r' = mapi f r in + Node(l', v, d', r', h) + + let rec fold f m accu = + match m with + Empty -> accu + | Node(l, v, d, r, _) -> + fold f r (f v d (fold f l accu)) + + let rec for_all p = function + Empty -> true + | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r + + let rec exists p = function + Empty -> false + | Node(l, v, d, r, _) -> p v d || exists p l || exists p r + + let filter p s = + let rec filt accu = function + | Empty -> accu + | Node(l, v, d, r, _) -> + filt (filt (if p v d then add v d accu else accu) l) r in + filt Empty s + + let partition p s = + let rec part (t, f as accu) = function + | Empty -> accu + | Node(l, v, d, r, _) -> + part (part (if p v d then (add v d t, f) else (t, add v d f)) l) r in + part (Empty, Empty) s + + (* Same as create and bal, but no assumptions are made on the + relative heights of l and r. *) + + let rec join l v d r = + match (l, r) with + (Empty, _) -> add v d r + | (_, Empty) -> add v d l + | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) -> + if lh > rh + 2 then bal ll lv ld (join lr v d r) else + if rh > lh + 2 then bal (join l v d rl) rv rd rr else + create l v d r + + (* Merge two trees l and r into one. + All elements of l must precede the elements of r. + No assumption on the heights of l and r. *) + + let concat t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> + let (x, d) = min_binding t2 in + join t1 x d (remove_min_binding t2) + + let concat_or_join t1 v d t2 = + match d with + | Some d -> join t1 v d t2 + | None -> concat t1 t2 + + let rec split x = function + Empty -> + (Empty, None, Empty) + | Node(l, v, d, r, _) -> + let c = Ord.compare x v in + if c = 0 then (l, Some d, r) + else if c < 0 then + let (ll, pres, rl) = split x l in (ll, pres, join rl v d r) + else + let (lr, pres, rr) = split x r in (join l v d lr, pres, rr) + + let rec merge f s1 s2 = + match (s1, s2) with + (Empty, Empty) -> Empty + | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 -> + let (l2, d2, r2) = split v1 s2 in + concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2) + | (_, Node (l2, v2, d2, r2, h2)) -> + let (l1, d1, r1) = split v2 s1 in + concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2) + | _ -> + assert false + + type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration + + let rec cons_enum m e = + match m with + Empty -> e + | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e)) + + let compare cmp m1 m2 = + let rec compare_aux e1 e2 = + match (e1, e2) with + (End, End) -> 0 + | (End, _) -> -1 + | (_, End) -> 1 + | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> + let c = Ord.compare v1 v2 in + if c <> 0 then c else + let c = cmp d1 d2 in + if c <> 0 then c else + compare_aux (cons_enum r1 e1) (cons_enum r2 e2) + in compare_aux (cons_enum m1 End) (cons_enum m2 End) + + let equal cmp m1 m2 = + let rec equal_aux e1 e2 = + match (e1, e2) with + (End, End) -> true + | (End, _) -> false + | (_, End) -> false + | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> + Ord.compare v1 v2 = 0 && cmp d1 d2 && + equal_aux (cons_enum r1 e1) (cons_enum r2 e2) + in equal_aux (cons_enum m1 End) (cons_enum m2 End) + + let rec cardinal = function + Empty -> 0 + | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r + + let rec bindings_aux accu = function + Empty -> accu + | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l + + let bindings s = + bindings_aux [] s + + let choose = min_binding + +end diff --git a/ocaml-binary-annot/stdlib/map.mli b/ocaml-binary-annot/stdlib/map.mli new file mode 100644 index 0000000000..b025b8c0a6 --- /dev/null +++ b/ocaml-binary-annot/stdlib/map.mli @@ -0,0 +1,194 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Association tables over ordered types. + + This module implements applicative association tables, also known as + finite maps or dictionaries, given a total ordering function + over the keys. + All operations over maps are purely applicative (no side-effects). + The implementation uses balanced binary trees, and therefore searching + and insertion take time logarithmic in the size of the map. +*) + +module type OrderedType = + sig + type t + (** The type of the map keys. *) + val compare : t -> t -> int + (** A total ordering function over the keys. + This is a two-argument function [f] such that + [f e1 e2] is zero if the keys [e1] and [e2] are equal, + [f e1 e2] is strictly negative if [e1] is smaller than [e2], + and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + Example: a suitable ordering function is the generic structural + comparison function {!Pervasives.compare}. *) + end +(** Input signature of the functor {!Map.Make}. *) + +module type S = + sig + type key + (** The type of the map keys. *) + + type (+'a) t + (** The type of maps from type [key] to type ['a]. *) + + val empty: 'a t + (** The empty map. *) + + val is_empty: 'a t -> bool + (** Test whether a map is empty or not. *) + + val mem: key -> 'a t -> bool + (** [mem x m] returns [true] if [m] contains a binding for [x], + and [false] otherwise. *) + + val add: key -> 'a -> 'a t -> 'a t + (** [add x y m] returns a map containing the same bindings as + [m], plus a binding of [x] to [y]. If [x] was already bound + in [m], its previous binding disappears. *) + + val singleton: key -> 'a -> 'a t + (** [singleton x y] returns the one-element map that contains a binding [y] + for [x]. + @since 3.12.0 + *) + + val remove: key -> 'a t -> 'a t + (** [remove x m] returns a map containing the same bindings as + [m], except for [x] which is unbound in the returned map. *) + + val merge: + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] + and of [m2]. The presence of each such binding, and the corresponding + value, is determined with the function [f]. + @since 3.12.0 + *) + + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + (** Total ordering between maps. The first argument is a total ordering + used to compare data associated with equal keys in the two maps. *) + + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are + equal, that is, contain equal keys and associate them with + equal data. [cmp] is the equality predicate used to compare + the data associated with the keys. *) + + val iter: (key -> 'a -> unit) -> 'a t -> unit + (** [iter f m] applies [f] to all bindings in map [m]. + [f] receives the key as first argument, and the associated value + as second argument. The bindings are passed to [f] in increasing + order with respect to the ordering over the type of the keys. *) + + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1 ... kN] are the keys of all bindings in [m] + (in increasing order), and [d1 ... dN] are the associated data. *) + + val for_all: (key -> 'a -> bool) -> 'a t -> bool + (** [for_all p m] checks if all the bindings of the map + satisfy the predicate [p]. + @since 3.12.0 + *) + + val exists: (key -> 'a -> bool) -> 'a t -> bool + (** [exists p m] checks if at least one binding of the map + satisfy the predicate [p]. + @since 3.12.0 + *) + + val filter: (key -> 'a -> bool) -> 'a t -> 'a t + (** [filter p m] returns the map with all the bindings in [m] + that satisfy predicate [p]. + @since 3.12.0 + *) + + val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + (** [partition p m] returns a pair of maps [(m1, m2)], where + [m1] contains all the bindings of [s] that satisfy the + predicate [p], and [m2] is the map with all the bindings of + [s] that do not satisfy [p]. + @since 3.12.0 + *) + + val cardinal: 'a t -> int + (** Return the number of bindings of a map. + @since 3.12.0 + *) + + val bindings: 'a t -> (key * 'a) list + (** Return the list of all bindings of the given map. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Map.Make}. + @since 3.12.0 + *) + + val min_binding: 'a t -> (key * 'a) + (** Return the smallest binding of the given map + (with respect to the [Ord.compare] ordering), or raise + [Not_found] if the map is empty. + @since 3.12.0 + *) + + val max_binding: 'a t -> (key * 'a) + (** Same as {!Map.S.min_binding}, but returns the largest binding + of the given map. + @since 3.12.0 + *) + + val choose: 'a t -> (key * 'a) + (** Return one binding of the given map, or raise [Not_found] if + the map is empty. Which binding is chosen is unspecified, + but equal bindings will be chosen for equal maps. + @since 3.12.0 + *) + + val split: key -> 'a t -> 'a t * 'a option * 'a t + (** [split x m] returns a triple [(l, data, r)], where + [l] is the map with all the bindings of [m] whose key + is strictly less than [x]; + [r] is the map with all the bindings of [m] whose key + is strictly greater than [x]; + [data] is [None] if [m] contains no binding for [x], + or [Some v] if [m] binds [v] to [x]. + @since 3.12.0 + *) + + val find: key -> 'a t -> 'a + (** [find x m] returns the current binding of [x] in [m], + or raises [Not_found] if no such binding exists. *) + + val map: ('a -> 'b) -> 'a t -> 'b t + (** [map f m] returns a map with same domain as [m], where the + associated value [a] of all bindings of [m] has been + replaced by the result of the application of [f] to [a]. + The bindings are passed to [f] in increasing order + with respect to the ordering over the type of the keys. *) + + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t + (** Same as {!Map.S.map}, but the function receives as arguments both the + key and the associated value for each binding of the map. *) + + + end +(** Output signature of the functor {!Map.Make}. *) + +module Make (Ord : OrderedType) : S with type key = Ord.t +(** Functor building an implementation of the map structure + given a totally ordered type. *) diff --git a/ocaml-binary-annot/stdlib/marshal.ml b/ocaml-binary-annot/stdlib/marshal.ml new file mode 100644 index 0000000000..0410a23e99 --- /dev/null +++ b/ocaml-binary-annot/stdlib/marshal.ml @@ -0,0 +1,53 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +type extern_flags = + No_sharing + | Closures + +external to_channel: out_channel -> 'a -> extern_flags list -> unit + = "caml_output_value" +external to_string: 'a -> extern_flags list -> string + = "caml_output_value_to_string" +external to_buffer_unsafe: + string -> int -> int -> 'a -> extern_flags list -> int + = "caml_output_value_to_buffer" + +let to_buffer buff ofs len v flags = + if ofs < 0 || len < 0 || ofs > String.length buff - len + then invalid_arg "Marshal.to_buffer: substring out of bounds" + else to_buffer_unsafe buff ofs len v flags + +external from_channel: in_channel -> 'a = "caml_input_value" +external from_string_unsafe: string -> int -> 'a + = "caml_input_value_from_string" +external data_size_unsafe: string -> int -> int = "caml_marshal_data_size" + +let header_size = 20 +let data_size buff ofs = + if ofs < 0 || ofs > String.length buff - header_size + then invalid_arg "Marshal.data_size" + else data_size_unsafe buff ofs +let total_size buff ofs = header_size + data_size buff ofs + +let from_string buff ofs = + if ofs < 0 || ofs > String.length buff - header_size + then invalid_arg "Marshal.from_size" + else begin + let len = data_size_unsafe buff ofs in + if ofs > String.length buff - (header_size + len) + then invalid_arg "Marshal.from_string" + else from_string_unsafe buff ofs + end diff --git a/ocaml-binary-annot/stdlib/marshal.mli b/ocaml-binary-annot/stdlib/marshal.mli new file mode 100644 index 0000000000..ac0775bb16 --- /dev/null +++ b/ocaml-binary-annot/stdlib/marshal.mli @@ -0,0 +1,136 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Marshaling of data structures. + + This module provides functions to encode arbitrary data structures + as sequences of bytes, which can then be written on a file or + sent over a pipe or network connection. The bytes can then + be read back later, possibly in another process, and decoded back + into a data structure. The format for the byte sequences + is compatible across all machines for a given version of Objective Caml. + + Warning: marshaling is currently not type-safe. The type + of marshaled data is not transmitted along the value of the data, + making it impossible to check that the data read back possesses the + type expected by the context. In particular, the result type of + the [Marshal.from_*] functions is given as ['a], but this is + misleading: the returned Caml value does not possess type ['a] + for all ['a]; it has one, unique type which cannot be determined + at compile-type. The programmer should explicitly give the expected + type of the returned value, using the following syntax: + - [(Marshal.from_channel chan : type)]. + Anything can happen at run-time if the object in the file does not + belong to the given type. + + The representation of marshaled values is not human-readable, + and uses bytes that are not printable characters. Therefore, + input and output channels used in conjunction with [Marshal.to_channel] + and [Marshal.from_channel] must be opened in binary mode, using e.g. + [open_out_bin] or [open_in_bin]; channels opened in text mode will + cause unmarshaling errors on platforms where text channels behave + differently than binary channels, e.g. Windows. +*) + +type extern_flags = + No_sharing (** Don't preserve sharing *) + | Closures (** Send function closures *) +(** The flags to the [Marshal.to_*] functions below. *) + +val to_channel : out_channel -> 'a -> extern_flags list -> unit +(** [Marshal.to_channel chan v flags] writes the representation + of [v] on channel [chan]. The [flags] argument is a + possibly empty list of flags that governs the marshaling + behavior with respect to sharing and functional values. + + If [flags] does not contain [Marshal.No_sharing], circularities + and sharing inside the value [v] are detected and preserved + in the sequence of bytes produced. In particular, this + guarantees that marshaling always terminates. Sharing + between values marshaled by successive calls to + [Marshal.to_channel] is not detected, though. + If [flags] contains [Marshal.No_sharing], sharing is ignored. + This results in faster marshaling if [v] contains no shared + substructures, but may cause slower marshaling and larger + byte representations if [v] actually contains sharing, + or even non-termination if [v] contains cycles. + + If [flags] does not contain [Marshal.Closures], + marshaling fails when it encounters a functional value + inside [v]: only ``pure'' data structures, containing neither + functions nor objects, can safely be transmitted between + different programs. If [flags] contains [Marshal.Closures], + functional values will be marshaled as a position in the code + of the program. In this case, the output of marshaling can + only be read back in processes that run exactly the same program, + with exactly the same compiled code. (This is checked + at un-marshaling time, using an MD5 digest of the code + transmitted along with the code position.) *) + +external to_string : + 'a -> extern_flags list -> string = "caml_output_value_to_string" +(** [Marshal.to_string v flags] returns a string containing + the representation of [v] as a sequence of bytes. + The [flags] argument has the same meaning as for + {!Marshal.to_channel}. *) + +val to_buffer : string -> int -> int -> 'a -> extern_flags list -> int +(** [Marshal.to_buffer buff ofs len v flags] marshals the value [v], + storing its byte representation in the string [buff], + starting at character number [ofs], and writing at most + [len] characters. It returns the number of characters + actually written to the string. If the byte representation + of [v] does not fit in [len] characters, the exception [Failure] + is raised. *) + +val from_channel : in_channel -> 'a +(** [Marshal.from_channel chan] reads from channel [chan] the + byte representation of a structured value, as produced by + one of the [Marshal.to_*] functions, and reconstructs and + returns the corresponding value.*) + +val from_string : string -> int -> 'a +(** [Marshal.from_string buff ofs] unmarshals a structured value + like {!Marshal.from_channel} does, except that the byte + representation is not read from a channel, but taken from + the string [buff], starting at position [ofs]. *) + +val header_size : int +(** The bytes representing a marshaled value are composed of + a fixed-size header and a variable-sized data part, + whose size can be determined from the header. + {!Marshal.header_size} is the size, in characters, of the header. + {!Marshal.data_size}[ buff ofs] is the size, in characters, + of the data part, assuming a valid header is stored in + [buff] starting at position [ofs]. + Finally, {!Marshal.total_size}[ buff ofs] is the total size, + in characters, of the marshaled value. + Both {!Marshal.data_size} and {!Marshal.total_size} raise [Failure] + if [buff], [ofs] does not contain a valid header. + + To read the byte representation of a marshaled value into + a string buffer, the program needs to read first + {!Marshal.header_size} characters into the buffer, + then determine the length of the remainder of the + representation using {!Marshal.data_size}, + make sure the buffer is large enough to hold the remaining + data, then read it, and finally call {!Marshal.from_string} + to unmarshal the value. *) + +val data_size : string -> int -> int +(** See {!Marshal.header_size}.*) + +val total_size : string -> int -> int +(** See {!Marshal.header_size}.*) diff --git a/ocaml-binary-annot/stdlib/moreLabels.ml b/ocaml-binary-annot/stdlib/moreLabels.ml new file mode 100644 index 0000000000..f6cfddabc6 --- /dev/null +++ b/ocaml-binary-annot/stdlib/moreLabels.ml @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Module [MoreLabels]: meta-module for compatibility labelled libraries *) + +module Hashtbl = Hashtbl + +module Map = Map + +module Set = Set diff --git a/ocaml-binary-annot/stdlib/moreLabels.mli b/ocaml-binary-annot/stdlib/moreLabels.mli new file mode 100644 index 0000000000..55c773347f --- /dev/null +++ b/ocaml-binary-annot/stdlib/moreLabels.mli @@ -0,0 +1,136 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Extra labeled libraries. + + This meta-module provides labelized version of the {!Hashtbl}, + {!Map} and {!Set} modules. + + They only differ by their labels. They are provided to help + porting from previous versions of Objective Caml. + The contents of this module are subject to change. +*) + +module Hashtbl : sig + type ('a, 'b) t = ('a, 'b) Hashtbl.t + val create : int -> ('a, 'b) t + val clear : ('a, 'b) t -> unit + val add : ('a, 'b) t -> key:'a -> data:'b -> unit + val copy : ('a, 'b) t -> ('a, 'b) t + val find : ('a, 'b) t -> 'a -> 'b + val find_all : ('a, 'b) t -> 'a -> 'b list + val mem : ('a, 'b) t -> 'a -> bool + val remove : ('a, 'b) t -> 'a -> unit + val replace : ('a, 'b) t -> key:'a -> data:'b -> unit + val iter : f:(key:'a -> data:'b -> unit) -> ('a, 'b) t -> unit + val fold : + f:(key:'a -> data:'b -> 'c -> 'c) -> + ('a, 'b) t -> init:'c -> 'c + val length : ('a, 'b) t -> int + module type HashedType = Hashtbl.HashedType + module type S = + sig + type key + and 'a t + val create : int -> 'a t + val clear : 'a t -> unit + val copy : 'a t -> 'a t + val add : 'a t -> key:key -> data:'a -> unit + val remove : 'a t -> key -> unit + val find : 'a t -> key -> 'a + val find_all : 'a t -> key -> 'a list + val replace : 'a t -> key:key -> data:'a -> unit + val mem : 'a t -> key -> bool + val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit + val fold : + f:(key:key -> data:'a -> 'b -> 'b) -> + 'a t -> init:'b -> 'b + val length : 'a t -> int + end + module Make : functor (H : HashedType) -> S with type key = H.t + val hash : 'a -> int + external hash_param : int -> int -> 'a -> int + = "caml_hash_univ_param" "noalloc" +end + +module Map : sig + module type OrderedType = Map.OrderedType + module type S = + sig + type key + and (+'a) t + val empty : 'a t + val is_empty: 'a t -> bool + val mem : key -> 'a t -> bool + val add : key:key -> data:'a -> 'a t -> 'a t + val singleton: key -> 'a -> 'a t + val remove : key -> 'a t -> 'a t + val merge: f:(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val compare: cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: cmp:('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit + val fold : + f:(key:key -> data:'a -> 'b -> 'b) -> + 'a t -> init:'b -> 'b + val for_all: f:(key -> 'a -> bool) -> 'a t -> bool + val exists: f:(key -> 'a -> bool) -> 'a t -> bool + val filter: f:(key -> 'a -> bool) -> 'a t -> 'a t + val partition: f:(key -> 'a -> bool) -> 'a t -> 'a t * 'a t + val cardinal: 'a t -> int + val bindings: 'a t -> (key * 'a) list + val min_binding: 'a t -> (key * 'a) + val max_binding: 'a t -> (key * 'a) + val choose: 'a t -> (key * 'a) + val split: key -> 'a t -> 'a t * 'a option * 'a t + val find : key -> 'a t -> 'a + val map : f:('a -> 'b) -> 'a t -> 'b t + val mapi : f:(key -> 'a -> 'b) -> 'a t -> 'b t + end + module Make : functor (Ord : OrderedType) -> S with type key = Ord.t +end + +module Set : sig + module type OrderedType = Set.OrderedType + module type S = + sig + type elt + and t + val empty : t + val is_empty : t -> bool + val mem : elt -> t -> bool + val add : elt -> t -> t + val singleton : elt -> 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 subset : t -> t -> bool + val iter : f:(elt -> unit) -> t -> unit + val fold : f:(elt -> 'a -> 'a) -> t -> init:'a -> 'a + val for_all : f:(elt -> bool) -> t -> bool + val exists : f:(elt -> bool) -> t -> bool + val filter : f:(elt -> bool) -> t -> t + val partition : f:(elt -> bool) -> t -> t * t + val cardinal : t -> int + val elements : t -> elt list + val min_elt : t -> elt + val max_elt : t -> elt + val choose : t -> elt + val split: elt -> t -> t * bool * t + end + module Make : functor (Ord : OrderedType) -> S with type elt = Ord.t +end diff --git a/ocaml-binary-annot/stdlib/nativeint.ml b/ocaml-binary-annot/stdlib/nativeint.ml new file mode 100644 index 0000000000..9347843619 --- /dev/null +++ b/ocaml-binary-annot/stdlib/nativeint.ml @@ -0,0 +1,55 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Module [Nativeint]: processor-native integers *) + +external neg: nativeint -> nativeint = "%nativeint_neg" +external add: nativeint -> nativeint -> nativeint = "%nativeint_add" +external sub: nativeint -> nativeint -> nativeint = "%nativeint_sub" +external mul: nativeint -> nativeint -> nativeint = "%nativeint_mul" +external div: nativeint -> nativeint -> nativeint = "%nativeint_div" +external rem: nativeint -> nativeint -> nativeint = "%nativeint_mod" +external logand: nativeint -> nativeint -> nativeint = "%nativeint_and" +external logor: nativeint -> nativeint -> nativeint = "%nativeint_or" +external logxor: nativeint -> nativeint -> nativeint = "%nativeint_xor" +external shift_left: nativeint -> int -> nativeint = "%nativeint_lsl" +external shift_right: nativeint -> int -> nativeint = "%nativeint_asr" +external shift_right_logical: nativeint -> int -> nativeint = "%nativeint_lsr" +external of_int: int -> nativeint = "%nativeint_of_int" +external to_int: nativeint -> int = "%nativeint_to_int" +external of_float : float -> nativeint = "caml_nativeint_of_float" +external to_float : nativeint -> float = "caml_nativeint_to_float" +external of_int32: int32 -> nativeint = "%nativeint_of_int32" +external to_int32: nativeint -> int32 = "%nativeint_to_int32" + +let zero = 0n +let one = 1n +let minus_one = -1n +let succ n = add n 1n +let pred n = sub n 1n +let abs n = if n >= 0n then n else neg n +let size = Sys.word_size +let min_int = shift_left 1n (size - 1) +let max_int = sub min_int 1n +let lognot n = logxor n (-1n) + +external format : string -> nativeint -> string = "caml_nativeint_format" +let to_string n = format "%d" n + +external of_string: string -> nativeint = "caml_nativeint_of_string" + +type t = nativeint + +let compare (x: t) (y: t) = Pervasives.compare x y diff --git a/ocaml-binary-annot/stdlib/nativeint.mli b/ocaml-binary-annot/stdlib/nativeint.mli new file mode 100644 index 0000000000..ff499a26f8 --- /dev/null +++ b/ocaml-binary-annot/stdlib/nativeint.mli @@ -0,0 +1,185 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Processor-native integers. + + This module provides operations on the type [nativeint] of + signed 32-bit integers (on 32-bit platforms) or + signed 64-bit integers (on 64-bit platforms). + This integer type has exactly the same width as that of a [long] + integer type in the C compiler. All arithmetic operations over + [nativeint] are taken modulo 2{^32} or 2{^64} depending + on the word size of the architecture. + + Performance notice: values of type [nativeint] occupy more memory + space than values of type [int], and arithmetic operations on + [nativeint] are generally slower than those on [int]. Use [nativeint] + only when the application requires the extra bit of precision + over the [int] type. +*) + +val zero : nativeint +(** The native integer 0.*) + +val one : nativeint +(** The native integer 1.*) + +val minus_one : nativeint +(** The native integer -1.*) + +external neg : nativeint -> nativeint = "%nativeint_neg" +(** Unary negation. *) + +external add : nativeint -> nativeint -> nativeint = "%nativeint_add" +(** Addition. *) + +external sub : nativeint -> nativeint -> nativeint = "%nativeint_sub" +(** Subtraction. *) + +external mul : nativeint -> nativeint -> nativeint = "%nativeint_mul" +(** Multiplication. *) + +external div : nativeint -> nativeint -> nativeint = "%nativeint_div" +(** Integer division. Raise [Division_by_zero] if the second + argument is zero. This division rounds the real quotient of + its arguments towards zero, as specified for {!Pervasives.(/)}. *) + +external rem : nativeint -> nativeint -> nativeint = "%nativeint_mod" +(** Integer remainder. If [y] is not zero, the result + of [Nativeint.rem x y] satisfies the following properties: + [Nativeint.zero <= Nativeint.rem x y < Nativeint.abs y] and + [x = Nativeint.add (Nativeint.mul (Nativeint.div x y) y) (Nativeint.rem x y)]. + If [y = 0], [Nativeint.rem x y] raises [Division_by_zero]. *) + +val succ : nativeint -> nativeint +(** Successor. + [Nativeint.succ x] is [Nativeint.add x Nativeint.one]. *) + +val pred : nativeint -> nativeint +(** Predecessor. + [Nativeint.pred x] is [Nativeint.sub x Nativeint.one]. *) + +val abs : nativeint -> nativeint +(** Return the absolute value of its argument. *) + +val size : int +(** The size in bits of a native integer. This is equal to [32] + on a 32-bit platform and to [64] on a 64-bit platform. *) + +val max_int : nativeint +(** The greatest representable native integer, + either 2{^31} - 1 on a 32-bit platform, + or 2{^63} - 1 on a 64-bit platform. *) + +val min_int : nativeint +(** The greatest representable native integer, + either -2{^31} on a 32-bit platform, + or -2{^63} on a 64-bit platform. *) + +external logand : nativeint -> nativeint -> nativeint = "%nativeint_and" +(** Bitwise logical and. *) + +external logor : nativeint -> nativeint -> nativeint = "%nativeint_or" +(** Bitwise logical or. *) + +external logxor : nativeint -> nativeint -> nativeint = "%nativeint_xor" +(** Bitwise logical exclusive or. *) + +val lognot : nativeint -> nativeint +(** Bitwise logical negation *) + +external shift_left : nativeint -> int -> nativeint = "%nativeint_lsl" +(** [Nativeint.shift_left x y] shifts [x] to the left by [y] bits. + The result is unspecified if [y < 0] or [y >= bitsize], + where [bitsize] is [32] on a 32-bit platform and + [64] on a 64-bit platform. *) + +external shift_right : nativeint -> int -> nativeint = "%nativeint_asr" +(** [Nativeint.shift_right x y] shifts [x] to the right by [y] bits. + This is an arithmetic shift: the sign bit of [x] is replicated + and inserted in the vacated bits. + The result is unspecified if [y < 0] or [y >= bitsize]. *) + +external shift_right_logical : + nativeint -> int -> nativeint = "%nativeint_lsr" +(** [Nativeint.shift_right_logical x y] shifts [x] to the right + by [y] bits. + This is a logical shift: zeroes are inserted in the vacated bits + regardless of the sign of [x]. + The result is unspecified if [y < 0] or [y >= bitsize]. *) + + +external of_int : int -> nativeint = "%nativeint_of_int" +(** Convert the given integer (type [int]) to a native integer + (type [nativeint]). *) + +external to_int : nativeint -> int = "%nativeint_to_int" +(** Convert the given native integer (type [nativeint]) to an + integer (type [int]). The high-order bit is lost during + the conversion. *) + +external of_float : float -> nativeint = "caml_nativeint_of_float" +(** Convert the given floating-point number to a native integer, + discarding the fractional part (truncate towards 0). + The result of the conversion is undefined if, after truncation, + the number is outside the range + \[{!Nativeint.min_int}, {!Nativeint.max_int}\]. *) + +external to_float : nativeint -> float = "caml_nativeint_to_float" +(** Convert the given native integer to a floating-point number. *) + +external of_int32 : int32 -> nativeint = "%nativeint_of_int32" +(** Convert the given 32-bit integer (type [int32]) + to a native integer. *) + +external to_int32 : nativeint -> int32 = "%nativeint_to_int32" +(** Convert the given native integer to a + 32-bit integer (type [int32]). On 64-bit platforms, + the 64-bit native integer is taken modulo 2{^32}, + i.e. the top 32 bits are lost. On 32-bit platforms, + the conversion is exact. *) + +external of_string : string -> nativeint = "caml_nativeint_of_string" +(** Convert the given string to a native integer. + The string is read in decimal (by default) or in hexadecimal, + octal or binary if the string begins with [0x], [0o] or [0b] + respectively. + Raise [Failure "int_of_string"] if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [nativeint]. *) + +val to_string : nativeint -> string +(** Return the string representation of its argument, in decimal. *) + +type t = nativeint +(** An alias for the type of native integers. *) + +val compare: t -> t -> int +(** The comparison function for native integers, with the same specification as + {!Pervasives.compare}. Along with the type [t], this function [compare] + allows the module [Nativeint] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +(**/**) + +(** {6 Deprecated functions} *) + +external format : string -> nativeint -> string = "caml_nativeint_format" +(** [Nativeint.format fmt n] return the string representation of the + native integer [n] in the format specified by [fmt]. + [fmt] is a [Printf]-style format consisting of exactly + one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification. + This function is deprecated; use {!Printf.sprintf} with a [%nx] format + instead. *) diff --git a/ocaml-binary-annot/stdlib/obj.ml b/ocaml-binary-annot/stdlib/obj.ml new file mode 100644 index 0000000000..c16b511560 --- /dev/null +++ b/ocaml-binary-annot/stdlib/obj.ml @@ -0,0 +1,60 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Operations on internal representations of values *) + +type t + +external repr : 'a -> t = "%identity" +external obj : t -> 'a = "%identity" +external magic : 'a -> 'b = "%identity" +external is_block : t -> bool = "caml_obj_is_block" +external is_int : t -> bool = "%obj_is_int" +external tag : t -> int = "caml_obj_tag" +external set_tag : t -> int -> unit = "caml_obj_set_tag" +external size : t -> int = "%obj_size" +external field : t -> int -> t = "%obj_field" +external set_field : t -> int -> t -> unit = "%obj_set_field" +let double_field x i = Array.get (obj x : float array) i +let set_double_field x i v = Array.set (obj x : float array) i v +external new_block : int -> int -> t = "caml_obj_block" +external dup : t -> t = "caml_obj_dup" +external truncate : t -> int -> unit = "caml_obj_truncate" +external add_offset : t -> Int32.t -> t = "caml_obj_add_offset" + +let marshal (obj : t) = + Marshal.to_string obj [] +let unmarshal str pos = + (Marshal.from_string str pos, pos + Marshal.total_size str pos) + +let lazy_tag = 246 +let closure_tag = 247 +let object_tag = 248 +let infix_tag = 249 +let forward_tag = 250 + +let no_scan_tag = 251 + +let abstract_tag = 251 +let string_tag = 252 +let double_tag = 253 +let double_array_tag = 254 +let custom_tag = 255 +let final_tag = custom_tag + + +let int_tag = 1000 +let out_of_heap_tag = 1001 +let unaligned_tag = 1002 diff --git a/ocaml-binary-annot/stdlib/obj.mli b/ocaml-binary-annot/stdlib/obj.mli new file mode 100644 index 0000000000..57df04917d --- /dev/null +++ b/ocaml-binary-annot/stdlib/obj.mli @@ -0,0 +1,62 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Operations on internal representations of values. + + Not for the casual user. +*) + +type t + +external repr : 'a -> t = "%identity" +external obj : t -> 'a = "%identity" +external magic : 'a -> 'b = "%identity" +external is_block : t -> bool = "caml_obj_is_block" +external is_int : t -> bool = "%obj_is_int" +external tag : t -> int = "caml_obj_tag" +external set_tag : t -> int -> unit = "caml_obj_set_tag" +external size : t -> int = "%obj_size" +external field : t -> int -> t = "%obj_field" +external set_field : t -> int -> t -> unit = "%obj_set_field" +val double_field : t -> int -> float (* @since 3.11.2 *) +val set_double_field : t -> int -> float -> unit (* @since 3.11.2 *) +external new_block : int -> int -> t = "caml_obj_block" +external dup : t -> t = "caml_obj_dup" +external truncate : t -> int -> unit = "caml_obj_truncate" +external add_offset : t -> Int32.t -> t = "caml_obj_add_offset" + (* @since 3.12.0 *) + +val lazy_tag : int +val closure_tag : int +val object_tag : int +val infix_tag : int +val forward_tag : int +val no_scan_tag : int +val abstract_tag : int +val string_tag : int +val double_tag : int +val double_array_tag : int +val custom_tag : int +val final_tag : int (* DEPRECATED *) + +val int_tag : int +val out_of_heap_tag : int +val unaligned_tag : int (* should never happen @since 3.11.0 *) + +(** The following two functions are deprecated. Use module {!Marshal} + instead. *) + +val marshal : t -> string +val unmarshal : string -> int -> t * int diff --git a/ocaml-binary-annot/stdlib/oo.ml b/ocaml-binary-annot/stdlib/oo.ml new file mode 100644 index 0000000000..c9ec64ae44 --- /dev/null +++ b/ocaml-binary-annot/stdlib/oo.ml @@ -0,0 +1,19 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jerome Vouillon, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +let copy = CamlinternalOO.copy +external id : < .. > -> int = "%field1" +let new_method = CamlinternalOO.public_method_label +let public_method_label = CamlinternalOO.public_method_label diff --git a/ocaml-binary-annot/stdlib/oo.mli b/ocaml-binary-annot/stdlib/oo.mli new file mode 100644 index 0000000000..b3111ce857 --- /dev/null +++ b/ocaml-binary-annot/stdlib/oo.mli @@ -0,0 +1,29 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jerome Vouillon, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Operations on objects *) + +val copy : (< .. > as 'a) -> 'a +(** [Oo.copy o] returns a copy of object [o], that is a fresh + object with the same methods and instance variables as [o] *) + +external id : < .. > -> int = "%field1" +(** Return an integer identifying this object, unique for + the current execution of the program. *) + +(**/**) +(** For internal use (CamlIDL) *) +val new_method : string -> CamlinternalOO.tag +val public_method_label : string -> CamlinternalOO.tag diff --git a/ocaml-binary-annot/stdlib/parsing.ml b/ocaml-binary-annot/stdlib/parsing.ml new file mode 100644 index 0000000000..44c7fb2715 --- /dev/null +++ b/ocaml-binary-annot/stdlib/parsing.ml @@ -0,0 +1,205 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The parsing engine *) + +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 : position array; (* Start positions *) + mutable symb_end_stack : position array; (* End positions *) + mutable stacksize : int; (* Size of the stacks *) + mutable stackbase : int; (* Base sp for current parse *) + mutable curr_char : int; (* Last token read *) + mutable lval : Obj.t; (* Its semantic attribute *) + mutable symb_start : position; (* Start pos. of the current symbol*) + mutable symb_end : position; (* 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 *) + mutable errflag : int } (* Saved error flag for parse_engine *) + +type parse_tables = + { actions : (parser_env -> Obj.t) array; + transl_const : int array; + transl_block : int array; + lhs : string; + len : string; + defred : string; + dgoto : string; + sindex : string; + rindex : string; + gindex : string; + tablesize : int; + table : string; + check : string; + error_function : string -> unit; + names_const : string; + names_block : string } + +exception YYexit of Obj.t +exception Parse_error + +type parser_input = + Start + | Token_read + | Stacks_grown_1 + | Stacks_grown_2 + | Semantic_action_computed + | Error_detected + +type parser_output = + Read_token + | Raise_parse_error + | Grow_stacks_1 + | Grow_stacks_2 + | Compute_semantic_action + | Call_error_function + +external parse_engine : + parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output + = "caml_parse_engine" + +external set_trace: bool -> bool + = "caml_set_parser_trace" + +let env = + { s_stack = Array.create 100 0; + v_stack = Array.create 100 (Obj.repr ()); + symb_start_stack = Array.create 100 dummy_pos; + symb_end_stack = Array.create 100 dummy_pos; + stacksize = 100; + stackbase = 0; + curr_char = 0; + lval = Obj.repr (); + symb_start = dummy_pos; + symb_end = dummy_pos; + asp = 0; + rule_len = 0; + rule_number = 0; + sp = 0; + state = 0; + errflag = 0 } + +let grow_stacks() = + let oldsize = env.stacksize in + let newsize = oldsize * 2 in + let new_s = Array.create newsize 0 + and new_v = Array.create newsize (Obj.repr ()) + and new_start = Array.create newsize dummy_pos + and new_end = Array.create newsize dummy_pos 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_start_p; + env.symb_end <- lexbuf.lex_curr_p; + loop Token_read t + | Raise_parse_error -> + raise Parse_error + | Compute_semantic_action -> + let (action, value) = + try + (Semantic_action_computed, tables.actions.(env.rule_number) env) + with Parse_error -> + (Error_detected, Obj.repr ()) in + loop action value + | Grow_stacks_1 -> + grow_stacks(); loop Stacks_grown_1 (Obj.repr ()) + | Grow_stacks_2 -> + grow_stacks(); loop Stacks_grown_2 (Obj.repr ()) + | Call_error_function -> + tables.error_function "syntax error"; + loop Error_detected (Obj.repr ()) in + let init_asp = env.asp + and init_sp = env.sp + and init_stackbase = env.stackbase + and init_state = env.state + and init_curr_char = env.curr_char + and init_errflag = env.errflag in + env.stackbase <- env.sp + 1; + env.curr_char <- start; + env.symb_end <- lexbuf.lex_curr_p; + try + loop Start (Obj.repr ()) + with exn -> + let curr_char = env.curr_char in + env.asp <- init_asp; + env.sp <- init_sp; + env.stackbase <- init_stackbase; + env.state <- init_state; + env.curr_char <- init_curr_char; + env.errflag <- init_errflag; + match exn with + YYexit v -> + Obj.magic v + | _ -> + current_lookahead_fun := + (fun tok -> + if Obj.is_block tok + then tables.transl_block.(Obj.tag tok) = curr_char + else tables.transl_const.(Obj.magic tok) = curr_char); + raise exn + +let peek_val env n = + Obj.magic env.v_stack.(env.asp - n) + +let symbol_start_pos () = + let rec loop i = + if i <= 0 then env.symb_end_stack.(env.asp) + else begin + let st = env.symb_start_stack.(env.asp - i + 1) in + let en = env.symb_end_stack.(env.asp - i + 1) in + if st <> en then st else loop (i - 1) + end + in + loop env.rule_len +;; +let symbol_end_pos () = env.symb_end_stack.(env.asp);; +let rhs_start_pos n = env.symb_start_stack.(env.asp - (env.rule_len - n));; +let rhs_end_pos n = env.symb_end_stack.(env.asp - (env.rule_len - n));; + +let symbol_start () = (symbol_start_pos ()).pos_cnum;; +let symbol_end () = (symbol_end_pos ()).pos_cnum;; +let rhs_start n = (rhs_start_pos n).pos_cnum;; +let rhs_end n = (rhs_end_pos n).pos_cnum;; + +let is_current_lookahead tok = + (!current_lookahead_fun)(Obj.repr tok) + +let parse_error (msg : string) = () diff --git a/ocaml-binary-annot/stdlib/parsing.mli b/ocaml-binary-annot/stdlib/parsing.mli new file mode 100644 index 0000000000..03721ba308 --- /dev/null +++ b/ocaml-binary-annot/stdlib/parsing.mli @@ -0,0 +1,105 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The run-time library for parsers generated by [ocamlyacc]. *) + +val symbol_start : unit -> int +(** [symbol_start] and {!Parsing.symbol_end} are to be called in the + action part of a grammar rule only. They return the offset of the + string that matches the left-hand side of the rule: [symbol_start()] + returns the offset of the first character; [symbol_end()] returns the + offset after the last character. The first character in a file is at + offset 0. *) + +val symbol_end : unit -> int +(** See {!Parsing.symbol_start}. *) + +val rhs_start : int -> int +(** Same as {!Parsing.symbol_start} and {!Parsing.symbol_end}, but + return the offset of the string matching the [n]th item on the + right-hand side of the rule, where [n] is the integer parameter + to [rhs_start] and [rhs_end]. [n] is 1 for the leftmost item. *) + +val rhs_end : int -> int +(** See {!Parsing.rhs_start}. *) + +val symbol_start_pos : unit -> Lexing.position;; +(** Same as [symbol_start], but return a [position] instead of an offset. *) + +val symbol_end_pos : unit -> Lexing.position +(** Same as [symbol_end], but return a [position] instead of an offset. *) + +val rhs_start_pos : int -> Lexing.position +(** Same as [rhs_start], but return a [position] instead of an offset. *) + +val rhs_end_pos : int -> Lexing.position +(** Same as [rhs_end], but return a [position] instead of an offset. *) + +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. + Can also be raised from the action part of a grammar rule, + to initiate error recovery. *) + +val set_trace: bool -> bool +(** Control debugging support for [ocamlyacc]-generated parsers. + After [Parsing.set_trace true], the pushdown automaton that + executes the parsers prints a trace of its actions (reading a token, + shifting a state, reducing by a rule) on standard output. + [Parsing.set_trace false] turns this debugging trace off. + The boolean returned is the previous state of the trace flag. + @since 3.11.0 +*) + +(**/**) + +(** {6 } *) + +(** The following definitions are used by the generated parsers only. + They are not intended to be used by user programs. *) + +type parser_env + +type parse_tables = + { actions : (parser_env -> Obj.t) array; + transl_const : int array; + transl_block : int array; + lhs : string; + len : string; + defred : string; + dgoto : string; + sindex : string; + rindex : string; + gindex : string; + tablesize : int; + table : string; + check : string; + error_function : string -> unit; + names_const : string; + names_block : string } + +exception YYexit of Obj.t + +val yyparse : + parse_tables -> int -> (Lexing.lexbuf -> 'a) -> Lexing.lexbuf -> 'b +val peek_val : parser_env -> int -> 'a +val is_current_lookahead : 'a -> bool +val parse_error : string -> unit diff --git a/ocaml-binary-annot/stdlib/pervasives.ml b/ocaml-binary-annot/stdlib/pervasives.ml new file mode 100644 index 0000000000..7a1c0aeab8 --- /dev/null +++ b/ocaml-binary-annot/stdlib/pervasives.ml @@ -0,0 +1,453 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* type 'a option = None | Some of 'a *) + +(* 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 ( && ) : bool -> bool -> bool = "%sequand" +external ( or ) : bool -> bool -> bool = "%sequor" +external ( || ) : bool -> bool -> bool = "%sequor" + +(* Integer operations *) + +external ( ~- ) : int -> int = "%negint" +external ( ~+ ) : int -> int = "%identity" +external (~+) : int -> int = "%identity" +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" + +let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62) +let max_int = min_int - 1 + +(* Floating-point operations *) + +external ( ~-. ) : float -> float = "%negfloat" +external ( ~+. ) : float -> float = "%identity" +external ( +. ) : float -> float -> float = "%addfloat" +external ( -. ) : float -> float -> float = "%subfloat" +external ( *. ) : float -> float -> float = "%mulfloat" +external ( /. ) : float -> float -> float = "%divfloat" +external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float" +external exp : float -> float = "caml_exp_float" "exp" "float" +external expm1 : float -> float = "caml_expm1_float" "caml_expm1" "float" +external acos : float -> float = "caml_acos_float" "acos" "float" +external asin : float -> float = "caml_asin_float" "asin" "float" +external atan : float -> float = "caml_atan_float" "atan" "float" +external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" +external cos : float -> float = "caml_cos_float" "cos" "float" +external cosh : float -> float = "caml_cosh_float" "cosh" "float" +external log : float -> float = "caml_log_float" "log" "float" +external log10 : float -> float = "caml_log10_float" "log10" "float" +external log1p : float -> float = "caml_log1p_float" "caml_log1p" "float" +external sin : float -> float = "caml_sin_float" "sin" "float" +external sinh : float -> float = "caml_sinh_float" "sinh" "float" +external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float" +external tan : float -> float = "caml_tan_float" "tan" "float" +external tanh : float -> float = "caml_tanh_float" "tanh" "float" +external ceil : float -> float = "caml_ceil_float" "ceil" "float" +external floor : float -> float = "caml_floor_float" "floor" "float" +external abs_float : float -> float = "%absfloat" +external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" +external frexp : float -> float * int = "caml_frexp_float" +external ldexp : float -> int -> float = "caml_ldexp_float" +external modf : float -> float * float = "caml_modf_float" +external float : int -> float = "%floatofint" +external float_of_int : int -> float = "%floatofint" +external truncate : float -> int = "%intoffloat" +external int_of_float : float -> int = "%intoffloat" +external float_of_bits : int64 -> float = "caml_int64_float_of_bits" +let infinity = + float_of_bits 0x7F_F0_00_00_00_00_00_00L +let neg_infinity = + float_of_bits 0xFF_F0_00_00_00_00_00_00L +let nan = + float_of_bits 0x7F_F0_00_00_00_00_00_01L +let max_float = + float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL +let min_float = + float_of_bits 0x00_10_00_00_00_00_00_00L +let epsilon_float = + float_of_bits 0x3C_B0_00_00_00_00_00_00L + +type fpclass = + FP_normal + | FP_subnormal + | FP_zero + | FP_infinite + | FP_nan +external classify_float : float -> fpclass = "caml_classify_float" + +(* String operations -- more in module String *) + +external string_length : string -> int = "%string_length" +external string_create : int -> string = "caml_create_string" +external string_blit : string -> int -> string -> int -> int -> unit + = "caml_blit_string" "noalloc" + +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 + +(* Character operations -- more in module Char *) + +external int_of_char : char -> int = "%identity" +external unsafe_char_of_int : int -> char = "%identity" +let char_of_int n = + if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n + +(* Unit operations *) + +external ignore : 'a -> unit = "%ignore" + +(* Pair operations *) + +external fst : 'a * 'b -> 'a = "%field0" +external snd : 'a * 'b -> 'b = "%field1" + +(* String conversion functions *) + +external format_int : string -> int -> string = "caml_format_int" +external format_float : string -> float -> string = "caml_format_float" + +let string_of_bool b = + if b then "true" else "false" +let bool_of_string = function + | "true" -> true + | "false" -> false + | _ -> invalid_arg "bool_of_string" + +let string_of_int n = + format_int "%d" n + +external int_of_string : string -> int = "caml_int_of_string" + +module String = struct + external get : string -> int -> char = "%string_safe_get" +end + +let valid_float_lexem s = + let l = string_length s in + let rec loop i = + if i >= l then s ^ "." else + match s.[i] with + | '0' .. '9' | '-' -> loop (i + 1) + | _ -> s + in + loop 0 +;; + +let string_of_float f = valid_float_lexem (format_float "%.12g" f);; + +external float_of_string : string -> float = "caml_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 = "caml_ml_open_descriptor_out" +external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in" + +let stdin = open_descriptor_in 0 +let stdout = open_descriptor_out 1 +let stderr = open_descriptor_out 2 + +(* General output functions *) + +type open_flag = + Open_rdonly | Open_wronly | Open_append + | Open_creat | Open_trunc | Open_excl + | Open_binary | Open_text | Open_nonblock + +external open_desc : string -> open_flag list -> int -> int = "caml_sys_open" + +let open_out_gen mode perm name = + open_descriptor_out(open_desc name mode perm) + +let open_out name = + open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name + +let open_out_bin name = + open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name + +external flush : out_channel -> unit = "caml_ml_flush" + +external out_channels_list : unit -> out_channel list + = "caml_ml_out_channels_list" + +let flush_all () = + let rec iter = function + [] -> () + | a :: l -> (try flush a with _ -> ()); iter l + in iter (out_channels_list ()) + +external unsafe_output : out_channel -> string -> int -> int -> unit + = "caml_ml_output" + +external output_char : out_channel -> char -> unit = "caml_ml_output_char" + +let output_string oc s = + unsafe_output oc s 0 (string_length s) + +let output oc s ofs len = + if ofs < 0 || len < 0 || ofs > string_length s - len + then invalid_arg "output" + else unsafe_output oc s ofs len + +external output_byte : out_channel -> int -> unit = "caml_ml_output_char" +external output_binary_int : out_channel -> int -> unit = "caml_ml_output_int" + +external marshal_to_channel : out_channel -> 'a -> unit list -> unit + = "caml_output_value" +let output_value chan v = marshal_to_channel chan v [] + +external seek_out : out_channel -> int -> unit = "caml_ml_seek_out" +external pos_out : out_channel -> int = "caml_ml_pos_out" +external out_channel_length : out_channel -> int = "caml_ml_channel_size" +external close_out_channel : out_channel -> unit = "caml_ml_close_channel" +let close_out oc = flush oc; close_out_channel oc +let close_out_noerr oc = + (try flush oc with _ -> ()); + (try close_out_channel oc with _ -> ()) +external set_binary_mode_out : out_channel -> bool -> unit + = "caml_ml_set_binary_mode" + +(* 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 = "caml_ml_input_char" + +external unsafe_input : in_channel -> string -> int -> int -> int + = "caml_ml_input" + +let input ic s ofs len = + if ofs < 0 || len < 0 || ofs > string_length s - len + 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 || len < 0 || ofs > string_length s - len + then invalid_arg "really_input" + else unsafe_really_input ic s ofs len + +external input_scan_line : in_channel -> int = "caml_ml_input_scan_line" + +let input_line chan = + let rec build_result buf pos = function + [] -> buf + | hd :: tl -> + let len = string_length hd in + string_blit hd 0 buf (pos - len) len; + build_result buf (pos - len) tl in + let rec scan accu len = + let n = input_scan_line chan in + if n = 0 then begin (* n = 0: we are at EOF *) + match accu with + [] -> raise End_of_file + | _ -> build_result (string_create len) len accu + end else if n > 0 then begin (* n > 0: newline found in buffer *) + let res = string_create (n - 1) in + ignore (unsafe_input chan res 0 (n - 1)); + ignore (input_char chan); (* skip the newline *) + match accu with + [] -> res + | _ -> let len = len + n - 1 in + build_result (string_create len) len (res :: accu) + end else begin (* n < 0: newline not found *) + let beg = string_create (-n) in + ignore(unsafe_input chan beg 0 (-n)); + scan (beg :: accu) (len - n) + end + in scan [] 0 + +external input_byte : in_channel -> int = "caml_ml_input_char" +external input_binary_int : in_channel -> int = "caml_ml_input_int" +external input_value : in_channel -> 'a = "caml_input_value" +external seek_in : in_channel -> int -> unit = "caml_ml_seek_in" +external pos_in : in_channel -> int = "caml_ml_pos_in" +external in_channel_length : in_channel -> int = "caml_ml_channel_size" +external close_in : in_channel -> unit = "caml_ml_close_channel" +let close_in_noerr ic = (try close_in ic with _ -> ());; +external set_binary_mode_in : in_channel -> bool -> unit + = "caml_ml_set_binary_mode" + +(* 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'; flush stdout +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()) + +(* Operations on large files *) + +module LargeFile = + struct + external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64" + external pos_out : out_channel -> int64 = "caml_ml_pos_out_64" + external out_channel_length : out_channel -> int64 + = "caml_ml_channel_size_64" + external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64" + external pos_in : in_channel -> int64 = "caml_ml_pos_in_64" + external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64" + end + +(* References *) + +type 'a ref = { mutable contents : 'a } +external ref : 'a -> 'a ref = "%makemutable" +external ( ! ) : 'a ref -> 'a = "%field0" +external ( := ) : 'a ref -> 'a -> unit = "%setfield0" +external incr : int ref -> unit = "%incr" +external decr : int ref -> unit = "%decr" + +(* Formats *) +type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 + +type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 + +external format_of_string : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" + +external format_to_string : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" +external string_to_format : + string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" + +let (( ^^ ) : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('f, 'b, 'c, 'e, 'g, 'h) format6 -> + ('a, 'b, 'c, 'd, 'g, 'h) format6) = + fun fmt1 fmt2 -> + string_to_format (format_to_string fmt1 ^ "%," ^ format_to_string fmt2) +;; + +let string_of_format fmt = + let s = format_to_string fmt in + let l = string_length s in + let r = string_create l in + string_blit s 0 r 0 l; + r + +(* Miscellaneous *) + +external sys_exit : int -> 'a = "caml_sys_exit" + +let exit_function = ref flush_all + +let at_exit f = + let g = !exit_function in + exit_function := (fun () -> f(); g()) + +let do_at_exit () = (!exit_function) () + +let exit retcode = + do_at_exit (); + sys_exit retcode + +external register_named_value : string -> 'a -> unit + = "caml_register_named_value" + +let _ = register_named_value "Pervasives.do_at_exit" do_at_exit diff --git a/ocaml-binary-annot/stdlib/pervasives.mli b/ocaml-binary-annot/stdlib/pervasives.mli new file mode 100644 index 0000000000..13905ecc3d --- /dev/null +++ b/ocaml-binary-annot/stdlib/pervasives.mli @@ -0,0 +1,913 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** The initially opened module. + + This module provides the basic operations over the built-in types + (numbers, booleans, strings, exceptions, references, lists, arrays, + input-output channels, ...). + + This module is automatically opened at the beginning of each compilation. + All components of this module can therefore be referred by their short + name, without prefixing them by [Pervasives]. +*) + + +(** {6 Exceptions} *) + +external raise : exn -> 'a = "%raise" +(** Raise the given exception value *) + +val invalid_arg : string -> 'a +(** Raise exception [Invalid_argument] with the given string. *) + +val failwith : string -> 'a +(** Raise exception [Failure] with the given string. *) + +exception Exit +(** The [Exit] exception is not raised by any library function. It is + provided for use in your programs.*) + + +(** {6 Comparisons} *) + +external ( = ) : 'a -> 'a -> bool = "%equal" +(** [e1 = e2] tests for structural equality of [e1] and [e2]. + Mutable structures (e.g. references and arrays) are equal + if and only if their current contents are structurally equal, + even if the two mutable objects are not the same physical object. + Equality between functional values raises [Invalid_argument]. + Equality between cyclic data structures may not terminate. *) + +external ( <> ) : 'a -> 'a -> bool = "%notequal" +(** Negation of {!Pervasives.( = )}. *) + +external ( < ) : 'a -> 'a -> bool = "%lessthan" +(** See {!Pervasives.( >= )}. *) + +external ( > ) : 'a -> 'a -> bool = "%greaterthan" +(** See {!Pervasives.( >= )}. *) + +external ( <= ) : 'a -> 'a -> bool = "%lessequal" +(** See {!Pervasives.( >= )}. *) + +external ( >= ) : 'a -> 'a -> bool = "%greaterequal" +(** Structural ordering functions. These functions coincide with + the usual orderings over integers, characters, strings + and floating-point numbers, and extend them to a + total ordering over all types. + The ordering is compatible with [( = )]. As in the case + of [( = )], mutable structures are compared by contents. + Comparison between functional values raises [Invalid_argument]. + Comparison between cyclic structures may not terminate. *) + +external compare : 'a -> 'a -> int = "%compare" +(** [compare x y] returns [0] if [x] is equal to [y], + a negative integer if [x] is less than [y], and a positive integer + if [x] is greater than [y]. The ordering implemented by [compare] + is compatible with the comparison predicates [=], [<] and [>] + defined above, with one difference on the treatment of the float value + {!Pervasives.nan}. Namely, the comparison predicates treat [nan] + as different from any other float value, including itself; + while [compare] treats [nan] as equal to itself and less than any + other float value. This treatment of [nan] ensures that [compare] + defines a total ordering relation. + + [compare] applied to functional values may raise [Invalid_argument]. + [compare] applied to cyclic structures may not terminate. + + The [compare] function can be used as the comparison function + required by the {!Set.Make} and {!Map.Make} functors, as well as + the {!List.sort} and {!Array.sort} functions. *) + +val min : 'a -> 'a -> 'a +(** Return the smaller of the two arguments. + The result is unspecified if one of the arguments contains + the float value [nan]. *) + +val max : 'a -> 'a -> 'a +(** Return the greater of the two arguments. + The result is unspecified if one of the arguments contains + the float value [nan]. *) + +external ( == ) : 'a -> 'a -> bool = "%eq" +(** [e1 == e2] tests for physical equality of [e1] and [e2]. + On mutable types such as references, arrays, strings, records with + mutable fields and objects with mutable instance variables, + [e1 == e2] is true if and only if physical modification of [e1] + also affects [e2]. + On non-mutable types, the behavior of [( == )] is + implementation-dependent; however, it is guaranteed that + [e1 == e2] implies [compare e1 e2 = 0]. *) + +external ( != ) : 'a -> 'a -> bool = "%noteq" +(** Negation of {!Pervasives.( == )}. *) + + +(** {6 Boolean operations} *) + +external not : bool -> bool = "%boolnot" +(** The boolean negation. *) + +external ( && ) : bool -> bool -> bool = "%sequand" +(** The boolean ``and''. Evaluation is sequential, left-to-right: + in [e1 && e2], [e1] is evaluated first, and if it returns [false], + [e2] is not evaluated at all. *) + +external ( & ) : bool -> bool -> bool = "%sequand" +(** @deprecated {!Pervasives.( && )} should be used instead. *) + +external ( || ) : bool -> bool -> bool = "%sequor" +(** The boolean ``or''. Evaluation is sequential, left-to-right: + in [e1 || e2], [e1] is evaluated first, and if it returns [true], + [e2] is not evaluated at all. *) + +external ( or ) : bool -> bool -> bool = "%sequor" +(** @deprecated {!Pervasives.( || )} should be used instead.*) + + +(** {6 Integer arithmetic} *) + +(** Integers are 31 bits wide (or 63 bits on 64-bit processors). + All operations are taken modulo 2{^31} (or 2{^63}). + They do not fail on overflow. *) + +external ( ~- ) : int -> int = "%negint" +(** Unary negation. You can also write [- e] instead of [~- e]. *) + +external ( ~+ ) : int -> int = "%identity" +(** Unary addition. You can also write [+ e] instead of [~+ e]. + @since 3.12.0 +*) + +external succ : int -> int = "%succint" +(** [succ x] is [x + 1]. *) + +external pred : int -> int = "%predint" +(** [pred x] is [x - 1]. *) + +external ( + ) : int -> int -> int = "%addint" +(** Integer addition. *) + +external ( - ) : int -> int -> int = "%subint" +(** Integer subtraction. *) + +external ( * ) : int -> int -> int = "%mulint" +(** Integer multiplication. *) + +external ( / ) : int -> int -> int = "%divint" +(** Integer division. + Raise [Division_by_zero] if the second argument is 0. + Integer division rounds the real quotient of its arguments towards zero. + More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer + less than or equal to the real quotient of [x] by [y]. Moreover, + [(- x) / y = x / (- y) = - (x / y)]. *) + +external ( mod ) : int -> int -> int = "%modint" +(** Integer remainder. If [y] is not zero, the result + of [x mod y] satisfies the following properties: + [x = (x / y) * y + x mod y] and + [abs(x mod y) <= abs(y) - 1]. + If [y = 0], [x mod y] raises [Division_by_zero]. + Note that [x mod y] is negative only if [x < 0]. + Raise [Division_by_zero] if [y] is zero. *) + +val abs : int -> int +(** Return the absolute value of the argument. Note that this may be + negative if the argument is [min_int]. *) + +val max_int : int +(** The greatest representable integer. *) + +val min_int : int +(** The smallest representable integer. *) + + +(** {7 Bitwise operations} *) + +external ( land ) : int -> int -> int = "%andint" +(** Bitwise logical and. *) + +external ( lor ) : int -> int -> int = "%orint" +(** Bitwise logical or. *) + +external ( lxor ) : int -> int -> int = "%xorint" +(** Bitwise logical exclusive or. *) + +val lnot : int -> int +(** Bitwise logical negation. *) + +external ( lsl ) : int -> int -> int = "%lslint" +(** [n lsl m] shifts [n] to the left by [m] bits. + The result is unspecified if [m < 0] or [m >= bitsize], + where [bitsize] is [32] on a 32-bit platform and + [64] on a 64-bit platform. *) + +external ( lsr ) : int -> int -> int = "%lsrint" +(** [n lsr m] shifts [n] to the right by [m] bits. + This is a logical shift: zeroes are inserted regardless of + the sign of [n]. + The result is unspecified if [m < 0] or [m >= bitsize]. *) + +external ( asr ) : int -> int -> int = "%asrint" +(** [n asr m] shifts [n] to the right by [m] bits. + This is an arithmetic shift: the sign bit of [n] is replicated. + The result is unspecified if [m < 0] or [m >= bitsize]. *) + + +(** {6 Floating-point arithmetic} + + Caml's floating-point numbers follow the + IEEE 754 standard, using double precision (64 bits) numbers. + Floating-point operations never raise an exception on overflow, + underflow, division by zero, etc. Instead, special IEEE numbers + are returned as appropriate, such as [infinity] for [1.0 /. 0.0], + [neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'') + for [0.0 /. 0.0]. These special numbers then propagate through + floating-point computations as expected: for instance, + [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan] + as argument returns [nan] as result. +*) + +external ( ~-. ) : float -> float = "%negfloat" +(** Unary negation. You can also write [-. e] instead of [~-. e]. *) + +external ( ~+. ) : float -> float = "%identity" +(** Unary addition. You can also write [+. e] instead of [~+. e]. + @since 3.12.0 +*) + +external ( +. ) : float -> float -> float = "%addfloat" +(** Floating-point addition *) + +external ( -. ) : float -> float -> float = "%subfloat" +(** Floating-point subtraction *) + +external ( *. ) : float -> float -> float = "%mulfloat" +(** Floating-point multiplication *) + +external ( /. ) : float -> float -> float = "%divfloat" +(** Floating-point division. *) + +external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float" +(** Exponentiation. *) + +external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float" +(** Square root. *) + +external exp : float -> float = "caml_exp_float" "exp" "float" +(** Exponential. *) + +external log : float -> float = "caml_log_float" "log" "float" +(** Natural logarithm. *) + +external log10 : float -> float = "caml_log10_float" "log10" "float" +(** Base 10 logarithm. *) + +external expm1 : float -> float = "caml_expm1_float" "caml_expm1" "float" +(** [expm1 x] computes [exp x -. 1.0], giving numerically-accurate results + even if [x] is close to [0.0]. + @since 3.12.0 +*) + +external log1p : float -> float = "caml_log1p_float" "caml_log1p" "float" +(** [log1p x] computes [log(1.0 +. x)] (natural logarithm), + giving numerically-accurate results even if [x] is close to [0.0]. + @since 3.12.0 +*) + +external cos : float -> float = "caml_cos_float" "cos" "float" +(** Cosine. Argument is in radians. *) + +external sin : float -> float = "caml_sin_float" "sin" "float" +(** Sine. Argument is in radians. *) + +external tan : float -> float = "caml_tan_float" "tan" "float" +(** Tangent. Argument is in radians. *) + +external acos : float -> float = "caml_acos_float" "acos" "float" +(** Arc cosine. The argument must fall within the range [[-1.0, 1.0]]. + Result is in radians and is between [0.0] and [pi]. *) + +external asin : float -> float = "caml_asin_float" "asin" "float" +(** Arc sine. The argument must fall within the range [[-1.0, 1.0]]. + Result is in radians and is between [-pi/2] and [pi/2]. *) + +external atan : float -> float = "caml_atan_float" "atan" "float" +(** Arc tangent. + Result is in radians and is between [-pi/2] and [pi/2]. *) + +external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" +(** [atan x y] returns the arc tangent of [y /. x]. The signs of [x] + and [y] are used to determine the quadrant of the result. + Result is in radians and is between [-pi] and [pi]. *) + +external cosh : float -> float = "caml_cosh_float" "cosh" "float" +(** Hyperbolic cosine. Argument is in radians. *) + +external sinh : float -> float = "caml_sinh_float" "sinh" "float" +(** Hyperbolic sine. Argument is in radians. *) + +external tanh : float -> float = "caml_tanh_float" "tanh" "float" +(** Hyperbolic tangent. Argument is in radians. *) + +external ceil : float -> float = "caml_ceil_float" "ceil" "float" +(** Round above to an integer value. + [ceil f] returns the least integer value greater than or equal to [f]. + The result is returned as a float. *) + +external floor : float -> float = "caml_floor_float" "floor" "float" +(** Round below to an integer value. + [floor f] returns the greatest integer value less than or + equal to [f]. + The result is returned as a float. *) + +external abs_float : float -> float = "%absfloat" +(** [abs_float f] returns the absolute value of [f]. *) + +external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" +(** [mod_float a b] returns the remainder of [a] with respect to + [b]. The returned value is [a -. n *. b], where [n] + is the quotient [a /. b] rounded towards zero to an integer. *) + +external frexp : float -> float * int = "caml_frexp_float" +(** [frexp f] returns the pair of the significant + and the exponent of [f]. When [f] is zero, the + significant [x] and the exponent [n] of [f] are equal to + zero. When [f] is non-zero, they are defined by + [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *) + +external ldexp : float -> int -> float = "caml_ldexp_float" +(** [ldexp x n] returns [x *. 2 ** n]. *) + +external modf : float -> float * float = "caml_modf_float" +(** [modf f] returns the pair of the fractional and integral + part of [f]. *) + +external float : int -> float = "%floatofint" +(** Same as {!Pervasives.float_of_int}. *) + +external float_of_int : int -> float = "%floatofint" +(** Convert an integer to floating-point. *) + +external truncate : float -> int = "%intoffloat" +(** Same as {!Pervasives.int_of_float}. *) + +external int_of_float : float -> int = "%intoffloat" +(** Truncate the given floating-point number to an integer. + The result is unspecified if the argument is [nan] or falls outside the + range of representable integers. *) + +val infinity : float +(** Positive infinity. *) + +val neg_infinity : float +(** Negative infinity. *) + +val nan : float +(** A special floating-point value denoting the result of an + undefined operation such as [0.0 /. 0.0]. Stands for + ``not a number''. Any floating-point operation with [nan] as + argument returns [nan] as result. As for floating-point comparisons, + [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] + if one or both of their arguments is [nan]. *) + +val max_float : float +(** The largest positive finite value of type [float]. *) + +val min_float : float +(** The smallest positive, non-zero, non-denormalized value of type [float]. *) + +val epsilon_float : float +(** The difference between [1.0] and the smallest exactly representable + floating-point number greater than [1.0]. *) + +type fpclass = + FP_normal (** Normal number, none of the below *) + | FP_subnormal (** Number very close to 0.0, has reduced precision *) + | FP_zero (** Number is 0.0 or -0.0 *) + | FP_infinite (** Number is positive or negative infinity *) + | FP_nan (** Not a number: result of an undefined operation *) +(** The five classes of floating-point numbers, as determined by + the {!Pervasives.classify_float} function. *) + +external classify_float : float -> fpclass = "caml_classify_float" +(** Return the class of the given floating-point number: + normal, subnormal, zero, infinite, or not a number. *) + + +(** {6 String operations} + + More string operations are provided in module {!String}. +*) + +val ( ^ ) : string -> string -> string +(** String concatenation. *) + + +(** {6 Character operations} + + More character operations are provided in module {!Char}. +*) + +external int_of_char : char -> int = "%identity" +(** Return the ASCII code of the argument. *) + +val char_of_int : int -> char +(** Return the character with the given ASCII code. + Raise [Invalid_argument "char_of_int"] if the argument is + outside the range 0--255. *) + + +(** {6 Unit operations} *) + +external ignore : 'a -> unit = "%ignore" +(** Discard the value of its argument and return [()]. + For instance, [ignore(f x)] discards the result of + the side-effecting function [f]. It is equivalent to + [f x; ()], except that the latter may generate a + compiler warning; writing [ignore(f x)] instead + avoids the warning. *) + + +(** {6 String conversion functions} *) + +val string_of_bool : bool -> string +(** Return the string representation of a boolean. *) + +val bool_of_string : string -> bool +(** Convert the given string to a boolean. + Raise [Invalid_argument "bool_of_string"] if the string is not + ["true"] or ["false"]. *) + +val string_of_int : int -> string +(** Return the string representation of an integer, in decimal. *) + +external int_of_string : string -> int = "caml_int_of_string" +(** Convert the given string to an integer. + The string is read in decimal (by default) or in hexadecimal (if it + begins with [0x] or [0X]), octal (if it begins with [0o] or [0O]), + or binary (if it begins with [0b] or [0B]). + Raise [Failure "int_of_string"] if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [int]. *) + +val string_of_float : float -> string +(** Return the string representation of a floating-point number. *) + +external float_of_string : string -> float = "caml_float_of_string" +(** Convert the given string to a float. Raise [Failure "float_of_string"] + if the given string is not a valid representation of a float. *) + + +(** {6 Pair operations} *) + +external fst : 'a * 'b -> 'a = "%field0" +(** Return the first component of a pair. *) + +external snd : 'a * 'b -> 'b = "%field1" +(** Return the second component of a pair. *) + + +(** {6 List operations} + + More list operations are provided in module {!List}. +*) + +val ( @ ) : 'a list -> 'a list -> 'a list +(** List concatenation. *) + + +(** {6 Input/output} *) + +type in_channel +(** The type of input channel. *) + +type out_channel +(** The type of output channel. *) + +val stdin : in_channel +(** The standard input for the process. *) + +val stdout : out_channel +(** The standard output for the process. *) + +val stderr : out_channel +(** The standard error ouput for the process. *) + + +(** {7 Output functions on standard output} *) + +val print_char : char -> unit +(** Print a character on standard output. *) + +val print_string : string -> unit +(** Print a string on standard output. *) + +val print_int : int -> unit +(** Print an integer, in decimal, on standard output. *) + +val print_float : float -> unit +(** Print a floating-point number, in decimal, on standard output. *) + +val print_endline : string -> unit +(** Print a string, followed by a newline character, on + standard output and flush standard output. *) + +val print_newline : unit -> unit +(** Print a newline character on standard output, and flush + standard output. This can be used to simulate line + buffering of standard output. *) + + +(** {7 Output functions on standard error} *) + +val prerr_char : char -> unit +(** Print a character on standard error. *) + +val prerr_string : string -> unit +(** Print a string on standard error. *) + +val prerr_int : int -> unit +(** Print an integer, in decimal, on standard error. *) + +val prerr_float : float -> unit +(** Print a floating-point number, in decimal, on standard error. *) + +val prerr_endline : string -> unit +(** Print a string, followed by a newline character on standard error + and flush standard error. *) + +val prerr_newline : unit -> unit +(** Print a newline character on standard error, and flush + standard error. *) + + +(** {7 Input functions on standard input} *) + +val read_line : unit -> string +(** Flush standard output, then read characters from standard input + until a newline character is encountered. Return the string of + all characters read, without the newline character at the end. *) + +val read_int : unit -> int +(** Flush standard output, then read one line from standard input + and convert it to an integer. Raise [Failure "int_of_string"] + if the line read is not a valid representation of an integer. *) + +val read_float : unit -> float +(** Flush standard output, then read one line from standard input + and convert it to a floating-point number. + The result is unspecified if the line read is not a valid + representation of a floating-point number. *) + + +(** {7 General output functions} *) + +type open_flag = + Open_rdonly (** open for reading. *) + | Open_wronly (** open for writing. *) + | Open_append (** open for appending: always write at end of file. *) + | Open_creat (** create the file if it does not exist. *) + | Open_trunc (** empty the file if it already exists. *) + | Open_excl (** fail if Open_creat and the file already exists. *) + | Open_binary (** open in binary mode (no conversion). *) + | Open_text (** open in text mode (may perform conversions). *) + | Open_nonblock (** open in non-blocking mode. *) +(** Opening modes for {!Pervasives.open_out_gen} and + {!Pervasives.open_in_gen}. *) + +val open_out : string -> out_channel +(** Open the named file for writing, and return a new output channel + on that file, positionned at the beginning of the file. The + file is truncated to zero length if it already exists. It + is created if it does not already exists. + Raise [Sys_error] if the file could not be opened. *) + +val open_out_bin : string -> out_channel +(** Same as {!Pervasives.open_out}, but the file is opened in binary mode, + so that no translation takes place during writes. On operating + systems that do not distinguish between text mode and binary + mode, this function behaves like {!Pervasives.open_out}. *) + +val open_out_gen : open_flag list -> int -> string -> out_channel +(** [open_out_gen mode perm filename] opens the named file for writing, + as described above. The extra argument [mode] + specify the opening mode. The extra argument [perm] specifies + the file permissions, in case the file must be created. + {!Pervasives.open_out} and {!Pervasives.open_out_bin} are special + cases of this function. *) + +val flush : out_channel -> unit +(** Flush the buffer associated with the given output channel, + performing all pending writes on that channel. + Interactive programs must be careful about flushing standard + output and standard error at the right time. *) + +val flush_all : unit -> unit +(** Flush all open output channels; ignore errors. *) + +val output_char : out_channel -> char -> unit +(** Write the character on the given output channel. *) + +val output_string : out_channel -> string -> unit +(** Write the string on the given output channel. *) + +val output : out_channel -> string -> int -> int -> unit +(** [output oc buf pos len] writes [len] characters from string [buf], + starting at offset [pos], to the given output channel [oc]. + Raise [Invalid_argument "output"] if [pos] and [len] do not + designate a valid substring of [buf]. *) + +val output_byte : out_channel -> int -> unit +(** Write one 8-bit integer (as the single character with that code) + on the given output channel. The given integer is taken modulo + 256. *) + +val output_binary_int : out_channel -> int -> unit +(** Write one integer in binary format (4 bytes, big-endian) + on the given output channel. + The given integer is taken modulo 2{^32}. + The only reliable way to read it back is through the + {!Pervasives.input_binary_int} function. The format is compatible across + all machines for a given version of Objective Caml. *) + +val output_value : out_channel -> 'a -> unit +(** Write the representation of a structured value of any type + to a channel. Circularities and sharing inside the value + are detected and preserved. The object can be read back, + by the function {!Pervasives.input_value}. See the description of module + {!Marshal} for more information. {!Pervasives.output_value} is equivalent + to {!Marshal.to_channel} with an empty list of flags. *) + +val seek_out : out_channel -> int -> unit +(** [seek_out chan pos] sets the current writing position to [pos] + for channel [chan]. This works only for regular files. On + files of other kinds (such as terminals, pipes and sockets), + the behavior is unspecified. *) + +val pos_out : out_channel -> int +(** Return the current writing position for the given channel. Does + not work on channels opened with the [Open_append] flag (returns + unspecified results). *) + +val out_channel_length : out_channel -> int +(** Return the size (number of characters) of the regular file + on which the given channel is opened. If the channel is opened + on a file that is not a regular file, the result is meaningless. *) + +val close_out : out_channel -> unit +(** Close the given channel, flushing all buffered write operations. + Output functions raise a [Sys_error] exception when they are + applied to a closed output channel, except [close_out] and [flush], + which do nothing when applied to an already closed channel. + Note that [close_out] may raise [Sys_error] if the operating + system signals an error when flushing or closing. *) + +val close_out_noerr : out_channel -> unit +(** Same as [close_out], but ignore all errors. *) + +val set_binary_mode_out : out_channel -> bool -> unit +(** [set_binary_mode_out oc true] sets the channel [oc] to binary + mode: no translations take place during output. + [set_binary_mode_out oc false] sets the channel [oc] to text + mode: depending on the operating system, some translations + may take place during output. For instance, under Windows, + end-of-lines will be translated from [\n] to [\r\n]. + This function has no effect under operating systems that + do not distinguish between text mode and binary mode. *) + + +(** {7 General input functions} *) + +val open_in : string -> in_channel +(** Open the named file for reading, and return a new input channel + on that file, positionned at the beginning of the file. + Raise [Sys_error] if the file could not be opened. *) + +val open_in_bin : string -> in_channel +(** Same as {!Pervasives.open_in}, but the file is opened in binary mode, + so that no translation takes place during reads. On operating + systems that do not distinguish between text mode and binary + mode, this function behaves like {!Pervasives.open_in}. *) + +val open_in_gen : open_flag list -> int -> string -> in_channel +(** [open_in_gen mode perm filename] opens the named file for reading, + as described above. The extra arguments + [mode] and [perm] specify the opening mode and file permissions. + {!Pervasives.open_in} and {!Pervasives.open_in_bin} are special + cases of this function. *) + +val input_char : in_channel -> char +(** Read one character from the given input channel. + Raise [End_of_file] if there are no more characters to read. *) + +val input_line : in_channel -> string +(** Read characters from the given input channel, until a + newline character is encountered. Return the string of + all characters read, without the newline character at the end. + Raise [End_of_file] if the end of the file is reached + at the beginning of line. *) + +val input : in_channel -> string -> int -> int -> int +(** [input ic buf pos len] reads up to [len] characters from + the given channel [ic], storing them in string [buf], starting at + character number [pos]. + It returns the actual number of characters read, between 0 and + [len] (inclusive). + A return value of 0 means that the end of file was reached. + A return value between 0 and [len] exclusive means that + not all requested [len] characters were read, either because + no more characters were available at that time, or because + the implementation found it convenient to do a partial read; + [input] must be called again to read the remaining characters, + if desired. (See also {!Pervasives.really_input} for reading + exactly [len] characters.) + Exception [Invalid_argument "input"] is raised if [pos] and [len] + do not designate a valid substring of [buf]. *) + +val really_input : in_channel -> string -> int -> int -> unit +(** [really_input ic buf pos len] reads [len] characters from channel [ic], + storing them in string [buf], starting at character number [pos]. + Raise [End_of_file] if the end of file is reached before [len] + characters have been read. + Raise [Invalid_argument "really_input"] if + [pos] and [len] do not designate a valid substring of [buf]. *) + +val input_byte : in_channel -> int +(** Same as {!Pervasives.input_char}, but return the 8-bit integer representing + the character. + Raise [End_of_file] if an end of file was reached. *) + +val input_binary_int : in_channel -> int +(** Read an integer encoded in binary format (4 bytes, big-endian) + from the given input channel. See {!Pervasives.output_binary_int}. + Raise [End_of_file] if an end of file was reached while reading the + integer. *) + +val input_value : in_channel -> 'a +(** Read the representation of a structured value, as produced + by {!Pervasives.output_value}, and return the corresponding value. + This function is identical to {!Marshal.from_channel}; + see the description of module {!Marshal} for more information, + in particular concerning the lack of type safety. *) + +val seek_in : in_channel -> int -> unit +(** [seek_in chan pos] sets the current reading position to [pos] + for channel [chan]. This works only for regular files. On + files of other kinds, the behavior is unspecified. *) + +val pos_in : in_channel -> int +(** Return the current reading position for the given channel. *) + +val in_channel_length : in_channel -> int +(** Return the size (number of characters) of the regular file + on which the given channel is opened. If the channel is opened + on a file that is not a regular file, the result is meaningless. + The returned size does not take into account the end-of-line + translations that can be performed when reading from a channel + opened in text mode. *) + +val close_in : in_channel -> unit +(** Close the given channel. Input functions raise a [Sys_error] + exception when they are applied to a closed input channel, + except [close_in], which does nothing when applied to an already + closed channel. Note that [close_in] may raise [Sys_error] if + the operating system signals an error. *) + +val close_in_noerr : in_channel -> unit +(** Same as [close_in], but ignore all errors. *) + +val set_binary_mode_in : in_channel -> bool -> unit +(** [set_binary_mode_in ic true] sets the channel [ic] to binary + mode: no translations take place during input. + [set_binary_mode_out ic false] sets the channel [ic] to text + mode: depending on the operating system, some translations + may take place during input. For instance, under Windows, + end-of-lines will be translated from [\r\n] to [\n]. + This function has no effect under operating systems that + do not distinguish between text mode and binary mode. *) + + +(** {7 Operations on large files} *) + +module LargeFile : + sig + val seek_out : out_channel -> int64 -> unit + val pos_out : out_channel -> int64 + val out_channel_length : out_channel -> int64 + val seek_in : in_channel -> int64 -> unit + val pos_in : in_channel -> int64 + val in_channel_length : in_channel -> int64 + end +(** Operations on large files. + This sub-module provides 64-bit variants of the channel functions + that manipulate file positions and file sizes. By representing + positions and sizes by 64-bit integers (type [int64]) instead of + regular integers (type [int]), these alternate functions allow + operating on files whose sizes are greater than [max_int]. *) + + +(** {6 References} *) + +type 'a ref = { mutable contents : 'a } +(** The type of references (mutable indirection cells) containing + a value of type ['a]. *) + +external ref : 'a -> 'a ref = "%makemutable" +(** Return a fresh reference containing the given value. *) + +external ( ! ) : 'a ref -> 'a = "%field0" +(** [!r] returns the current contents of reference [r]. + Equivalent to [fun r -> r.contents]. *) + +external ( := ) : 'a ref -> 'a -> unit = "%setfield0" +(** [r := a] stores the value of [a] in reference [r]. + Equivalent to [fun r v -> r.contents <- v]. *) + +external incr : int ref -> unit = "%incr" +(** Increment the integer contained in the given reference. + Equivalent to [fun r -> r := succ !r]. *) + +external decr : int ref -> unit = "%decr" +(** Decrement the integer contained in the given reference. + Equivalent to [fun r -> r := pred !r]. *) + + +(** {6 Operations on format strings} *) + +(** Format strings are used to read and print data using formatted input + functions in module {!Scanf} and formatted output in modules {!Printf} and + {!Format}. *) + +(** Format strings have a general and highly polymorphic type + [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in. + The two simplified types, [format] and [format4] below are + included for backward compatibility with earlier releases of Objective + Caml. + ['a] is the type of the parameters of the format, + ['c] is the result type for the "printf"-style function, + and ['b] is the type of the first argument given to + [%a] and [%t] printing functions. *) +type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 + +type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 + +val string_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string +(** Converts a format string into a string. *) + +external format_of_string : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" +(** [format_of_string s] returns a format string read from the string + literal [s]. *) + +val ( ^^ ) : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('f, 'b, 'c, 'e, 'g, 'h) format6 -> + ('a, 'b, 'c, 'd, 'g, 'h) format6 +(** [f1 ^^ f2] catenates formats [f1] and [f2]. The result is a format + that accepts arguments from [f1], then arguments from [f2]. *) + + +(** {6 Program termination} *) + +val exit : int -> 'a +(** Terminate the process, returning the given status code + to the operating system: usually 0 to indicate no errors, + and a small positive integer to indicate failure. + All open output channels are flushed with flush_all. + An implicit [exit 0] is performed each time a program + terminates normally. An implicit [exit 2] is performed if the program + terminates early because of an uncaught exception. *) + +val at_exit : (unit -> unit) -> unit +(** Register the given function to be called at program + termination time. The functions registered with [at_exit] + will be called when the program executes {!Pervasives.exit}, + or terminates, either normally or because of an uncaught exception. + The functions are called in ``last in, first out'' order: + the function most recently added with [at_exit] is called first. *) + +(**/**) + + +(** {6 For system use only, not for the casual user} *) + +val valid_float_lexem : string -> string + +val unsafe_really_input : in_channel -> string -> int -> int -> unit + +val do_at_exit : unit -> unit diff --git a/ocaml-binary-annot/stdlib/printexc.ml b/ocaml-binary-annot/stdlib/printexc.ml new file mode 100644 index 0000000000..9e435c590b --- /dev/null +++ b/ocaml-binary-annot/stdlib/printexc.ml @@ -0,0 +1,138 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Printf;; + +let printers = ref [] + +let locfmt = format_of_string "File \"%s\", line %d, characters %d-%d: %s";; + +let field x i = + let f = Obj.field x i in + if not (Obj.is_block f) then + sprintf "%d" (Obj.magic f : int) (* can also be a char *) + else if Obj.tag f = Obj.string_tag then + sprintf "%S" (Obj.magic f : string) + else if Obj.tag f = Obj.double_tag then + string_of_float (Obj.magic f : float) + else + "_" +;; +let rec other_fields x i = + if i >= Obj.size x then "" + else sprintf ", %s%s" (field x i) (other_fields x (i+1)) +;; +let fields x = + match Obj.size x with + | 0 -> "" + | 1 -> "" + | 2 -> sprintf "(%s)" (field x 1) + | n -> sprintf "(%s%s)" (field x 1) (other_fields x 2) +;; + +let to_string x = + let rec conv = function + | hd :: tl -> + (match try hd x with _ -> None with + | Some s -> s + | None -> conv tl) + | [] -> + match x with + | Out_of_memory -> "Out of memory" + | Stack_overflow -> "Stack overflow" + | Match_failure(file, line, char) -> + sprintf locfmt file line char (char+5) "Pattern matching failed" + | Assert_failure(file, line, char) -> + sprintf locfmt file line char (char+6) "Assertion failed" + | _ -> + let x = Obj.repr x in + let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in + constructor ^ (fields x) in + conv !printers + +let print fct arg = + try + fct arg + with x -> + eprintf "Uncaught exception: %s\n" (to_string x); + flush stderr; + raise x + +let catch fct arg = + try + fct arg + with x -> + flush stdout; + eprintf "Uncaught exception: %s\n" (to_string x); + exit 2 + +type loc_info = + | Known_location of bool (* is_raise *) + * string (* filename *) + * int (* line number *) + * int (* start char *) + * int (* end char *) + | Unknown_location of bool (*is_raise*) + +external get_exception_backtrace: + unit -> loc_info array option = "caml_get_exception_backtrace" + +let format_loc_info pos li = + let is_raise = + match li with + | Known_location(is_raise, _, _, _, _) -> is_raise + | Unknown_location(is_raise) -> is_raise in + let info = + if is_raise then + if pos = 0 then "Raised at" else "Re-raised at" + else + if pos = 0 then "Raised by primitive operation at" else "Called from" + in + match li with + | Known_location(is_raise, filename, lineno, startchar, endchar) -> + sprintf "%s file \"%s\", line %d, characters %d-%d" + info filename lineno startchar endchar + | Unknown_location(is_raise) -> + sprintf "%s unknown location" + info + +let print_backtrace outchan = + match get_exception_backtrace() with + | None -> + fprintf outchan + "(Program not linked with -g, cannot print stack backtrace)\n" + | Some a -> + for i = 0 to Array.length a - 1 do + if a.(i) <> Unknown_location true then + fprintf outchan "%s\n" (format_loc_info i a.(i)) + done + +let get_backtrace () = + match get_exception_backtrace() with + | None -> + "(Program not linked with -g, cannot print stack backtrace)\n" + | Some a -> + let b = Buffer.create 1024 in + for i = 0 to Array.length a - 1 do + if a.(i) <> Unknown_location true then + bprintf b "%s\n" (format_loc_info i a.(i)) + done; + Buffer.contents b + +external record_backtrace: bool -> unit = "caml_record_backtrace" +external backtrace_status: unit -> bool = "caml_backtrace_status" + +let register_printer fn = + printers := fn :: !printers diff --git a/ocaml-binary-annot/stdlib/printexc.mli b/ocaml-binary-annot/stdlib/printexc.mli new file mode 100644 index 0000000000..71a6af5533 --- /dev/null +++ b/ocaml-binary-annot/stdlib/printexc.mli @@ -0,0 +1,81 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Facilities for printing exceptions. *) + +val to_string: exn -> string +(** [Printexc.to_string e] returns a string representation of + the exception [e]. *) + +val print: ('a -> 'b) -> 'a -> 'b +(** [Printexc.print 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 exception is raised again. + The typical use is to catch and report exceptions that + escape a function application. *) + +val catch: ('a -> 'b) -> 'a -> 'b +(** [Printexc.catch fn x] is similar to {!Printexc.print}, but + aborts the program with exit code 2 after printing the + uncaught exception. This function is deprecated: the runtime + system is now able to print uncaught exceptions as precisely + as [Printexc.catch] does. Moreover, calling [Printexc.catch] + makes it harder to track the location of the exception + using the debugger or the stack backtrace facility. + So, do not use [Printexc.catch] in new code. *) + +val print_backtrace: out_channel -> unit +(** [Printexc.print_backtrace oc] prints an exception backtrace + on the output channel [oc]. The backtrace lists the program + locations where the most-recently raised exception was raised + and where it was propagated through function calls. + @since 3.11.0 +*) + +val get_backtrace: unit -> string +(** [Printexc.get_backtrace ()] returns a string containing the + same exception backtrace that [Printexc.print_backtrace] would + print. + @since 3.11.0 +*) + +val record_backtrace: bool -> unit +(** [Printexc.record_backtrace b] turns recording of exception backtraces + on (if [b = true]) or off (if [b = false]). Initially, backtraces + are not recorded, unless the [b] flag is given to the program + through the [OCAMLRUNPARAM] variable. + @since 3.11.0 +*) + +val backtrace_status: unit -> bool +(** [Printexc.backtrace_status()] returns [true] if exception + backtraces are currently recorded, [false] if not. + @since 3.11.0 +*) + +val register_printer: (exn -> string option) -> unit +(** [Printexc.register_printer fn] registers [fn] as an exception + printer. The printer should return [None] or raise an exception + if it does not know how to convert the passed exception, and [Some + s] with [s] the resulting string if it can convert the passed + exception. Exceptions raised by the printer are ignored. + + When converting an exception into a string, the printers will be invoked + in the reverse order of their registrations, until a printer returns + a [Some s] value (if no such printer exists, the runtime will use a + generic printer). + @since 3.11.2 +*) diff --git a/ocaml-binary-annot/stdlib/printf.ml b/ocaml-binary-annot/stdlib/printf.ml new file mode 100644 index 0000000000..a16c9184a1 --- /dev/null +++ b/ocaml-binary-annot/stdlib/printf.ml @@ -0,0 +1,698 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy and Pierre Weis, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +external format_float: string -> float -> string + = "caml_format_float" +external format_int: string -> int -> string + = "caml_format_int" +external format_int32: string -> int32 -> string + = "caml_int32_format" +external format_nativeint: string -> nativeint -> string + = "caml_nativeint_format" +external format_int64: string -> int64 -> string + = "caml_int64_format" + +module Sformat = struct + + type index;; + + external unsafe_index_of_int : int -> index = "%identity" + ;; + let index_of_int i = + if i >= 0 then unsafe_index_of_int i + else failwith ("Sformat.index_of_int: negative argument " ^ string_of_int i) + ;; + external int_of_index : index -> int = "%identity" + ;; + + let add_int_index i idx = index_of_int (i + int_of_index idx);; + let succ_index = add_int_index 1;; + (* Literal position are one-based (hence pred p instead of p). *) + let index_of_literal_position p = index_of_int (pred p);; + + external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int + = "%string_length" + ;; + external get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char + = "%string_safe_get" + ;; + external unsafe_get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char + = "%string_unsafe_get" + ;; + external unsafe_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string + = "%identity" + ;; + let sub fmt idx len = + String.sub (unsafe_to_string fmt) (int_of_index idx) len + ;; + let to_string fmt = sub fmt (unsafe_index_of_int 0) (length fmt) + ;; + +end +;; + +let bad_conversion sfmt i c = + invalid_arg + ("Printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^ + string_of_int i ^ " in format string ``" ^ sfmt ^ "''") +;; + +let bad_conversion_format fmt i c = + bad_conversion (Sformat.to_string fmt) i c +;; + +let incomplete_format fmt = + invalid_arg + ("Printf: premature end of format string ``" ^ + Sformat.to_string fmt ^ "''") +;; + +(* Parses a string conversion to return the specified length and the padding direction. *) +let parse_string_conversion sfmt = + let rec parse neg i = + if i >= String.length sfmt then (0, neg) else + match String.unsafe_get sfmt i with + | '1'..'9' -> + (int_of_string + (String.sub sfmt i (String.length sfmt - i - 1)), + neg) + | '-' -> + parse true (succ i) + | _ -> + parse neg (succ i) in + try parse false 1 with + | Failure _ -> bad_conversion sfmt 0 's' +;; + +(* Pad a (sub) string into a blank string of length [p], + on the right if [neg] is true, on the left otherwise. *) +let pad_string pad_char p neg s i len = + if p = len && i = 0 then s else + if p <= len then String.sub s i len else + let res = String.make p pad_char in + if neg + then String.blit s i res 0 len + else String.blit s i res (p - len) len; + res + +(* Format a string given a %s format, e.g. %40s or %-20s. + To do ?: ignore other flags (#, +, etc). *) +let format_string sfmt s = + let (p, neg) = parse_string_conversion sfmt in + pad_string ' ' p neg s 0 (String.length s) +;; + +(* Extract a format string out of [fmt] between [start] and [stop] inclusive. + ['*'] in the format are replaced by integers taken from the [widths] list. + [extract_format] returns a string which is the string representation of + the resulting format string. *) +let extract_format fmt start stop widths = + let skip_positional_spec start = + match Sformat.unsafe_get fmt start with + | '0'..'9' -> + let rec skip_int_literal i = + match Sformat.unsafe_get fmt i with + | '0'..'9' -> skip_int_literal (succ i) + | '$' -> succ i + | _ -> start in + skip_int_literal (succ start) + | _ -> start in + let start = skip_positional_spec (succ start) in + let b = Buffer.create (stop - start + 10) in + Buffer.add_char b '%'; + let rec fill_format i widths = + if i <= stop then + match (Sformat.unsafe_get fmt i, widths) with + | ('*', h :: t) -> + Buffer.add_string b (string_of_int h); + let i = skip_positional_spec (succ i) in + fill_format i t + | ('*', []) -> + assert false (* Should not happen since this is ill-typed. *) + | (c, _) -> + Buffer.add_char b c; + fill_format (succ i) widths in + fill_format start (List.rev widths); + Buffer.contents b +;; + +let extract_format_int conv fmt start stop widths = + let sfmt = extract_format fmt start stop widths in + match conv with + | 'n' | 'N' -> + sfmt.[String.length sfmt - 1] <- 'u'; + sfmt + | _ -> sfmt +;; + +let extract_format_float conv fmt start stop widths = + let sfmt = extract_format fmt start stop widths in + match conv with + | 'F' -> + sfmt.[String.length sfmt - 1] <- 'g'; + sfmt + | _ -> sfmt +;; + +(* Returns the position of the next character following the meta format + string, starting from position [i], inside a given format [fmt]. + According to the character [conv], the meta format string is + enclosed by the delimiters %{ and %} (when [conv = '{']) or %( and + %) (when [conv = '(']). Hence, [sub_format] returns the index of + the character following the [')'] or ['}'] that ends the meta format, + according to the character [conv]. *) +let sub_format incomplete_format bad_conversion_format conv fmt i = + let len = Sformat.length fmt in + let rec sub_fmt c i = + let close = if c = '(' then ')' else (* '{' *) '}' in + let rec sub j = + if j >= len then incomplete_format fmt else + match Sformat.get fmt j with + | '%' -> sub_sub (succ j) + | _ -> sub (succ j) + and sub_sub j = + if j >= len then incomplete_format fmt else + match Sformat.get fmt j with + | '(' | '{' as c -> + let j = sub_fmt c (succ j) in + sub (succ j) + | '}' | ')' as c -> + if c = close then succ j else bad_conversion_format fmt i c + | _ -> sub (succ j) in + sub i in + sub_fmt conv i +;; + +let sub_format_for_printf conv = + sub_format incomplete_format bad_conversion_format conv;; + +let iter_on_format_args fmt add_conv add_char = + + let lim = Sformat.length fmt - 1 in + + let rec scan_flags skip i = + if i > lim then incomplete_format fmt else + match Sformat.unsafe_get fmt i with + | '*' -> scan_flags skip (add_conv skip i 'i') + (* | '$' -> scan_flags skip (succ i) *** PR#4321 *) + | '#' | '-' | ' ' | '+' -> scan_flags skip (succ i) + | '_' -> scan_flags true (succ i) + | '0'..'9' + | '.' -> scan_flags skip (succ i) + | _ -> scan_conv skip i + and scan_conv skip i = + if i > lim then incomplete_format fmt else + match Sformat.unsafe_get fmt i with + | '%' | '!' | ',' -> succ i + | 's' | 'S' | '[' -> add_conv skip i 's' + | 'c' | 'C' -> add_conv skip i 'c' + | 'd' | 'i' |'o' | 'u' | 'x' | 'X' | 'N' -> add_conv skip i 'i' + | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> add_conv skip i 'f' + | 'B' | 'b' -> add_conv skip i 'B' + | 'a' | 'r' | 't' as conv -> add_conv skip i conv + | 'l' | 'n' | 'L' as conv -> + let j = succ i in + if j > lim then add_conv skip i 'i' else begin + match Sformat.get fmt j with + | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> + add_char (add_conv skip i conv) 'i' + | c -> add_conv skip i 'i' end + | '{' as conv -> + (* Just get a regular argument, skipping the specification. *) + let i = add_conv skip i conv in + (* To go on, find the index of the next char after the meta format. *) + let j = sub_format_for_printf conv fmt i in + (* Add the meta specification to the summary anyway. *) + let rec loop i = + if i < j - 2 then loop (add_char i (Sformat.get fmt i)) in + loop i; + (* Go on, starting at the closing brace to properly close the meta + specification in the summary. *) + scan_conv skip (j - 1) + | '(' as conv -> + (* Use the static format argument specification instead of + the runtime format argument value: they must have the same type + anyway. *) + scan_fmt (add_conv skip i conv) + | '}' | ')' as conv -> add_conv skip i conv + | conv -> bad_conversion_format fmt i conv + + and scan_fmt i = + if i < lim then + if Sformat.get fmt i = '%' + then scan_fmt (scan_flags false (succ i)) + else scan_fmt (succ i) + else i in + + ignore (scan_fmt 0) +;; + +(* Returns a string that summarizes the typing information that a given + format string contains. + For instance, [summarize_format_type "A number %d\n"] is "%i". + It also checks the well-formedness of the format string. *) +let summarize_format_type fmt = + let len = Sformat.length fmt in + let b = Buffer.create len in + let add_char i c = Buffer.add_char b c; succ i in + let add_conv skip i c = + if skip then Buffer.add_string b "%_" else Buffer.add_char b '%'; + add_char i c in + iter_on_format_args fmt add_conv add_char; + Buffer.contents b +;; + +module Ac = struct + type ac = { + mutable ac_rglr : int; + mutable ac_skip : int; + mutable ac_rdrs : int; + } +end +;; + +open Ac;; + +(* Computes the number of arguments of a format (including the flag + arguments if any). *) +let ac_of_format fmt = + let ac = { ac_rglr = 0; ac_skip = 0; ac_rdrs = 0; } in + let incr_ac skip c = + let inc = if c = 'a' then 2 else 1 in + if c = 'r' then ac.ac_rdrs <- ac.ac_rdrs + 1; + if skip + then ac.ac_skip <- ac.ac_skip + inc + else ac.ac_rglr <- ac.ac_rglr + inc in + let add_conv skip i c = + (* Just finishing a meta format: no additional argument to record. *) + if c <> ')' && c <> '}' then incr_ac skip c; + succ i + and add_char i c = succ i in + + iter_on_format_args fmt add_conv add_char; + ac +;; + +let count_arguments_of_format fmt = + let ac = ac_of_format fmt in + (* For printing only regular arguments have to be counted. *) + ac.ac_rglr +;; + +let list_iter_i f l = + let rec loop i = function + | [] -> () + | [x] -> f i x (* Tail calling [f] *) + | x :: xs -> f i x; loop (succ i) xs in + loop 0 l +;; + +(* ``Abstracting'' version of kprintf: returns a (curried) function that + will print when totally applied. + Note: in the following, we are careful not to be badly caught + by the compiler optimizations for the representation of arrays. *) +let kapr kpr fmt = + match count_arguments_of_format fmt with + | 0 -> kpr fmt [||] + | 1 -> Obj.magic (fun x -> + let a = Array.make 1 (Obj.repr 0) in + a.(0) <- x; + kpr fmt a) + | 2 -> Obj.magic (fun x y -> + let a = Array.make 2 (Obj.repr 0) in + a.(0) <- x; a.(1) <- y; + kpr fmt a) + | 3 -> Obj.magic (fun x y z -> + let a = Array.make 3 (Obj.repr 0) in + a.(0) <- x; a.(1) <- y; a.(2) <- z; + kpr fmt a) + | 4 -> Obj.magic (fun x y z t -> + let a = Array.make 4 (Obj.repr 0) in + a.(0) <- x; a.(1) <- y; a.(2) <- z; + a.(3) <- t; + kpr fmt a) + | 5 -> Obj.magic (fun x y z t u -> + let a = Array.make 5 (Obj.repr 0) in + a.(0) <- x; a.(1) <- y; a.(2) <- z; + a.(3) <- t; a.(4) <- u; + kpr fmt a) + | 6 -> Obj.magic (fun x y z t u v -> + let a = Array.make 6 (Obj.repr 0) in + a.(0) <- x; a.(1) <- y; a.(2) <- z; + a.(3) <- t; a.(4) <- u; a.(5) <- v; + kpr fmt a) + | nargs -> + let rec loop i args = + if i >= nargs then + let a = Array.make nargs (Obj.repr 0) in + list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args; + kpr fmt a + else Obj.magic (fun x -> loop (succ i) (x :: args)) in + loop 0 [] +;; + +type positional_specification = + | Spec_none | Spec_index of Sformat.index +;; + +(* To scan an optional positional parameter specification, + i.e. an integer followed by a [$]. + + Calling [got_spec] with appropriate arguments, we ``return'' a positional + specification and an index to go on scanning the [fmt] format at hand. + + Note that this is optimized for the regular case, i.e. no positional + parameter, since in this case we juste ``return'' the constant + [Spec_none]; in case we have a positional parameter, we ``return'' a + [Spec_index] [positional_specification] which a bit more costly. + + Note also that we do not support [*$] specifications, since this would + lead to type checking problems: a [*$] positional specification means + ``take the next argument to [printf] (which must be an integer value)'', + name this integer value $n$; [*$] now designates parameter $n$. + + Unfortunately, the type of a parameter specified via a [*$] positional + specification should be the type of the corresponding argument to + [printf], hence this should be the type of the $n$-th argument to [printf] + with $n$ being the {\em value} of the integer argument defining [*]; we + clearly cannot statically guess the value of this parameter in the general + case. Put it another way: this means type dependency, which is completely + out of scope of the Caml type algebra. *) + +let scan_positional_spec fmt got_spec n i = + match Sformat.unsafe_get fmt i with + | '0'..'9' as d -> + let rec get_int_literal accu j = + match Sformat.unsafe_get fmt j with + | '0'..'9' as d -> + get_int_literal (10 * accu + (int_of_char d - 48)) (succ j) + | '$' -> + if accu = 0 then + failwith "printf: bad positional specification (0)." else + got_spec (Spec_index (Sformat.index_of_literal_position accu)) (succ j) + (* Not a positional specification: tell so the caller, and go back to + scanning the format from the original [i] position we were called at + first. *) + | _ -> got_spec Spec_none i in + get_int_literal (int_of_char d - 48) (succ i) + (* No positional specification: tell so the caller, and go back to scanning + the format from the original [i] position. *) + | _ -> got_spec Spec_none i +;; + +(* Get the index of the next argument to printf, according to the given + positional specification. *) +let next_index spec n = + match spec with + | Spec_none -> Sformat.succ_index n + | Spec_index _ -> n +;; + +(* Get the index of the actual argument to printf, according to its + optional positional specification. *) +let get_index spec n = + match spec with + | Spec_none -> n + | Spec_index p -> p +;; + +(* Format a float argument as a valid Caml lexeme. *) +let format_float_lexeme = + + (* To be revised: this procedure should be a unique loop that performs the + validity check and the string lexeme modification at the same time. + Otherwise, it is too difficult to handle the strange padding facilities + given by printf. Let alone handling the correct widths indication, + knowing that we have sometime to add a '.' at the end of the result! + *) + + let make_valid_float_lexeme s = + (* Check if s is already a valid lexeme: + in this case do nothing, + otherwise turn s into a valid Caml lexeme. *) + let l = String.length s in + let rec valid_float_loop i = + if i >= l then s ^ "." else + match s.[i] with + (* Sure, this is already a valid float lexeme. *) + | '.' | 'e' | 'E' -> s + | _ -> valid_float_loop (i + 1) in + + valid_float_loop 0 in + + (fun sfmt x -> + let s = format_float sfmt x in + match classify_float x with + | FP_normal | FP_subnormal | FP_zero -> make_valid_float_lexeme s + | FP_nan | FP_infinite -> s) +;; + +(* Decode a format string and act on it. + [fmt] is the [printf] format string, and [pos] points to a [%] character in + the format string. + After consuming the appropriate number of arguments and formatting + them, one of the following five continuations described below is called: + + - [cont_s] for outputting a string (arguments: arg num, string, next pos) + - [cont_a] for performing a %a action (arguments: arg num, fn, arg, next pos) + - [cont_t] for performing a %t action (arguments: arg num, fn, next pos) + - [cont_f] for performing a flush action (arguments: arg num, next pos) + - [cont_m] for performing a %( action (arguments: arg num, sfmt, next pos) + + "arg num" is the index in array [args] of the next argument to [printf]. + "next pos" is the position in [fmt] of the first character following + the %conversion specification in [fmt]. *) + +(* Note: here, rather than test explicitly against [Sformat.length fmt] + to detect the end of the format, we use [Sformat.unsafe_get] and + rely on the fact that we'll get a "null" character if we access + one past the end of the string. These "null" characters are then + caught by the [_ -> bad_conversion] clauses below. + Don't do this at home, kids. *) +let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = + + let get_arg spec n = + Obj.magic (args.(Sformat.int_of_index (get_index spec n))) in + + let rec scan_positional n widths i = + let got_spec spec i = scan_flags spec n widths i in + scan_positional_spec fmt got_spec n i + + and scan_flags spec n widths i = + match Sformat.unsafe_get fmt i with + | '*' -> + let got_spec wspec i = + let (width : int) = get_arg wspec n in + scan_flags spec (next_index wspec n) (width :: widths) i in + scan_positional_spec fmt got_spec n (succ i) + | '0'..'9' + | '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i) + | _ -> scan_conv spec n widths i + + and scan_conv spec n widths i = + match Sformat.unsafe_get fmt i with + | '%' -> + cont_s n "%" (succ i) + | 's' | 'S' as conv -> + let (x : string) = get_arg spec n in + let x = if conv = 's' then x else "\"" ^ String.escaped x ^ "\"" in + let s = + (* Optimize for common case %s *) + if i = succ pos then x else + format_string (extract_format fmt pos i widths) x in + cont_s (next_index spec n) s (succ i) + | 'c' | 'C' as conv -> + let (x : char) = get_arg spec n in + let s = + if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in + cont_s (next_index spec n) s (succ i) + | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' as conv -> + let (x : int) = get_arg spec n in + let s = + format_int (extract_format_int conv fmt pos i widths) x in + cont_s (next_index spec n) s (succ i) + | 'f' | 'e' | 'E' | 'g' | 'G' -> + let (x : float) = get_arg spec n in + let s = format_float (extract_format fmt pos i widths) x in + cont_s (next_index spec n) s (succ i) + | 'F' as conv -> + let (x : float) = get_arg spec n in + let s = + if widths = [] then Pervasives.string_of_float x else + format_float_lexeme (extract_format_float conv fmt pos i widths) x in + cont_s (next_index spec n) s (succ i) + | 'B' | 'b' -> + let (x : bool) = get_arg spec n in + cont_s (next_index spec n) (string_of_bool x) (succ i) + | 'a' -> + let printer = get_arg spec n in + (* If the printer spec is Spec_none, go on as usual. + If the printer spec is Spec_index p, + printer's argument spec is Spec_index (succ_index p). *) + let n = Sformat.succ_index (get_index spec n) in + let arg = get_arg Spec_none n in + cont_a (next_index spec n) printer arg (succ i) + | 't' -> + let printer = get_arg spec n in + cont_t (next_index spec n) printer (succ i) + | 'l' | 'n' | 'L' as conv -> + begin match Sformat.unsafe_get fmt (succ i) with + | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> + let i = succ i in + let s = + match conv with + | 'l' -> + let (x : int32) = get_arg spec n in + format_int32 (extract_format fmt pos i widths) x + | 'n' -> + let (x : nativeint) = get_arg spec n in + format_nativeint (extract_format fmt pos i widths) x + | _ -> + let (x : int64) = get_arg spec n in + format_int64 (extract_format fmt pos i widths) x in + cont_s (next_index spec n) s (succ i) + | _ -> + let (x : int) = get_arg spec n in + let s = format_int (extract_format_int 'n' fmt pos i widths) x in + cont_s (next_index spec n) s (succ i) + end + | ',' -> cont_s n "" (succ i) + | '!' -> cont_f n (succ i) + | '{' | '(' as conv (* ')' '}' *) -> + let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg spec n in + let i = succ i in + let j = sub_format_for_printf conv fmt i in + if conv = '{' (* '}' *) then + (* Just print the format argument as a specification. *) + cont_s + (next_index spec n) + (summarize_format_type xf) + j else + (* Use the format argument instead of the format specification. *) + cont_m (next_index spec n) xf j + | (* '(' *) ')' -> + cont_s n "" (succ i) + | conv -> + bad_conversion_format fmt i conv in + + scan_positional n [] (succ pos) +;; + +let mkprintf to_s get_out outc outs flush k fmt = + + (* [out] is global to this definition of [pr], and must be shared by all its + recursive calls (if any). *) + let out = get_out fmt in + + let rec pr k n fmt v = + + let len = Sformat.length fmt in + + let rec doprn n i = + if i >= len then Obj.magic (k out) else + match Sformat.unsafe_get fmt i with + | '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m + | c -> outc out c; doprn n (succ i) + and cont_s n s i = + outs out s; doprn n i + and cont_a n printer arg i = + if to_s then + outs out ((Obj.magic printer : unit -> _ -> string) () arg) + else + printer out arg; + doprn n i + and cont_t n printer i = + if to_s then + outs out ((Obj.magic printer : unit -> string) ()) + else + printer out; + doprn n i + and cont_f n i = + flush out; doprn n i + and cont_m n xf i = + let m = Sformat.add_int_index (count_arguments_of_format xf) n in + pr (Obj.magic (fun _ -> doprn m i)) n xf v in + + doprn n 0 in + + let kpr = pr k (Sformat.index_of_int 0) in + + kapr kpr fmt +;; + +let kfprintf k oc = + mkprintf false (fun _ -> oc) output_char output_string flush k +;; +let ifprintf oc = kapr (fun _ -> Obj.magic ignore);; + +let fprintf oc = kfprintf ignore oc;; +let printf fmt = fprintf stdout fmt;; +let eprintf fmt = fprintf stderr fmt;; + +let kbprintf k b = + mkprintf false (fun _ -> b) Buffer.add_char Buffer.add_string ignore k +;; +let bprintf b = kbprintf ignore b;; + +let get_buff fmt = + let len = 2 * Sformat.length fmt in + Buffer.create len +;; + +let get_contents b = + let s = Buffer.contents b in + Buffer.clear b; + s +;; + +let get_cont k b = k (get_contents b);; + +let ksprintf k = + mkprintf true get_buff Buffer.add_char Buffer.add_string ignore (get_cont k) +;; + +let kprintf = ksprintf;; + +let sprintf fmt = ksprintf (fun s -> s) fmt;; + +module CamlinternalPr = struct + + module Sformat = Sformat;; + + module Tformat = struct + + type ac = + Ac.ac = { + mutable ac_rglr : int; + mutable ac_skip : int; + mutable ac_rdrs : int; + } + ;; + + let ac_of_format = ac_of_format;; + + let sub_format = sub_format;; + + let summarize_format_type = summarize_format_type;; + + let scan_format = scan_format;; + + let kapr = kapr;; + + end + ;; + +end +;; diff --git a/ocaml-binary-annot/stdlib/printf.mli b/ocaml-binary-annot/stdlib/printf.mli new file mode 100644 index 0000000000..35d390a5f4 --- /dev/null +++ b/ocaml-binary-annot/stdlib/printf.mli @@ -0,0 +1,218 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy and Pierre Weis, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Formatted output 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 arguments. + + Conversion specifications have the following form: + + [% \[flags\] \[width\] \[.precision\] type] + + In short, a conversion specification consists in the [%] character, + followed by optional modifiers and a type which is made of one or + two characters. The types and their meanings are: + + - [d], [i], [n], [l], [L], or [N]: 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. + - [o]: convert an integer argument to unsigned octal. + - [s]: insert a string argument. + - [S]: insert a string argument in Caml syntax (double quotes, escapes). + - [c]: insert a character argument. + - [C]: insert a character argument in Caml syntax (single quotes, escapes). + - [f]: convert a floating-point argument to decimal notation, + in the style [dddd.ddd]. + - [F]: convert a floating-point argument to Caml syntax ([dddd.] + or [dddd.ddd] or [d.ddd e+-dd]). + - [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] + - [b]: convert a boolean argument (for backward compatibility; do not + use in new programs). + - [ld], [li], [lu], [lx], [lX], [lo]: convert an [int32] argument to + the format specified by the second letter (decimal, hexadecimal, etc). + - [nd], [ni], [nu], [nx], [nX], [no]: convert a [nativeint] argument to + the format specified by the second letter. + - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: convert an [int64] argument to + the format specified by the second letter. + - [a]: user-defined printer. Takes two arguments and applies 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 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]. + - [\{ fmt %\}]: convert a format string argument. The argument must + have the same type as the internal format string [fmt]. + - [( fmt %)]: format string substitution. Takes a format string + argument and substitutes it to the internal format string [fmt] + to print following arguments. The argument must have the same + type as [fmt]. + - [!]: take no argument and flush the output. + - [%]: take no argument and output one [%] character. + - [,]: the no-op delimiter for conversion specifications. + + The optional [flags] are: + - [-]: left-justify the output (default is right justification). + - [0]: for numerical conversions, pad with zeroes instead of spaces. + - [+]: for numerical conversions, prefix number with a [+] sign if positive. + - space: for numerical conversions, prefix number with a space if positive. + - [#]: request an alternate formatting style for numbers. + + The optional [width] is an integer indicating the minimal + width of the result. For instance, [%6d] prints an integer, + prefixing it with spaces to fill at least 6 characters. + + The optional [precision] is a dot [.] followed by an integer + indicating how many digits follow the decimal point in the [%f], + [%e], and [%E] conversions. For instance, [%.4f] prints a [float] with + 4 fractional digits. + + The integer in a [width] or [precision] can also be specified as + [*], in which case an extra integer argument is taken to specify + the corresponding [width] or [precision]. This integer argument + precedes immediately the argument to print. + For instance, [%.*f] prints a [float] with as many fractional + digits as the value of the argument given before the float. *) + +val printf : ('a, out_channel, unit) format -> 'a +(** Same as {!Printf.fprintf}, but output on [stdout]. *) + +val eprintf : ('a, out_channel, unit) format -> 'a +(** Same as {!Printf.fprintf}, but output on [stderr]. *) + +val ifprintf : 'a -> ('b, 'a, unit) format -> 'b +(** Same as {!Printf.fprintf}, but does not print anything. + Useful to ignore some material when conditionally printing. + @since 3.10.0 +*) + +val sprintf : ('a, unit, string) format -> 'a +(** Same as {!Printf.fprintf}, but instead of printing on an output channel, + return a string containing the result of formatting the arguments. *) + +val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a +(** Same as {!Printf.fprintf}, but instead of printing on an output channel, + append the formatted arguments to the given extensible buffer + (see module {!Buffer}). *) + +(** Formatted output functions with continuations. *) + +val kfprintf : (out_channel -> 'a) -> out_channel -> + ('b, out_channel, unit, 'a) format4 -> 'b;; +(** Same as [fprintf], but instead of returning immediately, + passes the out channel to its first argument at the end of printing. + @since 3.09.0 +*) + +val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; +(** Same as [sprintf] above, but instead of returning the string, + passes it to the first argument. + @since 3.09.0 +*) + +val kbprintf : (Buffer.t -> 'a) -> Buffer.t -> + ('b, Buffer.t, unit, 'a) format4 -> 'b;; +(** Same as [bprintf], but instead of returning immediately, + passes the buffer to its first argument at the end of printing. + @since 3.10.0 +*) + +val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; +(** A deprecated synonym for [ksprintf]. *) + +(**/**) + +(* For system use only. Don't call directly. *) + +module CamlinternalPr : sig + + module Sformat : sig + type index;; + + val index_of_int : int -> index;; + external int_of_index : index -> int = "%identity";; + external unsafe_index_of_int : int -> index = "%identity";; + + val succ_index : index -> index;; + + val sub : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> index -> int -> string;; + val to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string;; + external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int + = "%string_length";; + external get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char + = "%string_safe_get";; + external unsafe_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string + = "%identity";; + external unsafe_get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char + = "%string_unsafe_get";; + + end;; + + module Tformat : sig + + type ac = { + mutable ac_rglr : int; + mutable ac_skip : int; + mutable ac_rdrs : int; + };; + + val ac_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ac;; + + val sub_format : + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int) -> + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char -> int) -> + char -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + int -> + int + + val summarize_format_type : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string + + val scan_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + 'g array -> + Sformat.index -> + int -> + (Sformat.index -> string -> int -> 'h) -> + (Sformat.index -> 'i -> 'j -> int -> 'h) -> + (Sformat.index -> 'k -> int -> 'h) -> + (Sformat.index -> int -> 'h) -> + (Sformat.index -> ('l, 'm, 'n, 'o, 'p, 'q) format6 -> int -> 'h) -> + 'h + + val kapr : + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> Obj.t array -> 'g) -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + 'g + + end;; + +end;; diff --git a/ocaml-binary-annot/stdlib/queue.ml b/ocaml-binary-annot/stdlib/queue.ml new file mode 100644 index 0000000000..9e21686a13 --- /dev/null +++ b/ocaml-binary-annot/stdlib/queue.ml @@ -0,0 +1,165 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* François Pottier, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +exception Empty + +(* O'Caml currently does not allow the components of a sum type to be + mutable. Yet, for optimal space efficiency, we must have cons cells + whose [next] field is mutable. This leads us to define a type of + cyclic lists, so as to eliminate the [Nil] case and the sum + type. *) + +type 'a cell = { + content: 'a; + mutable next: 'a cell + } + +(* A queue is a reference to either nothing or some cell of a cyclic + list. By convention, that cell is to be viewed as the last cell in + the queue. The first cell in the queue is then found in constant + time: it is the next cell in the cyclic list. The queue's length is + also recorded, so as to make [length] a constant-time operation. + + The [tail] field should really be of type ['a cell option], but + then it would be [None] when [length] is 0 and [Some] otherwise, + leading to redundant memory allocation and accesses. We avoid this + overhead by filling [tail] with a dummy value when [length] is 0. + Of course, this requires bending the type system's arm slightly, + because it does not have dependent sums. *) + +type 'a t = { + mutable length: int; + mutable tail: 'a cell + } + +let create () = { + length = 0; + tail = Obj.magic None +} + +let clear q = + q.length <- 0; + q.tail <- Obj.magic None + +let add x q = + q.length <- q.length + 1; + if q.length = 1 then + let rec cell = { + content = x; + next = cell + } in + q.tail <- cell + else + let tail = q.tail in + let head = tail.next in + let cell = { + content = x; + next = head + } in + tail.next <- cell; + q.tail <- cell + +let push = + add + +let peek q = + if q.length = 0 then + raise Empty + else + q.tail.next.content + +let top = + peek + +let take q = + if q.length = 0 then raise Empty; + q.length <- q.length - 1; + let tail = q.tail in + let head = tail.next in + if head == tail then + q.tail <- Obj.magic None + else + tail.next <- head.next; + head.content + +let pop = + take + +let copy q = + if q.length = 0 then + create() + else + let tail = q.tail in + + let rec tail' = { + content = tail.content; + next = tail' + } in + + let rec copy cell = + if cell == tail then tail' + else { + content = cell.content; + next = copy cell.next + } in + + tail'.next <- copy tail.next; + { + length = q.length; + tail = tail' + } + +let is_empty q = + q.length = 0 + +let length q = + q.length + +let iter f q = + if q.length > 0 then + let tail = q.tail in + let rec iter cell = + f cell.content; + if cell != tail then + iter cell.next in + iter tail.next + +let fold f accu q = + if q.length = 0 then + accu + else + let tail = q.tail in + let rec fold accu cell = + let accu = f accu cell.content in + if cell == tail then + accu + else + fold accu cell.next in + fold accu tail.next + +let transfer q1 q2 = + let length1 = q1.length in + if length1 > 0 then + let tail1 = q1.tail in + clear q1; + if q2.length > 0 then begin + let tail2 = q2.tail in + let head1 = tail1.next in + let head2 = tail2.next in + tail1.next <- head2; + tail2.next <- head1 + end; + q2.length <- q2.length + length1; + q2.tail <- tail1 diff --git a/ocaml-binary-annot/stdlib/queue.mli b/ocaml-binary-annot/stdlib/queue.mli new file mode 100644 index 0000000000..085cfb003e --- /dev/null +++ b/ocaml-binary-annot/stdlib/queue.mli @@ -0,0 +1,78 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** First-in first-out 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 {!Queue.take} or {!Queue.peek} is applied to an empty queue. *) + + +val create : 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 push : 'a -> 'a t -> unit +(** [push] is a synonym for [add]. *) + +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 pop : 'a t -> 'a +(** [pop] is a synonym for [take]. *) + +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 top : 'a t -> 'a +(** [top] is a synonym for [peek]. *) + +val clear : 'a t -> unit +(** Discard all elements from a queue. *) + +val copy : 'a t -> 'a t +(** Return a copy of the given queue. *) + +val is_empty : 'a t -> bool +(** Return [true] if the given queue is empty, [false] otherwise. *) + +val length : 'a t -> int +(** Return the number of elements in a queue. *) + +val iter : ('a -> unit) -> '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. *) + +val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b +(** [fold f accu q] is equivalent to [List.fold_left f accu l], + where [l] is the list of [q]'s elements. The queue remains + unchanged. *) + +val transfer : 'a t -> 'a t -> unit +(** [transfer q1 q2] adds all of [q1]'s elements at the end of + the queue [q2], then clears [q1]. It is equivalent to the + sequence [iter (fun x -> add x q2) q1; clear q1], but runs + in constant time. *) diff --git a/ocaml-binary-annot/stdlib/random.ml b/ocaml-binary-annot/stdlib/random.ml new file mode 100644 index 0000000000..bd3979914a --- /dev/null +++ b/ocaml-binary-annot/stdlib/random.ml @@ -0,0 +1,275 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Pseudo-random number generator + This is a lagged-Fibonacci F(55, 24, +) with a modified addition + function to enhance the mixing of bits. + If we use normal addition, the low-order bit fails tests 1 and 7 + of the Diehard test suite, and bits 1 and 2 also fail test 7. + If we use multiplication as suggested by Marsaglia, it doesn't fare + much better. + By mixing the bits of one of the numbers before addition (XOR the + 5 high-order bits into the low-order bits), we get a generator that + passes all the Diehard tests. +*) + +external random_seed: unit -> int = "caml_sys_random_seed";; + +module State = struct + + type t = { st : int array; mutable idx : int };; + + let new_state () = { st = Array.make 55 0; idx = 0 };; + let assign st1 st2 = + Array.blit st2.st 0 st1.st 0 55; + st1.idx <- st2.idx; + ;; + + let full_init s seed = + let combine accu x = Digest.string (accu ^ string_of_int x) in + let extract d = + Char.code d.[0] + (Char.code d.[1] lsl 8) + (Char.code d.[2] lsl 16) + + (Char.code d.[3] lsl 24) + in + let seed = if seed = [| |] then [| 0 |] else seed in + let l = Array.length seed in + for i = 0 to 54 do + s.st.(i) <- i; + done; + let accu = ref "x" in + for i = 0 to 54 + max 55 l do + let j = i mod 55 in + let k = i mod l in + accu := combine !accu seed.(k); + s.st.(j) <- s.st.(j) lxor extract !accu; + done; + s.idx <- 0; + ;; + + let make seed = + let result = new_state () in + full_init result seed; + result + ;; + + let make_self_init () = make [| random_seed () |];; + + let copy s = + let result = new_state () in + assign result s; + result + ;; + + (* Returns 30 random bits as an integer 0 <= x < 1073741824 *) + let bits s = + s.idx <- (s.idx + 1) mod 55; + let newval = s.st.((s.idx + 24) mod 55) + + (s.st.(s.idx) lxor ((s.st.(s.idx) lsr 25) land 31)) in + s.st.(s.idx) <- newval; + newval land 0x3FFFFFFF (* land is needed for 64-bit arch *) + ;; + + let rec intaux s n = + let r = bits s in + let v = r mod n in + if r - v > 0x3FFFFFFF - n + 1 then intaux s n else v + ;; + let int s bound = + if bound > 0x3FFFFFFF || bound <= 0 + then invalid_arg "Random.int" + else intaux s bound + ;; + + let rec int32aux s n = + let b1 = Int32.of_int (bits s) in + let b2 = Int32.shift_left (Int32.of_int (bits s land 1)) 30 in + let r = Int32.logor b1 b2 in + let v = Int32.rem r n in + if Int32.sub r v > Int32.add (Int32.sub Int32.max_int n) 1l + then int32aux s n + else v + ;; + let int32 s bound = + if bound <= 0l + then invalid_arg "Random.int32" + else int32aux s bound + ;; + + let rec int64aux s n = + let b1 = Int64.of_int (bits s) in + let b2 = Int64.shift_left (Int64.of_int (bits s)) 30 in + let b3 = Int64.shift_left (Int64.of_int (bits s land 7)) 60 in + let r = Int64.logor b1 (Int64.logor b2 b3) in + let v = Int64.rem r n in + if Int64.sub r v > Int64.add (Int64.sub Int64.max_int n) 1L + then int64aux s n + else v + ;; + let int64 s bound = + if bound <= 0L + then invalid_arg "Random.int64" + else int64aux s bound + ;; + + let nativeint = + if Nativeint.size = 32 + then fun s bound -> Nativeint.of_int32 (int32 s (Nativeint.to_int32 bound)) + else fun s bound -> Int64.to_nativeint (int64 s (Int64.of_nativeint bound)) + ;; + + (* Returns a float 0 <= x < 1 with at most 90 bits of precision. *) + let rawfloat s = + let scale = 1073741824.0 + and r0 = Pervasives.float (bits s) + and r1 = Pervasives.float (bits s) + and r2 = Pervasives.float (bits s) + in ((r0 /. scale +. r1) /. scale +. r2) /. scale + ;; + + let float s bound = rawfloat s *. bound;; + + let bool s = (bits s land 1 = 0);; + +end;; + +(* This is the state you get with [init 27182818]. *) +let default = { + State.st = [| + 0x7ae2522b; 0x5d8d4634; 0x15b4fad0; 0x18b14ace; 0x12f8a3c4; 0x7b086c47; + 0x16d467d6; 0x501d91c7; 0x321df177; 0x4176c193; 0x1ff72bf1; 0x5e889109; + 0x0b464b18; 0x6b86b97c; 0x4891da48; 0x03137463; 0x485ac5a1; 0x15d61f2f; + 0x7bced359; 0x69c1c132; 0x7a86766e; 0x366d8c86; 0x1f5b6222; 0x7ce1b59f; + 0x2ebf78e1; 0x67cd1b86; 0x658f3dc3; 0x789a8194; 0x42e4c44c; 0x58c43f7d; + 0x0f6e534f; 0x1e7df359; 0x455d0b7e; 0x10e84e7e; 0x126198e4; 0x4e7722cb; + 0x5cbede28; 0x7391b964; 0x7d40e92a; 0x4c59933d; 0x0b8cd0b7; 0x64efff1c; + 0x2803fdaa; 0x08ebc72e; 0x4f522e32; 0x45398edc; 0x2144a04c; 0x4aef3cbd; + 0x41ad4719; 0x75b93cd6; 0x2a559d4f; 0x5e6fd768; 0x66e27f36; 0x186f18c3; + 0x2fbf967a; + |]; + State.idx = 0; +};; + +let bits () = State.bits default;; +let int bound = State.int default bound;; +let int32 bound = State.int32 default bound;; +let nativeint bound = State.nativeint default bound;; +let int64 bound = State.int64 default bound;; +let float scale = State.float default scale;; +let bool () = State.bool default;; + +let full_init seed = State.full_init default seed;; +let init seed = State.full_init default [| seed |];; +let self_init () = init (random_seed());; + +(* Manipulating the current state. *) + +let get_state () = State.copy default;; +let set_state s = State.assign default s;; + +(******************** + +(* Test functions. Not included in the library. + The [chisquare] function should be called with n > 10r. + It returns a triple (low, actual, high). + If low <= actual <= high, the [g] function passed the test, + otherwise it failed. + + Some results: + +init 27182818; chisquare int 100000 1000;; +init 27182818; chisquare int 100000 100;; +init 27182818; chisquare int 100000 5000;; +init 27182818; chisquare int 1000000 1000;; +init 27182818; chisquare int 100000 1024;; +init 299792643; chisquare int 100000 1024;; +init 14142136; chisquare int 100000 1024;; +init 27182818; init_diff 1024; chisquare diff 100000 1024;; +init 27182818; init_diff 100; chisquare diff 100000 100;; +init 27182818; init_diff2 1024; chisquare diff2 100000 1024;; +init 27182818; init_diff2 100; chisquare diff2 100000 100;; +init 14142136; init_diff2 100; chisquare diff2 100000 100;; +init 299792643; init_diff2 100; chisquare diff2 100000 100;; +- : float * float * float = (936.754446796632465, 997.5, 1063.24555320336754) +# - : float * float * float = (80., 89.7400000000052387, 120.) +# - : float * float * float = (4858.57864376269, 5045.5, 5141.42135623731) +# - : float * float * float = +(936.754446796632465, 944.805999999982305, 1063.24555320336754) +# - : float * float * float = (960., 1019.19744000000355, 1088.) +# - : float * float * float = (960., 1059.31776000000536, 1088.) +# - : float * float * float = (960., 1039.98463999999512, 1088.) +# - : float * float * float = (960., 1054.38207999999577, 1088.) +# - : float * float * float = (80., 90.096000000005, 120.) +# - : float * float * float = (960., 1076.78720000000612, 1088.) +# - : float * float * float = (80., 85.1760000000067521, 120.) +# - : float * float * float = (80., 85.2160000000003492, 120.) +# - : float * float * float = (80., 80.6220000000030268, 120.) + +*) + +(* Return the sum of the squares of v[i0,i1[ *) +let rec sumsq v i0 i1 = + if i0 >= i1 then 0.0 + else if i1 = i0 + 1 then Pervasives.float v.(i0) *. Pervasives.float v.(i0) + else sumsq v i0 ((i0+i1)/2) +. sumsq v ((i0+i1)/2) i1 +;; + +let chisquare g n r = + if n <= 10 * r then invalid_arg "chisquare"; + let f = Array.make r 0 in + for i = 1 to n do + let t = g r in + f.(t) <- f.(t) + 1 + done; + let t = sumsq f 0 r + and r = Pervasives.float r + and n = Pervasives.float n in + let sr = 2.0 *. sqrt r in + (r -. sr, (r *. t /. n) -. n, r +. sr) +;; + +(* This is to test for linear dependencies between successive random numbers. +*) +let st = ref 0;; +let init_diff r = st := int r;; +let diff r = + let x1 = !st + and x2 = int r + in + st := x2; + if x1 >= x2 then + x1 - x2 + else + r + x1 - x2 +;; + +let st1 = ref 0 +and st2 = ref 0 +;; + +(* This is to test for quadratic dependencies between successive random + numbers. +*) +let init_diff2 r = st1 := int r; st2 := int r;; +let diff2 r = + let x1 = !st1 + and x2 = !st2 + and x3 = int r + in + st1 := x2; + st2 := x3; + (x3 - x2 - x2 + x1 + 2*r) mod r +;; + +********************) diff --git a/ocaml-binary-annot/stdlib/random.mli b/ocaml-binary-annot/stdlib/random.mli new file mode 100644 index 0000000000..88387d191b --- /dev/null +++ b/ocaml-binary-annot/stdlib/random.mli @@ -0,0 +1,104 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Pseudo-random number generators (PRNG). *) + +(** {6 Basic functions} *) + +val init : int -> unit +(** Initialize the generator, using the argument as a seed. + The same seed will always yield the same sequence of numbers. *) + +val full_init : int array -> unit +(** Same as {!Random.init} but takes more data as seed. *) + +val self_init : unit -> unit +(** Initialize the generator with a more-or-less random seed chosen + in a system-dependent way. *) + +val bits : unit -> int +(** Return 30 random bits in a nonnegative integer. + @before 3.12.0 used a different algorithm (affects all the following + functions) +*) + +val int : int -> int +(** [Random.int bound] returns a random integer between 0 (inclusive) + and [bound] (exclusive). [bound] must be greater than 0 and less + than 2{^30}. *) + +val int32 : Int32.t -> Int32.t;; +(** [Random.int32 bound] returns a random integer between 0 (inclusive) + and [bound] (exclusive). [bound] must be greater than 0. *) + +val nativeint : Nativeint.t -> Nativeint.t;; +(** [Random.nativeint bound] returns a random integer between 0 (inclusive) + and [bound] (exclusive). [bound] must be greater than 0. *) + +val int64 : Int64.t -> Int64.t;; +(** [Random.int64 bound] returns a random integer between 0 (inclusive) + and [bound] (exclusive). [bound] must be greater than 0. *) + +val float : float -> float +(** [Random.float bound] returns a random floating-point number + between 0 (inclusive) and [bound] (exclusive). If [bound] is + negative, the result is negative or zero. If [bound] is 0, + the result is 0. *) + +val bool : unit -> bool +(** [Random.bool ()] returns [true] or [false] with probability 0.5 each. *) + + +(** {6 Advanced functions} *) + +(** The functions from module [State] manipulate the current state + of the random generator explicitely. + This allows using one or several deterministic PRNGs, + even in a multi-threaded program, without interference from + other parts of the program. +*) + +module State : sig + type t + (** The type of PRNG states. *) + + val make : int array -> t + (** Create a new state and initialize it with the given seed. *) + + val make_self_init : unit -> t + (** Create a new state and initialize it with a system-dependent + low-entropy seed. *) + + val copy : t -> t + (** Return a copy of the given state. *) + + val bits : t -> int + val int : t -> int -> int + val int32 : t -> Int32.t -> Int32.t + val nativeint : t -> Nativeint.t -> Nativeint.t + val int64 : t -> Int64.t -> Int64.t + val float : t -> float -> float + val bool : t -> bool + (** These functions are the same as the basic functions, except that they + use (and update) the given PRNG state instead of the default one. + *) +end;; + + +val get_state : unit -> State.t +(** Return the current state of the generator used by the basic functions. *) + +val set_state : State.t -> unit +(** Set the state of the generator used by the basic functions. *) diff --git a/ocaml-binary-annot/stdlib/scanf.ml b/ocaml-binary-annot/stdlib/scanf.ml new file mode 100644 index 0000000000..3d3d16c233 --- /dev/null +++ b/ocaml-binary-annot/stdlib/scanf.ml @@ -0,0 +1,1515 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Pierre Weis, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The run-time library for scanners. *) + +(* Scanning buffers. *) +module type SCANNING = sig + + type in_channel;; + + type scanbuf = in_channel;; + + val stdin : in_channel;; + (* The scanning buffer reading from [Pervasives.stdin]. + [stdib] is equivalent to [Scanning.from_channel Pervasives.stdin]. *) + + val stdib : in_channel;; + (* An alias for [Scanf.stdin], the scanning buffer reading from + [Pervasives.stdin]. *) + + val next_char : scanbuf -> char;; + (* [Scanning.next_char ib] advance the scanning buffer for + one character. + If no more character can be read, sets a end of file condition and + returns '\000'. *) + + val invalidate_current_char : scanbuf -> unit;; + (* [Scanning.invalidate_current_char ib] mark the current_char as already + scanned. *) + + val peek_char : scanbuf -> char;; + (* [Scanning.peek_char ib] returns the current char available in + the buffer or reads one if necessary (when the current character is + already scanned). + If no character can be read, sets an end of file condition and + returns '\000'. *) + + val checked_peek_char : scanbuf -> char;; + (* Same as above but always returns a valid char or fails: + instead of returning a null char when the reading method of the + input buffer has reached an end of file, the function raises exception + [End_of_file]. *) + + val store_char : int -> scanbuf -> char -> int;; + (* [Scanning.store_char lim ib c] adds [c] to the token buffer + of the scanning buffer. It also advances the scanning buffer for one + character and returns [lim - 1], indicating the new limit + for the length of the current token. *) + + val skip_char : int -> scanbuf -> int;; + (* [Scanning.skip_char lim ib] ignores the current character. *) + + val ignore_char : int -> scanbuf -> int;; + (* [Scanning.ignore_char ib lim] ignores the current character and + decrements the limit. *) + + val token : scanbuf -> string;; + (* [Scanning.token ib] returns the string stored into the token + buffer of the scanning buffer: it returns the token matched by the + format. *) + + val reset_token : scanbuf -> unit;; + (* [Scanning.reset_token ib] resets the token buffer of + the given scanning buffer. *) + + val char_count : scanbuf -> int;; + (* [Scanning.char_count ib] returns the number of characters + read so far from the given buffer. *) + + val line_count : scanbuf -> int;; + (* [Scanning.line_count ib] returns the number of new line + characters read so far from the given buffer. *) + + val token_count : scanbuf -> int;; + (* [Scanning.token_count ib] returns the number of tokens read + so far from [ib]. *) + + val eof : scanbuf -> bool;; + (* [Scanning.eof ib] returns the end of input condition + of the given buffer. *) + + val end_of_input : scanbuf -> bool;; + (* [Scanning.end_of_input ib] tests the end of input condition + of the given buffer (if no char has ever been read, an attempt to + read one is performed). *) + + val beginning_of_input : scanbuf -> bool;; + (* [Scanning.beginning_of_input ib] tests the beginning of input + condition of the given buffer. *) + + val name_of_input : scanbuf -> string;; + (* [Scanning.name_of_input ib] returns the name of the character + source for input buffer [ib]. *) + + val open_in : string -> scanbuf;; + val open_in_bin : string -> scanbuf;; + val from_file : string -> scanbuf;; + val from_file_bin : string -> scanbuf;; + val from_string : string -> scanbuf;; + val from_function : (unit -> char) -> scanbuf;; + val from_channel : Pervasives.in_channel -> scanbuf;; + + val close_in : scanbuf -> unit;; + +end +;; + +module Scanning : SCANNING = struct + + (* The run-time library for scanf. *) + type in_channel_name = + | From_file of string * Pervasives.in_channel + | From_string + | From_function + | From_channel of Pervasives.in_channel + ;; + + type in_channel = { + mutable eof : bool; + mutable current_char : char; + mutable current_char_is_valid : bool; + mutable char_count : int; + mutable line_count : int; + mutable token_count : int; + mutable get_next_char : unit -> char; + tokbuf : Buffer.t; + input_name : in_channel_name; + } + ;; + + type scanbuf = in_channel;; + + let null_char = '\000';; + + (* Reads a new character from input buffer. Next_char never fails, + even in case of end of input: it then simply sets the end of file + condition. *) + let next_char ib = + try + let c = ib.get_next_char () in + ib.current_char <- c; + ib.current_char_is_valid <- true; + ib.char_count <- succ ib.char_count; + if c = '\n' then ib.line_count <- succ ib.line_count; + c with + | End_of_file -> + let c = null_char in + ib.current_char <- c; + ib.current_char_is_valid <- false; + ib.eof <- true; + c + ;; + + let peek_char ib = + if ib.current_char_is_valid then ib.current_char else next_char ib;; + + (* Returns a valid current char for the input buffer. In particular + no irrelevant null character (as set by [next_char] in case of end + of input) is returned, since [End_of_file] is raised when + [next_char] sets the end of file condition while trying to read a + new character. *) + let checked_peek_char ib = + let c = peek_char ib in + if ib.eof then raise End_of_file; + c + ;; + + let end_of_input ib = + ignore (peek_char ib); + ib.eof + ;; + + let eof ib = ib.eof;; + + let beginning_of_input ib = ib.char_count = 0;; + let name_of_input ib = + match ib.input_name with + | From_file (fname, _ic) -> fname + | From_string -> "unnamed character string" + | From_function -> "unnamed function" + | From_channel _ic -> "unnamed pervasives input channel" + ;; + + let char_count ib = + if ib.current_char_is_valid then ib.char_count - 1 else ib.char_count + ;; + let line_count ib = ib.line_count;; + let reset_token ib = Buffer.reset ib.tokbuf;; + let invalidate_current_char ib = ib.current_char_is_valid <- false;; + + let token ib = + let tokbuf = ib.tokbuf in + let tok = Buffer.contents tokbuf in + Buffer.clear tokbuf; + ib.token_count <- succ ib.token_count; + tok + ;; + + let token_count ib = ib.token_count;; + + let skip_char max ib = + invalidate_current_char ib; + max + ;; + + let ignore_char max ib = skip_char (max - 1) ib;; + + let store_char max ib c = + Buffer.add_char ib.tokbuf c; + ignore_char max ib + ;; + + let default_token_buffer_size = 1024;; + + let create iname next = { + eof = false; + current_char = null_char; + current_char_is_valid = false; + char_count = 0; + line_count = 0; + token_count = 0; + get_next_char = next; + tokbuf = Buffer.create default_token_buffer_size; + input_name = iname; + } + ;; + + let from_string s = + let i = ref 0 in + let len = String.length s in + let next () = + if !i >= len then raise End_of_file else + let c = s.[!i] in + incr i; + c in + create From_string next + ;; + + let from_function = create From_function;; + + (* Scanning from an input channel. *) + + (* Position of the problem: + + We cannot prevent the scanning mechanism to use one lookahead character, + if needed by the semantics of the format string specifications (e.g. a + trailing ``skip space'' specification in the format string); in this case, + the mandatory lookahead character is indeed read from the input and not + used to return the token read. It is thus mandatory to be able to store + an unused lookahead character somewhere to get it as the first character + of the next scan. + + To circumvent this problem, all the scanning functions get a low level + input buffer argument where they store the lookahead character when + needed; additionally, the input buffer is the only source of character of + a scanner. The [scanbuf] input buffers are defined in module {!Scanning}. + + Now we understand that it is extremely important that related successive + calls to scanners indeed read from the same input buffer. In effect, if a + scanner [scan1] is reading from [ib1] and stores an unused lookahead + character [c1] into its input buffer [ib1], then another scanner [scan2] + not reading from the same buffer [ib1] will miss the character [c], + seemingly vanished in the air from the point of view of [scan2]. + + This mechanism works perfectly to read from strings, from files, and from + functions, since in those cases, allocating two buffers reading from the + same source is unnatural. + + Still, there is a difficulty in the case of scanning from an input + channel. In effect, when scanning from an input channel [ic], this channel + may not have been allocated from within this library. Hence, it may be + shared (two functions of the user's program may successively read from + [ic]). This is highly error prone since, one of the function may seek the + input channel, while the other function has still an unused lookahead + character in its input buffer. In conclusion, you should never mix direct + low level reading and high level scanning from the same input channel. + + This phenomenon of reading mess is even worse when one defines more than + one scanning buffer reading from the same input channel + [ic]. Unfortunately, we have no simple way to get rid of this problem + (unless the basic input channel API is modified to offer a ``consider this + char as unread'' procedure to keep back the unused lookahead character as + available in the input channel for further reading). + + To prevent some of the confusion the scanning buffer allocation function + is a memo function that never allocates two different scanning buffers for + the same input channel. This way, the user can naively perform successive + call to [fscanf] below, without allocating a new scanning buffer at each + invocation and hence preserving the expected semantics. + + As mentioned above, a more ambitious fix could be to change the input + channel API to allow arbitrary mixing of direct and formatted reading from + input channels. *) + + (* Perform bufferized input to improve efficiency. *) + let file_buffer_size = ref 1024;; + + (* The scanner closes the input channel at end of input. *) + let scan_close_at_end ic = close_in ic; raise End_of_file;; + + (* The scanner does not close the input channel at end of input: + it just raises [End_of_file]. *) + let scan_raise_at_end _ic = raise End_of_file;; + + let from_ic scan_close_ic iname ic = + let len = !file_buffer_size in + let buf = String.create len in + let i = ref 0 in + let lim = ref 0 in + let eof = ref false in + let next () = + if !i < !lim then begin let c = buf.[!i] in incr i; c end else + if !eof then raise End_of_file else begin + lim := input ic buf 0 len; + if !lim = 0 then begin eof := true; scan_close_ic ic end else begin + i := 1; + buf.[0] + end + end in + create iname next + ;; + + let from_ic_close_at_end = from_ic scan_close_at_end;; + + (* The scanning buffer reading from [Pervasives.stdin]. + One could try to define [stdib] as a scanning buffer reading a character at a + time (no bufferization at all), but unfortunately the top-level + interaction would be wrong. + This is due to some kind of ``race condition'' when reading from [Pervasives.stdin], + since the interactive compiler and [scanf] will simultaneously read the + material they need from [Pervasives.stdin]; then, confusion will result from what should + be read by the top-level and what should be read by [scanf]. + This is even more complicated by the one character lookahead that [scanf] + is sometimes obliged to maintain: the lookahead character will be available + for the next ([scanf]) entry, seemingly coming from nowhere. + Also no [End_of_file] is raised when reading from stdin: if not enough + characters have been read, we simply ask to read more. *) + let stdin = + from_ic scan_raise_at_end + (From_file ("-", Pervasives.stdin)) Pervasives.stdin + ;; + + let stdib = stdin;; + + let open_in fname = + match fname with + | "-" -> stdin + | fname -> + let ic = open_in fname in + from_ic_close_at_end (From_file (fname, ic)) ic + ;; + + let open_in_bin fname = + match fname with + | "-" -> stdin + | fname -> + let ic = open_in_bin fname in + from_ic_close_at_end (From_file (fname, ic)) ic + ;; + + let from_file = open_in;; + let from_file_bin = open_in_bin;; + + let memo_from_ic = + let memo = ref [] in + (fun scan_close_ic ic -> + try List.assq ic !memo with + | Not_found -> + let ib = from_ic scan_close_ic (From_channel ic) ic in + memo := (ic, ib) :: !memo; + ib) + ;; + + let from_channel = memo_from_ic scan_raise_at_end;; + + let close_in ib = + match ib.input_name with + | From_file (_fname, ic) -> Pervasives.close_in ic + | From_string | From_function -> () + | From_channel ic -> Pervasives.close_in ic + ;; + +end +;; + +(* Formatted input functions. *) + +type ('a, 'b, 'c, 'd) scanner = + ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c +;; + +external string_to_format : + string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" +;; + +(* Reporting errors. *) +exception Scan_failure of string;; + +let bad_input s = raise (Scan_failure s);; + +let bad_input_escape c = + bad_input (Printf.sprintf "illegal escape character %C" c) +;; + +let bad_token_length message = + bad_input + (Printf.sprintf + "scanning of %s failed: \ + the specified length was too short for token" message) +;; + +let bad_end_of_input message = + bad_input + (Printf.sprintf + "scanning of %s failed: \ + premature end of file occurred before end of token" message) +;; + +let int_max = function + | None -> max_int + | Some max -> max +;; + +let int_min = function + | None -> 0 + | Some max -> max +;; + +let float_min = function + | None -> max_int + | Some min -> min +;; + +module Sformat = Printf.CamlinternalPr.Sformat;; +module Tformat = Printf.CamlinternalPr.Tformat;; + +let bad_conversion fmt i c = + invalid_arg + (Printf.sprintf + "scanf: bad conversion %%%C, at char number %i \ + in format string ``%s''" c i (Sformat.to_string fmt)) +;; + +let incomplete_format fmt = + invalid_arg + (Printf.sprintf "scanf: premature end of format string ``%s''" + (Sformat.to_string fmt)) +;; + +let bad_float () = + bad_input "no dot or exponent part found in float token" +;; + +let character_mismatch_err c ci = + Printf.sprintf "looking for %C, found %C" c ci +;; + +let character_mismatch c ci = + bad_input (character_mismatch_err c ci) +;; + +let format_mismatch_err fmt1 fmt2 = + Printf.sprintf + "format read ``%s'' does not match specification ``%s''" fmt1 fmt2 +;; + +let format_mismatch fmt1 fmt2 = bad_input (format_mismatch_err fmt1 fmt2);; + +(* Checking that 2 format strings are type compatible. *) +let compatible_format_type fmt1 fmt2 = + Tformat.summarize_format_type (string_to_format fmt1) = + Tformat.summarize_format_type (string_to_format fmt2);; + +(* Checking that [c] is indeed in the input, then skips it. + In this case, the character c has been explicitely specified in the + format as being mandatory in the input; hence we should fail with + End_of_file in case of end_of_input. (Remember that Scan_failure is raised + only when (we can prove by evidence) that the input does not match the + format string given. We must thus differentiate End_of_file as an error + due to lack of input, and Scan_failure which is due to provably wrong + input. I am not sure this is worth to burden: it is complex and somehow + subliminal; should be clearer to fail with Scan_failure "Not enough input + to complete scanning"!) + + That's why, waiting for a better solution, we use checked_peek_char here. + We are also careful to treat "\r\n" in the input as a end of line marker: it + always matches a '\n' specification in the input format string. *) +let rec check_char ib c = + let ci = Scanning.checked_peek_char ib in + if ci = c then Scanning.invalidate_current_char ib else begin + match ci with + | '\r' when c = '\n' -> + Scanning.invalidate_current_char ib; check_char ib '\n' + | _ -> character_mismatch c ci + end +;; + +(* Checks that the current char is indeed one of the stopper characters, + then skips it. + Be careful that if ib has no more character this procedure should + just do nothing (since %s@c defaults to the entire rest of the + buffer, when no character c can be found in the input). *) +let ignore_stoppers stps ib = + if stps <> [] && not (Scanning.eof ib) then + let ci = Scanning.peek_char ib in + if List.memq ci stps then Scanning.invalidate_current_char ib else + let sr = String.concat "" (List.map (String.make 1) stps) in + bad_input + (Printf.sprintf "looking for one of range %S, found %C" sr ci) +;; + +(* Extracting tokens from the output token buffer. *) + +let token_char ib = (Scanning.token ib).[0];; + +let token_string = Scanning.token;; + +let token_bool ib = + match Scanning.token ib with + | "true" -> true + | "false" -> false + | s -> bad_input (Printf.sprintf "invalid boolean %S" s) +;; + +(* Extract an integer literal token. + Since the functions Pervasives.*int*_of_string do not accept a leading +, + we skip it if necessary. *) +let token_int_literal conv ib = + let tok = + match conv with + | 'd' | 'i' | 'u' -> Scanning.token ib + | 'o' -> "0o" ^ Scanning.token ib + | 'x' | 'X' -> "0x" ^ Scanning.token ib + | 'b' -> "0b" ^ Scanning.token ib + | _ -> assert false in + let l = String.length tok in + if l = 0 || tok.[0] <> '+' then tok else String.sub tok 1 (l - 1) +;; + +(* All the functions that convert a string to a number raise the exception + Failure when the conversion is not possible. + This exception is then trapped in [kscanf]. *) +let token_int conv ib = int_of_string (token_int_literal conv ib);; + +let token_float ib = float_of_string (Scanning.token ib);; + +(* To scan native ints, int32 and int64 integers. + We cannot access to conversions to/from strings for those types, + Nativeint.of_string, Int32.of_string, and Int64.of_string, + since those modules are not available to [Scanf]. + However, we can bind and use the corresponding primitives that are + available in the runtime. *) +external nativeint_of_string : string -> nativeint + = "caml_nativeint_of_string" +;; +external int32_of_string : string -> int32 + = "caml_int32_of_string" +;; +external int64_of_string : string -> int64 + = "caml_int64_of_string" +;; + +let token_nativeint conv ib = nativeint_of_string (token_int_literal conv ib);; +let token_int32 conv ib = int32_of_string (token_int_literal conv ib);; +let token_int64 conv ib = int64_of_string (token_int_literal conv ib);; + +(* Scanning numbers. *) + +(* Digits scanning functions suppose that one character has been checked and + is available, since they return at end of file with the currently found + token selected. + + Put it in another way, the digits scanning functions scan for a possibly + empty sequence of digits, (hence, a successful scanning from one of those + functions does not imply that the token is a well-formed number: to get a + true number, it is mandatory to check that at least one valid digit is + available before calling one of the digit scanning functions). *) + +(* The decimal case is treated especially for optimization purposes. *) +let rec scan_decimal_digits max ib = + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + match c with + | '0' .. '9' as c -> + let max = Scanning.store_char max ib c in + scan_decimal_digits max ib + | '_' -> + let max = Scanning.ignore_char max ib in + scan_decimal_digits max ib + | _ -> max +;; + +let scan_decimal_digits_plus max ib = + if max = 0 then bad_token_length "decimal digits" else + let c = Scanning.checked_peek_char ib in + match c with + | '0' .. '9' -> + let max = Scanning.store_char max ib c in + scan_decimal_digits max ib + | c -> + bad_input (Printf.sprintf "character %C is not a decimal digit" c) +;; + +let scan_digits_plus digitp max ib = + (* To scan numbers from other bases, we use a predicate argument to + scan_digits. *) + let rec scan_digits max = + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + match c with + | c when digitp c -> + let max = Scanning.store_char max ib c in + scan_digits max + | '_' -> + let max = Scanning.ignore_char max ib in + scan_digits max + | _ -> max in + + (* Ensure we have got enough width left, + and read at list one digit. *) + if max = 0 then bad_token_length "digits" else + let c = Scanning.checked_peek_char ib in + + if digitp c then + let max = Scanning.store_char max ib c in + scan_digits max + else + bad_input (Printf.sprintf "character %C is not a digit" c) +;; + +let is_binary_digit = function + | '0' .. '1' -> true + | _ -> false +;; + +let scan_binary_int = scan_digits_plus is_binary_digit;; + +let is_octal_digit = function + | '0' .. '7' -> true + | _ -> false +;; + +let scan_octal_int = scan_digits_plus is_octal_digit;; + +let is_hexa_digit = function + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false +;; + +let scan_hexadecimal_int = scan_digits_plus is_hexa_digit;; + +(* Scan a decimal integer. *) +let scan_unsigned_decimal_int = scan_decimal_digits_plus;; + +let scan_sign max ib = + let c = Scanning.checked_peek_char ib in + match c with + | '+' -> Scanning.store_char max ib c + | '-' -> Scanning.store_char max ib c + | c -> max +;; + +let scan_optionally_signed_decimal_int max ib = + let max = scan_sign max ib in + scan_unsigned_decimal_int max ib +;; + +(* Scan an unsigned integer that could be given in any (common) basis. + If digits are prefixed by one of 0x, 0X, 0o, or 0b, the number is + assumed to be written respectively in hexadecimal, hexadecimal, + octal, or binary. *) +let scan_unsigned_int max ib = + match Scanning.checked_peek_char ib with + | '0' as c -> + let max = Scanning.store_char max ib c in + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + begin match c with + | 'x' | 'X' -> scan_hexadecimal_int (Scanning.store_char max ib c) ib + | 'o' -> scan_octal_int (Scanning.store_char max ib c) ib + | 'b' -> scan_binary_int (Scanning.store_char max ib c) ib + | c -> scan_decimal_digits max ib end + | c -> scan_unsigned_decimal_int max ib +;; + +let scan_optionally_signed_int max ib = + let max = scan_sign max ib in + scan_unsigned_int max ib +;; + +let scan_int_conv conv max _min ib = + match conv with + | 'b' -> scan_binary_int max ib + | 'd' -> scan_optionally_signed_decimal_int max ib + | 'i' -> scan_optionally_signed_int max ib + | 'o' -> scan_octal_int max ib + | 'u' -> scan_unsigned_decimal_int max ib + | 'x' | 'X' -> scan_hexadecimal_int max ib + | c -> assert false +;; + +(* Scanning floating point numbers. *) +(* Fractional part is optional and can be reduced to 0 digits. *) +let scan_frac_part max ib = + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + match c with + | '0' .. '9' as c -> + scan_decimal_digits (Scanning.store_char max ib c) ib + | _ -> max +;; + +(* Exp part is optional and can be reduced to 0 digits. *) +let scan_exp_part max ib = + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + match c with + | 'e' | 'E' as c -> + scan_optionally_signed_decimal_int (Scanning.store_char max ib c) ib + | _ -> max +;; + +(* Scan the integer part of a floating point number, (not using the + Caml lexical convention since the integer part can be empty): + an optional sign, followed by a possibly empty sequence of decimal + digits (e.g. -.1). *) +let scan_int_part max ib = + let max = scan_sign max ib in + scan_decimal_digits max ib +;; + +(* + For the time being we have (as found in scanf.mli): + The field width is composed of an optional integer literal + indicating the maximal width of the token to read. + Unfortunately, the type-checker let the user write an optional precision, + since this is valid for printf format strings. + + Thus, the next step for Scanf is to support a full width indication, more + or less similar to the one for printf, possibly extended to the + specification of a [max, min] range for the width of the token read for + strings. Something like the following spec for scanf.mli: + + The optional [width] is an integer indicating the maximal + width of the token read. For instance, [%6d] reads an integer, + having at most 6 characters. + + The optional [precision] is a dot [.] followed by an integer: + - in the floating point number conversions ([%f], [%e], [%g], [%F], [%E], and + [%F] conversions, the [precision] indicates the maximum number of digits + that may follow the decimal point. For instance, [%.4f] reads a [float] + with at most 4 fractional digits, + - in the string conversions ([%s], [%S], [%\[ range \]]), and in the + integer number conversions ([%i], [%d], [%u], [%x], [%o], and their + [int32], [int64], and [native_int] correspondent), the + [precision] indicates the required minimum width of the token read, + - on all other conversions, the width and precision are meaningless and + ignored (FIXME: lead to a runtime error ? type checking error ?). + +*) +let scan_float max max_frac_part ib = + let max = scan_int_part max ib in + if max = 0 then max, max_frac_part else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max, max_frac_part else + match c with + | '.' -> + let max = Scanning.store_char max ib c in + let max_precision = min max max_frac_part in + let max = max - (max_precision - scan_frac_part max_precision ib) in + scan_exp_part max ib, max_frac_part + | c -> + scan_exp_part max ib, max_frac_part +;; + +let scan_Float max max_frac_part ib = + let max = scan_optionally_signed_decimal_int max ib in + if max = 0 then bad_float () else + let c = Scanning.peek_char ib in + if Scanning.eof ib then bad_float () else + match c with + | '.' -> + let max = Scanning.store_char max ib c in + let max_precision = min max max_frac_part in + let max = max - (max_precision - scan_frac_part max_precision ib) in + let max = scan_frac_part max ib in + scan_exp_part max ib + | 'e' | 'E' -> + scan_exp_part max ib + | c -> bad_float () +;; + +(* Scan a regular string: + stops when encountering a space, if no scanning indication has been given; + otherwise, stops when encountering one of the characters in the scanning + indication list [stp]. + It also stops at end of file or when the maximum number of characters has + been read.*) +let scan_string stp max ib = + let rec loop max = + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + if stp = [] then + match c with + | ' ' | '\t' | '\n' | '\r' -> max + | c -> loop (Scanning.store_char max ib c) else + if List.memq c stp then Scanning.skip_char max ib else + loop (Scanning.store_char max ib c) in + loop max +;; + +(* Scan a char: peek strictly one character in the input, whatsoever. *) +let scan_char max ib = + (* The case max = 0 could not happen here, since it is tested before + calling scan_char, in the main scanning function. + if max = 0 then bad_token_length "a character" else *) + Scanning.store_char max ib (Scanning.checked_peek_char ib) +;; + +let char_for_backslash = function + | 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c +;; + +(* The integer value corresponding to the facial value of a valid + decimal digit character. *) +let decimal_value_of_char c = int_of_char c - int_of_char '0';; + +let char_for_decimal_code c0 c1 c2 = + let c = + 100 * decimal_value_of_char c0 + + 10 * decimal_value_of_char c1 + + decimal_value_of_char c2 in + if c < 0 || c > 255 then + bad_input + (Printf.sprintf + "bad character decimal encoding \\%c%c%c" c0 c1 c2) else + char_of_int c +;; + +(* The integer value corresponding to the facial value of a valid + hexadecimal digit character. *) +let hexadecimal_value_of_char c = + let d = int_of_char c in + (* Could also be: + if d <= int_of_char '9' then d - int_of_char '0' else + if d <= int_of_char 'F' then 10 + d - int_of_char 'A' else + if d <= int_of_char 'f' then 10 + d - int_of_char 'a' else assert false + *) + if d >= int_of_char 'a' then + d - 87 (* 10 + int_of_char c - int_of_char 'a' *) else + if d >= int_of_char 'A' then + d - 55 (* 10 + int_of_char c - int_of_char 'A' *) else + d - int_of_char '0' +;; + +let char_for_hexadecimal_code c1 c2 = + let c = + 16 * hexadecimal_value_of_char c1 + + hexadecimal_value_of_char c2 in + if c < 0 || c > 255 then + bad_input + (Printf.sprintf "bad character hexadecimal encoding \\%c%c" c1 c2) else + char_of_int c +;; + +(* Called in particular when encountering '\\' as starter of a char. + Stops before the corresponding '\''. *) +let check_next_char message max ib = + if max = 0 then bad_token_length message else + let c = Scanning.peek_char ib in + if Scanning.eof ib then bad_end_of_input message else + c +;; + +let check_next_char_for_char = check_next_char "a Char";; +let check_next_char_for_string = check_next_char "a String";; + +let scan_backslash_char max ib = + match check_next_char_for_char max ib with + | '\\' | '\'' | '\"' | 'n' | 't' | 'b' | 'r' as c -> + Scanning.store_char max ib (char_for_backslash c) + | '0' .. '9' as c -> + let get_digit () = + let c = Scanning.next_char ib in + match c with + | '0' .. '9' as c -> c + | c -> bad_input_escape c in + let c0 = c in + let c1 = get_digit () in + let c2 = get_digit () in + Scanning.store_char (max - 2) ib (char_for_decimal_code c0 c1 c2) + | 'x' -> + let get_digit () = + let c = Scanning.next_char ib in + match c with + | '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' as c -> c + | c -> bad_input_escape c in + let c1 = get_digit () in + let c2 = get_digit () in + Scanning.store_char (max - 2) ib (char_for_hexadecimal_code c1 c2) + | c -> + bad_input_escape c +;; + +(* Scan a character (a Caml token). *) +let scan_Char max ib = + + let rec find_start max = + match Scanning.checked_peek_char ib with + | '\'' -> find_char (Scanning.ignore_char max ib) + | c -> character_mismatch '\'' c + + and find_char max = + match check_next_char_for_char max ib with + | '\\' -> find_stop (scan_backslash_char (Scanning.ignore_char max ib) ib) + | c -> find_stop (Scanning.store_char max ib c) + + and find_stop max = + match check_next_char_for_char max ib with + | '\'' -> Scanning.ignore_char max ib + | c -> character_mismatch '\'' c in + + find_start max +;; + +(* Scan a delimited string (a Caml token). *) +let scan_String max ib = + + let rec find_start max = + match Scanning.checked_peek_char ib with + | '\"' -> find_stop (Scanning.ignore_char max ib) + | c -> character_mismatch '\"' c + + and find_stop max = + match check_next_char_for_string max ib with + | '\"' -> Scanning.ignore_char max ib + | '\\' -> scan_backslash (Scanning.ignore_char max ib) + | c -> find_stop (Scanning.store_char max ib c) + + and scan_backslash max = + match check_next_char_for_string max ib with + | '\r' -> skip_newline (Scanning.ignore_char max ib) + | '\n' -> skip_spaces (Scanning.ignore_char max ib) + | c -> find_stop (scan_backslash_char max ib) + + and skip_newline max = + match check_next_char_for_string max ib with + | '\n' -> skip_spaces (Scanning.ignore_char max ib) + | _ -> find_stop (Scanning.store_char max ib '\r') + + and skip_spaces max = + match check_next_char_for_string max ib with + | ' ' -> skip_spaces (Scanning.ignore_char max ib) + | _ -> find_stop max in + + find_start max +;; + +(* Scan a boolean (a Caml token). *) +let scan_bool max ib = + if max < 4 then bad_token_length "a boolean" else + let c = Scanning.checked_peek_char ib in + let m = + match c with + | 't' -> 4 + | 'f' -> 5 + | c -> + bad_input + (Printf.sprintf "the character %C cannot start a boolean" c) in + scan_string [] (min max m) ib +;; + +(* Reading char sets in %[...] conversions. *) +type char_set = + | Pos_set of string (* Positive (regular) set. *) + | Neg_set of string (* Negative (complementary) set. *) +;; + +(* Char sets are read as sub-strings in the format string. *) +let read_char_set fmt i = + let lim = Sformat.length fmt - 1 in + + let rec find_in_set j = + if j > lim then incomplete_format fmt else + match Sformat.get fmt j with + | ']' -> j + | c -> find_in_set (succ j) + + and find_set i = + if i > lim then incomplete_format fmt else + match Sformat.get fmt i with + | ']' -> find_in_set (succ i) + | c -> find_in_set i in + + if i > lim then incomplete_format fmt else + match Sformat.get fmt i with + | '^' -> + let i = succ i in + let j = find_set i in + j, Neg_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) + | _ -> + let j = find_set i in + j, Pos_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) +;; + +(* Char sets are now represented as bit vectors that are represented as + byte strings. *) + +(* Bit manipulations into bytes. *) +let set_bit_of_byte byte idx b = + (b lsl idx) lor (byte land (* mask idx *) (lnot (1 lsl idx))) +;; + +let get_bit_of_byte byte idx = (byte lsr idx) land 1;; + +(* Bit manipulations in vectors of bytes represented as strings. *) +let set_bit_of_range r c b = + let idx = c land 0x7 in + let ydx = c lsr 3 in + let byte = r.[ydx] in + r.[ydx] <- char_of_int (set_bit_of_byte (int_of_char byte) idx b) +;; + +let get_bit_of_range r c = + let idx = c land 0x7 in + let ydx = c lsr 3 in + let byte = r.[ydx] in + get_bit_of_byte (int_of_char byte) idx +;; + +(* Char sets represented as bit vectors represented as fixed length byte + strings. *) +(* Create a full or empty set of chars. *) +let make_range bit = + let c = char_of_int (if bit = 0 then 0 else 0xFF) in + String.make 32 c +;; + +(* Test if a char belongs to a set of chars. *) +let get_char_in_range r c = get_bit_of_range r (int_of_char c);; + +let bit_not b = (lnot b) land 1;; + +(* Build the bit vector corresponding to the set of characters + that belongs to the string argument [set]. + (In the [Scanf] module [set] is always a sub-string of the format.) *) +let make_char_bit_vect bit set = + let r = make_range (bit_not bit) in + let lim = String.length set - 1 in + let rec loop bit rp i = + if i <= lim then + match set.[i] with + | '-' when rp -> + (* if i = 0 then rp is false (since the initial call is + loop bit false 0). Hence i >= 1 and the following is safe. *) + let c1 = set.[i - 1] in + let i = succ i in + if i > lim then loop bit false (i - 1) else + let c2 = set.[i] in + for j = int_of_char c1 to int_of_char c2 do + set_bit_of_range r j bit done; + loop bit false (succ i) + | c -> + set_bit_of_range r (int_of_char set.[i]) bit; + loop bit true (succ i) in + loop bit false 0; + r +;; + +(* Compute the predicate on chars corresponding to a char set. *) +let make_pred bit set stp = + let r = make_char_bit_vect bit set in + List.iter + (fun c -> set_bit_of_range r (int_of_char c) (bit_not bit)) stp; + (fun c -> get_char_in_range r c) +;; + +let make_setp stp char_set = + match char_set with + | Pos_set set -> + begin match String.length set with + | 0 -> (fun c -> 0) + | 1 -> + let p = set.[0] in + (fun c -> if c == p then 1 else 0) + | 2 -> + let p1 = set.[0] and p2 = set.[1] in + (fun c -> if c == p1 || c == p2 then 1 else 0) + | 3 -> + let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in + if p2 = '-' then make_pred 1 set stp else + (fun c -> if c == p1 || c == p2 || c == p3 then 1 else 0) + | n -> make_pred 1 set stp + end + | Neg_set set -> + begin match String.length set with + | 0 -> (fun c -> 1) + | 1 -> + let p = set.[0] in + (fun c -> if c != p then 1 else 0) + | 2 -> + let p1 = set.[0] and p2 = set.[1] in + (fun c -> if c != p1 && c != p2 then 1 else 0) + | 3 -> + let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in + if p2 = '-' then make_pred 0 set stp else + (fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0) + | n -> make_pred 0 set stp + end +;; + +let setp_table = Hashtbl.create 7;; + +let add_setp stp char_set setp = + let char_set_tbl = + try Hashtbl.find setp_table char_set with + | Not_found -> + let char_set_tbl = Hashtbl.create 3 in + Hashtbl.add setp_table char_set char_set_tbl; + char_set_tbl in + Hashtbl.add char_set_tbl stp setp +;; + +let find_setp stp char_set = + try Hashtbl.find (Hashtbl.find setp_table char_set) stp with + | Not_found -> + let setp = make_setp stp char_set in + add_setp stp char_set setp; + setp +;; + +let scan_chars_in_char_set stp char_set max ib = + let rec loop_pos1 cp1 max = + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + if c == cp1 + then loop_pos1 cp1 (Scanning.store_char max ib c) + else max + and loop_pos2 cp1 cp2 max = + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + if c == cp1 || c == cp2 + then loop_pos2 cp1 cp2 (Scanning.store_char max ib c) + else max + and loop_pos3 cp1 cp2 cp3 max = + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + if c == cp1 || c == cp2 || c == cp3 + then loop_pos3 cp1 cp2 cp3 (Scanning.store_char max ib c) + else max + and loop_neg1 cp1 max = + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + if c != cp1 + then loop_neg1 cp1 (Scanning.store_char max ib c) + else max + and loop_neg2 cp1 cp2 max = + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + if c != cp1 && c != cp2 + then loop_neg2 cp1 cp2 (Scanning.store_char max ib c) + else max + and loop_neg3 cp1 cp2 cp3 max = + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + if c != cp1 && c != cp2 && c != cp3 + then loop_neg3 cp1 cp2 cp3 (Scanning.store_char max ib c) + else max + and loop setp max = + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + if setp c == 1 + then loop setp (Scanning.store_char max ib c) + else max in + + let max = + match char_set with + | Pos_set set -> + begin match String.length set with + | 0 -> loop (fun c -> 0) max + | 1 -> loop_pos1 set.[0] max + | 2 -> loop_pos2 set.[0] set.[1] max + | 3 when set.[1] != '-' -> loop_pos3 set.[0] set.[1] set.[2] max + | n -> loop (find_setp stp char_set) max end + | Neg_set set -> + begin match String.length set with + | 0 -> loop (fun c -> 1) max + | 1 -> loop_neg1 set.[0] max + | 2 -> loop_neg2 set.[0] set.[1] max + | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] max + | n -> loop (find_setp stp char_set) max end in + ignore_stoppers stp ib; + max +;; + +let get_count t ib = + match t with + | 'l' -> Scanning.line_count ib + | 'n' -> Scanning.char_count ib + | _ -> Scanning.token_count ib +;; + +let rec skip_whites ib = + let c = Scanning.peek_char ib in + if not (Scanning.eof ib) then begin + match c with + | ' ' | '\t' | '\n' | '\r' -> + Scanning.invalidate_current_char ib; skip_whites ib + | _ -> () + end +;; + +(* The global error report function for [Scanf]. *) +let scanf_bad_input ib = function + | Scan_failure s | Failure s -> + let i = Scanning.char_count ib in + bad_input (Printf.sprintf "scanf: bad input at char number %i: ``%s''" i s) + | x -> raise x +;; + +let list_iter_i f l = + let rec loop i = function + | [] -> () + | [x] -> f i x (* Tail calling [f] *) + | x :: xs -> f i x; loop (succ i) xs in + loop 0 l +;; + +let ascanf sc fmt = + let ac = Tformat.ac_of_format fmt in + match ac.Tformat.ac_rdrs with + | 0 -> + Obj.magic (fun f -> sc fmt [||] f) + | 1 -> + Obj.magic (fun x f -> sc fmt [| Obj.repr x |] f) + | 2 -> + Obj.magic (fun x y f -> sc fmt [| Obj.repr x; Obj.repr y; |] f) + | 3 -> + Obj.magic + (fun x y z f -> sc fmt [| Obj.repr x; Obj.repr y; Obj.repr z; |] f) + | nargs -> + let rec loop i args = + if i >= nargs then + let a = Array.make nargs (Obj.repr 0) in + list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args; + Obj.magic (fun f -> sc fmt a f) + else Obj.magic (fun x -> loop (succ i) (x :: args)) in + loop 0 [] +;; + +(* The [scan_format] main scanning function. + It takes as arguments: + - an input buffer [ib] from which to read characters, + - an error handling function [ef], + - a format [fmt] that specifies what to read in the input, + - a vector of user's defined readers [rv], + - and a function [f] to pass the tokens read to. + + Then [scan_format] scans the format and the input buffer in parallel to + find out tokens as specified by the format; when it finds one token, it + converts it as specified, remembers the converted value as a future + argument to the function [f], and continues scanning. + + If the entire scanning succeeds (i.e. the format string has been + exhausted and the buffer has provided tokens according to the + format string), [f] is applied to the tokens read. + + If the scanning or some conversion fails, the main scanning function + aborts and applies the scanning buffer and a string that explains + the error to the error handling function [ef] (the error continuation). *) + +let scan_format ib ef fmt rv f = + + let limr = Array.length rv - 1 in + + let return v = Obj.magic v () in + let delay f x () = f x in + let stack f = delay (return f) in + let no_stack f x = f in + + let rec scan fmt = + + let lim = Sformat.length fmt - 1 in + + let rec scan_fmt ir f i = + if i > lim then ir, f else + match Sformat.get fmt i with + | ' ' -> skip_whites ib; scan_fmt ir f (succ i) + | '%' -> scan_skip ir f (succ i) + | '@' -> + let i = succ i in + if i > lim then incomplete_format fmt else begin + check_char ib (Sformat.get fmt i); + scan_fmt ir f (succ i) end + | c -> check_char ib c; scan_fmt ir f (succ i) + + and scan_skip ir f i = + if i > lim then ir, f else + match Sformat.get fmt i with + | '_' -> scan_limits true ir f (succ i) + | _ -> scan_limits false ir f i + + and scan_limits skip ir f i = + if i > lim then ir, f else + let max_opt, min_opt, i = + match Sformat.get fmt i with + | '0' .. '9' as conv -> + let rec read_width accu i = + if i > lim then accu, i else + match Sformat.get fmt i with + | '0' .. '9' as c -> + let accu = 10 * accu + decimal_value_of_char c in + read_width accu (succ i) + | _ -> accu, i in + + let max, i = read_width (decimal_value_of_char conv) (succ i) in + + if i > lim then incomplete_format fmt else + begin + match Sformat.get fmt i with + | '.' -> + let min, i = read_width 0 (succ i) in + (Some max, Some min, i) + | _ -> Some max, None, i + end + | _ -> None, None, i in + + scan_conversion skip max_opt min_opt ir f i + + and scan_conversion skip max_opt min_opt ir f i = + let stack = if skip then no_stack else stack in + let max = int_max max_opt in + let min = int_min min_opt in + match Sformat.get fmt i with + | '%' as conv -> + check_char ib conv; scan_fmt ir f (succ i) + | 's' -> + let i, stp = scan_fmt_stoppers (succ i) in + let _x = scan_string stp max ib in + scan_fmt ir (stack f (token_string ib)) (succ i) + | 'S' -> + let _x = scan_String max ib in + scan_fmt ir (stack f (token_string ib)) (succ i) + | '[' (* ']' *) -> + let i, char_set = read_char_set fmt (succ i) in + let i, stp = scan_fmt_stoppers (succ i) in + let _x = scan_chars_in_char_set stp char_set max ib in + scan_fmt ir (stack f (token_string ib)) (succ i) + | ('c' | 'C') when max = 0 -> + let c = Scanning.checked_peek_char ib in + scan_fmt ir (stack f c) (succ i) + | 'c' -> + let _x = scan_char max ib in + scan_fmt ir (stack f (token_char ib)) (succ i) + | 'C' -> + let _x = scan_Char max ib in + scan_fmt ir (stack f (token_char ib)) (succ i) + | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv -> + let _x = scan_int_conv conv max min ib in + scan_fmt ir (stack f (token_int conv ib)) (succ i) + | 'N' as conv -> + scan_fmt ir (stack f (get_count conv ib)) (succ i) + | 'f' | 'e' | 'E' | 'g' | 'G' -> + let min = float_min min_opt in + let _x = scan_float max min ib in + scan_fmt ir (stack f (token_float ib)) (succ i) + | 'F' -> + let min = float_min min_opt in + let _x = scan_Float max min ib in + scan_fmt ir (stack f (token_float ib)) (succ i) +(* | 'B' | 'b' when max = Some 0 -> + let _x = scan_bool max ib in + scan_fmt ir (stack f (token_int ib)) (succ i) *) + | 'B' | 'b' -> + let _x = scan_bool max ib in + scan_fmt ir (stack f (token_bool ib)) (succ i) + | 'r' -> + if ir > limr then assert false else + let token = Obj.magic rv.(ir) ib in + scan_fmt (succ ir) (stack f token) (succ i) + | 'l' | 'n' | 'L' as conv0 -> + let i = succ i in + if i > lim then scan_fmt ir (stack f (get_count conv0 ib)) i else begin + match Sformat.get fmt i with + (* This is in fact an integer conversion (e.g. %ld, %ni, or %Lo). *) + | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv1 -> + let _x = scan_int_conv conv1 max min ib in + (* Look back to the character that triggered the integer conversion + (this character is either 'l', 'n' or 'L') to find the + conversion to apply to the integer token read. *) + begin match conv0 with + | 'l' -> scan_fmt ir (stack f (token_int32 conv1 ib)) (succ i) + | 'n' -> scan_fmt ir (stack f (token_nativeint conv1 ib)) (succ i) + | _ -> scan_fmt ir (stack f (token_int64 conv1 ib)) (succ i) end + (* This is not an integer conversion, but a regular %l, %n or %L. *) + | _ -> scan_fmt ir (stack f (get_count conv0 ib)) i end + | '!' -> + if Scanning.end_of_input ib then scan_fmt ir f (succ i) + else bad_input "end of input not found" + | ',' -> + scan_fmt ir f (succ i) + | '(' | '{' as conv (* ')' '}' *) -> + let i = succ i in + (* Find the static specification for the format to read. *) + let j = + Tformat.sub_format + incomplete_format bad_conversion conv fmt i in + let mf = Sformat.sub fmt (Sformat.index_of_int i) (j - 2 - i) in + (* Read the specified format string in the input buffer, + and check its correctness. *) + let _x = scan_String max ib in + let rf = token_string ib in + if not (compatible_format_type rf mf) then format_mismatch rf mf else + (* For conversion %{%}, just return this format string as the token + read. *) + if conv = '{' (* '}' *) then scan_fmt ir (stack f rf) j else + (* Or else, read according to the format string just read. *) + let ir, nf = scan (string_to_format rf) ir (stack f rf) 0 in + (* Return the format string read and the value just read, + then go on with the rest of the format. *) + scan_fmt ir nf j + + | c -> bad_conversion fmt i c + + and scan_fmt_stoppers i = + if i > lim then i - 1, [] else + match Sformat.get fmt i with + | '@' when i < lim -> let i = succ i in i, [Sformat.get fmt i] + | '@' when i = lim -> incomplete_format fmt + | _ -> i - 1, [] in + + scan_fmt in + + + Scanning.reset_token ib; + + let v = + try snd (scan fmt 0 (fun () -> f) 0) with + | (Scan_failure _ | Failure _ | End_of_file) as exc -> + stack (delay ef ib) exc in + return v +;; + +let mkscanf ib ef fmt = + let sc = scan_format ib ef in + ascanf sc fmt +;; + +let kscanf ib ef fmt = mkscanf ib ef fmt;; + +let bscanf ib = kscanf ib scanf_bad_input;; + +let fscanf ic = bscanf (Scanning.from_channel ic);; + +let sscanf s = bscanf (Scanning.from_string s);; + +let scanf fmt = bscanf Scanning.stdib fmt;; + +let bscanf_format ib fmt f = + let fmt = Sformat.unsafe_to_string fmt in + let fmt1 = + ignore (scan_String max_int ib); + token_string ib in + if not (compatible_format_type fmt1 fmt) then + format_mismatch fmt1 fmt else + f (string_to_format fmt1) +;; + +let sscanf_format s fmt = bscanf_format (Scanning.from_string s) fmt;; + +let string_to_String s = + let l = String.length s in + let b = Buffer.create (l + 2) in + Buffer.add_char b '\"'; + for i = 0 to l - 1 do + let c = s.[i] in + if c = '\"' then Buffer.add_char b '\\'; + Buffer.add_char b c; + done; + Buffer.add_char b '\"'; + Buffer.contents b +;; + +let format_from_string s fmt = + sscanf_format (string_to_String s) fmt (fun x -> x) +;; diff --git a/ocaml-binary-annot/stdlib/scanf.mli b/ocaml-binary-annot/stdlib/scanf.mli new file mode 100644 index 0000000000..483f3357ff --- /dev/null +++ b/ocaml-binary-annot/stdlib/scanf.mli @@ -0,0 +1,473 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Pierre Weis, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Formatted input functions. *) + +(** {6 Introduction} *) + +(** {7 Functional input with format strings} *) + +(** The module [Scanf] provides formatted input functions or {e scanners}. + + The formatted input functions can read from any kind of input, including + strings, files, or anything that can return characters. The more general + source of characters is named a {e formatted input channel} (or {e + scanning buffer}) and has type {!Scanning.in_channel}. The more general + formatted input function reads from any scanning buffer and is named [bscanf]. + + Generally speaking, the formatted input functions have 3 arguments: + - the first argument is a source of characters for the input, + - the second argument is a format string that specifies the values to + read, + - the third argument is a {e receiver function} that is applied to the + values read. + + Hence, a typical call to the formatted input function {!Scanf.bscanf} is + [bscanf ic fmt f], where: + + - [ic] is a source of characters (typically a {e + formatted input channel} with type {!Scanning.in_channel}), + + - [fmt] is a format string (the same format strings as those used to print + material with module {!Printf} or {!Format}), + + - [f] is a function that has as many arguments as the number of values to + read in the input. *) + +(** {7 A simple example} *) + +(** As suggested above, the expression [bscanf ic "%d" f] reads a decimal + integer [n] from the source of characters [ic] and returns [f n]. + + For instance, + + - if we use [stdin] as the source of characters ({!Scanning.stdin} is + the predefined formatted input channel that reads from standard input), + + - if we define the receiver [f] as [let f x = x + 1], + + then [bscanf Scanning.stdin "%d" f] reads an integer [n] from the standard input + and returns [f n] (that is [n + 1]). Thus, if we evaluate [bscanf stdin + "%d" f], and then enter [41] at the keyboard, we get [42] as the final + result. *) + +(** {7 Formatted input as a functional feature} *) + +(** The Caml scanning facility is reminiscent of the corresponding C feature. + However, it is also largely different, simpler, and yet more powerful: + the formatted input functions are higher-order functionals and the + parameter passing mechanism is just the regular function application not + the variable assignment based mechanism which is typical for formatted + input in imperative languages; the Caml format strings also feature + useful additions to easily define complex tokens; as expected within a + functional programming language, the formatted input functions also + support polymorphism, in particular arbitrary interaction with + polymorphic user-defined scanners. Furthermore, the Caml formatted input + facility is fully type-checked at compile time. *) + +(** {6 Formatted input channel} *) +module Scanning : sig + +type in_channel;; +(* The notion of input channel for the [Scanf] module: + those channels provide all the machinery necessary to read from a given + [Pervasives.in_channel] value. + A [Scanf.Scanning.in_channel] value is also called a {i formatted input + channel} or equivalently a {i scanning buffer}. + The type [scanbuf] below is an alias for [in_channel]. + @since 3.12.0 +*) + +type scanbuf = in_channel;; +(** The type of scanning buffers. A scanning buffer is the source from which a + formatted input function gets characters. The scanning buffer holds the + current state of the scan, plus a function to get the next char from the + input, and a token buffer to store the string matched so far. + + Note: a scanning action may often require to examine one character in + advance; when this ``lookahead'' character does not belong to the token + read, it is stored back in the scanning buffer and becomes the next + character read. *) + +val stdin : in_channel;; +(** The standard input notion for the module [Scanf]. + [stdin] is equivalent to [Scanning.from_channel Pervasives.stdin]. + + Note: when input is read interactively from [stdin], the newline character + that triggers the evaluation is incorporated in the input; thus, scanning + specifications must properly skip this character (simply add a ['\n'] + as the last character of the format string). + @since 3.12.0 +*) + +val open_in : string -> in_channel;; +(** Bufferized file reading in text mode. The efficient and usual + way to scan text mode files (in effect, [from_file] returns a + scanning buffer that reads characters in large chunks, rather than one + character at a time as buffers returned by [from_channel] below do). + [Scanning.from_file fname] returns a scanning buffer which reads + from the given file [fname] in text mode. + @since 3.12.0 +*) + +val open_in_bin : string -> in_channel;; +(** Bufferized file reading in binary mode. @since 3.12.0 *) + +val close_in : in_channel -> unit;; +(** Close the [Pervasives.input_channel] associated with the given + [Scanning.in_channel]. + @since 3.12.0 +*) + +val from_file : string -> in_channel;; +(** An alias for [open_in] above. *) +val from_file_bin : string -> in_channel;; +(** An alias for [open_in_bin] above. *) + +val from_string : string -> in_channel;; +(** [Scanning.from_string s] returns a formatted input channel which reads + from the given string. + Reading starts from the first character in the string. + The end-of-input condition is set when the end of the string is reached. *) + +val from_function : (unit -> char) -> in_channel;; +(** [Scanning.from_function f] returns a scanning buffer with the given + function as its reading method. + + When scanning needs one more character, the given function is called. + + When the function has no more character to provide, it {e must} signal an + end-of-input condition by raising the exception [End_of_file]. *) + +val from_channel : Pervasives.in_channel -> in_channel;; +(** [Scanning.from_channel ic] returns a formatted input channel which reads + from the regular input channel [ic] argument, starting at the current + reading position. *) + +val end_of_input : in_channel -> bool;; +(** [Scanning.end_of_input ic] tests the end-of-input condition of the given + formatted input channel. *) + +val beginning_of_input : in_channel -> bool;; +(** [Scanning.beginning_of_input ic] tests the beginning of input condition of + the given formatted input channel. *) + +val name_of_input : in_channel -> string;; +(** [Scanning.file_name_of_input ic] returns the name of the character source + for the formatted input channel [ic]. + @since 3.09.0 +*) + +val stdib : in_channel;; +(** A deprecated alias for [Scanning.stdin], the scanning buffer reading from + [Pervasives.stdin]. *) + +end;; + +(** {6 Type of formatted input functions} *) + +type ('a, 'b, 'c, 'd) scanner = + ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;; +(** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner] is the + type of a formatted input function that reads from some formatted input channel + according to some format string; more precisely, if [scan] is some + formatted input function, then [scan ic fmt f] applies [f] to the arguments + specified by the format string [fmt], when [scan] has read those arguments + from the formatted input channel [ic]. + + For instance, the [scanf] function below has type [('a, 'b, 'c, 'd) + scanner], since it is a formatted input function that reads from + [Scanning.stdin]: [scanf fmt f] applies [f] to the arguments specified by + [fmt], reading those arguments from [Pervasives.stdin] as expected. + + If the format [fmt] has some [%r] indications, the corresponding input + functions must be provided before the receiver [f] argument. For + instance, if [read_elem] is an input function for values of type [t], + then [bscanf ic "%r;" read_elem f] reads a value [v] of type [t] followed + by a [';'] character, and returns [f v]. + @since 3.10.0 +*) + +exception Scan_failure of string;; +(** The exception that formatted input functions raise when the input cannot be + read according to the given format. *) + +(** {6 The general formatted input function} *) + +val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; +(** [bscanf ic fmt r1 ... rN f] reads arguments for the function [f], from the + formatted input channel [ic], according to the format string [fmt], and + applies [f] to these values. + The result of this call to [f] is returned as the result of the entire + [bscanf] call. + For instance, if [f] is the function [fun s i -> i + 1], then + [Scanf.sscanf "x= 1" "%s = %i" f] returns [2]. + + Arguments [r1] to [rN] are user-defined input functions that read the + argument corresponding to a [%r] conversion. *) + +(** {6 Format string description} *) + +(** The format is a character string which contains three types of + objects: + - plain characters, which are simply matched with the characters of the + input (with a special case for {!Scanf.space} and line feed), + - conversion specifications, each of which causes reading and conversion of + one argument for the function [f] (see {!Scanf.conversion}), + - scanning indications to specify boundaries of tokens + (see scanning {!Scanf.indication}). *) + +(** {7:space The space character in format strings} *) + +(** As mentioned above, a plain character in the format string is just + matched with the next character of the input; however, two characters are + special exceptions to this rule: the space character ([' '] or ASCII code + 32) and the line feed character (['\n'] or ASCII code 10). + A space does not match a single space character, but any amount of + ``whitespace'' in the input. More precisely, a space inside the format + string matches {e any number} of tab, space, line feed and carriage + return characters. Similarly, a line feed character in the format string + matches either a single line feed or a carriage return followed by a line + feed. + + Matching {e any} amount of whitespace, a space in the format string + also matches no amount of whitespace at all; hence, the call [bscanf ib + "Price = %d $" (fun p -> p)] succeeds and returns [1] when reading an + input with various whitespace in it, such as [Price = 1 $], + [Price = 1 $], or even [Price=1$]. *) + +(** {7:conversion Conversion specifications in format strings} *) + +(** Conversion specifications consist in the [%] character, followed by + an optional flag, an optional field width, and followed by one or + two conversion characters. The conversion characters and their + meanings are: + + - [d]: reads an optionally signed decimal integer. + - [i]: reads an optionally signed integer + (usual input conventions for decimal ([0-9]+), hexadecimal + ([0x[0-9a-f]+] and [0X[0-9A-F]+]), octal ([0o[0-7]+]), and binary + ([0b[0-1]+]) notations are understood). + - [u]: reads an unsigned decimal integer. + - [x] or [X]: reads an unsigned hexadecimal integer ([[0-9a-f]+] or [[0-9A-F]+]). + - [o]: reads an unsigned octal integer ([[0-7]+]). + - [s]: reads a string argument that spreads as much as possible, until the + following bounding condition holds: + - a whitespace has been found (see {!Scanf.space}), + - a scanning indication (see scanning {!Scanf.indication}) has been + encountered, + - the end-of-input has been reached. + Hence, this conversion always succeeds: it returns an empty + string, if the bounding condition holds when the scan begins. + - [S]: reads a delimited string argument (delimiters and special + escaped characters follow the lexical conventions of Caml). + - [c]: reads a single character. To test the current input character + without reading it, specify a null field width, i.e. use + specification [%0c]. Raise [Invalid_argument], if the field width + specification is greater than 1. + - [C]: reads a single delimited character (delimiters and special + escaped characters follow the lexical conventions of Caml). + - [f], [e], [E], [g], [G]: reads an optionally signed + floating-point number in decimal notation, in the style [dddd.ddd + e/E+-dd]. + - [F]: reads a floating point number according to the lexical + conventions of Caml (hence the decimal point is mandatory if the + exponent part is not mentioned). + - [B]: reads a boolean argument ([true] or [false]). + - [b]: reads a boolean argument (for backward compatibility; do not use + in new programs). + - [ld], [li], [lu], [lx], [lX], [lo]: reads an [int32] argument to + the format specified by the second letter for regular integers. + - [nd], [ni], [nu], [nx], [nX], [no]: reads a [nativeint] argument to + the format specified by the second letter for regular integers. + - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: reads an [int64] argument to + the format specified by the second letter for regular integers. + - [\[ range \]]: reads characters that matches one of the characters + mentioned in the range of characters [range] (or not mentioned in + it, if the range starts with [^]). Reads a [string] that can be + empty, if the next input character does not match the range. The set of + characters from [c1] to [c2] (inclusively) is denoted by [c1-c2]. + Hence, [%\[0-9\]] returns a string representing a decimal number + or an empty string if no decimal digit is found; similarly, + [%\[\\048-\\057\\065-\\070\]] returns a string of hexadecimal digits. + If a closing bracket appears in a range, it must occur as the + first character of the range (or just after the [^] in case of + range negation); hence [\[\]\]] matches a [\]] character and + [\[^\]\]] matches any character that is not [\]]. + - [r]: user-defined reader. Takes the next [ri] formatted input function and + applies it to the scanning buffer [ib] to read the next argument. The + input function [ri] must therefore have type [Scanning.in_channel -> 'a] and + the argument read has type ['a]. + - [\{ fmt %\}]: reads a format string argument. + The format string read must have the same type as the format string + specification [fmt]. + For instance, ["%{ %i %}"] reads any format string that can read a value of + type [int]; hence [Scanf.sscanf "fmt:\"number is %u\"" "fmt:%{%i%}"] + succeeds and returns the format string ["number is %u"]. + - [\( fmt %\)]: scanning format substitution. + Reads a format string to read with it instead of [fmt]. + The format string read must have the same type as the format string + specification [fmt] that is replaces. + For instance, ["%( %i %)"] reads any format string that can read a value + of type [int]. + Returns the format string read, and the value read using the format + string read. + Hence, [Scanf.sscanf "\"%4d\"1234.00" "%(%i%)" + (fun fmt i -> fmt, i)] evaluates to [("%4d", 1234)]. + If the special flag [_] is used, the conversion discards the + format string read and only returns the value read with the format + string read. + Hence, [Scanf.sscanf "\"%4d\"1234.00" "%_(%i%)"] is simply + equivalent to [Scanf.sscanf "1234.00" "%4d"]. + - [l]: returns the number of lines read so far. + - [n]: returns the number of characters read so far. + - [N] or [L]: returns the number of tokens read so far. + - [!]: matches the end of input condition. + - [%]: matches one [%] character in the input. + - [,]: the no-op delimiter for conversion specifications. + + Following the [%] character that introduces a conversion, there may be + the special flag [_]: the conversion that follows occurs as usual, + but the resulting value is discarded. + For instance, if [f] is the function [fun i -> i + 1], then + [Scanf.sscanf "x = 1" "%_s = %i" f] returns [2]. + + The field width is composed of an optional integer literal + indicating the maximal width of the token to read. + For instance, [%6d] reads an integer, having at most 6 decimal digits; + [%4f] reads a float with at most 4 characters; and [%8\[\\000-\\255\]] + returns the next 8 characters (or all the characters still available, + if fewer than 8 characters are available in the input). + + Notes: + + - as mentioned above, a [%s] conversion always succeeds, even if there is + nothing to read in the input: in this case, it simply returns [""]. + + - in addition to the relevant digits, ['_'] characters may appear + inside numbers (this is reminiscent to the usual Caml lexical + conventions). If stricter scanning is desired, use the range + conversion facility instead of the number conversions. + + - the [scanf] facility is not intended for heavy duty lexical + analysis and parsing. If it appears not expressive enough for your + needs, several alternative exists: regular expressions (module + [Str]), stream parsers, [ocamllex]-generated lexers, + [ocamlyacc]-generated parsers. *) + +(** {7:indication Scanning indications in format strings} *) + +(** Scanning indications appear just after the string conversions [%s] + and [%\[ range \]] to delimit the end of the token. A scanning + indication is introduced by a [@] character, followed by some + constant character [c]. It means that the string token should end + just before the next matching [c] (which is skipped). If no [c] + character is encountered, the string token spreads as much as + possible. For instance, ["%s@\t"] reads a string up to the next + tab character or to the end of input. If a scanning + indication [\@c] does not follow a string conversion, it is treated + as a plain [c] character. + + Note: + + - the scanning indications introduce slight differences in the syntax of + [Scanf] format strings, compared to those used for the [Printf] + module. However, the scanning indications are similar to those used in + the [Format] module; hence, when producing formatted text to be scanned + by [!Scanf.bscanf], it is wise to use printing functions from the + [Format] module (or, if you need to use functions from [Printf], banish + or carefully double check the format strings that contain ['\@'] + characters). *) + +(** {7 Exceptions during scanning} *) + +(** Scanners may raise the following exceptions when the input cannot be read + according to the format string: + + - Raise [Scanf.Scan_failure] if the input does not match the format. + + - Raise [Failure] if a conversion to a number is not possible. + + - Raise [End_of_file] if the end of input is encountered while some more + characters are needed to read the current conversion specification. + + - Raise [Invalid_argument] if the format string is invalid. + + Note: + + - as a consequence, scanning a [%s] conversion never raises exception + [End_of_file]: if the end of input is reached the conversion succeeds and + simply returns the characters read so far, or [""] if none were ever read. *) + +(** {6 Specialised formatted input functions} *) + +val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner;; +(** Same as {!Scanf.bscanf}, but reads from the given regular input channel. + + Warning: since all formatted input functions operate from a {e formatted + input channel}, be aware that each [fscanf] invocation will operate with a + formatted input channel reading from the given channel. This extra level + of bufferization can lead to strange scanning behaviour if you use low + level primitives on the channel (reading characters, seeking the reading + position, and so on). + + As a consequence, never mix direct low level reading and high level + scanning from the same regular input channel. *) + +val sscanf : string -> ('a, 'b, 'c, 'd) scanner;; +(** Same as {!Scanf.bscanf}, but reads from the given string. *) + +val scanf : ('a, 'b, 'c, 'd) scanner;; +(** Same as {!Scanf.bscanf}, but reads from the predefined formatted input + channel {!Scanf.Scanning.stdin} that is connected to [Pervasives.stdin]. *) + +val kscanf : + Scanning.in_channel -> (Scanning.in_channel -> exn -> 'd) -> + ('a, 'b, 'c, 'd) scanner;; +(** Same as {!Scanf.bscanf}, but takes an additional function argument + [ef] that is called in case of error: if the scanning process or + some conversion fails, the scanning function aborts and calls the + error handling function [ef] with the scanning buffer and the + exception that aborted the scanning process as arguments. *) + +(** {6 Reading format strings from input} *) + +val bscanf_format : + Scanning.in_channel -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;; +(** [bscanf_format ic fmt f] reads a format string token from the formatted + input channel [ic], according to the given format string [fmt], and + applies [f] to the resulting format string value. + Raise [Scan_failure] if the format string value read does not have the + same type as [fmt]. + @since 3.09.0 +*) + +val sscanf_format : + string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;; +(** Same as {!Scanf.bscanf_format}, but reads from the given string. + @since 3.09.0 +*) + +val format_from_string : + string -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6;; +(** [format_from_string s fmt] converts a string argument to a format string, + according to the given format string [fmt]. + Raise [Scan_failure] if [s], considered as a format string, does not + have the same type as [fmt]. + @since 3.10.0 +*) diff --git a/ocaml-binary-annot/stdlib/set.ml b/ocaml-binary-annot/stdlib/set.ml new file mode 100644 index 0000000000..375fc5d0e4 --- /dev/null +++ b/ocaml-binary-annot/stdlib/set.ml @@ -0,0 +1,330 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* 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 singleton: elt -> 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 subset: t -> t -> bool + val iter: (elt -> unit) -> t -> unit + val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a + val for_all: (elt -> bool) -> t -> bool + val exists: (elt -> bool) -> t -> bool + val filter: (elt -> bool) -> t -> t + val partition: (elt -> bool) -> t -> t * t + val cardinal: t -> int + val elements: t -> elt list + val min_elt: t -> elt + val max_elt: t -> elt + val choose: t -> elt + val split: elt -> t -> t * bool * t + end + +module Make(Ord: OrderedType) = + struct + type elt = Ord.t + type t = Empty | Node of t * elt * t * int + + (* Sets are represented by balanced binary trees (the heights of the + children differ by at most 2 *) + + let height = function + Empty -> 0 + | Node(_, _, _, h) -> h + + (* Creates a new node with left son l, value v and right son r. + We must have all elements of l < v < all elements of r. + l and r must be balanced and | height l - height r | <= 2. + Inline expansion of height for better speed. *) + + let create l v r = + let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) + + (* Same as create, but performs one step of rebalancing if necessary. + Assumes l and r balanced and | height l - height r | <= 3. + Inline expansion of create for better speed in the most frequent case + where no rebalancing is required. *) + + let bal l v r = + let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + if hl > hr + 2 then begin + match l with + Empty -> invalid_arg "Set.bal" + | Node(ll, lv, lr, _) -> + if height ll >= height lr then + create ll lv (create lr v r) + else begin + match lr with + Empty -> invalid_arg "Set.bal" + | Node(lrl, lrv, lrr, _)-> + create (create ll lv lrl) lrv (create lrr v r) + end + end else if hr > hl + 2 then begin + match r with + Empty -> invalid_arg "Set.bal" + | Node(rl, rv, rr, _) -> + if height rr >= height rl then + create (create l v rl) rv rr + else begin + match rl with + Empty -> invalid_arg "Set.bal" + | Node(rll, rlv, rlr, _) -> + create (create l v rll) rlv (create rlr rv rr) + end + end else + Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) + + (* Insertion of one element *) + + let rec add x = function + Empty -> Node(Empty, x, Empty, 1) + | Node(l, v, r, _) as t -> + let c = Ord.compare x v in + if c = 0 then t else + if c < 0 then bal (add x l) v r else bal l v (add x r) + + (* Same as create and bal, but no assumptions are made on the + relative heights of l and r. *) + + let rec join l v r = + match (l, r) with + (Empty, _) -> add v r + | (_, Empty) -> add v l + | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) -> + if lh > rh + 2 then bal ll lv (join lr v r) else + if rh > lh + 2 then bal (join l v rl) rv rr else + create l v r + + (* Smallest and greatest element of a set *) + + let rec min_elt = function + Empty -> raise Not_found + | Node(Empty, v, r, _) -> v + | Node(l, v, r, _) -> min_elt l + + let rec max_elt = function + Empty -> raise Not_found + | Node(l, v, Empty, _) -> v + | Node(l, v, r, _) -> max_elt r + + (* Remove the smallest element of the given set *) + + let rec remove_min_elt = function + Empty -> invalid_arg "Set.remove_min_elt" + | Node(Empty, v, r, _) -> r + | Node(l, v, r, _) -> bal (remove_min_elt l) v r + + (* Merge two trees l and r into one. + All elements of l must precede the elements of r. + Assume | height l - height r | <= 2. *) + + let merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2) + + (* Merge two trees l and r into one. + All elements of l must precede the elements of r. + No assumption on the heights of l and r. *) + + let concat t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> join t1 (min_elt t2) (remove_min_elt t2) + + (* Splitting. split x s returns a triple (l, present, r) where + - l is the set of elements of s that are < x + - r is the set of elements of s that are > x + - present is false if s contains no element equal to x, + or true if s contains an element equal to x. *) + + let rec split x = function + Empty -> + (Empty, false, Empty) + | Node(l, v, r, _) -> + let c = Ord.compare x v in + if c = 0 then (l, true, r) + else if c < 0 then + let (ll, pres, rl) = split x l in (ll, pres, join rl v r) + else + let (lr, pres, rr) = split x r in (join l v lr, pres, rr) + + (* Implementation of the set operations *) + + let empty = Empty + + let is_empty = function Empty -> true | _ -> false + + let rec mem x = function + Empty -> false + | Node(l, v, r, _) -> + let c = Ord.compare x v in + c = 0 || mem x (if c < 0 then l else r) + + let singleton x = Node(Empty, x, Empty, 1) + + let rec remove x = function + Empty -> Empty + | Node(l, v, r, _) -> + let c = Ord.compare x v in + if c = 0 then merge l r else + if c < 0 then bal (remove x l) v r else bal l v (remove x r) + + let rec union s1 s2 = + match (s1, s2) with + (Empty, t2) -> t2 + | (t1, Empty) -> t1 + | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> + if h1 >= h2 then + if h2 = 1 then add v2 s1 else begin + let (l2, _, r2) = split v1 s2 in + join (union l1 l2) v1 (union r1 r2) + end + else + if h1 = 1 then add v1 s2 else begin + let (l1, _, r1) = split v2 s1 in + join (union l1 l2) v2 (union r1 r2) + end + + let rec inter s1 s2 = + match (s1, s2) with + (Empty, t2) -> Empty + | (t1, Empty) -> Empty + | (Node(l1, v1, r1, _), t2) -> + match split v1 t2 with + (l2, false, r2) -> + concat (inter l1 l2) (inter r1 r2) + | (l2, true, r2) -> + join (inter l1 l2) v1 (inter r1 r2) + + let rec diff s1 s2 = + match (s1, s2) with + (Empty, t2) -> Empty + | (t1, Empty) -> t1 + | (Node(l1, v1, r1, _), t2) -> + match split v1 t2 with + (l2, false, r2) -> + join (diff l1 l2) v1 (diff r1 r2) + | (l2, true, r2) -> + concat (diff l1 l2) (diff r1 r2) + + type enumeration = End | More of elt * t * enumeration + + let rec cons_enum s e = + match s with + Empty -> e + | Node(l, v, r, _) -> cons_enum l (More(v, r, e)) + + let rec compare_aux e1 e2 = + match (e1, e2) with + (End, End) -> 0 + | (End, _) -> -1 + | (_, End) -> 1 + | (More(v1, r1, e1), More(v2, r2, e2)) -> + let c = Ord.compare v1 v2 in + if c <> 0 + then c + else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) + + let compare s1 s2 = + compare_aux (cons_enum s1 End) (cons_enum s2 End) + + let equal s1 s2 = + compare s1 s2 = 0 + + let rec subset s1 s2 = + match (s1, s2) with + Empty, _ -> + true + | _, Empty -> + false + | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> + let c = Ord.compare v1 v2 in + if c = 0 then + subset l1 l2 && subset r1 r2 + else if c < 0 then + subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2 + else + subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2 + + 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 r (f v (fold f l accu)) + + let rec for_all p = function + Empty -> true + | Node(l, v, r, _) -> p v && for_all p l && for_all p r + + let rec exists p = function + Empty -> false + | Node(l, v, r, _) -> p v || exists p l || exists p r + + let filter p s = + let rec filt accu = function + | Empty -> accu + | Node(l, v, r, _) -> + filt (filt (if p v then add v accu else accu) l) r in + filt Empty s + + let partition p s = + let rec part (t, f as accu) = function + | Empty -> accu + | Node(l, v, r, _) -> + part (part (if p v then (add v t, f) else (t, add v f)) l) r in + part (Empty, Empty) s + + let rec cardinal = function + Empty -> 0 + | Node(l, v, r, _) -> cardinal l + 1 + cardinal r + + let rec elements_aux accu = function + Empty -> accu + | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l + + let elements s = + elements_aux [] s + + let choose = min_elt + + end diff --git a/ocaml-binary-annot/stdlib/set.mli b/ocaml-binary-annot/stdlib/set.mli new file mode 100644 index 0000000000..851a9ef51c --- /dev/null +++ b/ocaml-binary-annot/stdlib/set.mli @@ -0,0 +1,153 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Sets over ordered types. + + This module implements the set data structure, given a total ordering + function over the set elements. All operations over sets + are purely applicative (no side-effects). + The implementation uses balanced binary trees, and is therefore + reasonably efficient: insertion and membership take time + logarithmic in the size of the set, for instance. +*) + +module type OrderedType = + sig + type t + (** The type of the set elements. *) + val compare : t -> t -> int + (** A total ordering function over the set elements. + This is a two-argument function [f] such that + [f e1 e2] is zero if the elements [e1] and [e2] are equal, + [f e1 e2] is strictly negative if [e1] is smaller than [e2], + and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + Example: a suitable ordering function is the generic structural + comparison function {!Pervasives.compare}. *) + end +(** Input signature of the functor {!Set.Make}. *) + +module type S = + sig + type elt + (** The type of the set elements. *) + + type t + (** The type of sets. *) + + val empty: t + (** The empty set. *) + + val is_empty: t -> bool + (** Test whether a set is empty or not. *) + + val mem: elt -> t -> bool + (** [mem x s] tests whether [x] belongs to the set [s]. *) + + val add: elt -> t -> t + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + + val singleton: elt -> t + (** [singleton x] returns the one-element set containing only [x]. *) + + val remove: elt -> t -> t + (** [remove x s] returns a set containing all elements of [s], + except [x]. If [x] was not in [s], [s] is returned unchanged. *) + + val union: t -> t -> t + (** Set union. *) + + val inter: t -> t -> t + (** Set intersection. *) + + (** Set difference. *) + val diff: t -> t -> t + + val compare: t -> t -> int + (** Total ordering between sets. Can be used as the ordering function + for doing sets of sets. *) + + val equal: t -> t -> bool + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + + val subset: t -> t -> bool + (** [subset s1 s2] tests whether the set [s1] is a subset of + the set [s2]. *) + + val iter: (elt -> unit) -> t -> unit + (** [iter f s] applies [f] in turn to all elements of [s]. + The elements of [s] are presented to [f] in increasing order + with respect to the ordering over the type of the elements. *) + + val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a + (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], + where [x1 ... xN] are the elements of [s], in increasing order. *) + + val for_all: (elt -> bool) -> t -> bool + (** [for_all p s] checks if all elements of the set + satisfy the predicate [p]. *) + + val exists: (elt -> bool) -> t -> bool + (** [exists p s] checks if at least one element of + the set satisfies the predicate [p]. *) + + val filter: (elt -> bool) -> t -> t + (** [filter p s] returns the set of all elements in [s] + that satisfy predicate [p]. *) + + val partition: (elt -> bool) -> t -> t * t + (** [partition p s] returns a pair of sets [(s1, s2)], where + [s1] is the set of all the elements of [s] that satisfy the + predicate [p], and [s2] is the set of all the elements of + [s] that do not satisfy [p]. *) + + val cardinal: t -> int + (** Return the number of elements of a set. *) + + val elements: t -> elt list + (** Return the list of all elements of the given set. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Set.Make}. *) + + val min_elt: t -> elt + (** Return the smallest element of the given set + (with respect to the [Ord.compare] ordering), or raise + [Not_found] if the set is empty. *) + + val max_elt: t -> elt + (** Same as {!Set.S.min_elt}, but returns the largest element of the + given set. *) + + val choose: t -> elt + (** Return one element of the given set, or raise [Not_found] if + the set is empty. Which element is chosen is unspecified, + but equal elements will be chosen for equal sets. *) + + val split: elt -> t -> t * bool * t + (** [split x s] returns a triple [(l, present, r)], where + [l] is the set of elements of [s] that are + strictly less than [x]; + [r] is the set of elements of [s] that are + strictly greater than [x]; + [present] is [false] if [s] contains no element equal to [x], + or [true] if [s] contains an element equal to [x]. *) + end +(** Output signature of the functor {!Set.Make}. *) + +module Make (Ord : OrderedType) : S with type elt = Ord.t +(** Functor building an implementation of the set structure + given a totally ordered type. *) diff --git a/ocaml-binary-annot/stdlib/sharpbang b/ocaml-binary-annot/stdlib/sharpbang new file mode 100644 index 0000000000..04c9334b63 --- /dev/null +++ b/ocaml-binary-annot/stdlib/sharpbang @@ -0,0 +1 @@ +#!
\ No newline at end of file diff --git a/ocaml-binary-annot/stdlib/sort.ml b/ocaml-binary-annot/stdlib/sort.ml new file mode 100644 index 0000000000..7c53ab7774 --- /dev/null +++ b/ocaml-binary-annot/stdlib/sort.ml @@ -0,0 +1,99 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Merging and sorting *) + +open Array + +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) + +let swap arr i j = + let tmp = unsafe_get arr i in + unsafe_set arr i (unsafe_get arr j); + unsafe_set arr j tmp + +(* There is a known performance bug in the code below. If you find + it, don't bother reporting it. You're not supposed to use this + module anyway. *) +let array cmp arr = + let rec qsort lo hi = + if hi - lo >= 6 then begin + let mid = (lo + hi) lsr 1 in + (* Select median value from among LO, MID, and HI. Rearrange + LO and HI so the three values are sorted. This lowers the + probability of picking a pathological pivot. It also + avoids extra comparisons on i and j in the two tight "while" + loops below. *) + if cmp (unsafe_get arr mid) (unsafe_get arr lo) then swap arr mid lo; + if cmp (unsafe_get arr hi) (unsafe_get arr mid) then begin + swap arr mid hi; + if cmp (unsafe_get arr mid) (unsafe_get arr lo) then swap arr mid lo + end; + let pivot = unsafe_get arr mid in + let i = ref (lo + 1) and j = ref (hi - 1) in + if not (cmp pivot (unsafe_get arr hi)) + || not (cmp (unsafe_get arr lo) pivot) + then raise (Invalid_argument "Sort.array"); + while !i < !j do + while not (cmp pivot (unsafe_get arr !i)) do incr i done; + while not (cmp (unsafe_get arr !j) pivot) do decr j done; + if !i < !j then swap arr !i !j; + incr i; decr j + done; + (* Recursion on smaller half, tail-call on larger half *) + if !j - lo <= hi - !i then begin + qsort lo !j; qsort !i hi + end else begin + qsort !i hi; qsort lo !j + end + end in + qsort 0 (Array.length arr - 1); + (* Finish sorting by insertion sort *) + for i = 1 to Array.length arr - 1 do + let val_i = (unsafe_get arr i) in + if not (cmp (unsafe_get arr (i - 1)) val_i) then begin + unsafe_set arr i (unsafe_get arr (i - 1)); + let j = ref (i - 1) in + while !j >= 1 && not (cmp (unsafe_get arr (!j - 1)) val_i) do + unsafe_set arr !j (unsafe_get arr (!j - 1)); + decr j + done; + unsafe_set arr !j val_i + end + done diff --git a/ocaml-binary-annot/stdlib/sort.mli b/ocaml-binary-annot/stdlib/sort.mli new file mode 100644 index 0000000000..7069052eb4 --- /dev/null +++ b/ocaml-binary-annot/stdlib/sort.mli @@ -0,0 +1,41 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Sorting and merging lists. + + @deprecated This module is obsolete and exists only for backward + compatibility. + The sorting functions in {!Array} and {!List} should be used instead. + The new functions are faster and use less memory. +*) + +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 array : ('a -> 'a -> bool) -> 'a array -> unit +(** Sort an array 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. + The array is sorted in place. *) + +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/ocaml-binary-annot/stdlib/stack.ml b/ocaml-binary-annot/stdlib/stack.ml new file mode 100644 index 0000000000..03277d0794 --- /dev/null +++ b/ocaml-binary-annot/stdlib/stack.ml @@ -0,0 +1,42 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +type 'a t = { mutable c : 'a list } + +exception Empty + +let create () = { c = [] } + +let clear s = s.c <- [] + +let copy s = { c = 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 top s = + match s.c with + hd::_ -> hd + | [] -> raise Empty + +let is_empty s = (s.c = []) + +let length s = List.length s.c + +let iter f s = List.iter f s.c diff --git a/ocaml-binary-annot/stdlib/stack.mli b/ocaml-binary-annot/stdlib/stack.mli new file mode 100644 index 0000000000..bf33d01aba --- /dev/null +++ b/ocaml-binary-annot/stdlib/stack.mli @@ -0,0 +1,57 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Last-in first-out stacks. + + This module implements stacks (LIFOs), with in-place modification. +*) + +type 'a t +(** The type of stacks containing elements of type ['a]. *) + +exception Empty +(** Raised when {!Stack.pop} or {!Stack.top} is applied to an empty stack. *) + + +val create : 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 top : 'a t -> 'a +(** [top s] 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 copy : 'a t -> 'a t +(** Return a copy of the given stack. *) + +val is_empty : 'a t -> bool +(** Return [true] if the given stack is empty, [false] otherwise. *) + +val length : 'a t -> int +(** Return the number of elements in a stack. *) + +val iter : ('a -> unit) -> '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/ocaml-binary-annot/stdlib/stdLabels.ml b/ocaml-binary-annot/stdlib/stdLabels.ml new file mode 100644 index 0000000000..bd6a5841de --- /dev/null +++ b/ocaml-binary-annot/stdlib/stdLabels.ml @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Module [StdLabels]: meta-module for labelled libraries *) + +module Array = ArrayLabels + +module List = ListLabels + +module String = StringLabels diff --git a/ocaml-binary-annot/stdlib/stdLabels.mli b/ocaml-binary-annot/stdlib/stdLabels.mli new file mode 100644 index 0000000000..73f72dc687 --- /dev/null +++ b/ocaml-binary-annot/stdlib/stdLabels.mli @@ -0,0 +1,141 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Standard labeled libraries. + + This meta-module provides labelized version of the {!Array}, + {!List} and {!String} modules. + + They only differ by their labels. Detailed interfaces can be found + in [arrayLabels.mli], [listLabels.mli] and [stringLabels.mli]. +*) + +module Array : + sig + external length : 'a array -> int = "%array_length" + external get : 'a array -> int -> 'a = "%array_safe_get" + external set : 'a array -> int -> 'a -> unit = "%array_safe_set" + external make : int -> 'a -> 'a array = "caml_make_vect" + external create : int -> 'a -> 'a array = "caml_make_vect" + val init : int -> f:(int -> 'a) -> 'a array + val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array + val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array + val append : 'a array -> 'a array -> 'a array + val concat : 'a array list -> 'a array + val sub : 'a array -> pos:int -> len:int -> 'a array + val copy : 'a array -> 'a array + val fill : 'a array -> pos:int -> len:int -> 'a -> unit + val blit : + src:'a array -> src_pos:int -> dst:'a array -> dst_pos:int -> len:int -> + unit + val to_list : 'a array -> 'a list + val of_list : 'a list -> 'a array + val iter : f:('a -> unit) -> 'a array -> unit + val map : f:('a -> 'b) -> 'a array -> 'b array + val iteri : f:(int -> 'a -> unit) -> 'a array -> unit + val mapi : f:(int -> 'a -> 'b) -> 'a array -> 'b array + val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a + val fold_right : f:('a -> 'b -> 'b) -> 'a array -> init:'b -> 'b + val sort : cmp:('a -> 'a -> int) -> 'a array -> unit + val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit + val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit + external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" + external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" + end + +module List : + sig + val length : 'a list -> int + val hd : 'a list -> 'a + val tl : 'a list -> 'a list + val nth : 'a list -> int -> 'a + val rev : 'a list -> 'a list + val append : 'a list -> 'a list -> 'a list + val rev_append : 'a list -> 'a list -> 'a list + val concat : 'a list list -> 'a list + val flatten : 'a list list -> 'a list + val iter : f:('a -> unit) -> 'a list -> unit + val map : f:('a -> 'b) -> 'a list -> 'b list + val rev_map : f:('a -> 'b) -> 'a list -> 'b list + val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a + val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b + val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit + val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val fold_left2 : + f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a + val fold_right2 : + f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c + val for_all : f:('a -> bool) -> 'a list -> bool + val exists : f:('a -> bool) -> 'a list -> bool + val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val mem : 'a -> set:'a list -> bool + val memq : 'a -> set:'a list -> bool + val find : f:('a -> bool) -> 'a list -> 'a + val filter : f:('a -> bool) -> 'a list -> 'a list + val find_all : f:('a -> bool) -> 'a list -> 'a list + val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list + val assoc : 'a -> ('a * 'b) list -> 'b + val assq : 'a -> ('a * 'b) list -> 'b + val mem_assoc : 'a -> map:('a * 'b) list -> bool + val mem_assq : 'a -> map:('a * 'b) list -> bool + val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list + val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list + val split : ('a * 'b) list -> 'a list * 'b list + val combine : 'a list -> 'b list -> ('a * 'b) list + val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list + val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list + val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list + val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list + end + +module String : + sig + external length : string -> int = "%string_length" + external get : string -> int -> char = "%string_safe_get" + external set : string -> int -> char -> unit = "%string_safe_set" + external create : int -> string = "caml_create_string" + val make : int -> char -> string + val copy : string -> string + val sub : string -> pos:int -> len:int -> string + val fill : string -> pos:int -> len:int -> char -> unit + val blit : + src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> + unit + val concat : sep:string -> string list -> string + val iter : f:(char -> unit) -> string -> unit + val escaped : string -> string + val index : string -> char -> int + val rindex : string -> char -> int + val index_from : string -> int -> char -> int + val rindex_from : string -> int -> char -> int + val contains : string -> char -> bool + val contains_from : string -> int -> char -> bool + val rcontains_from : string -> int -> char -> bool + val uppercase : string -> string + val lowercase : string -> string + val capitalize : string -> string + val uncapitalize : string -> string + type t = string + val compare: t -> t -> int + external unsafe_get : string -> int -> char = "%string_unsafe_get" + external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" + external unsafe_blit : + src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> + unit = "caml_blit_string" "noalloc" + external unsafe_fill : string -> pos:int -> len:int -> char -> unit + = "caml_fill_string" "noalloc" + end diff --git a/ocaml-binary-annot/stdlib/std_exit.ml b/ocaml-binary-annot/stdlib/std_exit.ml new file mode 100644 index 0000000000..6f5ff301aa --- /dev/null +++ b/ocaml-binary-annot/stdlib/std_exit.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Ensure that [at_exit] functions are called at the end of every program *) + +let _ = do_at_exit() diff --git a/ocaml-binary-annot/stdlib/stdlib.mllib b/ocaml-binary-annot/stdlib/stdlib.mllib new file mode 100644 index 0000000000..91265e5da9 --- /dev/null +++ b/ocaml-binary-annot/stdlib/stdlib.mllib @@ -0,0 +1,49 @@ +# This file lists all standard library modules +# (in the same order as Makefile.shared). +# It is used in particular to know what to expunge in toplevels. +# $Id$ + +Pervasives +Array +List +Char +String +Sys +Hashtbl +Sort +Marshal +Obj +Int32 +Int64 +Nativeint +Lexing +Parsing +Set +Map +Stack +Queue +CamlinternalLazy +Lazy +Stream +Buffer +Printf +Format +Scanf +Arg +Printexc +Gc +Digest +Random +Callback +CamlinternalOO +Oo +CamlinternalMod +Genlex +Weak +Filename +Complex +ArrayLabels +ListLabels +StringLabels +MoreLabels +StdLabels diff --git a/ocaml-binary-annot/stdlib/stream.ml b/ocaml-binary-annot/stdlib/stream.ml new file mode 100644 index 0000000000..aa6a2a2ab2 --- /dev/null +++ b/ocaml-binary-annot/stdlib/stream.ml @@ -0,0 +1,200 @@ +(***********************************************************************) +(* *) +(* Ocaml *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The fields of type t are not mutable to preserve polymorphism of + the empty stream. This is type safe because the empty stream is never + patched. *) + +type 'a t = { count : int; data : 'a data } +and 'a data = + Sempty + | Scons of 'a * 'a data + | Sapp of 'a data * 'a data + | Slazy of 'a data Lazy.t + | Sgen of 'a gen + | Sbuffio of buffio +and 'a gen = { mutable curr : 'a option option; func : int -> 'a option } +and buffio = + { ic : in_channel; buff : string; mutable len : int; mutable ind : int } +;; +exception Failure;; +exception Error of string;; + +external count : 'a t -> int = "%field0";; +external set_count : 'a t -> int -> unit = "%setfield0";; +let set_data (s : 'a t) (d : 'a data) = + Obj.set_field (Obj.repr s) 1 (Obj.repr d) +;; + +let fill_buff b = + b.len <- input b.ic b.buff 0 (String.length b.buff); b.ind <- 0 +;; + +let rec get_data count d = match d with + (* Returns either Sempty or Scons(a, _) even when d is a generator + or a buffer. In those cases, the item a is seen as extracted from + the generator/buffer. + The count parameter is used for calling `Sgen-functions'. *) + Sempty | Scons (_, _) -> d + | Sapp (d1, d2) -> + begin match get_data count d1 with + Scons (a, d11) -> Scons (a, Sapp (d11, d2)) + | Sempty -> get_data count d2 + | _ -> assert false + end + | Sgen {curr = Some None; func = _ } -> Sempty + | Sgen ({curr = Some(Some a); func = f} as g) -> + g.curr <- None; Scons(a, d) + | Sgen g -> + begin match g.func count with + None -> g.curr <- Some(None); Sempty + | Some a -> Scons(a, d) + (* Warning: anyone using g thinks that an item has been read *) + end + | Sbuffio b -> + if b.ind >= b.len then fill_buff b; + if b.len == 0 then Sempty else + let r = Obj.magic (String.unsafe_get b.buff b.ind) in + (* Warning: anyone using g thinks that an item has been read *) + b.ind <- succ b.ind; Scons(r, d) + | Slazy f -> get_data count (Lazy.force f) +;; + +let rec peek s = + (* consult the first item of s *) + match s.data with + Sempty -> None + | Scons (a, _) -> Some a + | Sapp (_, _) -> + begin match get_data s.count s.data with + Scons(a, _) as d -> set_data s d; Some a + | Sempty -> None + | _ -> assert false + end + | Slazy f -> set_data s (Lazy.force f); peek s + | Sgen {curr = Some a} -> a + | Sgen g -> let x = g.func s.count in g.curr <- Some x; x + | Sbuffio b -> + if b.ind >= b.len then fill_buff b; + if b.len == 0 then begin set_data s Sempty; None end + else Some (Obj.magic (String.unsafe_get b.buff b.ind)) +;; + +let rec junk s = + match s.data with + Scons (_, d) -> set_count s (succ s.count); set_data s d + | Sgen ({curr = Some _} as g) -> set_count s (succ s.count); g.curr <- None + | Sbuffio b -> set_count s (succ s.count); b.ind <- succ b.ind + | _ -> + match peek s with + None -> () + | Some _ -> junk s +;; + +let rec nget n s = + if n <= 0 then [], s.data, 0 + else + match peek s with + Some a -> + junk s; + let (al, d, k) = nget (pred n) s in a :: al, Scons (a, d), succ k + | None -> [], s.data, 0 +;; + +let npeek n s = + let (al, d, len) = nget n s in set_count s (s.count - len); set_data s d; al +;; + +let next s = + match peek s with + Some a -> junk s; a + | None -> raise Failure +;; + +let empty s = + match peek s with + Some _ -> raise Failure + | None -> () +;; + +let iter f strm = + let rec do_rec () = + match peek strm with + Some a -> junk strm; ignore(f a); do_rec () + | None -> () + in + do_rec () +;; + +(* Stream building functions *) + +let from f = {count = 0; data = Sgen {curr = None; func = f}};; + +let of_list l = + {count = 0; data = List.fold_right (fun x l -> Scons (x, l)) l Sempty} +;; + +let of_string s = + from (fun c -> if c < String.length s then Some s.[c] else None) +;; + +let of_channel ic = + {count = 0; + data = Sbuffio {ic = ic; buff = String.create 4096; len = 0; ind = 0}} +;; + +(* Stream expressions builders *) + +let iapp i s = {count = 0; data = Sapp (i.data, s.data)};; +let icons i s = {count = 0; data = Scons (i, s.data)};; +let ising i = {count = 0; data = Scons (i, Sempty)};; + +let lapp f s = + {count = 0; data = Slazy (lazy(Sapp ((f ()).data, s.data)))} +;; +let lcons f s = {count = 0; data = Slazy (lazy(Scons (f (), s.data)))};; +let lsing f = {count = 0; data = Slazy (lazy(Scons (f (), Sempty)))};; + +let sempty = {count = 0; data = Sempty};; +let slazy f = {count = 0; data = Slazy (lazy(f ()).data)};; + +(* For debugging use *) + +let rec dump f s = + print_string "{count = "; + print_int s.count; + print_string "; data = "; + dump_data f s.data; + print_string "}"; + print_newline () +and dump_data f = + function + Sempty -> print_string "Sempty" + | Scons (a, d) -> + print_string "Scons ("; + f a; + print_string ", "; + dump_data f d; + print_string ")" + | Sapp (d1, d2) -> + print_string "Sapp ("; + dump_data f d1; + print_string ", "; + dump_data f d2; + print_string ")" + | Slazy _ -> print_string "Slazy" + | Sgen _ -> print_string "Sgen" + | Sbuffio b -> print_string "Sbuffio" +;; diff --git a/ocaml-binary-annot/stdlib/stream.mli b/ocaml-binary-annot/stdlib/stream.mli new file mode 100644 index 0000000000..28cfd3a1c4 --- /dev/null +++ b/ocaml-binary-annot/stdlib/stream.mli @@ -0,0 +1,106 @@ +(***********************************************************************) +(* *) +(* Ocaml *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Streams and parsers. *) + +type 'a t +(** The type of streams holding values of type ['a]. *) + +exception Failure +(** Raised by parsers when none of the first components of the stream + patterns is accepted. *) + +exception Error of string +(** Raised by parsers when the first component of a stream pattern is + accepted, but one of the following components is rejected. *) + + +(** {6 Stream builders} + + Warning: these functions create streams with fast access; it is illegal + to mix them with streams built with [[< >]]; would raise [Failure] + when accessing such mixed streams. +*) + +val from : (int -> 'a option) -> 'a t +(** [Stream.from f] returns a stream built from the function [f]. + To create a new stream element, the function [f] is called with + the current stream count. The user function [f] must return either + [Some <value>] for a value or [None] to specify the end of the + stream. *) + +val of_list : 'a list -> 'a t +(** Return the stream holding the elements of the list in the same + order. *) + +val of_string : string -> char t +(** Return the stream of the characters of the string parameter. *) + +val of_channel : in_channel -> char t +(** Return the stream of the characters read from the input channel. *) + + +(** {6 Stream iterator} *) + +val iter : ('a -> unit) -> 'a t -> unit +(** [Stream.iter f s] scans the whole stream s, applying function [f] + in turn to each stream element encountered. *) + + +(** {6 Predefined parsers} *) + +val next : 'a t -> 'a +(** Return the first element of the stream and remove it from the + stream. Raise Stream.Failure if the stream is empty. *) + +val empty : 'a t -> unit +(** Return [()] if the stream is empty, else raise [Stream.Failure]. *) + + +(** {6 Useful functions} *) + +val peek : 'a t -> 'a option +(** Return [Some] of "the first element" of the stream, or [None] if + the stream is empty. *) + +val junk : 'a t -> unit +(** Remove the first element of the stream, possibly unfreezing + it before. *) + +val count : 'a t -> int +(** Return the current count of the stream elements, i.e. the number + of the stream elements discarded. *) + +val npeek : int -> 'a t -> 'a list +(** [npeek n] returns the list of the [n] first elements of + the stream, or all its remaining elements if less than [n] + elements are available. *) + +(**/**) + +(** {6 For system use only, not for the casual user} *) + +val iapp : 'a t -> 'a t -> 'a t +val icons : 'a -> 'a t -> 'a t +val ising : 'a -> 'a t + +val lapp : (unit -> 'a t) -> 'a t -> 'a t +val lcons : (unit -> 'a) -> 'a t -> 'a t +val lsing : (unit -> 'a) -> 'a t + +val sempty : 'a t +val slazy : (unit -> 'a t) -> 'a t + +val dump : ('a -> unit) -> 'a t -> unit diff --git a/ocaml-binary-annot/stdlib/string.ml b/ocaml-binary-annot/stdlib/string.ml new file mode 100644 index 0000000000..e61e9efe90 --- /dev/null +++ b/ocaml-binary-annot/stdlib/string.ml @@ -0,0 +1,186 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* String operations *) + +external length : string -> int = "%string_length" +external get : string -> int -> char = "%string_safe_get" +external set : string -> int -> char -> unit = "%string_safe_set" +external create : int -> string = "caml_create_string" +external unsafe_get : string -> int -> char = "%string_unsafe_get" +external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" +external unsafe_blit : string -> int -> string -> int -> int -> unit + = "caml_blit_string" "noalloc" +external unsafe_fill : string -> int -> int -> char -> unit + = "caml_fill_string" "noalloc" + +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 || len < 0 || ofs > length s - len + 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 || len < 0 || ofs > length s - len + then invalid_arg "String.fill" + else unsafe_fill s ofs len c + +let blit s1 ofs1 s2 ofs2 len = + if len < 0 || ofs1 < 0 || ofs1 > length s1 - len + || ofs2 < 0 || ofs2 > length s2 - len + then invalid_arg "String.blit" + else unsafe_blit s1 ofs1 s2 ofs2 len + +let iter f a = + for i = 0 to length a - 1 do f(unsafe_get a i) done + +let iteri f a = + for i = 0 to length a - 1 do f i (unsafe_get a i) done + +let concat sep l = + match l with + [] -> "" + | hd :: tl -> + let num = ref 0 and len = ref 0 in + List.iter (fun s -> incr num; len := !len + length s) l; + let r = create (!len + length sep * (!num - 1)) in + unsafe_blit hd 0 r 0 (length hd); + let pos = ref(length hd) in + List.iter + (fun s -> + unsafe_blit sep 0 r !pos (length sep); + pos := !pos + length sep; + unsafe_blit s 0 r !pos (length s); + pos := !pos + length s) + tl; + r + +external is_printable: char -> bool = "caml_is_printable" +external char_code: char -> int = "%identity" +external char_chr: int -> char = "%identity" + +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' | '\r' | '\b' -> 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' + | '\r' -> + unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'r' + | '\b' -> + unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'b' + | 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_chr (48 + a / 100)); + incr n; + unsafe_set s' !n (char_chr (48 + (a / 10) mod 10)); + incr n; + unsafe_set s' !n (char_chr (48 + a mod 10)) + end + end; + incr n + done; + s' + end + +let map f s = + let l = length s in + if l = 0 then s else begin + let r = create l in + for i = 0 to l - 1 do unsafe_set r i (f(unsafe_get s i)) done; + r + end + +let uppercase s = map Char.uppercase s +let lowercase s = map Char.lowercase s + +let apply1 f s = + if length s = 0 then s else begin + let r = copy s in + unsafe_set r 0 (f(unsafe_get s 0)); + r + end + +let capitalize s = apply1 Char.uppercase s +let uncapitalize s = apply1 Char.lowercase s + +let rec index_rec s lim i c = + if i >= lim then raise Not_found else + if unsafe_get s i = c then i else index_rec s lim (i + 1) c;; + +let index s c = index_rec s (length s) 0 c;; + +let index_from s i c = + let l = length s in + if i < 0 || i > l then invalid_arg "String.index_from" else + index_rec s l i c;; + +let rec rindex_rec s i c = + if i < 0 then raise Not_found else + if unsafe_get s i = c then i else rindex_rec s (i - 1) c;; + +let rindex s c = rindex_rec s (length s - 1) c;; + +let rindex_from s i c = + if i < -1 || i >= length s then invalid_arg "String.rindex_from" else + rindex_rec s i c;; + +let contains_from s i c = + let l = length s in + if i < 0 || i > l then invalid_arg "String.contains_from" else + try ignore (index_rec s l i c); true with Not_found -> false;; + +let contains s c = contains_from s 0 c;; + +let rcontains_from s i c = + if i < 0 || i >= length s then invalid_arg "String.rcontains_from" else + try ignore (rindex_rec s i c); true with Not_found -> false;; + +type t = string + +let compare = Pervasives.compare diff --git a/ocaml-binary-annot/stdlib/string.mli b/ocaml-binary-annot/stdlib/string.mli new file mode 100644 index 0000000000..a2d995df24 --- /dev/null +++ b/ocaml-binary-annot/stdlib/string.mli @@ -0,0 +1,191 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** String operations. + Given a string [s] of length [l], we call character number in [s] + the index of a character in [s]. Indexes start at [0], and we will + call a character number valid in [s] if it falls within the range + [[0...l-1]]. A position is the point between two characters or at + the beginning or end of the string. We call a position valid + in [s] if it falls within the range [[0...l]]. Note that character + number [n] is between positions [n] and [n+1]. + + Two parameters [start] and [len] are said to designate a valid + substring of [s] if [len >= 0] and [start] and [start+len] are + valid positions in [s]. + *) + +external length : string -> int = "%string_length" +(** Return the length (number of characters) of the given string. *) + +external get : string -> int -> char = "%string_safe_get" +(** [String.get s n] returns character number [n] in string [s]. + You can also write [s.[n]] instead of [String.get s n]. + + Raise [Invalid_argument] if [n] not a valid character number in [s]. *) + + +external set : string -> int -> char -> unit = "%string_safe_set" +(** [String.set s n c] modifies string [s] in place, + replacing the character number [n] by [c]. + You can also write [s.[n] <- c] instead of [String.set s n c]. + + Raise [Invalid_argument] if [n] is not a valid character number in [s]. *) + +external create : int -> string = "caml_create_string" +(** [String.create n] returns a fresh string of length [n]. + The string initially contains arbitrary characters. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val make : int -> char -> string +(** [String.make n c] returns a fresh string of length [n], + filled with the character [c]. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.*) + +val copy : string -> string +(** Return a copy of the given string. *) + +val sub : string -> int -> int -> string +(** [String.sub s start len] returns a fresh string of length [len], + containing the substring of [s] that starts at position [start] and + has length [len]. + + Raise [Invalid_argument] if [start] and [len] do not + designate a valid substring of [s]. *) + +val fill : string -> int -> int -> char -> unit +(** [String.fill s start len c] modifies string [s] in place, + replacing [len] characters by [c], starting at [start]. + + Raise [Invalid_argument] if [start] and [len] do not + designate a valid substring of [s]. *) + +val blit : string -> int -> string -> int -> int -> unit +(** [String.blit src srcoff dst dstoff len] copies [len] characters + from string [src], starting at character number [srcoff], to + string [dst], starting at character number [dstoff]. It works + correctly even if [src] and [dst] are the same string, + and the source and destination intervals overlap. + + Raise [Invalid_argument] if [srcoff] and [len] do not + designate a valid substring of [src], or if [dstoff] and [len] + do not designate a valid substring of [dst]. *) + +val concat : string -> string list -> string +(** [String.concat sep sl] concatenates the list of strings [sl], + inserting the separator string [sep] between each. *) + +val iter : (char -> unit) -> string -> unit +(** [String.iter f s] applies function [f] in turn to all + the characters of [s]. It is equivalent to + [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *) + +val iteri : (int -> char -> unit) -> string -> unit +(** Same as {!String.iter}, but the + function is applied to the index of the element as first argument (counting from 0), + and the character itself as second argument. + @since 3.13.0 +*) + +val escaped : string -> string +(** Return a copy of the argument, with special characters + represented by escape sequences, following the lexical + conventions of Objective Caml. If there is no special + character in the argument, return the original string itself, + not a copy. *) + +val index : string -> char -> int +(** [String.index s c] returns the character number of the first + occurrence of character [c] in string [s]. + + Raise [Not_found] if [c] does not occur in [s]. *) + +val rindex : string -> char -> int +(** [String.rindex s c] returns the character number of the last + occurrence of character [c] in string [s]. + + Raise [Not_found] if [c] does not occur in [s]. *) + +val index_from : string -> int -> char -> int +(** [String.index_from s i c] returns the character number of the + first occurrence of character [c] in string [s] after position [i]. + [String.index s c] is equivalent to [String.index_from s 0 c]. + + Raise [Invalid_argument] if [i] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] after position [i]. *) + +val rindex_from : string -> int -> char -> int +(** [String.rindex_from s i c] returns the character number of the + last occurrence of character [c] in string [s] before position [i+1]. + [String.rindex s c] is equivalent to + [String.rindex_from s (String.length s - 1) c]. + + Raise [Invalid_argument] if [i+1] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) + +val contains : string -> char -> bool +(** [String.contains s c] tests if character [c] + appears in the string [s]. *) + +val contains_from : string -> int -> char -> bool +(** [String.contains_from s start c] tests if character [c] + appears in [s] after position [start]. + [String.contains s c] is equivalent to + [String.contains_from s 0 c]. + + Raise [Invalid_argument] if [start] is not a valid position in [s]. *) + +val rcontains_from : string -> int -> char -> bool +(** [String.rcontains_from s stop c] tests if character [c] + appears in [s] before position [stop+1]. + + Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid + position in [s]. *) + +val uppercase : string -> string +(** Return a copy of the argument, with all lowercase letters + translated to uppercase, including accented letters of the ISO + Latin-1 (8859-1) character set. *) + +val lowercase : string -> string +(** Return a copy of the argument, with all uppercase letters + translated to lowercase, including accented letters of the ISO + Latin-1 (8859-1) character set. *) + +val capitalize : string -> string +(** Return a copy of the argument, with the first character set to uppercase. *) + +val uncapitalize : string -> string +(** Return a copy of the argument, with the first character set to lowercase. *) + +type t = string +(** An alias for the type of strings. *) + +val compare: t -> t -> int +(** The comparison function for strings, with the same specification as + {!Pervasives.compare}. Along with the type [t], this function [compare] + allows the module [String] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +(**/**) + +external unsafe_get : string -> int -> char = "%string_unsafe_get" +external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" +external unsafe_blit : + string -> int -> string -> int -> int -> unit = "caml_blit_string" "noalloc" +external unsafe_fill : + string -> int -> int -> char -> unit = "caml_fill_string" "noalloc" diff --git a/ocaml-binary-annot/stdlib/stringLabels.ml b/ocaml-binary-annot/stdlib/stringLabels.ml new file mode 100644 index 0000000000..87d23d86fc --- /dev/null +++ b/ocaml-binary-annot/stdlib/stringLabels.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Module [StringLabels]: labelled String module *) + +include String diff --git a/ocaml-binary-annot/stdlib/stringLabels.mli b/ocaml-binary-annot/stdlib/stringLabels.mli new file mode 100644 index 0000000000..d1a3966f57 --- /dev/null +++ b/ocaml-binary-annot/stdlib/stringLabels.mli @@ -0,0 +1,171 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** String operations. *) + +external length : string -> int = "%string_length" +(** Return the length (number of characters) of the given string. *) + +external get : string -> int -> char = "%string_safe_get" +(** [String.get s n] returns character number [n] in string [s]. + The first character is character number 0. + The last character is character number [String.length s - 1]. + You can also write [s.[n]] instead of [String.get s n]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [(String.length s - 1)]. *) + + +external set : string -> int -> char -> unit = "%string_safe_set" +(** [String.set s n c] modifies string [s] in place, + replacing the character number [n] by [c]. + You can also write [s.[n] <- c] instead of [String.set s n c]. + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [(String.length s - 1)]. *) + +external create : int -> string = "caml_create_string" +(** [String.create n] returns a fresh string of length [n]. + The string initially contains arbitrary characters. + Raise [Invalid_argument] if [n < 0] or [n > Sys.max_string_length]. +*) + +val make : int -> char -> string +(** [String.make n c] returns a fresh string of length [n], + filled with the character [c]. + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.*) + +val copy : string -> string +(** Return a copy of the given string. *) + +val sub : string -> pos:int -> len:int -> string +(** [String.sub s start len] returns a fresh string of length [len], + containing the characters number [start] to [start + len - 1] + of string [s]. + Raise [Invalid_argument] if [start] and [len] do not + designate a valid substring of [s]; that is, if [start < 0], + or [len < 0], or [start + len > ]{!StringLabels.length}[ s]. *) + +val fill : string -> pos:int -> len:int -> char -> unit +(** [String.fill s start len c] modifies string [s] in place, + replacing the characters number [start] to [start + len - 1] + by [c]. + Raise [Invalid_argument] if [start] and [len] do not + designate a valid substring of [s]. *) + +val blit : + src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> unit +(** [String.blit src srcoff dst dstoff len] copies [len] characters + from string [src], starting at character number [srcoff], to + string [dst], starting at character number [dstoff]. It works + correctly even if [src] and [dst] are the same string, + and the source and destination chunks overlap. + Raise [Invalid_argument] if [srcoff] and [len] do not + designate a valid substring of [src], or if [dstoff] and [len] + do not designate a valid substring of [dst]. *) + +val concat : sep:string -> string list -> string +(** [String.concat sep sl] concatenates the list of strings [sl], + inserting the separator string [sep] between each. *) + +val iter : f:(char -> unit) -> string -> unit +(** [String.iter f s] applies function [f] in turn to all + the characters of [s]. It is equivalent to + [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *) + +val iteri : f:(int -> char -> unit) -> string -> unit +(** Same as {!String.iter}, but the + function is applied to the index of the element as first argument (counting from 0), + and the character itself as second argument. + @since 3.13.0 +*) + +val escaped : string -> string +(** Return a copy of the argument, with special characters + represented by escape sequences, following the lexical + conventions of Objective Caml. If there is no special + character in the argument, return the original string itself, + not a copy. *) + +val index : string -> char -> int +(** [String.index s c] returns the position of the leftmost + occurrence of character [c] in string [s]. + Raise [Not_found] if [c] does not occur in [s]. *) + +val rindex : string -> char -> int +(** [String.rindex s c] returns the position of the rightmost + occurrence of character [c] in string [s]. + Raise [Not_found] if [c] does not occur in [s]. *) + +val index_from : string -> int -> char -> int +(** Same as {!StringLabels.index}, but start + searching at the character position given as second argument. + [String.index s c] is equivalent to [String.index_from s 0 c].*) + +val rindex_from : string -> int -> char -> int +(** Same as {!StringLabels.rindex}, but start + searching at the character position given as second argument. + [String.rindex s c] is equivalent to + [String.rindex_from s (String.length s - 1) c]. *) + +val contains : string -> char -> bool +(** [String.contains s c] tests if character [c] + appears in the string [s]. *) + +val contains_from : string -> int -> char -> bool +(** [String.contains_from s start c] tests if character [c] + appears in the substring of [s] starting from [start] to the end + of [s]. + Raise [Invalid_argument] if [start] is not a valid index of [s]. *) + +val rcontains_from : string -> int -> char -> bool +(** [String.rcontains_from s stop c] tests if character [c] + appears in the substring of [s] starting from the beginning + of [s] to index [stop]. + Raise [Invalid_argument] if [stop] is not a valid index of [s]. *) + +val uppercase : string -> string +(** Return a copy of the argument, with all lowercase letters + translated to uppercase, including accented letters of the ISO + Latin-1 (8859-1) character set. *) + +val lowercase : string -> string +(** Return a copy of the argument, with all uppercase letters + translated to lowercase, including accented letters of the ISO + Latin-1 (8859-1) character set. *) + +val capitalize : string -> string +(** Return a copy of the argument, with the first character set to uppercase. *) + +val uncapitalize : string -> string +(** Return a copy of the argument, with the first character set to lowercase. *) + +type t = string +(** An alias for the type of strings. *) + +val compare: t -> t -> int +(** The comparison function for strings, with the same specification as + {!Pervasives.compare}. Along with the type [t], this function [compare] + allows the module [String] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +(**/**) + +external unsafe_get : string -> int -> char = "%string_unsafe_get" +external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" +external unsafe_blit : + src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> + unit = "caml_blit_string" "noalloc" +external unsafe_fill : + string -> pos:int -> len:int -> char -> unit = "caml_fill_string" "noalloc" diff --git a/ocaml-binary-annot/stdlib/sys.mli b/ocaml-binary-annot/stdlib/sys.mli new file mode 100644 index 0000000000..e1cf99aafa --- /dev/null +++ b/ocaml-binary-annot/stdlib/sys.mli @@ -0,0 +1,206 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** System interface. *) + +val argv : string array +(** The command line arguments given to the process. + The first element is the command name used to invoke the program. + The following elements are the command-line arguments + given to the program. *) + +val executable_name : string +(** The name of the file containing the executable currently running. *) + +external file_exists : string -> bool = "caml_sys_file_exists" +(** Test if a file with the given name exists. *) + +external is_directory : string -> bool = "caml_sys_is_directory" +(** Returns [true] if the given name refers to a directory, + [false] if it refers to another kind of file. + Raise [Sys_error] if no file exists with the given name. + @since 3.12.0 +*) + +external remove : string -> unit = "caml_sys_remove" +(** Remove the given file name from the file system. *) + +external rename : string -> string -> unit = "caml_sys_rename" +(** Rename a file. The first argument is the old name and the + second is the new name. If there is already another file + under the new name, [rename] may replace it, or raise an + exception, depending on your operating system. *) + +external getenv : string -> string = "caml_sys_getenv" +(** Return the value associated to a variable in the process + environment. Raise [Not_found] if the variable is unbound. *) + +external command : string -> int = "caml_sys_system_command" +(** Execute the given shell command and return its exit code. *) + +external time : unit -> float = "caml_sys_time" +(** Return the processor time, in seconds, used by the program + since the beginning of execution. *) + +external chdir : string -> unit = "caml_sys_chdir" +(** Change the current working directory of the process. *) + +external getcwd : unit -> string = "caml_sys_getcwd" +(** Return the current working directory of the process. *) + +external readdir : string -> string array = "caml_sys_read_directory" +(** Return the names of all files present in the given directory. + Names denoting the current directory and the parent directory + (["."] and [".."] in Unix) are not returned. Each string in the + result is a file name rather than a complete path. There is no + guarantee that the name strings in the resulting array will appear + in any specific order; they are not, in particular, guaranteed to + appear in alphabetical order. *) + +val interactive : bool ref +(** This reference is initially set to [false] in standalone + programs and to [true] if the code is being executed under + the interactive toplevel system [ocaml]. *) + +val os_type : string +(** Operating system currently executing the Caml program. One of +- ["Unix"] (for all Unix versions, including Linux and Mac OS X), +- ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or Mingw), +- ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). *) + +val word_size : int +(** Size of one word on the machine currently executing the Caml + program, in bits: 32 or 64. *) + +val max_string_length : int +(** Maximum length of a string. *) + +val max_array_length : int +(** Maximum length of a normal array. The maximum length of a float + array is [max_array_length/2] on 32-bit machines and + [max_array_length] on 64-bit machines. *) + + +(** {6 Signal handling} *) + + +type signal_behavior = + Signal_default + | Signal_ignore + | Signal_handle of (int -> unit) +(** What to do when receiving a signal: + - [Signal_default]: take the default behavior + (usually: abort the program) + - [Signal_ignore]: ignore the signal + - [Signal_handle f]: call function [f], giving it the signal + number as argument. *) + +external signal : + int -> signal_behavior -> signal_behavior = "caml_install_signal_handler" +(** Set the behavior of the system on receipt of a given signal. The + first argument is the signal number. Return the behavior + previously associated with the signal. If the signal number is + invalid (or not available on your system), an [Invalid_argument] + exception is raised. *) + +val set_signal : int -> signal_behavior -> unit +(** Same as {!Sys.signal} but return value is ignored. *) + + +(** {7 Signal numbers for the standard POSIX signals.} *) + +val sigabrt : int +(** Abnormal termination *) + +val sigalrm : int +(** Timeout *) + +val sigfpe : int +(** Arithmetic exception *) + +val sighup : int +(** Hangup on controlling terminal *) + +val sigill : int +(** Invalid hardware instruction *) + +val sigint : int +(** Interactive interrupt (ctrl-C) *) + +val sigkill : int +(** Termination (cannot be ignored) *) + +val sigpipe : int +(** Broken pipe *) + +val sigquit : int +(** Interactive termination *) + +val sigsegv : int +(** Invalid memory reference *) + +val sigterm : int +(** Termination *) + +val sigusr1 : int +(** Application-defined signal 1 *) + +val sigusr2 : int +(** Application-defined signal 2 *) + +val sigchld : int +(** Child process terminated *) + +val sigcont : int +(** Continue *) + +val sigstop : int +(** Stop *) + +val sigtstp : int +(** Interactive stop *) + +val sigttin : int +(** Terminal read from background process *) + +val sigttou : int +(** Terminal write from background process *) + +val sigvtalrm : int +(** Timeout in virtual time *) + +val sigprof : int +(** Profiling interrupt *) + + +exception Break +(** Exception raised on interactive interrupt if {!Sys.catch_break} + is on. *) + + +val catch_break : bool -> unit +(** [catch_break] governs whether interactive interrupt (ctrl-C) + terminates the program or raises the [Break] exception. + Call [catch_break true] to enable raising [Break], + and [catch_break false] to let the system + terminate the program on user interrupt. *) + + +val ocaml_version : string;; +(** [ocaml_version] is the version of Objective Caml. + It is a string of the form ["major.minor[.patchlevel][+additional-info]"], + where [major], [minor], and [patchlevel] are integers, and + [additional-info] is an arbitrary string. The [[.patchlevel]] and + [[+additional-info]] parts may be absent. *) diff --git a/ocaml-binary-annot/stdlib/sys.mlp b/ocaml-binary-annot/stdlib/sys.mlp new file mode 100644 index 0000000000..b58ca0bb3a --- /dev/null +++ b/ocaml-binary-annot/stdlib/sys.mlp @@ -0,0 +1,86 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* 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 Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* WARNING: sys.ml is generated from sys.mlp. DO NOT EDIT sys.ml or + your changes will be lost. +*) + +(* System interface *) + +external get_config: unit -> string * int = "caml_sys_get_config" +external get_argv: unit -> string * string array = "caml_sys_get_argv" + +let (executable_name, argv) = get_argv() +let (os_type, word_size) = get_config() +let max_array_length = (1 lsl (word_size - 10)) - 1;; +let max_string_length = word_size / 8 * max_array_length - 1;; + +external file_exists: string -> bool = "caml_sys_file_exists" +external is_directory : string -> bool = "caml_sys_is_directory" +external remove: string -> unit = "caml_sys_remove" +external rename : string -> string -> unit = "caml_sys_rename" +external getenv: string -> string = "caml_sys_getenv" +external command: string -> int = "caml_sys_system_command" +external time: unit -> float = "caml_sys_time" +external chdir: string -> unit = "caml_sys_chdir" +external getcwd: unit -> string = "caml_sys_getcwd" +external readdir : string -> string array = "caml_sys_read_directory" + +let interactive = ref false + +type signal_behavior = + Signal_default + | Signal_ignore + | Signal_handle of (int -> unit) + +external signal : int -> signal_behavior -> signal_behavior + = "caml_install_signal_handler" + +let set_signal sig_num sig_beh = ignore(signal sig_num sig_beh) + +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 +let sigvtalrm = -20 +let sigprof = -21 + +exception Break + +let catch_break on = + if on then + set_signal sigint (Signal_handle(fun _ -> raise Break)) + else + set_signal sigint Signal_default + + +(* The version string is found in file ../VERSION *) + +let ocaml_version = "%%VERSION%%";; diff --git a/ocaml-binary-annot/stdlib/weak.ml b/ocaml-binary-annot/stdlib/weak.ml new file mode 100644 index 0000000000..4adacd8e4a --- /dev/null +++ b/ocaml-binary-annot/stdlib/weak.ml @@ -0,0 +1,307 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Weak array operations *) + +type 'a t;; + +external create: int -> 'a t = "caml_weak_create";; + +let length x = Obj.size(Obj.repr x) - 1;; + +external set : 'a t -> int -> 'a option -> unit = "caml_weak_set";; +external get: 'a t -> int -> 'a option = "caml_weak_get";; +external get_copy: 'a t -> int -> 'a option = "caml_weak_get_copy";; +external check: 'a t -> int -> bool = "caml_weak_check";; +external blit: 'a t -> int -> 'a t -> int -> int -> unit = "caml_weak_blit";; +(* blit: src srcoff dst dstoff len *) + +let fill ar ofs len x = + if ofs < 0 || len < 0 || ofs + len > length ar + then raise (Invalid_argument "Weak.fill") + else begin + for i = ofs to (ofs + len - 1) do + set ar i x + done + end +;; + +(** Weak hash tables *) + +module type S = sig + type data + type t + val create : int -> t + val clear : t -> unit + val merge : t -> data -> data + val add : t -> data -> unit + val remove : t -> data -> unit + val find : t -> data -> data + val find_all : t -> data -> data list + val mem : t -> data -> bool + val iter : (data -> unit) -> t -> unit + val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a + val count : t -> int + val stats : t -> int * int * int * int * int * int +end;; + +module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct + + type 'a weak_t = 'a t;; + let weak_create = create;; + let emptybucket = weak_create 0;; + + type data = H.t;; + + type t = { + mutable table : data weak_t array; + mutable hashes : int array array; + mutable limit : int; (* bucket size limit *) + mutable oversize : int; (* number of oversize buckets *) + mutable rover : int; (* for internal bookkeeping *) + };; + + let get_index t h = (h land max_int) mod (Array.length t.table);; + + let limit = 7;; + let over_limit = 2;; + + let create sz = + let sz = if sz < 7 then 7 else sz in + let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in + { + table = Array.create sz emptybucket; + hashes = Array.create sz [| |]; + limit = limit; + oversize = 0; + rover = 0; + };; + + let clear t = + for i = 0 to Array.length t.table - 1 do + t.table.(i) <- emptybucket; + t.hashes.(i) <- [| |]; + done; + t.limit <- limit; + t.oversize <- 0; + ;; + + let fold f t init = + let rec fold_bucket i b accu = + if i >= length b then accu else + match get b i with + | Some v -> fold_bucket (i+1) b (f v accu) + | None -> fold_bucket (i+1) b accu + in + Array.fold_right (fold_bucket 0) t.table init + ;; + + let iter f t = + let rec iter_bucket i b = + if i >= length b then () else + match get b i with + | Some v -> f v; iter_bucket (i+1) b + | None -> iter_bucket (i+1) b + in + Array.iter (iter_bucket 0) t.table + ;; + + let iter_weak f t = + let rec iter_bucket i j b = + if i >= length b then () else + match check b i with + | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b + | false -> iter_bucket (i+1) j b + in + Array.iteri (iter_bucket 0) t.table + ;; + + let rec count_bucket i b accu = + if i >= length b then accu else + count_bucket (i+1) b (accu + (if check b i then 1 else 0)) + ;; + + let count t = + Array.fold_right (count_bucket 0) t.table 0 + ;; + + let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length;; + let prev_sz n = ((n - 3) * 2 + 2) / 3;; + + let test_shrink_bucket t = + let bucket = t.table.(t.rover) in + let hbucket = t.hashes.(t.rover) in + let len = length bucket in + let prev_len = prev_sz len in + let live = count_bucket 0 bucket 0 in + if live <= prev_len then begin + let rec loop i j = + if j >= prev_len then begin + if check bucket i then loop (i + 1) j + else if check bucket j then begin + blit bucket j bucket i 1; + hbucket.(i) <- hbucket.(j); + loop (i + 1) (j - 1); + end else loop i (j - 1); + end; + in + loop 0 (length bucket - 1); + if prev_len = 0 then begin + t.table.(t.rover) <- emptybucket; + t.hashes.(t.rover) <- [| |]; + end else begin + Obj.truncate (Obj.repr bucket) (prev_len + 1); + Obj.truncate (Obj.repr hbucket) prev_len; + end; + if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1; + end; + t.rover <- (t.rover + 1) mod (Array.length t.table); + ;; + + let rec resize t = + let oldlen = Array.length t.table in + let newlen = next_sz oldlen in + if newlen > oldlen then begin + let newt = create newlen in + let add_weak ob oh oi = + let setter nb ni _ = blit ob oi nb ni 1 in + let h = oh.(oi) in + add_aux newt setter None h (get_index newt h); + in + iter_weak add_weak t; + t.table <- newt.table; + t.hashes <- newt.hashes; + t.limit <- newt.limit; + t.oversize <- newt.oversize; + t.rover <- t.rover mod Array.length newt.table; + end else begin + t.limit <- max_int; (* maximum size already reached *) + t.oversize <- 0; + end + + and add_aux t setter d h index = + let bucket = t.table.(index) in + let hashes = t.hashes.(index) in + let sz = length bucket in + let rec loop i = + if i >= sz then begin + let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in + if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more"; + let newbucket = weak_create newsz in + let newhashes = Array.make newsz 0 in + blit bucket 0 newbucket 0 sz; + Array.blit hashes 0 newhashes 0 sz; + setter newbucket sz d; + newhashes.(sz) <- h; + t.table.(index) <- newbucket; + t.hashes.(index) <- newhashes; + if sz <= t.limit && newsz > t.limit then begin + t.oversize <- t.oversize + 1; + for i = 0 to over_limit do test_shrink_bucket t done; + end; + if t.oversize > Array.length t.table / over_limit then resize t; + end else if check bucket i then begin + loop (i + 1) + end else begin + setter bucket i d; + hashes.(i) <- h; + end; + in + loop 0; + ;; + + let add t d = + let h = H.hash d in + add_aux t set (Some d) h (get_index t h); + ;; + + let find_or t d ifnotfound = + let h = H.hash d in + let index = get_index t h in + let bucket = t.table.(index) in + let hashes = t.hashes.(index) in + let sz = length bucket in + let rec loop i = + if i >= sz then ifnotfound h index + else if h = hashes.(i) then begin + match get_copy bucket i with + | Some v when H.equal v d + -> begin match get bucket i with + | Some v -> v + | None -> loop (i + 1) + end + | _ -> loop (i + 1) + end else loop (i + 1) + in + loop 0 + ;; + + let merge t d = + find_or t d (fun h index -> add_aux t set (Some d) h index; d) + ;; + + let find t d = find_or t d (fun h index -> raise Not_found);; + + let find_shadow t d iffound ifnotfound = + let h = H.hash d in + let index = get_index t h in + let bucket = t.table.(index) in + let hashes = t.hashes.(index) in + let sz = length bucket in + let rec loop i = + if i >= sz then ifnotfound + else if h = hashes.(i) then begin + match get_copy bucket i with + | Some v when H.equal v d -> iffound bucket i + | _ -> loop (i + 1) + end else loop (i + 1) + in + loop 0 + ;; + + let remove t d = find_shadow t d (fun w i -> set w i None) ();; + + let mem t d = find_shadow t d (fun w i -> true) false;; + + let find_all t d = + let h = H.hash d in + let index = get_index t h in + let bucket = t.table.(index) in + let hashes = t.hashes.(index) in + let sz = length bucket in + let rec loop i accu = + if i >= sz then accu + else if h = hashes.(i) then begin + match get_copy bucket i with + | Some v when H.equal v d + -> begin match get bucket i with + | Some v -> loop (i + 1) (v :: accu) + | None -> loop (i + 1) accu + end + | _ -> loop (i + 1) accu + end else loop (i + 1) accu + in + loop 0 [] + ;; + + let stats t = + let len = Array.length t.table in + let lens = Array.map length t.table in + Array.sort compare lens; + let totlen = Array.fold_left ( + ) 0 lens in + (len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1)) + ;; + +end;; diff --git a/ocaml-binary-annot/stdlib/weak.mli b/ocaml-binary-annot/stdlib/weak.mli new file mode 100644 index 0000000000..33f4bf1d0c --- /dev/null +++ b/ocaml-binary-annot/stdlib/weak.mli @@ -0,0 +1,159 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Arrays of weak pointers and hash tables of weak pointers. *) + + +(** {6 Low-level functions} *) + +type 'a t +(** The type of arrays of weak pointers (weak arrays). A weak + pointer is a value that the garbage collector may erase whenever + the value is not used any more (through normal pointers) by the + program. Note that finalisation functions are run after the + weak pointers are erased. + + A weak pointer is said to be full if it points to a value, + empty if the value was erased by the GC. + + Notes: + - Integers are not allocated and cannot be stored in weak arrays. + - Weak arrays cannot be marshaled using {!Pervasives.output_value} + nor the functions of the {!Marshal} module. +*) + + +val create : int -> 'a t +(** [Weak.create n] returns a new weak array of length [n]. + All the pointers are initially empty. Raise [Invalid_argument] + if [n] is negative or greater than {!Sys.max_array_length}[-1].*) + +val length : 'a t -> int +(** [Weak.length ar] returns the length (number of elements) of + [ar].*) + +val set : 'a t -> int -> 'a option -> unit +(** [Weak.set ar n (Some el)] sets the [n]th cell of [ar] to be a + (full) pointer to [el]; [Weak.set ar n None] sets the [n]th + cell of [ar] to empty. + Raise [Invalid_argument "Weak.set"] if [n] is not in the range + 0 to {!Weak.length}[ a - 1].*) + +val get : 'a t -> int -> 'a option +(** [Weak.get ar n] returns None if the [n]th cell of [ar] is + empty, [Some x] (where [x] is the value) if it is full. + Raise [Invalid_argument "Weak.get"] if [n] is not in the range + 0 to {!Weak.length}[ a - 1].*) + +val get_copy : 'a t -> int -> 'a option +(** [Weak.get_copy ar n] returns None if the [n]th cell of [ar] is + empty, [Some x] (where [x] is a (shallow) copy of the value) if + it is full. + In addition to pitfalls with mutable values, the interesting + difference with [get] is that [get_copy] does not prevent + the incremental GC from erasing the value in its current cycle + ([get] may delay the erasure to the next GC cycle). + Raise [Invalid_argument "Weak.get"] if [n] is not in the range + 0 to {!Weak.length}[ a - 1].*) + + +val check : 'a t -> int -> bool +(** [Weak.check ar n] returns [true] if the [n]th cell of [ar] is + full, [false] if it is empty. Note that even if [Weak.check ar n] + returns [true], a subsequent {!Weak.get}[ ar n] can return [None].*) + +val fill : 'a t -> int -> int -> 'a option -> unit +(** [Weak.fill ar ofs len el] sets to [el] all pointers of [ar] from + [ofs] to [ofs + len - 1]. Raise [Invalid_argument "Weak.fill"] + if [ofs] and [len] do not designate a valid subarray of [a].*) + +val blit : 'a t -> int -> 'a t -> int -> int -> unit +(** [Weak.blit ar1 off1 ar2 off2 len] copies [len] weak pointers + from [ar1] (starting at [off1]) to [ar2] (starting at [off2]). + It works correctly even if [ar1] and [ar2] are the same. + Raise [Invalid_argument "Weak.blit"] if [off1] and [len] do + not designate a valid subarray of [ar1], or if [off2] and [len] + do not designate a valid subarray of [ar2].*) + + +(** {6 Weak hash tables} *) + +(** A weak hash table is a hashed set of values. Each value may + magically disappear from the set when it is not used by the + rest of the program any more. This is normally used to share + data structures without inducing memory leaks. + Weak hash tables are defined on values from a {!Hashtbl.HashedType} + module; the [equal] relation and [hash] function are taken from that + module. We will say that [v] is an instance of [x] if [equal x v] + is [true]. + + The [equal] relation must be able to work on a shallow copy of + the values and give the same result as with the values themselves. + *) + +module type S = sig + type data + (** The type of the elements stored in the table. *) + type t + (** The type of tables that contain elements of type [data]. + Note that weak hash tables cannot be marshaled using + {!Pervasives.output_value} or the functions of the {!Marshal} + module. *) + val create : int -> t + (** [create n] creates a new empty weak hash table, of initial + size [n]. The table will grow as needed. *) + val clear : t -> unit + (** Remove all elements from the table. *) + val merge : t -> data -> data + (** [merge t x] returns an instance of [x] found in [t] if any, + or else adds [x] to [t] and return [x]. *) + val add : t -> data -> unit + (** [add t x] adds [x] to [t]. If there is already an instance + of [x] in [t], it is unspecified which one will be + returned by subsequent calls to [find] and [merge]. *) + val remove : t -> data -> unit + (** [remove t x] removes from [t] one instance of [x]. Does + nothing if there is no instance of [x] in [t]. *) + val find : t -> data -> data + (** [find t x] returns an instance of [x] found in [t]. + Raise [Not_found] if there is no such element. *) + val find_all : t -> data -> data list + (** [find_all t x] returns a list of all the instances of [x] + found in [t]. *) + val mem : t -> data -> bool + (** [mem t x] returns [true] if there is at least one instance + of [x] in [t], false otherwise. *) + val iter : (data -> unit) -> t -> unit + (** [iter f t] calls [f] on each element of [t], in some unspecified + order. It is not specified what happens if [f] tries to change + [t] itself. *) + val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a + (** [fold f t init] computes [(f d1 (... (f dN init)))] where + [d1 ... dN] are the elements of [t] in some unspecified order. + It is not specified what happens if [f] tries to change [t] + itself. *) + val count : t -> int + (** Count the number of elements in the table. [count t] gives the + same result as [fold (fun _ n -> n+1) t 0] but does not delay the + deallocation of the dead elements. *) + val stats : t -> int * int * int * int * int * int + (** Return statistics on the table. The numbers are, in order: + table length, number of entries, sum of bucket lengths, + smallest bucket length, median bucket length, biggest bucket length. *) +end;; +(** The output signature of the functor {!Weak.Make}. *) + +module Make (H : Hashtbl.HashedType) : S with type data = H.t;; +(** Functor building an implementation of the weak hash table structure. *) |