diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..ae62d97
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,61 @@
+GPLv3 for all my stuff (everything but ocs and cdb.ml).
+
+------------------------------------------------------------------------
+
+ocs was downloaded from and came with
+the following COPYING file.
+
+
+Copyright (c) 2003-2004 Ville-Pertti Keinonen
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.
+
+------------------------------------------------------------------------
+
+cdb.ml was downloaded from
+. It came with the
+following text in the COPYING file. Dustin, if you're reading this,
+OCaml is not Irish.
+
+
+Copyright (c) 2004 by Dustin Sallings
+
+The package "Dustin's O'Caml lib" is copyright by Dustin Sallings.
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+the "Dustin's O'Caml lib" software (the "Software"), to deal in the Software
+without restriction, including without limitation the rights to use, copy,
+modify, merge, publish, distribute, sublicense, and/or sell copies of the
+Software, and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+The Software is provided ``as is'', without warranty of any kind, expressed or
+implied, including but not limited to the warranties of merchantability,
+fitness for a particular purpose and noninfringement. In no event shall Dustin
+Sallings be liable for any claim, damages or other liability, whether in an
+action of contract, tort or otherwise, arising from, out of or in connection
+with the Software or the use or other dealings in the software.
+
diff --git a/ocs-1.0.3/CHANGES b/ocs-1.0.3/CHANGES
new file mode 100644
index 0000000..d13f09c
--- /dev/null
+++ b/ocs-1.0.3/CHANGES
@@ -0,0 +1,76 @@
+1.0.3
+
+ - The various let forms now create new frames. This fixes
+ behavior for situations where the initializers for the bound
+ variables return multiple times due to captured continuations.
+
+ - Change define-syntax to return the unspecified value.
+
+ - Fix (lambda ...) forms where is env-tagged by
+ macro expansion.
+
+1.0.2
+
+ - Try to find a smaller invariant precision when converting from
+ floating point values to strings.
+
+ - Add missing function vector-fill!.
+
+ - Add an unspecified value that isn't printed by the repl.
+
+ - Add a value and functor that can be used to safely wrap arbitrary
+ OCaml values in Scheme values.
+
+ - Fix internal definitions inside (begin ...) forms.
+
+ - Consider literals in the literal list of syntax-rules locally
+ bound while parsing (but not while matching) patterns. R5RS is not
+ clear on this, but it is necessary to avoid breaking hygiene when
+ some expansions of an outer macro could change the interpretation of
+ pattern variables to literals within the patterns of inner macros.
+ This seems consistent with the behavior of other implementations.
+
+ - Fix namespace lookup for syntax-rules literals to allow changes
+ in global bindings.
+
+ - Fix namespace handling for nested macros.
+
+ - Fix copy-paste error in log.
+
+ - Fix the behavior of eval and arguments.
+
+ - Fix inexact->exact for negative numbers that don't fit into an
+ integer.
+
+ - The reader now also accepts square brackets [ and ] as list
+ delimiters.
+
+ - Fix remainder to handle differing signs correctly.
+
+1.0.1
+
+ - Fix sorting of byte code objects in Makefile.
+
+ - Add missing functions numerator and denominator.
+
+ - Keep rationals normalized.
+
+1.0 (changes from pre-releases)
+
+ - Rearrange build to generate bytecode and native libraries and a
+ native interpreter usable from the command line.
+
+ - Remove CVS Id's (the project is now being stored in a GNU Arch
+ repository) from all files.
+
+ - Fix Ocs_port.string_input_port to actually initialize the
+ port with the string length.
+
+ - Fix internal definitions of the form (define (fun args ...) ...).
+ Previously the first item of the body would be skipped.
+
+ - Fix the order of arguments to atan when called with two arguments.
+
+ - When invoking continuations with multiple arguments, the
+ arguments are now wrapped with Svalues as if (values ...) were used.
+
diff --git a/ocs-1.0.3/COPYING b/ocs-1.0.3/COPYING
new file mode 100644
index 0000000..a54d963
--- /dev/null
+++ b/ocs-1.0.3/COPYING
@@ -0,0 +1,25 @@
+
+Copyright (c) 2003-2004 Ville-Pertti Keinonen
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.
+
diff --git a/ocs-1.0.3/README b/ocs-1.0.3/README
new file mode 100644
index 0000000..768d180
--- /dev/null
+++ b/ocs-1.0.3/README
@@ -0,0 +1,136 @@
+1. General
+
+Ocs is an implementation of Scheme, as defined by R5RS. It is
+written entirely in OCaml and can be trivially embedded in any
+OCaml program.
+
+Known deviations from R5RS:
+
+ - transcript-on and transcript-off are currently not implemented
+ - scheme-report-environment and null-environment ignore their
+ argument
+
+Anything else that does not work as specified in R5RS is a bug.
+
+
+2. Installation
+
+Requirements:
+
+ - GNU make or pmake (BSD make)
+ - OCaml 3.x (versions 3.06 and newer tested)
+
+Type make or gmake in the src directory. This should produce the
+following:
+
+ - A bytecode library (ocs.cma)
+ - A native library (ocs.cmxa, ocs.a)
+ - A stand-alone, native interpreter (ocscm)
+
+2.1 The 'ocscm' command
+
+If invoked without arguments, the interpreter will run in interactive
+mode.
+
+If invoked with arguments, the interpreter will read and evaluate
+the files listed as arguments and exit. The evaluation results are
+not printed.
+
+
+3. Implementation Details
+
+Implementing Scheme in OCaml is so straightforward that it hardly
+needs any documentation. The following mappings between languages
+are done:
+
+ - Scheme is dynamically typed. Scheme values are represented by
+the OCaml type Ocs_types.sval.
+
+ - In Scheme, top-level bindings are global and all variables are
+mutable. Variables references are bound through environments
+(Ocs_types.env) to global slots (Ocs_types.gvar) or frame indices
+(the actual frames are visible at evaluation-time through
+Ocs_types.thread).
+
+ - Scheme has capturable, first-class continuations. Most of the
+evaluator is written in continuation-passing style in order to allow
+this.
+
+Where discussing types, the rest of this section assumes that the
+types defined in the module Ocs_types are visible.
+
+3.1 Evaluation
+
+Scheme values (S-expressions) are of the type sval.
+
+Before evaluation Scheme values are compiled to internal representations
+of the type code. This is done by the function
+
+ Ocs_compile.compile : env -> sval -> code
+
+The env type is used during compilation for variable bindings. A
+new env is created for each new scope and frame. The base
+environment with the basic language bindings can be created using
+
+ Ocs_top.make_env : unit -> env
+
+Evaluation is done by
+
+ Ocs_eval.eval : thread -> (sval -> unit) -> code -> unit
+
+where the second argument is a continuation to pass the result to.
+
+The thread type is used during evaluation for storing the current
+frame and display for local variables, the input/output ports and
+the current dynamic extent. It does not represent a thread in the
+concurrent sense, but rather the evaluation state, and is copied and
+changed rather than modified in place. The initial thread to be
+passed to the evaluator can be created using
+Ocs_top.make_thread : unit -> thread.
+
+3.2 Continuations and I/O
+
+Any continuations captured are associated with the thread at the
+time of capture, so if a continuation is used to escape a
+with-input-from-file or with-output-to-file, the input/output port
+is restored to those of the time of capture.
+
+If a continuation is used to return to a with-input-from-file or
+with-output-to-file, the port is once again set to the one
+opened by the with-...-file call. However, if the thunk has
+already exited once, the port will be closed and no longer be
+valid for I/O calls.
+
+3.3 Numbers
+
+The full R5RS numeric tower is implemented, with the following
+internal representations:
+
+Exact numbers are
+ - 31- or 63-bit integers (OCaml int)
+ - Big_int objects from the Num library when unboxed integers are
+ too small
+ - Ratio objects from the Num library for rationals
+
+Inexact numbers are
+ - 64-bit IEEE floats for reals (OCaml float)
+ - Pairs of 64-bit IEEE floats for complex numbers (OCaml Complex.t)
+
+Since inexact numbers are represented internally as binary floating
+point, conversions to exact numbers are most precise for fractions of
+powers of two
+
+ (inexact->exact 2.125) ==> 17/8
+
+compared to
+
+ (inexact->exact 0.3) ==> 5404319552844595/18014398509481984
+
+And in fact many rationals will not satisfy
+
+ (= (inexact->exact (exact->inexact r)) r)
+
+However
+
+ (rationalize (inexact->exact 0.3) (expt 2 -54)) ==> 3/10
+
diff --git a/ocs-1.0.3/src/.depend b/ocs-1.0.3/src/.depend
new file mode 100644
index 0000000..2ce83d6
--- /dev/null
+++ b/ocs-1.0.3/src/.depend
@@ -0,0 +1,107 @@
+ocs_char.cmo: ocs_types.cmi ocs_error.cmo ocs_env.cmi ocs_char.cmi
+ocs_char.cmx: ocs_types.cmi ocs_error.cmx ocs_env.cmx ocs_char.cmi
+ocs_compile.cmo: ocs_vartable.cmi ocs_types.cmi ocs_sym.cmi ocs_misc.cmi \
+ ocs_error.cmo ocs_env.cmi ocs_compile.cmi
+ocs_compile.cmx: ocs_vartable.cmx ocs_types.cmi ocs_sym.cmx ocs_misc.cmx \
+ ocs_error.cmx ocs_env.cmx ocs_compile.cmi
+ocs_complex.cmo: ocs_complex.cmi
+ocs_complex.cmx: ocs_complex.cmi
+ocs_contin.cmo: ocs_types.cmi ocs_misc.cmi ocs_eval.cmi ocs_error.cmo \
+ ocs_env.cmi ocs_contin.cmi
+ocs_contin.cmx: ocs_types.cmi ocs_misc.cmx ocs_eval.cmx ocs_error.cmx \
+ ocs_env.cmx ocs_contin.cmi
+ocs_env.cmo: ocs_vartable.cmi ocs_types.cmi ocs_sym.cmi ocs_error.cmo \
+ ocs_env.cmi
+ocs_env.cmx: ocs_vartable.cmx ocs_types.cmi ocs_sym.cmx ocs_error.cmx \
+ ocs_env.cmi
+ocs_eval.cmo: ocs_types.cmi ocs_sym.cmi ocs_misc.cmi ocs_error.cmo \
+ ocs_eval.cmi
+ocs_eval.cmx: ocs_types.cmi ocs_sym.cmx ocs_misc.cmx ocs_error.cmx \
+ ocs_eval.cmi
+ocs_io.cmo: ocs_types.cmi ocs_read.cmi ocs_print.cmi ocs_port.cmi \
+ ocs_eval.cmi ocs_error.cmo ocs_env.cmi ocs_io.cmi
+ocs_io.cmx: ocs_types.cmi ocs_read.cmx ocs_print.cmx ocs_port.cmx \
+ ocs_eval.cmx ocs_error.cmx ocs_env.cmx ocs_io.cmi
+ocs_lex.cmo: ocs_types.cmi ocs_port.cmi ocs_numstr.cmi ocs_error.cmo \
+ ocs_char.cmi ocs_lex.cmi
+ocs_lex.cmx: ocs_types.cmi ocs_port.cmx ocs_numstr.cmx ocs_error.cmx \
+ ocs_char.cmx ocs_lex.cmi
+ocs_list.cmo: ocs_types.cmi ocs_misc.cmi ocs_error.cmo ocs_env.cmi \
+ ocs_list.cmi
+ocs_list.cmx: ocs_types.cmi ocs_misc.cmx ocs_error.cmx ocs_env.cmx \
+ ocs_list.cmi
+ocs_macro.cmo: ocs_types.cmi ocs_sym.cmi ocs_misc.cmi ocs_error.cmo \
+ ocs_env.cmi ocs_compile.cmi ocs_macro.cmi
+ocs_macro.cmx: ocs_types.cmi ocs_sym.cmx ocs_misc.cmx ocs_error.cmx \
+ ocs_env.cmx ocs_compile.cmx ocs_macro.cmi
+ocs_main.cmo: ocs_types.cmi ocs_top.cmi ocs_prim.cmi ocs_error.cmo
+ocs_main.cmx: ocs_types.cmi ocs_top.cmx ocs_prim.cmx ocs_error.cmx
+ocs_misc.cmo: ocs_types.cmi ocs_error.cmo ocs_misc.cmi
+ocs_misc.cmx: ocs_types.cmi ocs_error.cmx ocs_misc.cmi
+ocs_num.cmo: ocs_types.cmi ocs_numaux.cmi ocs_error.cmo ocs_env.cmi \
+ ocs_complex.cmi ocs_num.cmi
+ocs_num.cmx: ocs_types.cmi ocs_numaux.cmx ocs_error.cmx ocs_env.cmx \
+ ocs_complex.cmx ocs_num.cmi
+ocs_numaux.cmo: ocs_types.cmi ocs_error.cmo ocs_numaux.cmi
+ocs_numaux.cmx: ocs_types.cmi ocs_error.cmx ocs_numaux.cmi
+ocs_numstr.cmo: ocs_types.cmi ocs_numaux.cmi ocs_num.cmi ocs_error.cmo \
+ ocs_env.cmi ocs_numstr.cmi
+ocs_numstr.cmx: ocs_types.cmi ocs_numaux.cmx ocs_num.cmx ocs_error.cmx \
+ ocs_env.cmx ocs_numstr.cmi
+ocs_port.cmo: ocs_error.cmo ocs_port.cmi
+ocs_port.cmx: ocs_error.cmx ocs_port.cmi
+ocs_prim.cmo: ocs_types.cmi ocs_sym.cmi ocs_read.cmi ocs_port.cmi \
+ ocs_misc.cmi ocs_macro.cmi ocs_lex.cmi ocs_io.cmi ocs_eval.cmi \
+ ocs_error.cmo ocs_env.cmi ocs_compile.cmi ocs_prim.cmi
+ocs_prim.cmx: ocs_types.cmi ocs_sym.cmx ocs_read.cmx ocs_port.cmx \
+ ocs_misc.cmx ocs_macro.cmx ocs_lex.cmx ocs_io.cmx ocs_eval.cmx \
+ ocs_error.cmx ocs_env.cmx ocs_compile.cmx ocs_prim.cmi
+ocs_print.cmo: ocs_types.cmi ocs_sym.cmi ocs_port.cmi ocs_numstr.cmi \
+ ocs_char.cmi ocs_print.cmi
+ocs_print.cmx: ocs_types.cmi ocs_sym.cmx ocs_port.cmx ocs_numstr.cmx \
+ ocs_char.cmx ocs_print.cmi
+ocs_read.cmo: ocs_types.cmi ocs_sym.cmi ocs_port.cmi ocs_misc.cmi ocs_lex.cmi \
+ ocs_error.cmo ocs_read.cmi
+ocs_read.cmx: ocs_types.cmi ocs_sym.cmx ocs_port.cmx ocs_misc.cmx ocs_lex.cmx \
+ ocs_error.cmx ocs_read.cmi
+ocs_string.cmo: ocs_types.cmi ocs_error.cmo ocs_env.cmi ocs_string.cmi
+ocs_string.cmx: ocs_types.cmi ocs_error.cmx ocs_env.cmx ocs_string.cmi
+ocs_sym.cmo: ocs_types.cmi ocs_error.cmo ocs_sym.cmi
+ocs_sym.cmx: ocs_types.cmi ocs_error.cmx ocs_sym.cmi
+ocs_top.cmo: ocs_vector.cmi ocs_types.cmi ocs_string.cmi ocs_read.cmi \
+ ocs_print.cmi ocs_prim.cmi ocs_port.cmi ocs_numstr.cmi ocs_num.cmi \
+ ocs_macro.cmi ocs_list.cmi ocs_lex.cmi ocs_io.cmi ocs_eval.cmi \
+ ocs_error.cmo ocs_env.cmi ocs_contin.cmi ocs_compile.cmi ocs_char.cmi \
+ ocs_top.cmi
+ocs_top.cmx: ocs_vector.cmx ocs_types.cmi ocs_string.cmx ocs_read.cmx \
+ ocs_print.cmx ocs_prim.cmx ocs_port.cmx ocs_numstr.cmx ocs_num.cmx \
+ ocs_macro.cmx ocs_list.cmx ocs_lex.cmx ocs_io.cmx ocs_eval.cmx \
+ ocs_error.cmx ocs_env.cmx ocs_contin.cmx ocs_compile.cmx ocs_char.cmx \
+ ocs_top.cmi
+ocs_vartable.cmo: ocs_vartable.cmi
+ocs_vartable.cmx: ocs_vartable.cmi
+ocs_vector.cmo: ocs_types.cmi ocs_error.cmo ocs_env.cmi ocs_vector.cmi
+ocs_vector.cmx: ocs_types.cmi ocs_error.cmx ocs_env.cmx ocs_vector.cmi
+ocs_wrap.cmo: ocs_types.cmi ocs_error.cmo
+ocs_wrap.cmx: ocs_types.cmi ocs_error.cmx
+ocs_char.cmi: ocs_types.cmi
+ocs_compile.cmi: ocs_types.cmi
+ocs_contin.cmi: ocs_types.cmi
+ocs_env.cmi: ocs_types.cmi ocs_sym.cmi
+ocs_eval.cmi: ocs_types.cmi
+ocs_io.cmi: ocs_types.cmi
+ocs_lex.cmi: ocs_types.cmi ocs_port.cmi ocs_error.cmo
+ocs_list.cmi: ocs_types.cmi
+ocs_macro.cmi: ocs_types.cmi
+ocs_misc.cmi: ocs_types.cmi
+ocs_num.cmi: ocs_types.cmi
+ocs_numaux.cmi: ocs_types.cmi
+ocs_numstr.cmi: ocs_types.cmi
+ocs_prim.cmi: ocs_types.cmi
+ocs_print.cmi: ocs_types.cmi ocs_port.cmi
+ocs_read.cmi: ocs_types.cmi ocs_port.cmi ocs_lex.cmi
+ocs_string.cmi: ocs_types.cmi
+ocs_sym.cmi: ocs_types.cmi
+ocs_top.cmi: ocs_types.cmi
+ocs_types.cmi: ocs_vartable.cmi ocs_port.cmi
+ocs_vector.cmi: ocs_types.cmi
diff --git a/ocs-1.0.3/src/Makefile b/ocs-1.0.3/src/Makefile
new file mode 100644
index 0000000..67b19b0
--- /dev/null
+++ b/ocs-1.0.3/src/Makefile
@@ -0,0 +1,57 @@
+#
+# Build system for ocs library and interpreter
+#
+
+include Makefile.common
+
+BC_LIB = ocs.cma
+N_LIB = ocs.cmxa
+C_LIB = ocs.a
+INTERP = ocscm
+
+BC_OBJS = ocs_error.cmo ocs_port.cmo ocs_vartable.cmo ocs_sym.cmo \
+ ocs_env.cmo ocs_char.cmo ocs_complex.cmo ocs_numaux.cmo \
+ ocs_num.cmo ocs_numstr.cmo ocs_lex.cmo ocs_misc.cmo ocs_read.cmo \
+ ocs_eval.cmo ocs_compile.cmo ocs_contin.cmo ocs_print.cmo \
+ ocs_io.cmo ocs_list.cmo ocs_macro.cmo ocs_prim.cmo ocs_string.cmo \
+ ocs_vector.cmo ocs_wrap.cmo ocs_top.cmo
+
+N_OBJS = ocs_error.cmx ocs_sym.cmx ocs_vartable.cmx ocs_env.cmx \
+ ocs_char.cmx ocs_misc.cmx ocs_compile.cmx ocs_eval.cmx \
+ ocs_contin.cmx ocs_port.cmx ocs_complex.cmx ocs_numaux.cmx \
+ ocs_num.cmx ocs_numstr.cmx ocs_print.cmx ocs_lex.cmx ocs_read.cmx \
+ ocs_io.cmx ocs_list.cmx ocs_macro.cmx ocs_prim.cmx ocs_string.cmx \
+ ocs_vector.cmx ocs_wrap.cmx ocs_top.cmx
+
+INTERP_OBJS = ocs_main.cmx
+
+BCI_OBJS = ocs_main.cmo
+BCI = ocscm-bc
+
+all: $(BC_LIB) $(N_LIB) $(INTERP)
+
+native: $(N_LIB)
+
+bytecode: $(BC_LIB)
+
+$(N_LIB): $(N_OBJS)
+ $(OCAMLOPT) -a -o $(N_LIB) $(N_OBJS)
+
+$(BC_LIB): $(BC_OBJS)
+ $(OCAMLC) -a -o $(BC_LIB) $(BC_OBJS)
+
+$(INTERP): $(N_LIB) $(INTERP_OBJS)
+ $(OCAMLOPT) -o $(INTERP) nums.cmxa unix.cmxa $(N_LIB) $(INTERP_OBJS)
+
+$(BCI): $(BC_LIB) $(BCI_OBJS)
+ $(OCAMLC) $(OCAMLFLAGS) -o $(BCI) nums.cma unix.cma $(BC_LIB) $(BCI_OBJS)
+
+clean:
+ -rm -f $(N_LIB) $(BC_LIB) $(C_LIB) $(INTERP) *.cm* *.o
+ -rm -f $(BCI)
+
+depend:
+ $(OCAMLDEP) *.ml *.mli > .depend
+
+include .depend
+
diff --git a/ocs-1.0.3/src/Makefile.common b/ocs-1.0.3/src/Makefile.common
new file mode 100644
index 0000000..9ac5f71
--- /dev/null
+++ b/ocs-1.0.3/src/Makefile.common
@@ -0,0 +1,21 @@
+#
+# General OCaml build settings
+#
+
+OCAMLOPT = ocamlopt
+OCAMLC = ocamlc
+OCAMLDEP = ocamldep
+
+OCAMLFLAGS =
+
+.SUFFIXES: .o .c .h .cc .cpp .y .l .a .ml .mli .cmx .cmi .cmo
+
+.mli.cmi:
+ $(OCAMLC) $(OCAMLFLAGS) -c $<
+
+.ml.cmx:
+ $(OCAMLOPT) $(OCAMLFLAGS) -c $<
+
+.ml.cmo:
+ $(OCAMLC) $(OCAMLFLAGS) -c $<
+
diff --git a/ocs-1.0.3/src/ocs_char.ml b/ocs-1.0.3/src/ocs_char.ml
new file mode 100644
index 0000000..26434be
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_char.ml
@@ -0,0 +1,153 @@
+(* Character primitives *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_env
+
+(* Character name equivalents (long). *)
+let char_long_names =
+ [|
+ "space", ' ';
+ "newline", '\n';
+
+ (* The rest are extensions. *)
+ "return", '\r';
+ "tab", '\t';
+ "backspace", '\008';
+ "escape", '\027';
+ "backslash", '\\';
+ "alarm", '\007';
+ "vtab", '\011';
+ "del", '\127' |]
+;;
+
+(* Table of short names for 0 .. 31 *)
+let char_short_names =
+ [| "nul"; "soh"; "stx"; "etx"; "eot"; "enq"; "ack"; "bel";
+ "bs"; "ht"; "nl"; "vt"; "np"; "cr"; "so"; "si";
+ "dle"; "dc1"; "dc2"; "dc3"; "dc4"; "nak"; "syn"; "etb";
+ "can"; "em"; "sub"; "esc"; "fs"; "gs"; "rs"; "us" |]
+;;
+
+let name_to_char name =
+ let name = (String.lowercase name)
+ and ln = Array.length char_long_names
+ and sn = Array.length char_short_names in
+ let rec lloop i =
+ if i = ln then sloop 0
+ else
+ match char_long_names.(i) with
+ (n, c) -> if n = name then Some c else lloop (i + 1)
+ and sloop i =
+ if i = sn then None
+ else if char_short_names.(i) = name then Some (char_of_int i)
+ else sloop (i + 1)
+ in
+ lloop 0
+;;
+
+(* Generate the preferred printed literal form of a character. *)
+let char_to_name =
+ function
+ '\n' -> "newline"
+ | ' ' -> "space"
+ | '\127' -> "del"
+ | '\000' .. '\031' as c -> char_short_names.(int_of_char c)
+ | '\033' .. '\126' as c -> String.make 1 c
+ | c -> Printf.sprintf "x%02x" (int_of_char c)
+;;
+
+let char_cmp op c1 c2 =
+ match (c1, c2) with
+ (Schar c1, Schar c2) -> if op c1 c2 then Strue else Sfalse
+ | _ -> raise (Error "args not characters")
+;;
+
+let char_eq = char_cmp (=);;
+let char_lt = char_cmp (<);;
+let char_gt = char_cmp (>);;
+let char_le = char_cmp (<=);;
+let char_ge = char_cmp (>=);;
+
+let char_ci_cmp op c1 c2 =
+ match (c1, c2) with
+ (Schar c1, Schar c2) ->
+ if op (Char.lowercase c1) (Char.lowercase c2) then Strue else Sfalse
+ | _ -> raise (Error "args not characters")
+;;
+
+let char_ci_eq = char_ci_cmp (=);;
+let char_ci_lt = char_ci_cmp (<);;
+let char_ci_gt = char_ci_cmp (>);;
+let char_ci_le = char_ci_cmp (<=);;
+let char_ci_ge = char_ci_cmp (>=);;
+
+let char_unop op =
+ function
+ Schar c -> op c
+ | _ -> raise (Error "arg not character")
+;;
+
+let char_alphabetic =
+ char_unop (function 'A' .. 'Z' | 'a' ..'z' -> Strue | _ -> Sfalse)
+;;
+
+let char_numeric =
+ char_unop (function '0' ..'9' -> Strue | _ -> Sfalse)
+;;
+
+let char_whitespace =
+ char_unop (function ' ' | '\t' | '\r' | '\n' | '\012' -> Strue | _ -> Sfalse)
+;;
+
+let char_uppercase =
+ char_unop (function 'A' .. 'Z' -> Strue | _ -> Sfalse)
+;;
+
+let char_lowercase =
+ char_unop (function 'a' .. 'z' -> Strue | _ -> Sfalse)
+;;
+
+let char_integer =
+ char_unop (fun c -> Sint (int_of_char c))
+;;
+
+let integer_char =
+ function
+ Sint i -> Schar (char_of_int i)
+ | _ -> raise (Error "arg not int")
+;;
+
+let char_upcase =
+ char_unop (fun c -> Schar (Char.uppercase c))
+;;
+
+let char_downcase =
+ char_unop (fun c -> Schar (Char.lowercase c))
+;;
+
+let init e =
+ set_pf2 e char_eq "char=?";
+ set_pf2 e char_lt "char?";
+ set_pf2 e char_le "char<=?";
+ set_pf2 e char_ge "char>=?";
+
+ set_pf2 e char_ci_eq "char-ci=?";
+ set_pf2 e char_ci_lt "char-ci?";
+ set_pf2 e char_ci_le "char-ci<=?";
+ set_pf2 e char_ci_ge "char-ci>=?";
+
+ set_pf1 e char_alphabetic "char-alphabetic?";
+ set_pf1 e char_numeric "char-numeric?";
+ set_pf1 e char_whitespace "char-whitespace?";
+ set_pf1 e char_uppercase "char-upper-case?";
+ set_pf1 e char_lowercase "char-lower-case?";
+
+ set_pf1 e char_integer "char->integer";
+ set_pf1 e integer_char "integer->char";
+
+ set_pf1 e char_upcase "char-upcase";
+ set_pf1 e char_downcase "char-downcase";
+;;
diff --git a/ocs-1.0.3/src/ocs_char.mli b/ocs-1.0.3/src/ocs_char.mli
new file mode 100644
index 0000000..40b350b
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_char.mli
@@ -0,0 +1,9 @@
+(* Character primitives. *)
+
+open Ocs_types
+
+val name_to_char : string -> char option
+val char_to_name : char -> string
+
+val init : env -> unit
+
diff --git a/ocs-1.0.3/src/ocs_compile.ml b/ocs-1.0.3/src/ocs_compile.ml
new file mode 100644
index 0000000..411ea4f
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_compile.ml
@@ -0,0 +1,487 @@
+(* Compile Scheme expressions into a form that can be evaluated efficiently. *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_sym
+open Ocs_misc
+open Ocs_env
+open Ocs_vartable
+
+(* Split the variables that are arguments to let/let*/letrec *)
+let letsplit f =
+ function
+ Spair { car = (Ssymbol _ | Sesym (_, _)) as s;
+ cdr = Spair { car = v; cdr = Snull }} -> f s v
+ | _ -> raise (Error "invalid let arglist")
+;;
+
+(* Split the variables that are arguments to do *)
+let dosplit f =
+ function
+ Spair { car = (Ssymbol _ | Sesym (_, _)) as sym;
+ cdr = Spair { car = init; cdr = t }} ->
+ begin
+ match t with
+ Snull -> f sym init sym
+ | Spair { car = step; cdr = Snull } -> f sym init step
+ | _ -> raise (Error "invalid do arglist")
+ end
+ | _ -> raise (Error "invalid do arglist")
+;;
+
+let genset b v =
+ match b with
+ Vglob g -> Csetg (g, v)
+ | Vloc (d, i) -> Csetl (d, i, v)
+ | _ -> raise (Error "cannot change syntactic keywords")
+;;
+
+let gendef b v =
+ match b with
+ Vglob g -> Cdefine (g, v)
+ | Vloc (d, i) -> Csetl (d, i, v)
+ | _ -> raise (Error "cannot change syntactic keywords")
+;;
+
+let genref =
+ function
+ Vglob g -> Cgetg g
+ | Vloc (d, i) -> Cgetl (d, i)
+ | Vsyntax _ -> Cval Sunspec
+ | Vmacro _ -> Cval Sunspec
+ | Vkeyword _ -> Cval Sunbound
+;;
+
+let mkseq s =
+ match Array.length s with
+ 0 -> Cval Sunspec
+ | 1 -> s.(0)
+ | 2 -> Cseq2 (s.(0), s.(1))
+ | 3 -> Cseq3 (s.(0), s.(1), s.(2))
+ | _ -> Cseqn s
+;;
+
+let mkand s =
+ match Array.length s with
+ 0 -> Cval Strue
+ | 1 -> s.(0)
+ | 2 -> Cand2 (s.(0), s.(1))
+ | 3 -> Cand3 (s.(0), s.(1), s.(2))
+ | _ -> Candn s
+;;
+
+let mkor s =
+ match Array.length s with
+ 0 -> Cval Sfalse
+ | 1 -> s.(0)
+ | 2 -> Cor2 (s.(0), s.(1))
+ | 3 -> Cor3 (s.(0), s.(1), s.(2))
+ | _ -> Corn s
+;;
+
+let make_proc c n hr fs =
+ { proc_body = c;
+ proc_nargs = n;
+ proc_has_rest = hr;
+ proc_frame_size = fs;
+ proc_name = "##" }
+;;
+
+let chksplice a =
+ let n = Array.length a in
+ let rec loop i =
+ if i < n then
+ begin
+ match a.(i) with
+ Cqqspl _ -> true
+ | _ -> loop (i + 1)
+ end
+ else
+ false
+ in
+ loop 0
+;;
+
+(* Scan quoted sections, eliminate environment-specific symbols *)
+let rec scanquoted =
+ function
+ Sesym (_, sym) -> sym
+ | Spair { car = h; cdr = t } ->
+ Spair { car = scanquoted h; cdr = scanquoted t }
+ | Svector v ->
+ Svector (Array.map (fun x -> scanquoted x) v)
+ | x -> x
+;;
+
+let is_uglobal e =
+ vt_global e.env_vartable
+;;
+
+let is_global e =
+ e.env_depth < 0
+;;
+
+let rec mkdefine e args =
+ let narg = Array.length args in
+ if narg < 1 then
+ raise (Error "define: not enough args");
+ match args.(0) with
+ Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = al } when narg > 1 ->
+ begin
+ match mklambda e al args with
+ Clambda p as l ->
+ p.proc_name <- sym_name s;
+ gendef (get_var e s) l
+ | _ -> assert false
+ end
+ | (Ssymbol _ | Sesym (_, _)) as s when narg = 2 ->
+ gendef (get_var e s) (compile e args.(1))
+ | (Ssymbol _ | Sesym (_, _)) as s when narg = 1 ->
+ gendef (get_var e s) (Cval Sunspec)
+ | _ -> raise (Error "define: invalid syntax")
+
+(* The following functions up to mkbody are used to compile the body
+ of a lambda, let etc., with possible internal definitions. The
+ internal definitions may be created by macro expansion, so we need
+ to do that here, too...and we might end up expanding a macro more
+ than once (so there must be no side-effects to expansion). *)
+and idpp =
+ function
+ Spair { car = (Ssymbol _ | Sesym (_, _)) as s;
+ cdr = Spair { car = v; cdr = Snull }} -> (s, s, v)
+ | Spair { car = Spair { car = (Ssymbol _ | Sesym (_, _)) as s;
+ cdr = _ } as x;
+ cdr = _ } as v -> (s, x, v)
+ | _ -> raise (Error "invalid internal definition")
+
+and getidef e =
+ function
+ Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = t } ->
+ begin
+ match find_var e s with
+ Some (Vsyntax f) when f == mkdefine -> Some (idpp t)
+ | Some (Vmacro f) -> getidef e (f e (Array.of_list (list_to_caml t)))
+ | _ -> None
+ end
+ | _ -> None
+
+and mkid e x v =
+ match x with
+ Spair { car = _; cdr = al } ->
+ mklambda e al (Array.of_list (list_to_caml v))
+ | _ -> compile e v
+
+and expand_begin e =
+ function
+ (Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = t }) as x ->
+ begin
+ match find_var e s with
+ Some (Vsyntax f) when f == mkbegin ->
+ Array.concat (List.map (expand_begin e) (list_to_caml t))
+ | Some (Vmacro f) ->
+ expand_begin e (f e (Array.of_list (list_to_caml t)))
+ | _ -> [| x |]
+ end
+ | x -> [| x |]
+
+and mkbody e args =
+ let args = Array.concat (List.map (expand_begin e) (Array.to_list args)) in
+ let n = Array.length args in
+ let rec loop i r =
+ if i < n then
+ begin
+ match getidef e args.(i) with
+ Some d -> loop (i + 1) (d::r)
+ | None -> r
+ end
+ else
+ r
+ in
+ let ids = Array.map (fun (s, x, v) -> let r = bind_var e s in (r, x, v))
+ (Array.of_list (List.rev (loop 0 []))) in
+ let sets = Array.map (fun (r, x, v) -> gendef r (mkid e x v)) ids in
+ let nid = Array.length sets in
+ let rest = Array.map (fun x -> compile e x)
+ (Array.sub args nid (n - nid))
+ in
+ Array.append sets rest
+
+and mkset e args =
+ if Array.length args != 2 then
+ raise (Error "set!: requires exactly two args");
+ match args.(0) with
+ (Ssymbol _ | Sesym (_, _)) as s ->
+ let v = compile e args.(1) in
+ genset (get_var e s) v
+ | _ -> raise (Error "set!: not a symbol")
+
+(* Note that the first item of the "body" array is ignored, it
+ corresponds to the argument list but may be in the form expected
+ by either define or lambda. *)
+and mklambda e args body =
+ let ne = new_frame e
+ and nargs = ref 0
+ and has_rest = ref false in
+ let rec scanargs =
+ function
+ Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = tl } ->
+ let _ = bind_var ne s in
+ incr nargs;
+ scanargs tl
+ | (Ssymbol _ | Sesym (_, _)) as s ->
+ let _ = bind_var ne s in
+ incr nargs;
+ has_rest := true;
+ ()
+ | Snull -> ()
+ | _ -> raise (Error "lambda: bad arg list")
+ in
+ scanargs args;
+ let body =
+ mkseq (mkbody ne (Array.sub body 1 (Array.length body - 1)))
+ in
+ Clambda (make_proc body !nargs !has_rest !(ne.env_frame_size))
+
+and mkif e args =
+ match Array.length args with
+ 2 -> Cif (compile e args.(0), compile e args.(1), Cval Sunspec)
+ | 3 -> Cif (compile e args.(0), compile e args.(1), compile e args.(2))
+ | _ -> raise (Error "if: needs two or three args")
+
+and mknamedlet e s args =
+ let argv =
+ Array.map
+ (letsplit (fun s v -> s, compile e v))
+ (Array.of_list (list_to_caml args.(1))) in
+ let ar = new_var e in
+ let ne = new_frame e in
+ bind_name ne s ar;
+ let av =
+ Array.map (fun (s, v) -> let _ = bind_var ne s in v) argv in
+ let body = mkseq (mkbody ne (Array.sub args 2 (Array.length args - 2))) in
+ let proc =
+ Clambda (make_proc body (Array.length av) false !(ne.env_frame_size))
+ in
+ Cseq2 (gendef ar proc, mkapply (genref ar) av)
+
+and mklet e args =
+ if Array.length args < 2 then
+ raise (Error "let: too few args");
+ match args.(0) with
+ (Ssymbol _ | Sesym (_, _)) as s -> mknamedlet e s args
+ | Snull -> mkseq (mkbody e (Array.sub args 1 (Array.length args - 1)))
+ | Spair _ as al ->
+ let argv =
+ Array.map
+ (letsplit (fun s v -> s, compile e v))
+ (Array.of_list (list_to_caml al)) in
+ let ne = new_frame e in
+ let av = Array.map (fun (s, v) -> let _ = bind_var ne s in v) argv in
+ let body = mkseq (mkbody ne (Array.sub args 1 (Array.length args - 1))) in
+ let proc =
+ Clambda (make_proc body (Array.length av) false !(ne.env_frame_size))
+ in
+ mkapply proc av
+ | _ -> raise (Error "let: missing argument list")
+
+and mkletstar e args =
+ if Array.length args < 2 then
+ raise (Error "let*: too few args");
+ let rec build e =
+ function
+ x::t ->
+ let (s, v) = letsplit (fun s v -> s, compile e v) x in
+ let ne = new_frame e in
+ let _ = bind_var ne s in
+ let body = build ne t in
+ let proc = Clambda (make_proc body 1 false !(ne.env_frame_size)) in
+ mkapply proc [| v |]
+ | [] -> mkseq (mkbody e (Array.sub args 1 (Array.length args - 1)))
+ in
+ build e (list_to_caml args.(0))
+
+and mkletrec e args =
+ if Array.length args < 2 then
+ raise (Error "letrec: too few args");
+ let ne = new_frame e in
+ let av =
+ Array.map (letsplit (fun s v -> let r = bind_var ne s in (r, v)))
+ (Array.of_list (list_to_caml args.(0))) in
+ let avi = Array.map (fun (r, v) -> compile ne v) av in
+ let ne' = new_frame ne in
+ let sets = Array.map (fun (r, v) -> gendef r (genref (new_var ne'))) av in
+ let body = mkseq (Array.append sets
+ (mkbody ne' (Array.sub args 1 (Array.length args - 1)))) in
+ let proc =
+ Clambda (make_proc body (Array.length av) false !(ne'.env_frame_size)) in
+ let proc =
+ Clambda (make_proc (mkapply proc avi)
+ (Array.length av) false !(ne.env_frame_size))
+ in
+ mkapply proc (Array.map (fun _ -> Cval Sunspec) av)
+
+and compileseq e s =
+ mkseq (Array.map (fun x -> compile e x)
+ (Array.of_list (list_to_caml s)))
+
+and mkcond e args =
+ Ccond
+ (Array.map
+ (function
+ Spair { car = test;
+ cdr = Spair { car = (Ssymbol _ | Sesym (_, _)) as s;
+ cdr = Spair { car = x; cdr = Snull }}}
+ when is_keyword e s "=>" ->
+ (Ccondspec (compile e test), (compile e x))
+ | Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = body }
+ when is_keyword e s "else" ->
+ (Cval Strue, compileseq e body)
+ | Spair { car = test; cdr = body } ->
+ (compile e test, compileseq e body)
+ | _ -> raise (Error "cond: syntax error"))
+ args)
+
+and mkcase e args =
+ Ccase
+ (compile e args.(0),
+ Array.map
+ (function
+ Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = body }
+ when is_keyword e s "else" ->
+ ([| |], compileseq e body)
+ | Spair { car = Spair _ as c; cdr = body } ->
+ (Array.of_list (list_to_caml c), compileseq e body)
+ | _ -> raise (Error "case: syntax error"))
+ (Array.sub args 1 (Array.length args - 1)))
+
+and mkdo e args =
+ if Array.length args < 2 then
+ raise (Error "do: bad args");
+ let vv =
+ Array.map
+ (dosplit (fun sym init step -> sym, compile e init, step))
+ (Array.of_list (list_to_caml args.(0)))
+ and (test, result) =
+ match args.(1) with
+ Spair { car = t; cdr = r } -> t, r
+ | _ -> raise (Error "do: bad args")
+ and anonvar = new_var e
+ and ne = new_frame e in
+ let av = Array.map (fun (sym, init, _) ->
+ let _ = bind_var ne sym in init) vv in
+ let body =
+ Cif (compile ne test, compileseq ne result,
+ mkseq
+ (Array.append
+ (Array.map (fun x -> compile ne x)
+ (Array.sub args 2 (Array.length args - 2)))
+ [| mkapply (genref anonvar)
+ (Array.map (fun (_, _, step) -> compile ne step) vv) |]))
+ in
+ let proc =
+ Clambda (make_proc body (Array.length av) false !(ne.env_frame_size))
+ in
+ Cseq2 (gendef anonvar proc, mkapply (genref anonvar) av)
+
+and mkdelay e =
+ function
+ [| expr |] -> Cdelay (compile e expr)
+ | _ -> raise (Error "delay: bad args")
+
+and mkqq e args =
+ if Array.length args <> 1 then
+ raise (Error "quasiquote: need exactly one arg")
+ else
+ let rec qq depth =
+ function
+ Spair { car = (Ssymbol _ | Sesym (_, _)) as s;
+ cdr = Spair { car = x; cdr = Snull }} ->
+ if is_syntax e s mkqq then
+ Cqqp (Cval s, Cqqp (qq (depth + 1) x, Cval Snull))
+ else if is_keyword e s "unquote" then
+ begin
+ if depth > 0 then
+ Cqqp (Cval s, Cqqp (qq (depth - 1) x, Cval Snull))
+ else
+ compile e x
+ end
+ else if is_keyword e s "unquote-splicing" then
+ begin
+ if depth > 0 then
+ Cqqp (Cval s, Cqqp (qq (depth - 1) x, Cval Snull))
+ else
+ Cqqspl (compile e x)
+ end
+ else
+ Cqqp (Cval s, Cqqp (qq depth x, Cval Snull))
+ | Spair { car = h; cdr = t } -> Cqqp (qq depth h, qq depth t)
+ | Svector v ->
+ let qv = Array.map (fun x -> qq depth x) v in
+ if chksplice qv then
+ Cqqvs (Array.to_list qv)
+ else
+ Cqqv qv
+ | x -> Cval (scanquoted x)
+ in
+ qq 0 args.(0)
+
+and applysym e s args =
+ match get_var e s with
+ Vsyntax f -> f e args
+ | Vmacro f -> compile e (f e args)
+ | r -> mkapply (genref r) (Array.map (fun x -> compile e x) args)
+
+and compile e =
+ function
+ (Ssymbol _ | Sesym (_, _)) as s -> genref (get_var e s)
+ | Spair p ->
+ let args = Array.of_list (list_to_caml p.cdr) in
+ begin
+ match p.car with
+ (Ssymbol _ | Sesym (_, _)) as s -> applysym e s args
+ | x ->
+ mkapply (compile e x) (Array.map (fun x -> compile e x) args)
+ end
+ | x -> Cval (scanquoted x)
+
+and mkbegin e args =
+ mkseq (Array.map (fun x -> compile e x) args)
+;;
+
+let bind_lang e =
+ let spec =
+ [ sym_define, mkdefine;
+ sym_set, mkset;
+ sym_let, mklet;
+ sym_letstar, mkletstar;
+ sym_letrec, mkletrec;
+ sym_if, mkif;
+ sym_cond, mkcond;
+ sym_case, mkcase;
+ sym_do, mkdo;
+ sym_begin, mkbegin;
+ sym_and, (fun e args -> mkand (Array.map (fun x -> compile e x) args));
+ sym_or, (fun e args -> mkor (Array.map (fun x -> compile e x) args));
+ sym_lambda,
+ (fun e args ->
+ if Array.length args >= 1 then
+ mklambda e args.(0) args
+ else
+ raise (Error "lambda: needs at least one arg"));
+ sym_delay, mkdelay;
+ sym_quote,
+ (fun e args ->
+ if Array.length args = 1 then
+ Cval (scanquoted args.(0))
+ else
+ raise (Error "quote: need exactly one arg"));
+ sym_quasiquote, mkqq ]
+ in
+ List.iter (fun (s, f) -> bind_name e s (Vsyntax f)) spec;
+ bind_name e sym_else (Vkeyword "else");
+ bind_name e sym_arrow (Vkeyword "=>");
+ bind_name e sym_unquote (Vkeyword "unquote");
+ bind_name e sym_unquote_splicing (Vkeyword "unquote-splicing");
+ bind_name e sym_syntax_rules (Vkeyword "syntax-rules");
+;;
+
diff --git a/ocs-1.0.3/src/ocs_compile.mli b/ocs-1.0.3/src/ocs_compile.mli
new file mode 100644
index 0000000..1333149
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_compile.mli
@@ -0,0 +1,13 @@
+(* Compile expressions *)
+
+open Ocs_types
+
+val compile : env -> sval -> code
+
+val bind_lang : env -> unit
+
+(* Internal, used by ocs_macro *)
+val letsplit : (sval -> sval -> 'a) -> sval -> 'a
+val mkseq : code array -> code
+val mkbody : env -> sval array -> code array
+
diff --git a/ocs-1.0.3/src/ocs_complex.ml b/ocs-1.0.3/src/ocs_complex.ml
new file mode 100644
index 0000000..8572a50
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_complex.ml
@@ -0,0 +1,44 @@
+(* Implement functions missing from Complex. *)
+
+open Complex
+
+let sin_cplx z =
+ { re = sin z.re *. cosh z.im;
+ im = cos z.re *. sinh z.im }
+;;
+
+let cos_cplx z =
+ { re = cos z.re *. cosh z.im;
+ im = -.(sin z.re) *. sinh z.im }
+;;
+
+let tan_cplx z =
+ div (sin_cplx z) (cos_cplx z)
+;;
+
+(* asin z = -i Ln (iz + sqrt (1 - z^2)) *)
+
+let asin_cplx =
+ function { re = x; im = y } ->
+ let t = sqrt { re = 1.0 +. y *. y -. x *. x; im = -2.0 *. x *. y } in
+ let z = log { re = t.re -. y; im = t.im +. x } in
+ { re = z.im; im = -.z.re }
+;;
+
+(* acos z = pi/2 - asin z *)
+
+let acos_cplx z =
+ match asin_cplx z with
+ { re = x; im = y } -> { re = 1.57079632679489661923 -. x; im = -.y }
+;;
+
+(* atan z = [Ln (1 + iz) - Ln (1 - iz)] / 2i *)
+
+let atan_cplx =
+ function { re = x; im = y } ->
+ let t1 = log { re = 1.0 -. y; im = x }
+ and t2 = log { re = 1.0 +. y; im = -.x } in
+ { re = (t1.im -. t2.im) *. 0.5;
+ im = -.(t1.re -. t2.re) *. 0.5 }
+;;
+
diff --git a/ocs-1.0.3/src/ocs_complex.mli b/ocs-1.0.3/src/ocs_complex.mli
new file mode 100644
index 0000000..b8f48bd
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_complex.mli
@@ -0,0 +1,11 @@
+(* Functions missing from Complex. *)
+
+open Complex
+
+val sin_cplx : t -> t
+val cos_cplx : t -> t
+val tan_cplx : t -> t
+val asin_cplx : t -> t
+val acos_cplx : t -> t
+val atan_cplx : t -> t
+
diff --git a/ocs-1.0.3/src/ocs_contin.ml b/ocs-1.0.3/src/ocs_contin.ml
new file mode 100644
index 0000000..118b36e
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_contin.ml
@@ -0,0 +1,114 @@
+(* Continuations *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_eval
+open Ocs_env
+open Ocs_misc
+
+let rec find_depth fdx tdx al bl =
+ match (fdx, tdx) with
+ (Some f, Some t) ->
+ if f.dynext_parent == t.dynext_parent then
+ (List.rev (f.dynext_after::al), t.dynext_before::bl)
+ else if f.dynext_depth > t.dynext_depth then
+ find_depth f.dynext_parent tdx (f.dynext_after::al) bl
+ else if f.dynext_depth < t.dynext_depth then
+ find_depth fdx t.dynext_parent al (t.dynext_before::bl)
+ else
+ find_depth f.dynext_parent t.dynext_parent
+ (f.dynext_after::al) (t.dynext_before::bl)
+ | (Some f, None) ->
+ find_depth f.dynext_parent tdx (f.dynext_after::al) bl
+ | (None, Some t) ->
+ find_depth fdx t.dynext_parent al (t.dynext_before::bl)
+ | _ -> (List.rev al, bl)
+;;
+
+(* Change from the dynamic extent fdx to the dynamic extent tdx *)
+let dxswitch fdx tdx cont =
+ if fdx == tdx then
+ cont ()
+ else
+ let (al, bl) = find_depth fdx tdx [] [] in
+ let rec bloop =
+ function
+ [] -> cont ()
+ | h::t -> eval (fst h) (fun _ -> bloop t) (snd h)
+ in
+ let rec aloop =
+ function
+ [] -> bloop bl
+ | h::t -> eval (fst h) (fun _ -> aloop t) (snd h)
+ in
+ aloop al
+;;
+
+let continuation dx cc th _ =
+ function
+ [| x |] -> dxswitch th.th_dynext dx (fun () -> cc x)
+ | av -> dxswitch th.th_dynext dx (fun () -> cc (Svalues av))
+;;
+
+let call_cc th cc =
+ function
+ [| proc |] ->
+ let cont =
+ Sprim { prim_fun = Pfcn (continuation th.th_dynext cc);
+ prim_name = "" }
+ in
+ eval th cc (Capply1 (Cval proc, Cval cont))
+ | _ -> raise (Error "call/cc: bad args")
+;;
+
+let values =
+ function
+ [| x |] -> x
+ | av -> Svalues av
+;;
+
+let call_values th cc =
+ function
+ [| producer; consumer |] ->
+ eval th
+ (function
+ Svalues av ->
+ eval th cc (mkapply (Cval consumer)
+ (Array.map (fun x -> Cval x) av))
+ | x -> eval th cc (Capply1 (Cval consumer, Cval x)))
+ (Capply0 (Cval producer))
+ | _ -> raise (Error "call-with-values: bad args")
+;;
+
+let dynamic_wind th cc =
+ function
+ [| before; thunk; after |] ->
+ let before = Capply0 (Cval before)
+ and after = Capply0 (Cval after) in
+ let ndx = {
+ dynext_parent = th.th_dynext;
+ dynext_depth =
+ (match th.th_dynext with
+ None -> 0
+ | Some dx -> dx.dynext_depth + 1);
+ dynext_before = (th, before);
+ dynext_after = (th, after)
+ } in
+ eval th
+ (fun _ ->
+ eval { th with th_dynext = Some ndx }
+ (fun r ->
+ eval th (fun _ -> cc r) after) (Capply0 (Cval thunk))) before
+ | _ -> raise (Error "dynamic-wind: bad args")
+;;
+
+let init e =
+ set_pfcn e call_cc "call-with-current-continuation";
+ set_pfcn e call_cc "call/cc";
+
+ set_pfn e values "values";
+
+ set_pfcn e call_values "call-with-values";
+ set_pfcn e dynamic_wind "dynamic-wind";
+;;
+
diff --git a/ocs-1.0.3/src/ocs_contin.mli b/ocs-1.0.3/src/ocs_contin.mli
new file mode 100644
index 0000000..6f25bd3
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_contin.mli
@@ -0,0 +1,6 @@
+(* Continuations *)
+
+open Ocs_types
+
+val init : env -> unit
+
diff --git a/ocs-1.0.3/src/ocs_env.ml b/ocs-1.0.3/src/ocs_env.ml
new file mode 100644
index 0000000..0e7eae4
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_env.ml
@@ -0,0 +1,143 @@
+(* Compilation environment, variable bindings. *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_sym
+open Ocs_vartable
+
+let top_env () =
+ { env_depth = -1;
+ env_vartable = vt_create ();
+ env_frame_size = ref 0;
+ env_tagged = [] }
+;;
+
+let new_scope e =
+ { env_depth = e.env_depth;
+ env_vartable = vt_inherit e.env_vartable;
+ env_frame_size = e.env_frame_size;
+ env_tagged = e.env_tagged }
+;;
+
+let new_frame e =
+ { env_depth = e.env_depth + 1;
+ env_vartable = vt_inherit e.env_vartable;
+ env_frame_size = ref 0;
+ env_tagged = e.env_tagged }
+;;
+
+let new_var e =
+ if e.env_depth < 0 then
+ Vglob { g_sym = Snull; g_val = Sunbound }
+ else
+ let v = Vloc (e.env_depth, !(e.env_frame_size)) in
+ incr e.env_frame_size;
+ v
+;;
+
+let bind_name e sym v =
+ match sym with
+ Sesym (te, sym) ->
+ e.env_tagged <- (te, sym, v)::e.env_tagged
+ | _ ->
+ begin
+ match v with
+ Vglob g -> g.g_sym <- sym
+ | _ -> ()
+ end;
+ var_insert e.env_vartable (sym_name sym) v
+;;
+
+let bind_var e sym =
+ let r = new_var e in
+ bind_name e sym r;
+ r
+;;
+
+let find_tagged te ts l =
+ let rec loop =
+ function
+ (e, s, v)::t ->
+ if e == te && s == ts then
+ Some v
+ else
+ loop t
+ | [] -> None
+ in
+ loop l
+;;
+
+let rec find_var e sym =
+ match sym with
+ Sesym (te, sym) ->
+ begin
+ match find_tagged te sym e.env_tagged with
+ Some _ as v -> v
+ | None -> find_var te sym
+ end
+ | _ -> var_find e.env_vartable (sym_name sym)
+;;
+
+let rec get_var e sym =
+ match sym with
+ Sesym (te, sym) ->
+ begin
+ match find_tagged te sym e.env_tagged with
+ Some v -> v
+ | None -> get_var te sym
+ end
+ | _ -> var_get e.env_vartable (sym_name sym)
+ (fun () -> Vglob { g_sym = sym; g_val = Sunbound })
+;;
+
+let set_glob e sym v =
+ match get_var e sym with
+ Vglob g -> g.g_val <- v
+ | _ -> raise (Error "set_glob: not a global")
+;;
+
+let vb_copy =
+ function
+ Vglob g -> Vglob { g with g_val = g.g_val }
+ | x -> x
+
+let env_copy e =
+ { e with
+ env_vartable = vt_copy e.env_vartable vb_copy;
+ env_tagged = [] }
+
+let is_a_keyword e sym =
+ match find_var e sym with
+ Some (Vkeyword _) -> true
+ | _ -> false
+;;
+
+let is_keyword e sym name =
+ match find_var e sym with
+ Some (Vkeyword kw) -> kw = name
+ | _ -> false
+;;
+
+let safe_is_keyword e sym name =
+ match sym with
+ Ssymbol _ | Sesym (_, _) -> is_keyword e sym name
+ | _ -> false
+;;
+
+let is_syntax e sym sf =
+ match find_var e sym with
+ Some (Vsyntax f) -> f == sf
+ | _ -> false
+;;
+
+let set_pfg e f n =
+ set_glob e (get_symbol n) (Sprim { prim_fun = f; prim_name = n })
+;;
+
+let set_pf0 e f n = set_pfg e (Pf0 f) n
+let set_pf1 e f n = set_pfg e (Pf1 f) n
+let set_pf2 e f n = set_pfg e (Pf2 f) n
+let set_pf3 e f n = set_pfg e (Pf3 f) n
+let set_pfn e f n = set_pfg e (Pfn f) n
+let set_pfcn e f n = set_pfg e (Pfcn f) n
+
diff --git a/ocs-1.0.3/src/ocs_env.mli b/ocs-1.0.3/src/ocs_env.mli
new file mode 100644
index 0000000..e84c55b
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_env.mli
@@ -0,0 +1,30 @@
+(* Compilation environment, variable bindings. *)
+
+open Ocs_types
+open Ocs_sym
+
+val top_env : unit -> env
+val new_scope : env -> env
+val new_frame : env -> env
+val new_var : env -> vbind
+val bind_name : env -> sval -> vbind -> unit
+val bind_var : env -> sval -> vbind
+val find_var : env -> sval -> vbind option
+val get_var : env -> sval -> vbind
+val set_glob : env -> sval -> sval -> unit
+val env_copy : env -> env
+
+val is_a_keyword : env -> sval -> bool
+val is_keyword : env -> sval -> string -> bool
+val safe_is_keyword : env -> sval -> string -> bool
+
+val is_syntax : env -> sval -> (env -> sval array -> code) -> bool
+
+val set_pf0 : env -> (unit -> sval) -> string -> unit
+val set_pf1 : env -> (sval -> sval) -> string -> unit
+val set_pf2 : env -> (sval -> sval -> sval) -> string -> unit
+val set_pf3 : env -> (sval -> sval -> sval -> sval) -> string -> unit
+val set_pfn : env -> (sval array -> sval) -> string -> unit
+val set_pfcn :
+ env -> (thread -> (sval -> unit) -> sval array -> unit) -> string -> unit
+
diff --git a/ocs-1.0.3/src/ocs_error.ml b/ocs-1.0.3/src/ocs_error.ml
new file mode 100644
index 0000000..bbed9a8
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_error.ml
@@ -0,0 +1,11 @@
+(* Errors (exceptions) generated by the library. *)
+
+(* Source location (file, line) *)
+type location =
+ string * int
+
+(* These errors indicate non-fatal run-time errors that should be
+ reported, generally interactively. *)
+exception Error of string
+exception ErrorL of location * string
+
diff --git a/ocs-1.0.3/src/ocs_eval.ml b/ocs-1.0.3/src/ocs_eval.ml
new file mode 100644
index 0000000..2681dd0
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_eval.ml
@@ -0,0 +1,339 @@
+(* Actual evaluator for the semi-compiled form. *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_sym
+open Ocs_misc
+
+(* Local variables are stored either in th_frame or th_display.
+ th_frame is the deepest frame, not yet part of the display. *)
+
+let getl th d i =
+ if d >= Array.length th.th_display then
+ th.th_frame.(i)
+ else
+ th.th_display.(d).(i)
+;;
+
+let setl th d i v =
+ if d >= Array.length th.th_display then
+ th.th_frame.(i) <- v
+ else
+ th.th_display.(d).(i) <- v
+;;
+
+let args_err p n =
+ if p.proc_has_rest then
+ Printf.sprintf "procedure %s expected %d or more args got %d"
+ p.proc_name (p.proc_nargs - 1) n
+ else
+ Printf.sprintf "procedure %s expected %d args got %d"
+ p.proc_name p.proc_nargs n
+
+let chkargs p n =
+ match p with
+ Sproc (p, _) ->
+ if n <> p.proc_nargs && (not p.proc_has_rest || n < p.proc_nargs - 1) then
+ raise (Error (args_err p n))
+ else
+ ()
+ | Sprim p ->
+ if
+ begin
+ match p.prim_fun with
+ Pf0 _ -> n = 0
+ | Pf1 _ -> n = 1
+ | Pf2 _ -> n = 2
+ | Pf3 _ -> n = 3
+ | Pfn _ | Pfcn _ -> true
+ end
+ then
+ ()
+ else
+ raise (Error (p.prim_name ^ ": wrong number of arguments"))
+ | _ -> raise (Error "apply: not a procedure or primitive")
+;;
+
+let rec doapply th cc p disp av =
+ let th = {
+ th with
+ th_frame = Array.make p.proc_frame_size Seof;
+ th_display = disp;
+ th_depth = Array.length disp }
+ in
+ if p.proc_has_rest then
+ begin
+ let nfixed = p.proc_nargs - 1
+ and n = Array.length av in
+ if nfixed > 0 then
+ Array.blit av 0 th.th_frame 0 nfixed;
+ let rec mkrest i r =
+ if i < nfixed then r
+ else mkrest (i - 1) (Spair { car = av.(i); cdr = r })
+ in
+ th.th_frame.(nfixed) <- mkrest (n - 1) Snull
+ end
+ else
+ Array.blit av 0 th.th_frame 0 p.proc_nargs;
+ eval th cc p.proc_body
+
+and eval th cc =
+ function
+ Cval v -> cc v
+ | Cseq2 (s1, s2) ->
+ eval th (fun _ -> eval th cc s2) s1
+ | Cseq3 (s1, s2, s3) ->
+ eval th (fun _ -> eval th (fun _ -> eval th cc s3) s2) s1
+ | Cseqn s ->
+ let n = Array.length s in
+ let rec loop i =
+ if i = n - 1 then
+ eval th cc s.(i)
+ else
+ eval th (fun _ -> loop (i + 1)) s.(i)
+ in
+ loop 0
+ | Cand2 (s1, s2) ->
+ eval th (function Sfalse -> cc Sfalse | _ -> eval th cc s2) s1
+ | Cand3 (s1, s2, s3) ->
+ eval th
+ (function
+ Sfalse -> cc Sfalse
+ | _ ->
+ eval th
+ (function
+ Sfalse -> cc Sfalse
+ | _ -> eval th cc s3) s2) s1
+ | Candn s ->
+ let n = Array.length s in
+ let rec loop i =
+ begin
+ if i = n - 1 then
+ eval th cc s.(i)
+ else
+ eval th (function Sfalse -> cc Sfalse | _ -> loop (i + 1)) s.(i)
+ end
+ in
+ loop 0
+ | Cor2 (s1, s2) ->
+ eval th (function Sfalse -> eval th cc s2 | x -> cc x) s1
+ | Cor3 (s1, s2, s3) ->
+ eval th
+ (function
+ Sfalse -> eval th
+ (function
+ Sfalse -> eval th cc s3
+ | x -> cc x) s2
+ | x -> cc x) s1
+ | Corn s ->
+ let n = Array.length s in
+ let rec loop i =
+ if i = n - 1 then
+ eval th cc s.(i)
+ else
+ eval th (function Sfalse -> loop (i + 1) | x -> cc x) s.(i)
+ in
+ loop 0
+ | Cif (c, tx, fx) ->
+ eval th
+ (function Sfalse -> eval th cc fx | _ -> eval th cc tx)
+ c
+ | Csetg (g, c) ->
+ eval th (fun v ->
+ if g.g_val == Sunbound then
+ raise (Error ("set!: unbound variable: " ^ (sym_name g.g_sym)))
+ else
+ g.g_val <- v; cc Sunspec) c
+ | Csetl (d, i, c) ->
+ eval th (fun v -> setl th d i v; cc Sunspec) c
+ | Cdefine (g, c) ->
+ eval th (fun v -> g.g_val <- v; cc Sunspec) c
+ | Cgetg g ->
+ if g.g_val == Sunbound then
+ raise (Error ("unbound variable: " ^ (sym_name g.g_sym)))
+ else
+ cc g.g_val
+ | Cgetl (d, i) -> cc (getl th d i)
+ | Capply0 c ->
+ eval th (fun cv ->
+ chkargs cv 0;
+ match cv with
+ Sproc (p, d) -> doapply th cc p d [| |]
+ | Sprim p ->
+ begin
+ match p.prim_fun with
+ Pf0 f -> cc (f ())
+ | Pfn f -> cc (f [| |])
+ | Pfcn f -> f th cc [| |]
+ | _ -> assert false
+ end
+ | _ -> assert false) c
+ | Capply1 (c, a1) ->
+ eval th (fun cv -> eval th (fun a1v ->
+ chkargs cv 1;
+ match cv with
+ Sproc (p, d) -> doapply th cc p d [| a1v |]
+ | Sprim p ->
+ begin
+ match p.prim_fun with
+ Pf1 f -> cc (f a1v)
+ | Pfn f -> cc (f [| a1v |])
+ | Pfcn f -> f th cc [| a1v |]
+ | _ -> assert false
+ end
+ | _ -> assert false) a1) c
+ | Capply2 (c, a1, a2) ->
+ eval th (fun cv -> eval th (fun a1v -> eval th (fun a2v ->
+ chkargs cv 2;
+ match cv with
+ Sproc (p, d) -> doapply th cc p d [| a1v; a2v |]
+ | Sprim p ->
+ begin
+ match p.prim_fun with
+ Pf2 f -> cc (f a1v a2v)
+ | Pfn f -> cc (f [| a1v; a2v |])
+ | Pfcn f -> f th cc [| a1v; a2v |]
+ | _ -> assert false
+ end
+ | _ -> assert false) a2) a1) c
+ | Capply3 (c, a1, a2, a3) ->
+ eval th (fun cv -> eval th (fun a1v -> eval th (fun a2v ->
+ eval th (fun a3v ->
+ chkargs cv 3;
+ match cv with
+ Sproc (p, d) -> doapply th cc p d [| a1v; a2v; a3v |]
+ | Sprim p ->
+ begin
+ match p.prim_fun with
+ Pf3 f -> cc (f a1v a2v a3v)
+ | Pfn f -> cc (f [| a1v; a2v; a3v |])
+ | Pfcn f -> f th cc [| a1v; a2v; a3v |]
+ | _ -> assert false
+ end
+ | _ -> assert false) a3) a2) a1) c
+ | Capplyn (c, a) ->
+ eval th (fun cv ->
+ let n = Array.length a in
+ let av = Array.make n Snull in
+ let rec loop i =
+ if i = n then
+ begin
+ chkargs cv n;
+ match cv with
+ Sproc (p, d) -> doapply th cc p d av
+ | Sprim p ->
+ begin
+ match p.prim_fun with
+ Pfn f -> cc (f av)
+ | Pfcn f -> f th cc av
+ | _ -> assert false
+ end
+ | _ -> assert false
+ end
+ else
+ eval th (fun x -> av.(i) <- x; loop (i + 1)) a.(i)
+ in
+ loop 0) c
+ | Clambda p ->
+ let n = th.th_depth + 1 in
+ let nd = Array.init n
+ (fun i -> if i < n - 1 then th.th_display.(i)
+ else th.th_frame)
+ in
+ cc (Sproc (p, nd))
+ | Cqqp (h, t) ->
+ begin
+ match h with
+ Cqqspl x ->
+ eval th (fun usl -> eval th (fun t ->
+ let rec findtl =
+ function
+ Spair ({ car = _; cdr = Snull } as p) ->
+ p.cdr <- t; usl
+ | Spair { car = _; cdr = nt } -> findtl nt
+ | Snull -> t
+ | _ -> raise (Error "unquote-splicing: not a list")
+ in
+ cc (findtl usl)) t) x
+ | _ ->
+ eval th (fun h -> eval th (fun t ->
+ cc (Spair { car = h; cdr = t })) t) h
+ end
+ | Cqqv v ->
+ let n = Array.length v in
+ let qv = Array.make n Snull in
+ let rec loop i =
+ if i = n then
+ cc (Svector qv)
+ else
+ eval th (fun x -> qv.(i) <- x; loop (i + 1)) v.(i)
+ in
+ loop 0
+ | Cqqvs l ->
+ begin
+ let rec loop r =
+ function
+ [] -> cc (Svector (Array.of_list r))
+ | (Cqqspl x)::t ->
+ eval th (fun l -> loop ((list_to_caml l) @ r) t) x
+ | h::t ->
+ eval th (fun x -> loop (x::r) t) h
+ in
+ loop [] (List.rev l)
+ end
+ | Cqqspl x -> raise (Error "unquote-splicing: not valid here")
+ | Ccond av ->
+ begin
+ let n = Array.length av in
+ let rec loop i =
+ if i < n then
+ begin
+ match av.(i) with
+ (Ccondspec c, b) ->
+ eval th (fun v ->
+ if v <> Sfalse then eval th cc (Capply1 (b, Cval v))
+ else loop (i + 1)) c
+ | (c, b) ->
+ eval th (fun v ->
+ if v <> Sfalse then eval th cc b
+ else loop (i + 1)) c
+ end
+ else
+ cc Sunspec
+ in
+ loop 0
+ end
+ | Ccase (c, m) ->
+ eval th (fun v ->
+ let n = Array.length m in
+ let rec loop i =
+ if i < n then
+ begin
+ match m.(i) with
+ ([| |], b) -> eval th cc b
+ | (mv, b) ->
+ let n = Array.length mv in
+ let rec has i =
+ if i < n then
+ begin
+ let mvv = mv.(i) in
+ if mvv == v || test_eqv mvv v then true
+ else has (i + 1)
+ end
+ else
+ false
+ in
+ if has 0 then eval th cc b
+ else loop (i + 1)
+ end
+ else
+ cc Sunspec
+ in
+ loop 0) c
+ | Cdelay c ->
+ cc (Spromise { promise_code = c;
+ promise_val = None;
+ promise_th = Some { th with th_frame = th.th_frame } })
+ | _ -> raise (Error "eval: internal error")
+;;
+
diff --git a/ocs-1.0.3/src/ocs_eval.mli b/ocs-1.0.3/src/ocs_eval.mli
new file mode 100644
index 0000000..10f9259
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_eval.mli
@@ -0,0 +1,6 @@
+(* Evaluation *)
+
+open Ocs_types
+
+val eval : thread -> (sval -> unit) -> code -> unit
+
diff --git a/ocs-1.0.3/src/ocs_io.ml b/ocs-1.0.3/src/ocs_io.ml
new file mode 100644
index 0000000..06fc612
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_io.ml
@@ -0,0 +1,224 @@
+(* I/O primitives. *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_env
+open Ocs_eval
+open Ocs_print
+
+let get_stdin th =
+ match th.th_stdin with
+ Sport p -> p
+ | _ -> assert false
+;;
+
+let get_stdout th =
+ match th.th_stdout with
+ Sport p -> p
+ | _ -> assert false
+;;
+
+let read th cc =
+ function
+ [| |] ->
+ cc (Ocs_read.read_from_port (get_stdin th))
+ | [| Sport port |] -> cc (Ocs_read.read_from_port port)
+ | _ -> raise (Error "read: bad args")
+;;
+
+let rdchr p cc =
+ match Ocs_port.getc p with
+ Some c -> cc (Schar c)
+ | None -> cc Seof
+;;
+
+let read_char th cc =
+ function
+ [| |] -> rdchr (get_stdin th) cc
+ | [| Sport port |] -> rdchr port cc
+ | _ -> raise (Error "read-char: bad args")
+;;
+
+let peekchr p cc =
+ match Ocs_port.getc p with
+ Some c ->
+ Ocs_port.ungetc p c;
+ cc (Schar c)
+ | None -> cc Seof
+;;
+
+let peek_char th cc =
+ function
+ [| |] -> peekchr (get_stdin th) cc
+ | [| Sport port |] -> peekchr port cc
+ | _ -> raise (Error "peek-char: bad args")
+;;
+
+let eof_object =
+ function
+ Seof -> Strue
+ | _ -> Sfalse
+;;
+
+let chrdy p cc =
+ cc (if Ocs_port.char_ready p then Strue else Sfalse)
+;;
+
+let char_ready th cc =
+ function
+ [| |] -> chrdy (get_stdin th) cc
+ | [| Sport port |] -> chrdy port cc
+ | _ -> raise (Error "char-ready?: bad args")
+;;
+
+let display th cc =
+ function
+ [| obj |] ->
+ let p = get_stdout th in print p true obj; Ocs_port.flush p; cc Sunspec
+ | [| obj; Sport p |] -> print p true obj; Ocs_port.flush p; cc Sunspec
+ | _ -> raise (Error "display: bad args")
+;;
+
+let write th cc =
+ function
+ [| obj |] ->
+ let p = get_stdout th in print p false obj; Ocs_port.flush p; cc Sunspec
+ | [| obj; Sport p |] -> print p false obj; Ocs_port.flush p; cc Sunspec
+ | _ -> raise (Error "write: bad args")
+;;
+
+let write_char th cc =
+ function
+ [| Schar c |] ->
+ let p = get_stdout th in Ocs_port.putc p c; Ocs_port.flush p; cc Sunspec
+ | [| Schar c; Sport p |] -> Ocs_port.putc p c; Ocs_port.flush p; cc Sunspec
+ | _ -> raise (Error "write-char: bad args")
+;;
+
+let newline th cc =
+ function
+ [| |] ->
+ let p = get_stdout th in Ocs_port.putc p '\n'; Ocs_port.flush p; cc Sunspec
+ | [| Sport p |] -> Ocs_port.putc p '\n'; Ocs_port.flush p; cc Sunspec
+ | _ -> raise (Error "newline: bad args")
+;;
+
+let current_input th cc =
+ function
+ [| |] -> cc th.th_stdin
+ | _ -> raise (Error "current-input-port: bad args")
+;;
+
+let current_output th cc =
+ function
+ [| |] -> cc th.th_stdout
+ | _ -> raise (Error "current-output-port: bad args")
+;;
+
+let is_input =
+ function
+ Sport p -> if Ocs_port.is_input p then Strue else Sfalse
+ | _ -> Sfalse
+;;
+
+let is_output =
+ function
+ Sport p -> if Ocs_port.is_output p then Strue else Sfalse
+ | _ -> Sfalse
+;;
+
+let open_input_file =
+ function
+ Sstring s -> Sport (Ocs_port.open_input_port s)
+ | _ -> raise (Error "expected string as input file name")
+;;
+
+let open_output_file =
+ function
+ Sstring s -> Sport (Ocs_port.open_output_port s)
+ | _ -> raise (Error "expected string as output file name")
+;;
+
+let close_port =
+ function
+ Sport p -> Ocs_port.close p
+ | _ -> raise (Error "close-port: invalid argument")
+;;
+
+let scm_close_port p =
+ close_port p; Sunspec
+;;
+
+(* Note that the call-with-*-file functions close the port if the
+ procedure exits, so they must not be re-called using a captured
+ continuation after they exit once. Dynamic extents can't be used
+ for this because closing and reopening the file would be an even
+ bigger problem. *)
+
+let call_w_in th cc =
+ function
+ [| name; proc |] ->
+ let p = open_input_file name in
+ eval th (fun x -> close_port p; cc x) (Capply1 (Cval proc, Cval p))
+ | _ -> raise (Error "call-with-input-file: bad args")
+;;
+
+let call_w_out th cc =
+ function
+ [| name; proc |] ->
+ let p = open_output_file name in
+ eval th (fun x -> close_port p; cc x) (Capply1 (Cval proc, Cval p))
+ | _ -> raise (Error "call-with-output-file: bad args")
+;;
+
+let w_in th cc =
+ function
+ [| name; thunk |] ->
+ let p = open_input_file name in
+ eval { th with th_stdin = p }
+ (fun x -> close_port p; cc x)
+ (Capply0 (Cval thunk))
+ | _ -> raise (Error "with-input-from-file: bad args")
+;;
+
+let w_out th cc =
+ function
+ [| name; thunk |] ->
+ let p = open_output_file name in
+ eval { th with th_stdout = p }
+ (fun x -> close_port p; cc x)
+ (Capply0 (Cval thunk))
+ | _ -> raise (Error "with-output-to-file: bad args")
+;;
+
+let init e =
+ set_pfcn e read "read";
+ set_pfcn e read_char "read-char";
+ set_pfcn e peek_char "peek-char";
+ set_pfcn e char_ready "char-ready?";
+
+ set_pf1 e eof_object "eof-object?";
+
+ set_pfcn e display "display";
+ set_pfcn e newline "newline";
+ set_pfcn e write "write";
+ set_pfcn e write_char "write-char";
+
+ set_pfcn e current_input "current-input-port";
+ set_pfcn e current_output "current-output-port";
+
+ set_pf1 e is_input "input-port?";
+ set_pf1 e is_output "output-port?";
+
+ set_pf1 e open_input_file "open-input-file";
+ set_pf1 e open_output_file "open-output-file";
+
+ set_pf1 e scm_close_port "close-input-port";
+ set_pf1 e scm_close_port "close-output-port";
+
+ set_pfcn e call_w_in "call-with-input-file";
+ set_pfcn e call_w_out "call-with-output-file";
+
+ set_pfcn e w_in "with-input-from-file";
+ set_pfcn e w_out "with-output-to-file";
+;;
diff --git a/ocs-1.0.3/src/ocs_io.mli b/ocs-1.0.3/src/ocs_io.mli
new file mode 100644
index 0000000..0398a99
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_io.mli
@@ -0,0 +1,11 @@
+(* I/O primitives *)
+
+open Ocs_types
+
+val read : thread -> (sval -> unit) -> sval array -> unit
+
+val open_input_file : sval -> sval
+val open_output_file : sval -> sval
+
+val init : env -> unit
+
diff --git a/ocs-1.0.3/src/ocs_lex.ml b/ocs-1.0.3/src/ocs_lex.ml
new file mode 100644
index 0000000..d4796ec
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_lex.ml
@@ -0,0 +1,279 @@
+(* Lexer for Scheme. *)
+
+open Ocs_types
+open Ocs_error
+
+type token =
+ Leof
+ | Lopenv (* #( *)
+ | Lunqsplice (* ,@ *)
+ | Lident of string
+ | Lstring of string
+ | Lnumber of sval
+ | Lbool of sval
+ | Lchar of sval
+ | Ltoken of char
+
+type lexer = {
+ l_port : Ocs_port.port;
+ l_buf : Buffer.t;
+ l_name : string;
+ mutable l_line : int
+}
+
+let make_lexer port name =
+ { l_port = port;
+ l_buf = Buffer.create 512;
+ l_name = name;
+ l_line = 0 }
+;;
+
+let get_loc lex =
+ (lex.l_name, lex.l_line)
+;;
+
+let lex_error lex err =
+ if String.length lex.l_name = 0 then
+ Error err
+ else
+ ErrorL (get_loc lex, err)
+;;
+
+let num_w_base lex s =
+ let base =
+ match s.[0] with
+ 'B' | 'b' -> 2
+ | 'D' | 'd' -> 10
+ | 'O' | 'o' -> 8
+ | 'X' | 'x' -> 16
+ | _ -> raise (lex_error lex "invalid character literal")
+ and n = String.length s
+ in
+ let rec scn v i =
+ if i >= n then v
+ else
+ match s.[i] with
+ '0' .. '9' as c when (int_of_char c) - (int_of_char '0') < base ->
+ scn (v * base + (int_of_char c) - (int_of_char '0')) (i + 1)
+ | 'a' .. 'f' as c when base = 16 ->
+ scn (v * base + (int_of_char c) - (int_of_char 'a') + 10) (i + 1)
+ | 'A' .. 'F' as c when base = 16 ->
+ scn (v * base + (int_of_char c) - (int_of_char 'A') + 10) (i + 1)
+ | _ -> v (* Ignore trailing junk *)
+ in
+ scn 0 1
+;;
+
+let string_num_esc lex base n =
+ let rec scn v i =
+ if i >= n then char_of_int v
+ else
+ match Ocs_port.getc lex.l_port with
+ Some ('0' .. '9' as c) when
+ (int_of_char c) - (int_of_char '0') < base ->
+ scn (v * base + (int_of_char c) - (int_of_char '0')) (i + 1)
+ | Some ('a' .. 'f' as c) when base = 16 ->
+ scn (v * base + (int_of_char c) - (int_of_char 'a') + 10) (i + 1)
+ | Some ('A' .. 'F' as c) when base = 16 ->
+ scn (v * base + (int_of_char c) - (int_of_char 'A') + 10) (i + 1)
+ | Some c ->
+ Ocs_port.ungetc lex.l_port c;
+ char_of_int v
+ | None -> raise (lex_error lex "unexpected eof in string literal")
+ in
+ scn 0 0
+;;
+
+let read_char lex =
+ begin
+ match Ocs_port.getc lex.l_port with
+ Some c -> Buffer.add_char lex.l_buf c
+ | None -> raise (lex_error lex "unexpected eof")
+ end;
+ let rec loop () =
+ match Ocs_port.getc lex.l_port with
+ Some (('a' .. 'z' | 'A' .. 'Z' | '0' .. '9') as c) ->
+ Buffer.add_char lex.l_buf c; loop ()
+ | Some c -> Ocs_port.ungetc lex.l_port c
+ | None -> ()
+ in
+ loop ();
+ let s = Buffer.contents lex.l_buf in
+ if String.length s = 1 then
+ Lchar (Schar s.[0])
+ else
+ match Ocs_char.name_to_char s with
+ Some c -> Lchar (Schar c)
+ | None -> Lchar (Schar (char_of_int (num_w_base lex s)))
+;;
+
+let rec read_string lex =
+ match Ocs_port.getc lex.l_port with
+ Some '\"' -> Lstring (Buffer.contents lex.l_buf)
+ | Some '\\' ->
+ begin
+ match Ocs_port.getc lex.l_port with
+ Some ('N' | 'n') ->
+ Buffer.add_char lex.l_buf '\n';
+ read_string lex
+ | Some ('R' | 'r') ->
+ Buffer.add_char lex.l_buf '\r';
+ read_string lex
+ | Some ('T' | 't') ->
+ Buffer.add_char lex.l_buf '\t';
+ read_string lex
+ | Some ('B' | 'b') ->
+ Buffer.add_char lex.l_buf (string_num_esc lex 2 8);
+ read_string lex
+ | Some ('D' | 'd') ->
+ Buffer.add_char lex.l_buf (string_num_esc lex 10 3);
+ read_string lex
+ | Some ('O' | 'o') ->
+ Buffer.add_char lex.l_buf (string_num_esc lex 8 3);
+ read_string lex
+ | Some ('X' | 'x') ->
+ Buffer.add_char lex.l_buf (string_num_esc lex 16 2);
+ read_string lex
+ | Some ('0' .. '9' as c) ->
+ Ocs_port.ungetc lex.l_port c;
+ Buffer.add_char lex.l_buf (string_num_esc lex 10 3);
+ read_string lex
+ | Some c ->
+ Buffer.add_char lex.l_buf c;
+ read_string lex
+ | None ->
+ raise (lex_error lex "unexpected eof in string literal")
+ end
+ | Some '\n' ->
+ lex.l_line <- lex.l_line + 1;
+ Buffer.add_char lex.l_buf '\n';
+ read_string lex
+ | Some c ->
+ Buffer.add_char lex.l_buf c;
+ read_string lex
+ | None -> raise (lex_error lex "unexpected eof in string literal")
+;;
+
+let rec read_ident lex =
+ match Ocs_port.getc lex.l_port with
+ Some (('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '!' | '$' | '%' | '&' |
+ '*' | '/' | ':' | '<' | '=' | '>' | '?' | '^' | '_' | '~' |
+ '+' | '-' | '.' | '@') as c) ->
+ Buffer.add_char lex.l_buf c;
+ read_ident lex
+ | Some c ->
+ Ocs_port.ungetc lex.l_port c;
+ Lident (Buffer.contents lex.l_buf)
+ | None ->
+ Lident (Buffer.contents lex.l_buf)
+;;
+
+let parse_number lex =
+ try
+ Lnumber (Ocs_numstr.string_to_num (Buffer.contents lex.l_buf) 0)
+ with
+ Error err -> raise (lex_error lex err)
+;;
+
+(* When reading numbers, accept almost any characters that look
+ like they may be part of a number. Some extremely obfuscated
+ inputs may be misinterpreted. *)
+let rec read_number lex =
+ match Ocs_port.getc lex.l_port with
+ Some (('0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '-' | '+' | '.' |
+ '#' | '/' | '@') as c) ->
+ Buffer.add_char lex.l_buf c;
+ read_number lex
+ | Some c ->
+ Ocs_port.ungetc lex.l_port c;
+ parse_number lex
+ | None ->
+ parse_number lex
+;;
+
+let rec tok lex =
+ match Ocs_port.getc lex.l_port with
+ Some c ->
+ begin
+ match c with
+ '\n' -> lex.l_line <- lex.l_line + 1; tok lex
+ | ' ' | '\t' | '\r' | '\012' -> tok lex
+ | ';' ->
+ begin
+ let rec loop () =
+ match Ocs_port.getc lex.l_port with
+ Some '\n' -> lex.l_line <- lex.l_line + 1; tok lex
+ | Some _ -> loop ()
+ | None -> Leof
+ in
+ loop ()
+ end
+ | ',' ->
+ begin
+ match Ocs_port.getc lex.l_port with
+ Some '@' -> Lunqsplice
+ | Some c -> Ocs_port.ungetc lex.l_port c; Ltoken ','
+ | None -> Ltoken ','
+ end
+ | '#' ->
+ begin
+ match Ocs_port.getc lex.l_port with
+ Some ('f' | 'F') -> Lbool Sfalse
+ | Some ('t' | 'T') -> Lbool Strue
+ | Some (('B' | 'b' | 'D' | 'd' | 'O' | 'o' | 'X' | 'x' |
+ 'E' | 'e' | 'I' | 'i') as c) ->
+ Buffer.add_char lex.l_buf '#';
+ Buffer.add_char lex.l_buf c;
+ read_number lex
+ | Some '\\' -> read_char lex
+ | Some '(' -> Lopenv
+ | Some c -> Ocs_port.ungetc lex.l_port c; Ltoken '#'
+ | None -> Ltoken '#'
+ end
+ | '\"' -> read_string lex
+ | '+' | '-' ->
+ begin
+ match Ocs_port.getc lex.l_port with
+ Some (('0' .. '9' | 'i' | 'I' | '.') as x) ->
+ Buffer.add_char lex.l_buf c;
+ Buffer.add_char lex.l_buf x;
+ read_number lex
+ | Some x ->
+ Ocs_port.ungetc lex.l_port x;
+ Lident (String.make 1 c)
+ | None -> Lident (String.make 1 c)
+ end
+ | '.' ->
+ begin
+ match Ocs_port.getc lex.l_port with
+ Some '.' ->
+ Buffer.add_string lex.l_buf "..";
+ read_ident lex
+ | Some ('0' .. '9' as c) ->
+ Buffer.add_char lex.l_buf '.';
+ Buffer.add_char lex.l_buf c;
+ read_number lex
+ | Some c ->
+ Ocs_port.ungetc lex.l_port c;
+ Ltoken '.'
+ | None -> Ltoken '.'
+ end
+ | '0' .. '9' ->
+ Buffer.add_char lex.l_buf c;
+ read_number lex
+ | 'a' .. 'z' | 'A' .. 'Z' | '!' | '$' | '%' | '&' | '*' | '/'
+ | ':' | '<' | '=' | '>' | '?' | '^' | '_' | '~' ->
+ begin
+ Buffer.add_char lex.l_buf c;
+ read_ident lex
+ end
+ | _ -> Ltoken c
+ end
+ | None -> Leof
+;;
+
+let get_tok lex =
+ Buffer.clear lex.l_buf;
+ tok lex
+;;
+
diff --git a/ocs-1.0.3/src/ocs_lex.mli b/ocs-1.0.3/src/ocs_lex.mli
new file mode 100644
index 0000000..55892ac
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_lex.mli
@@ -0,0 +1,22 @@
+(* Lexer for Scheme. *)
+
+open Ocs_types
+open Ocs_error
+
+type token =
+ Leof
+ | Lopenv (* #( *)
+ | Lunqsplice (* ,@ *)
+ | Lident of string
+ | Lstring of string
+ | Lnumber of sval
+ | Lbool of sval
+ | Lchar of sval
+ | Ltoken of char
+
+type lexer
+
+val make_lexer : Ocs_port.port -> string -> lexer
+val get_loc : lexer -> location
+val get_tok : lexer -> token
+
diff --git a/ocs-1.0.3/src/ocs_list.ml b/ocs-1.0.3/src/ocs_list.ml
new file mode 100644
index 0000000..781d948
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_list.ml
@@ -0,0 +1,302 @@
+(* List functionality. *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_env
+open Ocs_misc
+
+(* Primitives *)
+
+let make_list av =
+ let rec loop i r =
+ if i < 0 then r
+ else loop (i - 1) (Spair { car = Array.unsafe_get av i; cdr = r })
+ in
+ loop (Array.length av - 1) Snull
+;;
+
+let cons h t =
+ Spair { car = h; cdr = t }
+;;
+
+let gcar =
+ function
+ Spair { car = r; cdr = _ } -> r
+ | _ -> raise (Error "car: bad args")
+;;
+
+let gcdr =
+ function
+ Spair { car = _; cdr = r } -> r
+ | _ -> raise (Error "cdr: bad args")
+;;
+
+let caar x = gcar (gcar x);;
+let cadr x = gcar (gcdr x);;
+let cdar x = gcdr (gcar x);;
+let cddr x = gcdr (gcdr x);;
+
+let gcxr seq =
+ List.fold_left (fun f g -> fun x -> f (g x)) (fun x -> x) seq
+;;
+
+let set_car l v =
+ match l with
+ Spair p -> p.car <- v; Sunspec
+ | _ -> raise (Error "set-car!: bad args")
+;;
+
+let set_cdr l v =
+ match l with
+ Spair p -> p.cdr <- v; Sunspec
+ | _ -> raise (Error "set-cdr!: bad args")
+;;
+
+let safe_length l =
+ let next =
+ function
+ Spair { car = _; cdr = t } -> t
+ | _ -> raise (Error "length: invalid list") in
+ let rec loop l r n =
+ if l == Snull then
+ n
+ else if n land 1 = 0 then
+ loop (next l) r (n + 1)
+ else if l == r then
+ raise (Error "length: loop detected")
+ else
+ loop (next l) (next r) (n + 1)
+ in
+ loop l l 0
+;;
+
+let is_list l =
+ try
+ let _ = safe_length l in Strue
+ with
+ _ -> Sfalse
+;;
+
+let length l =
+ Sint (safe_length l)
+;;
+
+let reverse l =
+ let rec loop nl =
+ function
+ Snull -> nl
+ | Spair { car = h; cdr = t } -> loop (Spair { car = h; cdr = nl }) t
+ | _ -> raise (Error "reverse: invalid list")
+ in
+ loop Snull l
+;;
+
+(* Copy list and set tail, used by append *)
+let cptl tl =
+ function
+ Snull -> tl
+ | Spair { car = h; cdr = t } ->
+ let nl = Spair { car = h; cdr = Snull } in
+ let rec loop =
+ function
+ Spair p ->
+ begin
+ function
+ Spair { car = h; cdr = t } ->
+ let n = Spair { car = h; cdr = Snull } in
+ p.cdr <- n; loop n t
+ | Snull -> p.cdr <- tl
+ | _ -> raise (Error "append: bad list")
+ end
+ | _ -> assert false
+ in
+ loop nl t; nl
+ | _ -> raise (Error "append: bad list")
+;;
+
+let append =
+ function
+ [| |] -> Snull
+ | av ->
+ let n = Array.length av in
+ let rec loop i tl =
+ if i >= 0 then
+ loop (i - 1) (cptl tl av.(i))
+ else
+ tl
+ in
+ loop (n - 2) av.(n - 1)
+;;
+
+let list_tail l =
+ function
+ Sint k ->
+ begin
+ let rec tail i x =
+ if i = 0 then x
+ else
+ match x with
+ Spair { car = _; cdr = t } -> tail (i - 1) t
+ | _ -> raise (Error "list-tail: bad list")
+ in
+ tail k l
+ end
+ | _ -> raise (Error "list-tail: bad args")
+;;
+
+let list_ref l k =
+ match list_tail l k with
+ Spair { car = x; cdr = _ } -> x
+ | _ -> raise (Error "list-ref: bad args")
+;;
+
+let rec memq o =
+ function
+ Snull -> Sfalse
+ | Spair { car = x; cdr = t } as p -> if o == x then p else memq o t
+ | _ -> raise (Error "memq: bad list")
+;;
+
+let rec memv o =
+ function
+ Snull -> Sfalse
+ | Spair { car = x; cdr = t } as p ->
+ if o == x || test_eqv o x then p else memv o t
+ | _ -> raise (Error "memv: bad list")
+;;
+
+let rec member o =
+ function
+ Snull -> Sfalse
+ | Spair { car = x; cdr = t } as p ->
+ if o == x || test_equal o x then p else member o t
+ | _ -> raise (Error "member: bad list")
+;;
+
+let rec assq o =
+ function
+ Snull -> Sfalse
+ | Spair { car = Spair { car = x; cdr = _ } as p; cdr = t } ->
+ if o == x then p else assq o t
+ | _ -> raise (Error "assq: bad list")
+;;
+
+let rec assv o =
+ function
+ Snull -> Sfalse
+ | Spair { car = Spair { car = x; cdr = _ } as p; cdr = t } ->
+ if o == x || test_eqv o x then p else assv o t
+ | _ -> raise (Error "assv: bad list")
+;;
+
+let rec assoc o =
+ function
+ Snull -> Sfalse
+ | Spair { car = Spair { car = x; cdr = _ } as p; cdr = t } ->
+ if o == x || test_equal o x then p else assv o t
+ | _ -> raise (Error "assoc: bad list")
+;;
+
+let list_to_vector =
+ function
+ Snull -> Svector [| |]
+ | Spair _ as l ->
+ let n = safe_length l in
+ let v = Array.make n Snull in
+ let rec loop i l =
+ if i < n then
+ begin
+ match l with
+ Spair { car = h; cdr = t } -> v.(i) <- h; loop (i + 1) t
+ | _ -> assert false (* length was wrong? *)
+ end
+ else
+ ()
+ in
+ loop 0 l;
+ Svector v
+ | _ -> raise (Error "list->vector: bad args")
+;;
+
+let list_to_string =
+ function
+ Snull -> Sstring ""
+ | Spair _ as l ->
+ let n = safe_length l in
+ let s = String.create n in
+ let rec loop i l =
+ if i < n then
+ begin
+ match l with
+ Spair { car = Schar c; cdr = t } -> s.[i] <- c; loop (i + 1) t
+ | _ -> raise (Error "list->string: non-characters in list")
+ end
+ else
+ ()
+ in
+ loop 0 l;
+ Sstring s
+ | _ -> raise (Error "list->string: bad args")
+;;
+
+let init e =
+ set_pf1 e is_list "list?";
+ set_pfn e make_list "list";
+ set_pf2 e cons "cons";
+
+ set_pf1 e gcar "car";
+ set_pf1 e gcdr "cdr";
+
+ set_pf1 e caar "caar";
+ set_pf1 e cadr "cadr";
+ set_pf1 e cdar "cdar";
+ set_pf1 e cddr "cddr";
+
+ set_pf1 e (gcxr [ gcar; gcar; gcar ]) "caaar";
+ set_pf1 e (gcxr [ gcar; gcar; gcdr ]) "caadr";
+ set_pf1 e (gcxr [ gcar; gcdr; gcar ]) "cadar";
+ set_pf1 e (gcxr [ gcar; gcdr; gcdr ]) "caddr";
+ set_pf1 e (gcxr [ gcdr; gcar; gcar ]) "cdaar";
+ set_pf1 e (gcxr [ gcdr; gcar; gcdr ]) "cdadr";
+ set_pf1 e (gcxr [ gcdr; gcdr; gcar ]) "cddar";
+ set_pf1 e (gcxr [ gcdr; gcdr; gcdr ]) "cdddr";
+
+ set_pf1 e (gcxr [ gcar; gcar; gcar; gcar ]) "caaaar";
+ set_pf1 e (gcxr [ gcar; gcar; gcar; gcdr ]) "caaadr";
+ set_pf1 e (gcxr [ gcar; gcar; gcdr; gcar ]) "caadar";
+ set_pf1 e (gcxr [ gcar; gcar; gcdr; gcdr ]) "caaddr";
+ set_pf1 e (gcxr [ gcar; gcdr; gcar; gcar ]) "cadaar";
+ set_pf1 e (gcxr [ gcar; gcdr; gcar; gcdr ]) "cadadr";
+ set_pf1 e (gcxr [ gcar; gcdr; gcdr; gcar ]) "caddar";
+ set_pf1 e (gcxr [ gcar; gcdr; gcdr; gcdr ]) "cadddr";
+ set_pf1 e (gcxr [ gcdr; gcar; gcar; gcar ]) "cdaaar";
+ set_pf1 e (gcxr [ gcdr; gcar; gcar; gcdr ]) "cdaadr";
+ set_pf1 e (gcxr [ gcdr; gcar; gcdr; gcar ]) "cdadar";
+ set_pf1 e (gcxr [ gcdr; gcar; gcdr; gcdr ]) "cdaddr";
+ set_pf1 e (gcxr [ gcdr; gcdr; gcar; gcar ]) "cddaar";
+ set_pf1 e (gcxr [ gcdr; gcdr; gcar; gcdr ]) "cddadr";
+ set_pf1 e (gcxr [ gcdr; gcdr; gcdr; gcar ]) "cdddar";
+ set_pf1 e (gcxr [ gcdr; gcdr; gcdr; gcdr ]) "cddddr";
+
+ set_pf2 e set_car "set-car!";
+ set_pf2 e set_cdr "set-cdr!";
+
+ set_pf1 e length "length";
+ set_pf1 e reverse "reverse";
+
+ set_pfn e append "append";
+
+ set_pf2 e list_tail "list-tail";
+ set_pf2 e list_ref "list-ref";
+
+ set_pf2 e memq "memq";
+ set_pf2 e memv "memv";
+ set_pf2 e member "member";
+ set_pf2 e assq "assq";
+ set_pf2 e assv "assv";
+ set_pf2 e assoc "assoc";
+
+ set_pf1 e list_to_vector "list->vector";
+ set_pf1 e list_to_string "list->string";
+;;
+
diff --git a/ocs-1.0.3/src/ocs_list.mli b/ocs-1.0.3/src/ocs_list.mli
new file mode 100644
index 0000000..1b9c1da
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_list.mli
@@ -0,0 +1,6 @@
+(* List functionality. *)
+
+open Ocs_types
+
+val init : env -> unit
+
diff --git a/ocs-1.0.3/src/ocs_macro.ml b/ocs-1.0.3/src/ocs_macro.ml
new file mode 100644
index 0000000..e9afbc6
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_macro.ml
@@ -0,0 +1,438 @@
+(* Macro definitions and expanders. *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_sym
+open Ocs_env
+open Ocs_compile
+open Ocs_misc
+
+(* Pattern/template type in syntax rules. *)
+type pattern =
+ Pkeyword of env * sval
+ | Pvar of sval
+ | Pvalue of sval
+ | Ppair of pattern * pattern
+ | Pvector of pattern array
+ | Pmulti of pattern * pattern (* pattern ... in a list *)
+ | Pvmulti of pattern (* pattern ... in a vector *)
+ | Pmvector of pattern list (* Vector with Pvmulti patterns *)
+
+type ruleset = {
+ mutable r_rules : (pattern * pattern) list
+}
+(* Values of pattern variables *)
+type pattvar =
+ Vitem of sval
+ | Vmulti of pattvar list
+
+let rec var_name =
+ function
+ Sesym (_, s) -> var_name s
+ | Ssymbol _ as s -> sym_name s
+ | _ -> assert false
+;;
+
+let kw_name =
+ function
+ Vkeyword s -> s
+ | _ -> assert false
+;;
+
+(* Parse a pattern or template *)
+let parseptt e patt dovar =
+ let rec parse =
+ function
+ Spair { car = h; cdr = t } ->
+ let x = parse h in
+ begin
+ match t with (* Special case, ... *)
+ Spair { car = (Ssymbol _ | Sesym (_, _)) as s; cdr = t }
+ when is_keyword e s "..." -> Pmulti (x, parse t)
+ | _ -> Ppair (x, parse t)
+ end
+ | (Ssymbol _ | Sesym (_, _)) as s -> dovar s
+ | Svector v ->
+ let n = Array.length v
+ and has_multi = ref false in
+ let rec loop r i =
+ if i < 0 then
+ r
+ else if safe_is_keyword e v.(i) "..." && i > 0 then
+ begin
+ has_multi := true;
+ loop (Pvmulti (parse v.(i - 1))::r) (i - 2)
+ end
+ else
+ loop (parse v.(i)::r) (i - 1)
+ in
+ let nl = loop [] (n - 1) in
+ if !has_multi then
+ Pmvector nl
+ else
+ Pvector (Array.of_list nl)
+ | x -> Pvalue x
+ in
+ parse patt
+;;
+
+let rec match_sym s s' =
+ match (s, s') with
+ Sesym (e, s), Sesym (e', s') -> e == e' && match_sym s s'
+ | _, _ -> s == s'
+;;
+
+let parsepatt e litlist patt =
+ let vars = ref [] in
+ let p = parseptt e patt
+ (fun s ->
+ try
+ let _ = List.find (fun s' -> match_sym s s') litlist in
+ Pkeyword (e, s)
+ with Not_found ->
+ vars := s::!vars;
+ Pvar s)
+ in
+ (!vars, p)
+;;
+
+let parsetmpl e varlist tmpl =
+ let assocvar =
+ function
+ Sesym (e, s) as sym ->
+ begin
+ try
+ Pvar (List.find (function
+ Sesym (e', s') -> e' == e && s' == s
+ | _ -> false) varlist)
+ with Not_found ->
+ Pvalue sym
+ end
+ | s -> if List.memq s varlist then Pvar s else Pvalue s
+ in
+ parseptt e tmpl assocvar
+;;
+
+let parserule e ll =
+ function
+ Spair { car = Spair { car = _; cdr = patt };
+ cdr = Spair { car = tmpl; cdr = Snull }} ->
+ let (vars, patt) = parsepatt e ll patt in
+ let tmpl = parsetmpl e vars tmpl in
+ (patt, tmpl)
+ | _ -> raise (Error "syntax definition: invalid syntax rule")
+;;
+
+let parsetspec e sym =
+ function
+ Spair { car = (Ssymbol _ | Sesym (_, _)) as s;
+ cdr = Spair { car = literals; cdr = rules }}
+ when is_keyword e s "syntax-rules" ->
+ let litlist = list_to_caml literals in
+ List.map (parserule e litlist) (list_to_caml rules)
+ | _ -> raise (Error "syntax definition: invalid transformer spec")
+;;
+
+let rebuild a =
+ let rec loop i r =
+ if i < 0 then
+ r
+ else
+ loop (i - 1) (Spair { car = a.(i); cdr = r })
+ in
+ loop (Array.length a - 1) Snull
+;;
+
+(* Given a pattern, return an association list of pattern variables
+ with empty multiple value lists. *)
+let rec empty_vars =
+ function
+ Pvar v -> [ v, Vmulti [] ]
+ | Ppair (h, t) -> (empty_vars h) @ (empty_vars t)
+ | Pmulti (p, t) -> (empty_vars p) @ (empty_vars t)
+ | Pvmulti p -> empty_vars p
+ | Pvector v ->
+ Array.fold_left (@) [] (Array.map empty_vars v)
+ | Pmvector l ->
+ List.fold_left (@) [] (List.map empty_vars l)
+ | _ -> []
+;;
+
+(* Merge an association list of multi-vars and a set of values *)
+let merge_vars mv vs =
+ let rec merge =
+ function
+ (v, Vmulti m)::t -> (v, Vmulti (m @ [ List.assq v vs ]))::(merge t)
+ | [] -> []
+ | _ -> assert false
+ in
+ merge mv
+;;
+
+let rec normalize_name =
+ function
+ Ssymbol s -> s
+ | Sesym (_, s) -> normalize_name s
+ | _ -> ""
+;;
+
+let rec match_patt e patt expr =
+ let vars = ref [] in
+ let rec match_sub p x =
+ match p with
+ Pkeyword (e', s') ->
+ begin
+ match x with
+ Ssymbol _ | Sesym (_, _) -> (get_var e x) == (get_var e' s')
+ | _ -> false
+ end
+ | Pvar v -> vars := (v, Vitem x)::!vars; true
+ | Pvalue v -> test_equal v x
+ | Ppair (h, t) ->
+ begin
+ match x with
+ Spair { car = xh; cdr = xt } -> match_sub h xh && match_sub t xt
+ | _ -> false
+ end
+ | Pvector v ->
+ begin
+ match x with
+ Svector sv ->
+ let n = Array.length v in
+ if Array.length sv <> n then
+ false
+ else
+ let rec loop i =
+ if i = n then
+ true
+ else if match_sub v.(i) sv.(i) then
+ loop (i + 1)
+ else
+ false
+ in
+ loop 0
+ | _ -> false
+ end
+ | Pmulti (p, t) ->
+ if t <> (Pvalue Snull) then
+ raise (Error "invalid pattern");
+ begin
+ let rec loop r =
+ function
+ Spair { car = h; cdr = t } ->
+ begin
+ match match_patt e p h with
+ Some v -> loop (merge_vars r v) t
+ | None -> None
+ end
+ | Snull -> Some r
+ | _ -> None
+ in
+ match loop (empty_vars p) x with
+ Some vl -> vars := vl @ !vars; true
+ | None -> false
+ end
+ | Pmvector l ->
+ begin
+ match x with
+ Svector v ->
+ begin
+ let n = Array.length v in
+ let rec loop i =
+ function
+ Pvmulti p::t ->
+ if i >= n then
+ begin
+ vars := (empty_vars p) @ !vars;
+ loop i t
+ end
+ else
+ begin
+ let rec mloop r i =
+ if i >= n then Some r
+ else
+ match match_patt e p v.(i) with
+ Some v -> mloop (merge_vars r v) (i + 1)
+ | None -> None
+ in
+ match mloop (empty_vars p) i with
+ Some vl -> vars := vl @ !vars; true
+ | None -> false
+ end
+ | h::t ->
+ if i >= n then false
+ else if match_sub h v.(i) then loop (i + 1) t
+ else false
+ | [] -> i >= n
+ in
+ loop 0 l
+ end
+ | _ -> false
+ end
+ | _ -> assert false
+ in
+ if match_sub patt expr then
+ Some !vars
+ else
+ None
+;;
+
+(* Test whether a variable occurs in a pattern *)
+let var_in_patt p (v, _) =
+ let rec is_in =
+ function
+ Pvar pv -> pv == v
+ | Ppair (h, t) -> is_in h || is_in t
+ | Pmulti (p, t) -> is_in p || is_in t
+ | Pvmulti p -> is_in p
+ | Pvector v ->
+ let rec loop i =
+ if i < 0 then false
+ else if is_in v.(i) then true
+ else loop (i - 1)
+ in
+ loop (Array.length v - 1)
+ | Pmvector l -> List.exists is_in l
+ | _ -> false
+ in
+ is_in p
+;;
+
+(* Select variables that are applicable to this pattern *)
+let subvars vl p =
+ List.filter (var_in_patt p) vl
+;;
+
+(* Get the current values of variables, if available. *)
+let varvals vl =
+ try
+ let l = List.map
+ (function
+ (v, Vmulti (x::_)) -> (v, x)
+ | (v, Vmulti []) -> raise Not_found
+ | x -> x) vl
+ in
+ if l = [] then
+ raise (Error "bad template")
+ else
+ (true, l)
+ with Not_found -> (false, [])
+;;
+
+(* Get the next position in the variable list. *)
+let varnext vl =
+ List.map (function (v, Vmulti (_::t)) -> (v, Vmulti t) | x -> x) vl
+;;
+
+let rec expand_var =
+ function
+ Vitem x -> x
+ | Vmulti m -> make_slist Snull (List.rev_map expand_var m)
+;;
+
+let rec expand_tmpl e tmpl vars =
+ let rec fix_syms =
+ function
+ Ssymbol _ as s -> Sesym (e, s)
+ | Spair { car = h; cdr = t } ->
+ Spair { car = fix_syms h; cdr = fix_syms t }
+ | Svector v ->
+ Svector (Array.map (fun x -> fix_syms x) v)
+ | x -> x in
+ let rec expand_sub =
+ function
+ Pvar v -> expand_var (List.assq v vars)
+ | Pvalue v -> fix_syms v
+ | Ppair (h, t) ->
+ Spair { car = expand_sub h; cdr = expand_sub t }
+ | Pvector v ->
+ Svector (Array.map (fun x -> expand_sub x) v)
+ | Pmulti (p, t) ->
+ let rec loop r v =
+ let (ok, vv) = varvals v in
+ if ok then loop ((expand_tmpl e p vv)::r) (varnext v)
+ else r
+ in
+ make_slist (expand_sub t) (loop [] (subvars vars p))
+ | Pmvector l ->
+ begin
+ let rec loop r =
+ function
+ Pvmulti p::t ->
+ let rec mloop r v =
+ let (ok, vv) = varvals v in
+ if ok then mloop ((expand_tmpl e p vv)::r) (varnext v)
+ else r
+ in
+ loop (mloop [] (subvars vars p) @ r) t
+ | h::t -> loop (expand_sub h::r) t
+ | [] -> r
+ in
+ Svector (Array.of_list (List.rev (loop [] l)))
+ end
+ | _ -> assert false
+ in
+ expand_sub tmpl
+;;
+
+let expand name me rs e av =
+ let me = new_scope me in
+ let al = rebuild av in
+ let rec try_rule =
+ function
+ (patt, tmpl)::t ->
+ begin
+ match match_patt e patt al with
+ Some vars -> expand_tmpl me tmpl vars
+ | None -> try_rule t
+ end
+ | [] -> raise (Error (name ^ ": no matching syntax rule"))
+ in
+ try_rule rs.r_rules
+;;
+
+let mkdefine_syntax e =
+ function
+ [| (Ssymbol _ | Sesym (_, _)) as sym; tspec |] ->
+ let rules = parsetspec (new_scope e) sym tspec in
+ bind_name e sym (Vmacro (expand (normalize_name sym) e
+ { r_rules = rules }));
+ Cval Sunspec
+ | _ -> raise (Error "define-syntax: bad args")
+;;
+
+let mklet_syntax e args =
+ if Array.length args < 2 then
+ raise (Error "let-syntax: too few args");
+ let av =
+ Array.map (letsplit (fun s v -> s,
+ Vmacro (expand (normalize_name s) e { r_rules = parsetspec e s v })))
+ (Array.of_list (list_to_caml args.(0))) in
+ let ne = new_scope e in
+ Array.iter (fun (s, r) -> bind_name ne s r) av;
+ mkseq (mkbody ne (Array.sub args 1 (Array.length args - 1)))
+;;
+
+let mkletrec_syntax e args =
+ if Array.length args < 2 then
+ raise (Error "letrec-syntax: too few args");
+ let ne = new_scope e in
+ let t =
+ Array.map (letsplit
+ (fun s v -> let r = { r_rules = [] }
+ and name = normalize_name s in
+ bind_name ne s (Vmacro (expand name ne r));
+ r, s, v))
+ (Array.of_list (list_to_caml args.(0)))
+ in
+ Array.iter (fun (r, s, v) -> r.r_rules <- parsetspec (new_scope e) s v) t;
+ mkseq (mkbody ne (Array.sub args 1 (Array.length args - 1)))
+;;
+
+let bind_macro e =
+ bind_name e sym_define_syntax (Vsyntax mkdefine_syntax);
+ bind_name e sym_let_syntax (Vsyntax mklet_syntax);
+ bind_name e sym_letrec_syntax (Vsyntax mkletrec_syntax);
+ bind_name e sym_ellipsis (Vkeyword "...")
+;;
+
diff --git a/ocs-1.0.3/src/ocs_macro.mli b/ocs-1.0.3/src/ocs_macro.mli
new file mode 100644
index 0000000..80b6b20
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_macro.mli
@@ -0,0 +1,6 @@
+(* Syntax definitions and expansions. *)
+
+open Ocs_types
+
+val bind_macro : env -> unit
+
diff --git a/ocs-1.0.3/src/ocs_main.ml b/ocs-1.0.3/src/ocs_main.ml
new file mode 100644
index 0000000..36a4bb7
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_main.ml
@@ -0,0 +1,28 @@
+(* Main program entry point. *)
+
+open Ocs_types
+open Ocs_error
+
+let main () =
+ let loadf = ref [] in
+ let addf x = loadf := !loadf @ [x] in
+ let argspec = [
+ ("file", Arg.Rest addf, "Files to run in batch mode")
+ ] in
+ Arg.parse argspec addf "Usage: ocscm [ file ... ]";
+ if !loadf = [] then
+ Ocs_top.interactive ()
+ else
+ let e = Ocs_top.make_env ()
+ and th = Ocs_top.make_thread () in
+ try
+ List.iter (fun x -> Ocs_prim.load_file e th x) !loadf
+ with
+ Error err ->
+ Printf.eprintf "Error: %s\n" err
+ | ErrorL ((file, line), err) ->
+ Printf.eprintf "%s:%d: %s\n" file line err
+;;
+
+main ();;
+
diff --git a/ocs-1.0.3/src/ocs_misc.ml b/ocs-1.0.3/src/ocs_misc.ml
new file mode 100644
index 0000000..d72ebf6
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_misc.ml
@@ -0,0 +1,77 @@
+(* Miscellaneous utility functions *)
+
+open Ocs_types
+open Ocs_error
+
+let list_to_caml l =
+ let rec loop r =
+ function
+ Snull -> List.rev r
+ | Spair p -> loop (p.car::r) p.cdr
+ | _ -> raise (Error "not a valid list")
+ in
+ loop [] l
+;;
+
+(* Create a Scheme list from a reversed native list. *)
+let make_slist tl l =
+ let rec loop r =
+ function
+ h::t -> loop (Spair { car = h; cdr = r }) t
+ | [] -> r
+ in
+ loop tl l
+;;
+
+(* Create one of Capply[0123n] depending on the number of arguments. *)
+let mkapply f av =
+ match av with
+ [| |] -> Capply0 (f)
+ | [| a1 |] -> Capply1 (f, a1)
+ | [| a1; a2 |] -> Capply2 (f, a1, a2)
+ | [| a1; a2; a3 |] -> Capply3 (f, a1, a2, a3)
+ | av -> Capplyn (f, av)
+;;
+
+(* Test equivalence (as in eqv?) *)
+
+let test_eqv a b =
+ if a == b then true
+ else
+ match (a, b) with
+ (Sint i1, Sint i2) -> i1 = i2
+ | (Schar c1, Schar c2) -> c1 = c2
+ | (Sreal r1, Sreal r2) -> r1 = r2
+ | (Sbigint bi1, Sbigint bi2) -> Big_int.compare_big_int bi1 bi2 = 0
+ | (Srational r1, Srational r2) -> Ratio.compare_ratio r1 r2 = 0
+ | (Scomplex z1, Scomplex z2) -> z1 = z2
+ | (Sstring s1, Sstring s2) -> s1 = s2
+ | (Svector v1, Svector v2) -> v1 == v2
+ | _ -> false
+;;
+
+(* Test equality (as in equal?) *)
+
+let rec test_equal a b =
+ if a == b then true
+ else
+ match (a, b) with
+ (Svector v1, Svector v2) ->
+ let n = Array.length v1 in
+ if Array.length v2 <> n then
+ false
+ else
+ let rec loop i =
+ if i >= n then
+ true
+ else
+ if test_equal v1.(i) v2.(i) then
+ loop (i + 1)
+ else
+ false
+ in
+ loop 0
+ | (Spair p1, Spair p2) ->
+ test_equal p1.car p2.car && test_equal p1.cdr p2.cdr
+ | _ -> test_eqv a b
+;;
diff --git a/ocs-1.0.3/src/ocs_misc.mli b/ocs-1.0.3/src/ocs_misc.mli
new file mode 100644
index 0000000..229ec35
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_misc.mli
@@ -0,0 +1,12 @@
+(* Miscellaneous utility functions *)
+
+open Ocs_types
+
+val list_to_caml : sval -> sval list
+
+val make_slist : sval -> sval list -> sval
+
+val mkapply : code -> code array -> code
+
+val test_eqv : sval -> sval -> bool
+val test_equal : sval -> sval -> bool
diff --git a/ocs-1.0.3/src/ocs_num.ml b/ocs-1.0.3/src/ocs_num.ml
new file mode 100644
index 0000000..5de1fc9
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_num.ml
@@ -0,0 +1,633 @@
+(* Handle number types (Sint, Sreal, Sbigint, Srational, Scomplex) *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_env
+open Ocs_numaux
+open Ocs_complex
+
+open Num
+open Ratio
+open Big_int
+
+let rec negate =
+ function
+ (Sint i) as s ->
+ if i >= min_int then Sint (-i)
+ else negate (promote_bigint s)
+ | Sbigint bi -> Sbigint (minus_big_int bi)
+ | Srational r -> Srational (Ratio.minus_ratio r)
+ | Sreal r -> Sreal (-.r)
+ | Scomplex z -> Scomplex (Complex.neg z)
+ | _ -> raise (Error "bad number type")
+;;
+
+let add2 a b =
+ match (a, b) with
+ (Sint i1, Sint i2) ->
+ let r = i1 + i2 in
+ if (i1 lxor i2) lor (i1 lxor (r lxor (-1))) < 0
+ then Sint r
+ else Sbigint (add_big_int (big_int_of_int i1) (big_int_of_int i2))
+ | (Scomplex z1, Scomplex z2) -> Scomplex (Complex.add z1 z2)
+ | (Scomplex z, o) | (o, Scomplex z) ->
+ Scomplex (Complex.add z { Complex.re = float_of_snum o;
+ Complex.im = 0.0 })
+ | (Sreal r, o) | (o, Sreal r) ->
+ Sreal ((float_of_snum o) +. r)
+ | (Srational r, o) | (o, Srational r) ->
+ Srational (add_ratio (rational_of_snum o) r)
+ | (Sbigint bi, o) | (o, Sbigint bi) ->
+ bigint_res (add_big_int (bigint_of_snum o) bi)
+ | _ -> raise (Error "add: bad types")
+;;
+
+let sub2 a b =
+ add2 a (negate b)
+;;
+
+let mul2 a b =
+ match snum_fixtypes a b with
+ (Scomplex z1, Scomplex z2) -> Scomplex (Complex.mul z1 z2)
+ | (Sreal r1, Sreal r2) -> Sreal (r1 *. r2)
+ | (Srational r1, Srational r2) ->
+ snum_of_num (mult_num (Ratio r1) (Ratio r2))
+ | (Sbigint bi1, Sbigint bi2) ->
+ snum_of_num (mult_num (Big_int bi1) (Big_int bi2))
+ | (Sint i1, Sint i2) ->
+ snum_of_num (mult_num (Int i1) (Int i2))
+ | _ -> raise (Error "mul: invalid args")
+;;
+
+let div2 a b =
+ match snum_fixtypes a b with
+ (Scomplex n, Scomplex d) -> Scomplex (Complex.div n d)
+ | (Sreal n, Sreal d) -> Sreal (n /. d)
+ | (Srational n, Srational d) ->
+ snum_of_num (div_num (Ratio n) (Ratio d))
+ | (Sbigint n, Sbigint d) ->
+ snum_of_num (div_num (Big_int n) (Big_int d))
+ | (Sint n, Sint d) ->
+ if d = 0 then
+ raise (Error "division by zero")
+ else
+ snum_of_num (div_num (Int n) (Int d))
+ | _ -> raise (Error "div: invalid args")
+;;
+
+let cmp2 eq_only a b =
+ match (a, b) with
+ (Sint i1, Sint i2) ->
+ if i1 > i2 then 1 else if i1 < i2 then -1 else 0
+ | _ ->
+ begin
+ match snum_fixtypes a b with
+ (Sreal r1, Sreal r2) ->
+ let r = r1 -. r2 in
+ if r > 0.0 then 1 else if r < 0.0 then -1 else 0
+ | (Scomplex z1, Scomplex z2) ->
+ if eq_only then
+ if z1 = z2 then 0 else 1
+ else
+ if z1.Complex.im = 0.0 && z2.Complex.im = 0.0 then
+ begin
+ let r = z1.Complex.re -. z2.Complex.re in
+ if r > 0.0 then 1 else if r < 0.0 then -1 else 0
+ end
+ else
+ raise (Error "complex numbers compared")
+ | (Srational r1, Srational r2) ->
+ compare_ratio r1 r2
+ | (Sbigint bi1, Sbigint bi2) ->
+ compare_big_int bi1 bi2
+ | _ -> raise (Error "cmp: invalid args")
+ end
+;;
+
+let is_exact =
+ function
+ (Sint _ | Sbigint _ | Srational _) -> Strue
+ | _ -> Sfalse
+;;
+
+let is_inexact =
+ function
+ (Sreal _ | Scomplex _) -> Strue
+ | _ -> Sfalse
+;;
+
+let to_exact =
+ function
+ Sreal r -> float_to_exact r
+ | Scomplex z ->
+ if z.Complex.im = 0.0 then
+ float_to_exact z.Complex.re
+ else
+ raise (Error "inexact->exact: no exact complex representation")
+ | (Sint _ | Sbigint _ | Srational _) as n -> n
+ | _ -> raise (Error "inexact->exact: not a number")
+;;
+
+let to_inexact =
+ function
+ Sreal _ as r -> r
+ | Scomplex _ as z -> z
+ | x -> Sreal (float_of_snum x)
+;;
+
+let mkbool b = if b then Strue else Sfalse;;
+
+let is_zero =
+ function
+ Sint i -> mkbool (i = 0)
+ | (Sbigint _ | Srational _) -> Sfalse
+ | Sreal r -> mkbool (r = 0.0)
+ | Scomplex z -> mkbool (z.Complex.re = 0.0 && z.Complex.im = 0.0)
+ | _ -> Sfalse
+;;
+
+let is_positive =
+ function
+ Sint i -> mkbool (i > 0)
+ | Sbigint bi -> mkbool (sign_big_int bi > 0)
+ | Srational r -> mkbool (sign_ratio r > 0)
+ | Sreal r -> mkbool (r > 0.0)
+ | _ -> raise (Error "positive?: bad arg type")
+;;
+
+let is_negative =
+ function
+ Sint i -> mkbool (i < 0)
+ | Sbigint bi -> mkbool (sign_big_int bi < 0)
+ | Srational r -> mkbool (sign_ratio r < 0)
+ | Sreal r -> mkbool (r < 0.0)
+ | _ -> raise (Error "positive?: bad arg type")
+;;
+
+let is_number =
+ function
+ Sint _ | Sbigint _ | Srational _ | Sreal _ | Scomplex _ -> Strue
+ | _ -> Sfalse
+;;
+
+let is_real =
+ function
+ Sint _ | Sbigint _ | Srational _ | Sreal _ -> Strue
+ | Scomplex { Complex.re = _; Complex.im = i } -> mkbool (i = 0.0)
+ | _ -> Sfalse
+;;
+
+let is_rational =
+ is_real
+;;
+
+let is_integer =
+ function
+ Sint _ | Sbigint _ -> Strue
+ | Sreal r -> mkbool (float_is_int r)
+ | Scomplex z -> mkbool (z.Complex.im = 0.0 && float_is_int z.Complex.re)
+ | _ -> Sfalse
+;;
+
+let bi_modi bi i =
+ int_of_big_int (mod_big_int bi (big_int_of_int i))
+;;
+
+let is_even =
+ function
+ Sint i -> mkbool (i land 1 = 0)
+ | Sbigint bi -> mkbool (bi_modi bi 2 = 0)
+ | _ -> raise (Error "even?: bad arg type")
+;;
+
+let is_odd =
+ function
+ Sint i -> mkbool (i land 1 <> 0)
+ | Sbigint bi -> mkbool (bi_modi bi 2 <> 0)
+ | _ -> raise (Error "odd?: bad arg type")
+;;
+
+let do_ops op av n =
+ let rec oploop v i =
+ if i < n then
+ let r = op v av.(i) in
+ oploop r (i + 1)
+ else
+ v
+ in
+ oploop av.(0) 1
+;;
+
+let snum_add av =
+ let n = Array.length av in
+ if n = 0 then
+ Sint 0
+ else
+ do_ops add2 av n
+;;
+
+let snum_sub av =
+ match Array.length av with
+ 0 -> raise (Error "-: need args")
+ | 1 -> negate av.(0)
+ | n -> do_ops sub2 av n
+;;
+
+let snum_mul av =
+ match Array.length av with
+ 0 -> Sint 1
+ | n -> do_ops mul2 av n
+;;
+
+let snum_div av =
+ match Array.length av with
+ 0 -> raise (Error "/: need args")
+ | 1 -> div2 (Sint 1) av.(0)
+ | n -> do_ops div2 av n
+;;
+
+let snum_eq av =
+ match Array.length av with
+ 0 | 1 -> Strue
+ | n ->
+ let a0 = av.(0) in
+ let rec loop i =
+ if i < n then
+ begin
+ if cmp2 true a0 av.(i) <> 0 then Sfalse
+ else loop (i + 1)
+ end
+ else
+ Strue
+ in
+ loop 1
+;;
+
+let snum_rel op av =
+ match Array.length av with
+ 0 | 1 -> Strue
+ | n ->
+ let rec loop v i =
+ if i < n then
+ begin
+ if op (cmp2 false v av.(i)) 0 then loop av.(i) (i + 1)
+ else Sfalse
+ end
+ else
+ Strue
+ in
+ loop av.(0) 1
+;;
+
+let snum_minormax op av =
+ match Array.length av with
+ 0 -> raise (Error "args required")
+ | 1 -> av.(0)
+ | n ->
+ let inex = ref false in
+ let r = do_ops (fun a b ->
+ if is_inexact a = Strue || is_inexact b = Strue then
+ inex := true;
+ if op (cmp2 false a b) 0 then a else b) av n
+ in
+ if !inex then to_inexact r else r
+;;
+
+let snum_abs =
+ function
+ Sint i -> Sint (abs i)
+ | Sbigint bi -> Sbigint (abs_big_int bi)
+ | Sreal r -> Sreal (abs_float r)
+ | Srational r -> Srational (abs_ratio r)
+ | Scomplex _ -> raise (Error "abs: number is complex")
+ | _ -> raise (Error "abs: not a number")
+;;
+
+let snum_floor =
+ function
+ (Sint _ | Sbigint _) as x -> x
+ | Srational r -> bigint_res (floor_ratio r)
+ | Sreal r -> Sreal (floor r)
+ | _ -> raise (Error "floor: bad arg type")
+;;
+
+let snum_ceiling =
+ function
+ (Sint _ | Sbigint _) as x -> x
+ | Srational r -> bigint_res (ceiling_ratio r)
+ | Sreal r -> Sreal (ceil r)
+ | _ -> raise (Error "ceiling: bad arg type")
+;;
+
+let snum_truncate =
+ function
+ (Sint _ | Sbigint _) as x -> x
+ | Srational r -> bigint_res (integer_ratio r)
+ | Sreal r ->
+ if r < 0.0 then
+ Sreal (ceil r)
+ else
+ Sreal (floor r)
+ | _ -> raise (Error "truncate: bad arg type")
+;;
+
+let snum_round =
+ function
+ (Sint _ | Sbigint _) as x -> x
+ | Srational r -> bigint_res (round_ratio r)
+ | Sreal r -> Sreal (round_float r)
+ | _ -> raise (Error "round: bad arg type")
+;;
+
+let rcsw rfun cfun =
+ function
+ Scomplex z -> Scomplex (cfun z)
+ | x -> Sreal (rfun (float_of_snum x))
+;;
+
+let snum_exp = rcsw exp Complex.exp;;
+let snum_log = rcsw log Complex.log;;
+
+let snum_sin = rcsw sin sin_cplx;;
+let snum_cos = rcsw cos cos_cplx;;
+let snum_tan = rcsw tan tan_cplx;;
+let snum_asin = rcsw asin asin_cplx;;
+let snum_acos = rcsw acos acos_cplx;;
+
+let snum_atan =
+ function
+ [| x |] -> rcsw atan atan_cplx x
+ | [| y; x |] ->
+ Sreal (Complex.arg { Complex.re = float_of_snum x;
+ Complex.im = float_of_snum y })
+ | _ -> raise (Error "atan: bad args")
+;;
+
+let snum_sqrt =
+ function
+ Scomplex z -> Scomplex (Complex.sqrt z)
+ | x ->
+ let r = float_of_snum x in
+ if r < 0.0 then
+ Scomplex (Complex.sqrt { Complex.re = r; Complex.im = 0.0 })
+ else
+ let sq = sqrt r in
+ if is_exact x <> Sfalse && float_is_int sq then
+ float_to_exact sq
+ else
+ Sreal sq
+;;
+
+(* Optimize the simplest cases, leave the rest to Num. *)
+let snum_expt x y =
+ match (x, y) with
+ (_, Sint n) when n = 0 -> Sint 1
+ | ((Sint _ | Sbigint _), Sint n) when n > 0 ->
+ bigint_res (power_big_int_positive_int (bigint_of_snum x) n)
+ | ((Sint _ | Sbigint _ | Srational _), (Sint _ | Sbigint _)) ->
+ snum_of_num (power_num (num_of_snum x) (num_of_snum y))
+ | (Scomplex _, _) | (_, Scomplex _) ->
+ Scomplex (Complex.pow (complex_of_snum x) (complex_of_snum y))
+ | _ ->
+ Sreal (float_of_snum x ** float_of_snum y)
+;;
+
+let make_rectangular x y =
+ Scomplex { Complex.re = float_of_snum x; Complex.im = float_of_snum y }
+;;
+
+let make_polar x y =
+ Scomplex (Complex.polar (float_of_snum x) (float_of_snum y))
+;;
+
+let real_part x =
+ Sreal (complex_of_snum x).Complex.re
+;;
+
+let imag_part x =
+ Sreal (complex_of_snum x).Complex.im
+;;
+
+let magnitude x =
+ Sreal (Complex.norm (complex_of_snum x))
+;;
+
+let angle x =
+ Sreal (Complex.arg (complex_of_snum x))
+;;
+
+let quotient n d =
+ match (n, d) with
+ ((Sint _ | Sbigint _ | Srational _),
+ (Sint _ | Sbigint _ | Srational _)) ->
+ snum_of_num (integer_num (div_num (num_of_snum n) (num_of_snum d)))
+ | _ ->
+ let n = float_of_snum n
+ and d = float_of_snum d in
+ if not (float_is_int n && float_is_int d) then
+ raise (Error "quotient: non-integer arguments")
+ else
+ Sreal (n /. d -. (mod_float n d) /. d)
+;;
+
+let remainder n d =
+ match (n, d) with
+ ((Sint _ | Sbigint _ | Srational _),
+ (Sint _ | Sbigint _ | Srational _)) ->
+ let n = num_of_snum n
+ and d = num_of_snum d in
+ let m = mod_num n d in
+ if sign_num n + sign_num d = 0 then
+ snum_of_num (sub_num m d)
+ else
+ snum_of_num m
+ | _ ->
+ let n = float_of_snum n
+ and d = float_of_snum d in
+ if not (float_is_int n && float_is_int d) then
+ raise (Error "quotient: non-integer arguments")
+ else
+ Sreal (mod_float n d)
+;;
+
+let modulo n d =
+ match (n, d) with
+ ((Sint _ | Sbigint _ | Srational _),
+ (Sint _ | Sbigint _ | Srational _)) ->
+ snum_of_num (mod_num (num_of_snum n) (num_of_snum d))
+ | _ ->
+ let n = float_of_snum n
+ and d = float_of_snum d in
+ if not (float_is_int n && float_is_int d) then
+ raise (Error "quotient: non-integer arguments")
+ else
+ let m = mod_float n d in
+ if (n < 0.0 && d > 0.0) || (n > 0.0 && d < 0.0) then
+ Sreal (d +. m)
+ else
+ Sreal m
+;;
+
+(* Compute the gcd of two numbers *)
+let rec gcd2 a b =
+ match (a, b) with
+ ((Sint _ | Sbigint _), (Sint _ | Sbigint _)) ->
+ bigint_res (gcd_big_int (bigint_of_snum (snum_abs a))
+ (bigint_of_snum (snum_abs b)))
+ | _ ->
+ if is_integer a <> Sfalse && is_integer b <> Sfalse then
+ to_inexact (gcd2 (to_exact a) (to_exact b))
+ else
+ raise (Error "gcd: non-integer arguments")
+;;
+
+let snum_gcd av =
+ let n = Array.length av in
+ if n = 0 then
+ Sint 0
+ else
+ do_ops gcd2 av n
+;;
+
+let lcm2 a b =
+ let g = gcd2 a b in
+ snum_abs (mul2 (div2 a g) b)
+;;
+
+let snum_lcm av =
+ let n = Array.length av in
+ if n = 0 then
+ Sint 1
+ else
+ do_ops lcm2 av n
+;;
+
+(* The algorithm for calculating the simplest rational form of a number
+ is translated from the appendix in the IEEE draft. It implicitly
+ preserves exactness. *)
+
+let simplest_rational x y =
+ let one = Sint 1 in
+ let rec sri x y =
+ let fx = snum_floor x
+ and fy = snum_floor y in
+ if cmp2 false fx x >= 0 then
+ fx
+ else if cmp2 true fx fy = 0 then
+ add2 fx
+ (div2 one (sri (div2 one (sub2 y fy)) (div2 one (sub2 x fx))))
+ else
+ add2 fx one
+ in
+ if cmp2 false y x < 0 then
+ sri y x
+ else if cmp2 false x y >= 0 then
+ begin
+ if is_rational x <> Sfalse then
+ x
+ else
+ raise (Error "rationalize: not a rational")
+ end
+ else if is_positive x <> Sfalse then
+ sri x y
+ else if is_negative y <> Sfalse then
+ negate (sri (negate y) (negate x))
+ else if is_exact x <> Sfalse && is_exact y <> Sfalse then
+ Sint 0
+ else
+ Sreal 0.0
+;;
+
+let snum_rationalize x e =
+ simplest_rational (sub2 x e) (add2 x e)
+;;
+
+let rec snum_numerator =
+ function
+ (Sint _ | Sbigint _) as x -> x
+ | Srational q -> bigint_res (numerator_ratio q)
+ | Sreal _ as x -> to_inexact (snum_numerator (to_exact x))
+ | Scomplex _ -> raise (Error "numerator: not defined for complex numbers")
+ | _ -> raise (Error "numerator: not a numeric type")
+;;
+
+let rec snum_denominator =
+ function
+ Sint _ | Sbigint _ -> Sint 1
+ | Srational q -> bigint_res (denominator_ratio q)
+ | Sreal r as x ->
+ if r = 0.0 then Sreal 1.0 else
+ to_inexact (snum_denominator (to_exact x))
+ | Scomplex _ -> raise (Error "denominator: not defined for complex numbers")
+ | _ -> raise (Error "denominator: not a numeric type")
+;;
+
+let init e =
+ set_pf1 e is_exact "exact?";
+ set_pf1 e is_inexact "inexact?";
+ set_pf1 e is_zero "zero?";
+ set_pf1 e is_positive "positive?";
+ set_pf1 e is_negative "negative?";
+ set_pf1 e is_number "number?";
+ set_pf1 e is_number "complex?";
+ set_pf1 e is_real "real?";
+ set_pf1 e is_rational "rational?";
+ set_pf1 e is_integer "integer?";
+ set_pf1 e is_even "even?";
+ set_pf1 e is_odd "odd?";
+
+ set_pfn e snum_add "+";
+ set_pfn e snum_sub "-";
+ set_pfn e snum_mul "*";
+ set_pfn e snum_div "/";
+ set_pfn e snum_eq "=";
+ set_pfn e (snum_rel (>)) ">";
+ set_pfn e (snum_rel (<)) "<";
+ set_pfn e (snum_rel (>=)) ">=";
+ set_pfn e (snum_rel (<=)) "<=";
+
+ set_pfn e (snum_minormax (>)) "max";
+ set_pfn e (snum_minormax (<)) "min";
+
+ set_pf1 e snum_abs "abs";
+
+ set_pf1 e snum_floor "floor";
+ set_pf1 e snum_ceiling "ceiling";
+ set_pf1 e snum_truncate "truncate";
+ set_pf1 e snum_round "round";
+
+ set_pf1 e snum_exp "exp";
+ set_pf1 e snum_log "log";
+
+ set_pf1 e snum_sin "sin";
+ set_pf1 e snum_cos "cos";
+ set_pf1 e snum_tan "tan";
+ set_pf1 e snum_asin "asin";
+ set_pf1 e snum_acos "acos";
+ set_pfn e snum_atan "atan";
+
+ set_pf1 e snum_sqrt "sqrt";
+ set_pf2 e snum_expt "expt";
+
+ set_pf2 e make_rectangular "make-rectangular";
+ set_pf2 e make_polar "make-polar";
+ set_pf1 e real_part "real-part";
+ set_pf1 e imag_part "imag-part";
+ set_pf1 e magnitude "magnitude";
+ set_pf1 e angle "angle";
+
+ set_pf2 e quotient "quotient";
+ set_pf2 e remainder "remainder";
+ set_pf2 e modulo "modulo";
+
+ set_pf1 e to_exact "inexact->exact";
+ set_pf1 e to_inexact "exact->inexact";
+
+ set_pfn e snum_gcd "gcd";
+ set_pfn e snum_lcm "lcm";
+
+ set_pf2 e snum_rationalize "rationalize";
+
+ set_pf1 e snum_numerator "numerator";
+ set_pf1 e snum_denominator "denominator";
+;;
diff --git a/ocs-1.0.3/src/ocs_num.mli b/ocs-1.0.3/src/ocs_num.mli
new file mode 100644
index 0000000..6840dd6
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_num.mli
@@ -0,0 +1,13 @@
+(* Operations on number types. *)
+
+open Ocs_types
+
+val negate : sval -> sval
+
+val add2 : sval -> sval -> sval
+val sub2 : sval -> sval -> sval
+val mul2 : sval -> sval -> sval
+val div2 : sval -> sval -> sval
+
+val init : env -> unit
+
diff --git a/ocs-1.0.3/src/ocs_numaux.ml b/ocs-1.0.3/src/ocs_numaux.ml
new file mode 100644
index 0000000..eb7fa7a
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_numaux.ml
@@ -0,0 +1,201 @@
+(* Numeric utility functions. *)
+
+open Ocs_types
+open Ocs_error
+
+open Num
+open Ratio
+open Big_int
+
+let fix_floating_precision () =
+ let n = Arith_status.get_floating_precision () in
+ if n < 25 then
+ Arith_status.set_floating_precision 25
+;;
+
+fix_floating_precision ();;
+
+Arith_status.set_normalize_ratio true;;
+
+let promote_real =
+ function
+ Sint i -> Sreal (float_of_int i)
+ | (Sreal _) as r -> r
+ | (Scomplex _) as z -> z
+ | Sbigint bi -> Sreal (float_of_big_int bi)
+ | Srational r -> Sreal (float_of_ratio r)
+ | _ -> raise (Error "bad number type")
+;;
+
+let float_of_snum =
+ function
+ Sint i -> float_of_int i
+ | Sreal r -> r
+ (* Note - the imaginary part is discarded! *)
+ | Scomplex { Complex.re = r; Complex.im = _ } -> r
+ | Sbigint bi -> float_of_big_int bi
+ | Srational r -> float_of_ratio r
+ | _ -> raise (Error "bad number type")
+;;
+
+let promote_complex =
+ function
+ (Scomplex _) as z -> z
+ | x -> Scomplex { Complex.re = float_of_snum x; Complex.im = 0.0 }
+;;
+
+let complex_of_snum =
+ function
+ Scomplex z -> z
+ | x -> { Complex.re = float_of_snum x; Complex.im = 0.0 }
+;;
+
+let rational_of_snum =
+ function
+ Sbigint bi -> ratio_of_big_int bi
+ | Sint i -> ratio_of_int i
+ | Srational r -> r
+ | _ -> raise (Error "bad number type")
+;;
+
+let promote_rational s =
+ Srational (rational_of_snum s)
+;;
+
+let bigint_of_snum =
+ function
+ Sint i -> big_int_of_int i
+ | Sbigint bi -> bi
+ | _ -> raise (Error "bad number type")
+;;
+
+let promote_bigint =
+ function
+ Sint i -> Sbigint (big_int_of_int i)
+ | (Sbigint _) as bi -> bi
+ | _ -> raise (Error "bad number type")
+;;
+
+let snum_fixtypes a b =
+ match (a, b) with
+ (Sint _, Sint _) -> a, b
+ | (Scomplex _, _) -> a, promote_complex b
+ | (_, Scomplex _) -> (promote_complex a), b
+ | (Sreal _, _) -> a, promote_real b
+ | (_, Sreal _) -> (promote_real a), b
+ | (Srational _, _) -> a, promote_rational b
+ | (_, Srational _) -> (promote_rational a), b
+ | (Sbigint _, _) -> a, promote_bigint b
+ | (_, Sbigint _) -> (promote_bigint a), b
+ | _ -> raise (Error "snum_fixtypes: not numeric types")
+;;
+
+let snum_of_num =
+ function
+ Int x -> Sint x
+ | Big_int x -> Sbigint x
+ | Ratio x -> Srational x
+;;
+
+let num_of_snum =
+ function
+ Sint x -> Int x
+ | Sbigint x -> Big_int x
+ | Srational x -> Ratio x
+ | _ -> raise (Error "bad number type")
+;;
+
+(* Return a result as the simplest representation of a given bigint *)
+let bigint_res bi =
+ if is_int_big_int bi then
+ Sint (int_of_big_int bi)
+ else
+ Sbigint bi
+;;
+
+let round_float r =
+ let d = floor (r +. 0.5)
+ and e = ceil (r -. 0.5) in
+ if d <> e && (mod_float e 2.0) = 0.0 then e
+ else d
+;;
+
+let float_is_int f =
+ let (x, _) = modf f in
+ x = 0.0
+;;
+
+let max_f_int = 2.0 ** (float_of_int (Sys.word_size - 2)) -. 1.0;;
+let min_f_int = -.max_f_int -. 1.0;;
+
+(* We need to deconstruct IEEE floats to convert them. *)
+let fe_bits = Int64.of_string "0x7ff0000000000000";;
+let fm_bits = Int64.of_string "0x000fffffffffffff";;
+let fi_bit = Int64.of_string "0x0010000000000000";;
+let fs_bit = Int64.of_string "0x8000000000000000";;
+
+let fb_get_dm fb =
+ Int64.logand fb fm_bits
+;;
+
+let fb_get_m fb =
+ Int64.logor (fb_get_dm fb) fi_bit
+;;
+
+let fb_get_e fb =
+ Int64.to_int (Int64.shift_right (Int64.logand fb fe_bits) 52) - 1023
+;;
+
+let fb_get_s fb =
+ Int64.compare (Int64.logand fb fs_bit) Int64.zero <> 0;
+;;
+
+let f_is_int m e =
+ if e < 0 then false
+ else if e >= 52 then true
+ else Int64.compare (Int64.logand fm_bits
+ (Int64.shift_left m e)) Int64.zero = 0
+;;
+
+(* Convert an int64 into a bigint, possibly ignoring the most
+ significant 4 bits (on 32-bit machines). This is good enough
+ for the 52 + 1 -bit mantissa of 64-bit IEEE floats. *)
+let big_int_of_int64 i =
+ if Sys.word_size = 64 then
+ (big_int_of_int (Int64.to_int i))
+ else (* Assume 32 *)
+ let lo = Int64.to_int i land 0x3fffffff
+ and hi = Int64.to_int (Int64.shift_right i 30) in
+ add_big_int (big_int_of_int lo)
+ (mult_big_int (big_int_of_int hi) (power_int_positive_int 2 30))
+;;
+
+let float_to_exact f =
+ if float_is_int f && f >= min_f_int && f <= max_f_int then
+ Sint (int_of_float f)
+ else if f = infinity || f = neg_infinity || f = nan then
+ raise (Error "invalid float")
+ else
+ let fb = Int64.bits_of_float f in
+ let m = fb_get_m fb
+ and e = fb_get_e fb
+ and is_neg = fb_get_s fb in
+ let bm = big_int_of_int64 m in
+ if f_is_int m e then
+ let wrap = if is_neg then minus_big_int else fun x -> x in
+ if e = 52 then
+ Sbigint (wrap bm)
+ else if e > 52 then
+ Sbigint (wrap (mult_big_int bm (power_int_positive_int 2 (e - 52))))
+ else
+ Sbigint (wrap (div_big_int bm (power_int_positive_int 2 (52 - e))))
+ else
+ let wrap = if is_neg then minus_ratio else fun x -> x in
+ if e < -1022 then (* not normalized, no implied mantissa bit *)
+ Srational (wrap (create_ratio (big_int_of_int64 (fb_get_dm fb))
+ (power_int_positive_int 2 (51 - e))))
+ else
+ Srational (wrap (create_ratio bm
+ (power_int_positive_int 2 (52 - e))))
+;;
+
diff --git a/ocs-1.0.3/src/ocs_numaux.mli b/ocs-1.0.3/src/ocs_numaux.mli
new file mode 100644
index 0000000..3527676
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_numaux.mli
@@ -0,0 +1,29 @@
+(* Numeric utility functions. *)
+
+open Ocs_types
+
+open Num
+open Ratio
+open Big_int
+
+val promote_real : sval -> sval
+val promote_complex : sval -> sval
+val promote_rational : sval -> sval
+val promote_bigint : sval -> sval
+
+val complex_of_snum : sval -> Complex.t
+val float_of_snum : sval -> float
+val rational_of_snum : sval -> ratio
+val bigint_of_snum : sval -> big_int
+
+val snum_fixtypes : sval -> sval -> sval * sval
+
+val snum_of_num : num -> sval
+val num_of_snum : sval -> num
+
+val bigint_res : big_int -> sval
+
+val round_float : float -> float
+val float_is_int : float -> bool
+val float_to_exact : float -> sval
+
diff --git a/ocs-1.0.3/src/ocs_numstr.ml b/ocs-1.0.3/src/ocs_numstr.ml
new file mode 100644
index 0000000..fdf4825
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_numstr.ml
@@ -0,0 +1,403 @@
+(* Conversions between numbers and strings. *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_numaux
+open Ocs_num
+open Ocs_env
+
+open Num
+open Big_int
+open Ratio
+
+(* We need to scan strings and keep track of our position. *)
+
+type sbuf = {
+ s_str : string;
+ mutable s_pos : int
+}
+
+let speek s =
+ if s.s_pos < String.length s.s_str then
+ Some s.s_str.[s.s_pos]
+ else
+ None
+;;
+
+let skip s =
+ s.s_pos <- s.s_pos + 1
+;;
+
+let sget s =
+ match speek s with
+ (Some _) as c -> skip s; c
+ | _ -> None
+;;
+
+let ssleft s =
+ (String.length s.s_str) - s.s_pos
+;;
+
+(* Converting strings to numbers is fairly complex. We have a lot of
+ cases to consider. *)
+
+type exactness =
+ Exact
+ | Inexact
+ | Undef
+
+let parse_prefix s =
+ let rec nextp b e =
+ match speek s with
+ Some '#' ->
+ begin
+ skip s;
+ match sget s with
+ Some ('E' | 'e') ->
+ if e <> Undef then raise (Error "invalid #e") else nextp b Exact
+ | Some ('I' | 'i') ->
+ if e <> Undef then raise (Error "invalid #i") else nextp b Inexact
+ | Some ('B' | 'b') ->
+ if b <> 0 then raise (Error "invalid #b") else nextp 2 e
+ | Some ('O' | 'o') ->
+ if b <> 0 then raise (Error "invalid #o") else nextp 8 e
+ | Some ('D' | 'd') ->
+ if b <> 0 then raise (Error "invalid #d") else nextp 10 e
+ | Some ('X' | 'x') ->
+ if b <> 0 then raise (Error "invalid #x") else nextp 16 e
+ | _ -> raise (Error "invalid prefix")
+ end
+ | _ -> (b, e)
+ in
+ nextp 0 Undef
+;;
+
+let strtobi s base =
+ let n = String.length s
+ and am v i = add_int_big_int i (mult_int_big_int base v) in
+ let rec loop i v =
+ if i >= n then
+ v
+ else
+ loop (i + 1) (am v
+ (match s.[i] with
+ '0' .. '9' as c -> int_of_char c - int_of_char '0'
+ | 'a' .. 'f' as c -> int_of_char c - int_of_char 'a' + 10
+ | 'A' .. 'F' as c -> int_of_char c - int_of_char 'A' + 10
+ | _ -> raise (Error "invalid number")))
+ in
+ loop 0 (big_int_of_int 0)
+;;
+
+let read_bigint s base =
+ if base = 10 then
+ big_int_of_string s
+ else
+ strtobi s base
+;;
+
+(* The largest integer is at *least* this big (bigger on 64-bit machines). *)
+let max_int = 0x3fffffff
+let min_int = -max_int - 1
+
+let parse_num s base =
+ let fixsign =
+ match speek s with
+ Some '-' -> skip s; negate
+ | Some '+' -> skip s; fun x -> x
+ | _ -> fun x -> x
+ and maxv = max_int / base
+ and maxi = max_int mod base
+ in
+ let rec scann v o =
+ match speek s with
+ Some ('0' .. '9' as c)
+ when (int_of_char c) - (int_of_char '0') < base ->
+ addo v ((int_of_char c) - (int_of_char '0')) o
+ | Some ('a' .. 'f' as c) when base = 16 ->
+ addo v ((int_of_char c) - (int_of_char 'a') + 10) o
+ | Some ('A' .. 'F' as c) when base = 16 ->
+ addo v ((int_of_char c) - (int_of_char 'A') + 10) o
+ | _ -> (v, o)
+ and addo v i o =
+ skip s;
+ if o || v > maxv || (v = maxv && i > maxi) then
+ scann 0 true
+ else
+ scann (v * base + i) o
+ and readn () =
+ let sp = s.s_pos in
+ match scann 0 false with
+ (i, false) ->
+ if s.s_pos = sp then
+ raise (Error "invalid number")
+ else
+ Sint i
+ | (_, true) ->
+ Sbigint (read_bigint (String.sub s.s_str sp (s.s_pos - sp)) base)
+ in
+ let num = readn () in
+ match speek s with
+ Some '/' ->
+ skip s;
+ fixsign (div2 (Sbigint (bigint_of_snum num))
+ (Sbigint (bigint_of_snum (readn ()))))
+ | Some ('+' | '-' | '@') | None -> fixsign num
+ | _ -> raise (Error "invalid rational")
+;;
+
+let parse_flo10 s =
+ let sp = s.s_pos in
+ let rec skipd isfirst =
+ match speek s with
+ Some '0' .. '9' | Some '#' -> skip s; skipd false
+ | Some ('+' | '-') when isfirst -> skip s; skipd false
+ | _ -> ()
+ in
+ skipd true;
+ if speek s = Some '.' then
+ begin
+ skip s;
+ skipd false
+ end;
+ begin
+ match speek s with
+ Some ('E' | 'e' | 'F' | 'f' | 'D' | 'd' | 'S' | 's' | 'L' | 'l') ->
+ skip s; skipd true
+ | _ -> ()
+ end;
+ let t = String.sub s.s_str sp (s.s_pos - sp) in
+ for i = 0 to String.length t - 1 do
+ match t.[i] with
+ '#' -> t.[i] <- '0'
+ | 'F' | 'f' | 'D' | 'd' | 'S' | 's' | 'L' | 'l' -> t.[i] <- 'e'
+ | _ -> ()
+ done;
+ try
+ Sreal (float_of_string t)
+ with
+ Failure _ -> raise (Error "invalid float")
+;;
+
+let string_to_num str ub =
+ (* Special cases for [-+][iI] *)
+ if str = "+i" || str = "+I" then
+ Scomplex { Complex.re = 0.0; Complex.im = 1.0; }
+ else if str = "-i" || str = "-I" then
+ Scomplex { Complex.re = 0.0; Complex.im = -1.0; }
+ else
+ let s = { s_str = str; s_pos = 0 } in
+ let (base, ex) =
+ match parse_prefix s with
+ 0, x -> if ub = 0 then (10, x) else (ub, x)
+ | (b, x) as r ->
+ if ub <> 0 && ub <> b then
+ raise (Error "Base mismatch")
+ else r
+ in
+ let getn () =
+ if base = 10 && ex <> Exact then
+ begin
+ let sp = s.s_pos in
+ try
+ parse_num s 10
+ with _ ->
+ s.s_pos <- sp;
+ parse_flo10 s
+ end
+ else
+ parse_num s base
+ and fixex n =
+ match (ex, n) with
+ (Inexact, (Sint _ | Sbigint _ | Srational _)) -> promote_real n
+ | (Exact, (Sreal _ | Scomplex _)) -> raise (Error "Not exact")
+ | _ -> n
+ in
+ let a = fixex (getn ()) in
+ match speek s with
+ Some ('+' | '-' as c) ->
+ if ex = Exact then
+ raise (Error "Complex not exact")
+ else
+ if ssleft s = 2 && s.s_str.[s.s_pos + 1] = 'i' then
+ Scomplex { Complex.re = float_of_snum a;
+ Complex.im = (if c = '-' then -1.0 else 1.0) }
+ else
+ let b = getn () in
+ if ssleft s <> 1 || speek s <> Some 'i' then
+ raise (Error "invalid number")
+ else
+ Scomplex { Complex.re = float_of_snum a;
+ Complex.im = float_of_snum b }
+ | Some '@' ->
+ skip s;
+ if ex = Exact then
+ raise (Error "Complex not exact")
+ else
+ let b = getn () in
+ if ssleft s <> 0 then
+ raise (Error "invalid number")
+ else
+ let r = float_of_snum a
+ and t = float_of_snum b in
+ Scomplex (Complex.polar r t)
+ | Some c -> raise (Error "invalid number")
+ | None -> a
+;;
+
+let snum_strtonum av =
+ match Array.length av with
+ (1 | 2) as n ->
+ let r =
+ if n = 2 then
+ begin
+ match av.(1) with
+ Sint i -> i
+ | _ -> raise (Error "string->number: invalid radix")
+ end
+ else
+ 0
+ in
+ begin
+ match av.(0) with
+ Sstring s ->
+ begin
+ try
+ if s = "" then
+ Sfalse
+ else
+ string_to_num s r
+ with
+ _ -> Sfalse
+ end
+ | _ -> raise (Error "string->number: not a string")
+ end
+ | _ -> raise (Error "string->number: wrong number of args")
+;;
+
+let string_of_real_s r =
+ let rec loop n =
+ let s = Printf.sprintf "%.*g" n r in
+ if n >= 25 || r = float_of_string s then s
+ else loop (n + 1)
+ in
+ loop 14
+;;
+
+let string_of_real r =
+ let s = string_of_real_s r in
+ let n = String.length s in
+ let rec loop i =
+ if i >= n then s ^ ".0"
+ else if s.[i] = '.' || s.[i] = 'e' then s
+ else loop (i + 1)
+ in
+ loop 0
+;;
+
+let string_of_complex =
+ function { Complex.re = r; Complex.im = i } ->
+ (string_of_real_s r) ^
+ (if i < 0.0 then
+ begin
+ if i = -1.0 then
+ "-i"
+ else
+ (string_of_real_s i) ^ "i"
+ end
+ else
+ if i = 1.0 then
+ "+i"
+ else
+ "+" ^ (string_of_real_s i) ^ "i")
+;;
+
+let ichr i =
+ if i < 10 then
+ char_of_int (int_of_char '0' + i)
+ else
+ char_of_int (int_of_char 'a' + i - 10)
+;;
+
+let string_of_list l =
+ let n = List.length l in
+ let s = String.create n in
+ let rec loop i l =
+ if i < n then
+ begin
+ match l with
+ c::t -> s.[i] <- c; loop (i + 1) t
+ | _ -> assert false
+ end
+ else
+ ()
+ in
+ loop 0 l; s
+;;
+
+let itostr base i =
+ if i = 0 then
+ "0"
+ else
+ let pf = if i < 0 then "-" else "" in
+ let rec loop i r =
+ if i = 0 then
+ r
+ else
+ loop (i / base) ((ichr (i mod base))::r)
+ in
+ pf ^ string_of_list (loop (abs i) [])
+;;
+
+let biqmi bi i =
+ let (q, r) = quomod_big_int bi (big_int_of_int i) in
+ (q, int_of_big_int r)
+;;
+
+let bitostr base bi =
+ let pf = if sign_big_int bi < 0 then "-" else "" in
+ let rec loop bi r =
+ if sign_big_int bi = 0 then
+ begin
+ match r with
+ [] -> [ '0' ]
+ | _ -> r
+ end
+ else
+ let (q, m) = biqmi bi base in
+ loop q ((ichr m)::r)
+ in
+ pf ^ string_of_list (loop (abs_big_int bi) [])
+;;
+
+let ntostr base =
+ function
+ Sint i -> itostr base i
+ | Sbigint bi -> bitostr base bi
+ | Srational r -> bitostr base (numerator_ratio r) ^ "/" ^
+ bitostr base (denominator_ratio r)
+ | _ -> raise (Error "number->string: invalid radix for inexact number")
+;;
+
+let rec snum_numtostr =
+ function
+ [| Sint i |] -> Sstring (string_of_int i)
+ | [| Sbigint bi |] -> Sstring (string_of_big_int bi)
+ | [| Srational r |] -> Sstring (string_of_ratio r)
+ | [| Sreal r |] -> Sstring (string_of_real r)
+ | [| Scomplex z |] -> Sstring (string_of_complex z)
+ | [| snum; Sint radix |] ->
+ if radix = 10 then
+ snum_numtostr [| snum |]
+ else if radix = 2 || radix = 8 || radix = 16 then
+ Sstring (ntostr radix snum)
+ else
+ raise (Error "number->string: invalid radix")
+ | _ -> raise (Error "number->string: bad args")
+;;
+
+let init e =
+ set_pfn e snum_strtonum "string->number";
+ set_pfn e snum_numtostr "number->string";
+;;
+
diff --git a/ocs-1.0.3/src/ocs_numstr.mli b/ocs-1.0.3/src/ocs_numstr.mli
new file mode 100644
index 0000000..287fe4d
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_numstr.mli
@@ -0,0 +1,11 @@
+(* Conversions between numbers and strings. *)
+
+open Ocs_types
+
+val string_of_real : float -> string
+val string_of_complex : Complex.t -> string
+
+val string_to_num : string -> int -> sval
+
+val init : env -> unit
+
diff --git a/ocs-1.0.3/src/ocs_port.ml b/ocs-1.0.3/src/ocs_port.ml
new file mode 100644
index 0000000..801c519
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_port.ml
@@ -0,0 +1,223 @@
+(* Buffered I/O, Scheme ports. *)
+
+open Ocs_error
+
+(* Ports can either be file descriptors or string buffers. File
+ descriptors may be valid for both input and output, but when
+ switching between the two modes, the file offset may not work
+ as expected.
+
+ For unbuffered or asynchronous I/O, from Scheme or otherwise,
+ the port can simply be used as a reference to the file
+ descriptor. *)
+
+type port = {
+ mutable p_buf : string;
+ mutable p_pos : int;
+ mutable p_wend : int;
+ mutable p_rend : int;
+ mutable p_ugc : char option;
+ mutable p_fd : Unix.file_descr option;
+ mutable p_input : bool;
+ mutable p_output : bool;
+ p_close : bool
+}
+
+type port_flag =
+ Pf_input
+ | Pf_output
+ | Pf_close
+
+let mkbuf () =
+ String.create 1024
+;;
+
+let mkport buf fd inf outf cl =
+ { p_buf = buf;
+ p_pos = 0;
+ p_wend = 0;
+ p_rend = 0;
+ p_ugc = None;
+ p_fd = fd;
+ p_input = inf;
+ p_output = outf;
+ p_close = cl }
+;;
+
+let is_input p =
+ p.p_input
+;;
+
+let is_output p =
+ p.p_output
+;;
+
+let wrflush p =
+ if not p.p_output then
+ raise (Error "not a valid output port");
+ match p.p_fd with
+ Some fd ->
+ if p.p_wend > 0 && p.p_pos > 0 then
+ begin
+ try
+ let n = Unix.write fd p.p_buf 0 p.p_pos in
+ if n <> p.p_pos then
+ raise (Error "write error: incomplete write")
+ with
+ Unix.Unix_error (e, _, _) ->
+ raise (Error ("write error: " ^ Unix.error_message e))
+ end;
+ p.p_pos <- 0;
+ p.p_wend <- String.length p.p_buf
+ | None ->
+ if p.p_pos = p.p_wend then
+ let n = String.length p.p_buf in
+ let nbuf = String.create (n * 2) in
+ String.blit p.p_buf 0 nbuf 0 n;
+ p.p_buf <- nbuf;
+ p.p_wend <- String.length p.p_buf
+;;
+
+let rdfill p =
+ if not p.p_input then
+ raise (Error "not a valid input port");
+ if p.p_wend > 0 then
+ wrflush p;
+ p.p_pos <- 0;
+ p.p_rend <- 0;
+ p.p_wend <- 0;
+ match p.p_fd with
+ Some fd ->
+ begin
+ try
+ p.p_rend <- Unix.read fd p.p_buf 0 (String.length p.p_buf)
+ with
+ Unix.Unix_error (e, _, _) ->
+ raise (Error ("read error: " ^ Unix.error_message e))
+ end
+ | None -> ()
+;;
+
+let getc p =
+ match p.p_ugc with
+ Some _ as c -> p.p_ugc <- None; c
+ | None ->
+ if p.p_rend = 0 || p.p_pos >= p.p_rend then rdfill p;
+ if p.p_rend = 0 then None
+ else
+ begin
+ assert (p.p_pos < p.p_rend);
+ let c = p.p_buf.[p.p_pos] in
+ p.p_pos <- p.p_pos + 1;
+ Some c
+ end
+;;
+
+let get_fd p =
+ p.p_fd
+;;
+
+let flush p =
+ if p.p_wend > 0 then
+ wrflush p
+;;
+
+let close p =
+ if p.p_input || p.p_output then
+ begin
+ flush p;
+ p.p_input <- false;
+ p.p_output <- false;
+ match p.p_fd with
+ Some fd ->
+ if p.p_close then Unix.close fd;
+ p.p_fd <- None
+ | None -> ()
+ end
+;;
+
+let ungetc p c =
+ p.p_ugc <- Some c
+;;
+
+let char_ready p =
+ if p.p_ugc <> None || p.p_pos < p.p_rend then true
+ else if not p.p_input then false
+ else
+ match p.p_fd with
+ Some fd ->
+ let (r, _, _) = Unix.select [ fd ] [] [] 0.0 in
+ List.length r > 0
+ | None -> false
+;;
+
+let putc p c =
+ if p.p_wend = 0 || p.p_pos >= p.p_wend then
+ wrflush p;
+ assert (p.p_pos < p.p_wend);
+ p.p_buf.[p.p_pos] <- c;
+ p.p_pos <- p.p_pos + 1
+;;
+
+let puts p s =
+ let n = String.length s in
+ if n > 0 && p.p_rend - p.p_pos >= n then
+ begin
+ String.blit s 0 p.p_buf p.p_pos n;
+ p.p_pos <- p.p_pos + n
+ end
+ else
+ String.iter (fun c -> putc p c) s
+;;
+
+let fd_port fd flags =
+ let inf = ref false
+ and outf = ref false
+ and clf = ref false in
+ List.iter (function
+ Pf_input -> inf := true
+ | Pf_output -> outf := true
+ | Pf_close -> clf := true) flags;
+ let p = mkport (mkbuf ()) (Some fd) !inf !outf !clf in
+ if !clf then Gc.finalise close p;
+ p
+;;
+
+let input_port ch =
+ fd_port (Unix.descr_of_in_channel ch) [ Pf_input ]
+;;
+
+let output_port ch =
+ fd_port (Unix.descr_of_out_channel ch) [ Pf_output ]
+;;
+
+let open_input_port name =
+ try
+ let fd = Unix.openfile name [ Unix.O_RDONLY ] 0 in
+ fd_port fd [ Pf_input; Pf_close ]
+ with
+ Unix.Unix_error (e, _, _) ->
+ let err = Unix.error_message e in
+ raise (Error ("unable to open '" ^ name ^ "' for input: " ^ err))
+;;
+
+let open_output_port name =
+ try
+ let fd = Unix.openfile name [ Unix.O_WRONLY; Unix.O_APPEND;
+ Unix.O_CREAT; Unix.O_TRUNC ] 0o666 in
+ fd_port fd [ Pf_output; Pf_close ]
+ with
+ Unix.Unix_error (e, _, _) ->
+ let err = Unix.error_message e in
+ raise (Error ("unable to open '" ^ name ^ "' for output: " ^ err))
+;;
+
+let string_input_port s =
+ let p = mkport s None true false false in
+ p.p_rend <- String.length s;
+ p
+;;
+
+let string_output_port () =
+ mkport (mkbuf ()) None false true false
+;;
diff --git a/ocs-1.0.3/src/ocs_port.mli b/ocs-1.0.3/src/ocs_port.mli
new file mode 100644
index 0000000..3294e81
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_port.mli
@@ -0,0 +1,33 @@
+(* Buffered I/O, Scheme ports. *)
+
+type port
+
+type port_flag =
+ Pf_input
+ | Pf_output
+ | Pf_close
+
+val fd_port : Unix.file_descr -> port_flag list -> port
+val input_port : in_channel -> port
+val output_port : out_channel -> port
+val open_input_port : string -> port
+val open_output_port : string -> port
+val string_input_port : string -> port
+val string_output_port : unit -> port
+
+val is_input : port -> bool
+val is_output : port -> bool
+
+val getc : port -> char option
+val ungetc : port -> char -> unit
+val char_ready : port -> bool
+
+val putc : port -> char -> unit
+val puts : port -> string -> unit
+
+val get_fd : port -> Unix.file_descr option
+
+val flush : port -> unit
+
+val close : port -> unit
+
diff --git a/ocs-1.0.3/src/ocs_prim.ml b/ocs-1.0.3/src/ocs_prim.ml
new file mode 100644
index 0000000..8ec6eec
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_prim.ml
@@ -0,0 +1,269 @@
+(* Various primitives *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_env
+open Ocs_eval
+open Ocs_misc
+open Ocs_sym
+open Ocs_io
+open Ocs_compile
+open Ocs_macro
+
+let logical_not =
+ function
+ Sfalse -> Strue
+ | _ -> Sfalse
+;;
+
+(* Type predicates *)
+
+let is_boolean =
+ function
+ Strue | Sfalse -> Strue
+ | _ -> Sfalse
+;;
+
+let is_string =
+ function
+ Sstring _ -> Strue
+ | _ -> Sfalse
+;;
+
+let is_char =
+ function
+ Schar _ -> Strue
+ | _ -> Sfalse
+;;
+
+let is_pair =
+ function
+ Spair _ -> Strue
+ | _ -> Sfalse
+;;
+
+let is_null =
+ function
+ Snull -> Strue
+ | _ -> Sfalse
+;;
+
+let is_vector =
+ function
+ Svector _ -> Strue
+ | _ -> Sfalse
+;;
+
+let is_proc =
+ function
+ Sproc (_, _) | Sprim _ -> Strue
+ | _ -> Sfalse
+;;
+
+let is_port =
+ function
+ Sport _ -> Strue
+ | _ -> Sfalse
+;;
+
+let is_symbol =
+ function
+ Ssymbol _ -> Strue
+ | _ -> Sfalse
+;;
+
+let symbol_to_string =
+ function
+ Ssymbol s -> Sstring s
+ | _ -> raise (Error "symbol->string: not a symbol")
+;;
+
+let string_to_symbol =
+ function
+ Sstring s -> get_symbol (String.copy s)
+ | _ -> raise (Error "string->symbol: not a string")
+;;
+
+let is_eq a b =
+ if a == b then Strue else Sfalse
+;;
+
+let is_eqv a b =
+ if test_eqv a b then Strue else Sfalse
+;;
+
+let is_equal a b =
+ if test_equal a b then Strue else Sfalse
+;;
+
+let do_apply th cc av =
+ let n = Array.length av in
+ if n < 1 then
+ raise (Error "apply: bad args")
+ else
+ let f = av.(0) in
+ let rec loop i r =
+ if i = 0 then
+ r
+ else if i = n - 1 then (* r must be [] *)
+ loop (i - 1) (list_to_caml av.(i))
+ else
+ loop (i - 1) (av.(i)::r)
+ in
+ let args = Array.map (fun x -> Cval x)
+ (Array.of_list (loop (n - 1) []))
+ in
+ eval th cc (mkapply (Cval f) args)
+;;
+
+let force _ cc =
+ function
+ [| Spromise ({ promise_code = c;
+ promise_val = None;
+ promise_th = Some th } as p) |] ->
+ eval th
+ (fun v ->
+ match p.promise_val with (* Computed before returning? *)
+ Some v -> cc v
+ | None ->
+ p.promise_val <- Some v;
+ p.promise_th <- None; (* Release reference for gc *)
+ cc v) c
+ | [| Spromise { promise_code = _;
+ promise_val = Some v;
+ promise_th = _ } |] ->
+ cc v
+ | _ -> raise (Error "force: bad args")
+;;
+
+let map_for_each th cc av is_map =
+ let my_name = if is_map then "map" else "for-each"
+ and na = Array.length av - 1 in
+ if na <= 0 then
+ raise (Error (my_name ^ ": bad args"));
+ let proc = av.(0)
+ and get_cdr =
+ function
+ Spair { car = _; cdr = t } -> t
+ | _ -> raise (Error (my_name ^ ": list lengths don't match"))
+ and get_carc =
+ function
+ Spair { car = h; cdr = _ } -> Cval h
+ | _ -> raise (Error (my_name ^ ": list lengths don't match"))
+ and result = ref (if is_map then Snull else Sunspec)
+ and rtail = ref Snull in
+ let append v =
+ if !rtail == Snull then
+ begin
+ result := Spair { car = v; cdr = Snull };
+ rtail := !result;
+ end
+ else
+ begin
+ match !rtail with
+ Spair p ->
+ p.cdr <- Spair { car = v; cdr = Snull };
+ rtail := p.cdr
+ | _ -> assert false
+ end
+ in
+ let rec loop args =
+ match args.(0) with
+ Snull -> cc !result
+ | Spair _ ->
+ eval th
+ (fun v ->
+ if is_map then append v;
+ loop (Array.map get_cdr args))
+ (mkapply (Cval proc) (Array.map get_carc args))
+ | _ -> raise (Error (my_name ^ ": invalid argument lists"))
+ in
+ loop (Array.sub av 1 na)
+;;
+
+let map th cc av =
+ map_for_each th cc av true
+;;
+
+let for_each th cc av =
+ map_for_each th cc av false
+;;
+
+let load_file e th name =
+ let th = { th with th_display = [| |]; th_depth = -1 }
+ and inp = Ocs_port.open_input_port name in
+ let lex = Ocs_lex.make_lexer inp name in
+ let rec loop () =
+ match Ocs_read.read_expr lex with
+ Seof -> ()
+ | v ->
+ let c = compile e v in
+ eval th (fun _ -> ()) c;
+ loop ()
+ in
+ loop ()
+;;
+
+let load_prim e th cc =
+ function
+ [| Sstring name |] -> load_file e th name; cc Sunspec
+ | _ -> raise (Error "load: invalid name argument")
+;;
+
+let eval_prim th cc =
+ function
+ [| expr; Sesym (e, _) |] ->
+ eval { th with th_display = [| |]; th_depth = -1 } cc
+ (compile e expr)
+ | _ -> raise (Error "eval: invalid args")
+;;
+
+let report_env e _ =
+ Sesym (env_copy e, Ssymbol "")
+;;
+
+let null_env _ =
+ let e = top_env () in
+ bind_lang e;
+ bind_macro e;
+ Sesym (e, Ssymbol "")
+;;
+
+let interact_env e =
+ fun () -> Sesym (e, Ssymbol "")
+;;
+
+let init e =
+ set_pf1 e logical_not "not";
+ set_pf1 e is_boolean "boolean?";
+ set_pf1 e is_string "string?";
+ set_pf1 e is_char "char?";
+ set_pf1 e is_vector "vector?";
+ set_pf1 e is_pair "pair?";
+ set_pf1 e is_null "null?";
+ set_pf1 e is_proc "procedure?";
+ set_pf1 e is_port "port?";
+ set_pf1 e is_symbol "symbol?";
+
+ set_pf1 e symbol_to_string "symbol->string";
+ set_pf1 e string_to_symbol "string->symbol";
+
+ set_pf2 e is_eq "eq?";
+ set_pf2 e is_eqv "eqv?";
+ set_pf2 e is_equal "equal?";
+
+ set_pfcn e do_apply "apply";
+
+ set_pfcn e force "force";
+
+ set_pfcn e map "map";
+ set_pfcn e for_each "for-each";
+
+ set_pfcn e (load_prim e) "load";
+ set_pfcn e eval_prim "eval";
+
+ set_pf1 e (report_env (env_copy e)) "scheme-report-environment";
+ set_pf1 e null_env "null-environment";
+ set_pf0 e (interact_env e) "interaction-environment";
+;;
+
diff --git a/ocs-1.0.3/src/ocs_prim.mli b/ocs-1.0.3/src/ocs_prim.mli
new file mode 100644
index 0000000..b8f4a6d
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_prim.mli
@@ -0,0 +1,8 @@
+(* Miscellaneous primitives. *)
+
+open Ocs_types
+
+val load_file : env -> thread -> string -> unit
+
+val init : env -> unit
+
diff --git a/ocs-1.0.3/src/ocs_print.ml b/ocs-1.0.3/src/ocs_print.ml
new file mode 100644
index 0000000..e2f5671
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_print.ml
@@ -0,0 +1,75 @@
+(* Print Scheme values *)
+
+open Ocs_types
+open Ocs_sym
+open Ocs_numstr
+
+let write_string p s =
+ Ocs_port.putc p '\"';
+ for i = 0 to String.length s - 1 do
+ match s.[i] with
+ '\n' -> Ocs_port.puts p "\\n"
+ | '\r' -> Ocs_port.puts p "\\r"
+ | '\t' -> Ocs_port.puts p "\\t"
+ | '\\' -> Ocs_port.puts p "\\\\"
+ | '\"' -> Ocs_port.puts p "\\\""
+ | '\032' .. '\126' as c -> Ocs_port.putc p c
+ | c -> Ocs_port.puts p (Printf.sprintf "\\x%02x" (int_of_char c))
+ done;
+ Ocs_port.putc p '\"'
+;;
+
+let write_char p c =
+ Ocs_port.puts p "#\\";
+ match c with
+ '\033' .. '\126' -> Ocs_port.putc p c
+ | _ -> Ocs_port.puts p (Ocs_char.char_to_name c)
+;;
+
+let rec write_vector p disp v =
+ Ocs_port.puts p "#(";
+ for i = 0 to Array.length v - 1 do
+ if i <> 0 then Ocs_port.putc p ' ';
+ print p disp v.(i)
+ done;
+ Ocs_port.putc p ')'
+
+and write_list p disp l =
+ Ocs_port.putc p '(';
+ let rec pit l =
+ print p disp l.car;
+ match l.cdr with
+ Snull -> ()
+ | Spair t -> Ocs_port.putc p ' '; pit t
+ | x -> Ocs_port.puts p " . "; print p disp x
+ in
+ pit l;
+ Ocs_port.putc p ')'
+
+and print p disp =
+ function
+ Snull -> Ocs_port.puts p "()"
+ | Seof -> Ocs_port.puts p "#"
+ | Strue -> Ocs_port.puts p "#t"
+ | Sfalse -> Ocs_port.puts p "#f"
+ | Sstring s -> if disp then Ocs_port.puts p s else write_string p s
+ | Ssymbol s -> Ocs_port.puts p s
+ | Sint i -> Ocs_port.puts p (string_of_int i)
+ | Sreal r -> Ocs_port.puts p (string_of_real r)
+ | Scomplex z -> Ocs_port.puts p (string_of_complex z)
+ | Sbigint b -> Ocs_port.puts p (Big_int.string_of_big_int b)
+ | Srational r -> Ocs_port.puts p (Ratio.string_of_ratio r)
+ | Schar c -> if disp then Ocs_port.putc p c else write_char p c
+ | Spair l -> write_list p disp l
+ | Svector v -> write_vector p disp v
+ | Sport _ -> Ocs_port.puts p "#"
+ | Sproc _ -> Ocs_port.puts p "#"
+ | Sprim { prim_fun = _; prim_name = n } ->
+ Ocs_port.puts p "#'
+ | Spromise _ -> Ocs_port.puts p "#"
+ | Sesym (_, s) -> print p disp s
+ | Swrapped _ -> Ocs_port.puts p "#"
+ | Sunspec -> Ocs_port.puts p "#"
+ | _ -> Ocs_port.puts p "#"
+;;
+
diff --git a/ocs-1.0.3/src/ocs_print.mli b/ocs-1.0.3/src/ocs_print.mli
new file mode 100644
index 0000000..15e52ed
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_print.mli
@@ -0,0 +1,9 @@
+(* Print Scheme values *)
+
+open Ocs_types
+
+val write_string : Ocs_port.port -> string -> unit
+val write_char : Ocs_port.port -> char -> unit
+
+val print : Ocs_port.port -> bool -> sval -> unit
+
diff --git a/ocs-1.0.3/src/ocs_read.ml b/ocs-1.0.3/src/ocs_read.ml
new file mode 100644
index 0000000..5f10beb
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_read.ml
@@ -0,0 +1,87 @@
+(* Reader of Scheme expressions. *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_lex
+open Ocs_sym
+open Ocs_misc
+
+let read_error lex err =
+ let (file, name) = get_loc lex in
+ if String.length file = 0 then
+ Error err
+ else
+ ErrorL ((file, name), err)
+;;
+
+let show_token =
+ function
+ '"' -> "'\"'"
+ | '\032' .. '\126' as c -> Printf.sprintf "\"%c\"" c
+ | c -> Printf.sprintf "ascii %d" (int_of_char c)
+;;
+
+let rec read_item lex =
+ function
+ Leof -> Seof
+ | Lident s -> get_symbol (String.lowercase s)
+ | Lstring s -> Sstring s
+ | Lnumber s | Lbool s | Lchar s -> s
+ | Ltoken '(' -> read_list lex ')'
+ | Ltoken '[' -> read_list lex ']'
+ | Lopenv -> read_vector lex
+ | Ltoken '\'' -> read_quoted lex sym_quote
+ | Ltoken '`' -> read_quoted lex sym_quasiquote
+ | Ltoken ',' -> read_quoted lex sym_unquote
+ | Lunqsplice -> read_quoted lex sym_unquote_splicing
+ | Ltoken c -> raise (read_error lex ("unexpected " ^ show_token c))
+
+and read_list lex term =
+ let rec loop r =
+ match get_tok lex with
+ Leof -> raise (read_error lex "unexpected eof in list")
+ | Ltoken c when c = term -> make_slist Snull r
+ | Ltoken '.' ->
+ begin
+ let tl =
+ match get_tok lex with
+ Leof -> raise (read_error lex "unexpected eof in dotted tail")
+ | x -> read_item lex x
+ in
+ match get_tok lex with
+ Ltoken c when c = term -> make_slist tl r
+ | _ -> raise (read_error lex
+ "expected close paren after dotted tail")
+ end
+ | x -> loop ((read_item lex x)::r)
+ in
+ loop []
+
+and read_vector lex =
+ let rec loop r =
+ match get_tok lex with
+ Leof -> raise (read_error lex "unexpected eof in vector")
+ | Ltoken ')' -> r
+ | x -> loop ((read_item lex x)::r)
+ in
+ Svector (Array.of_list (List.rev (loop [])))
+
+and read_quoted lex sym =
+ match get_tok lex with
+ Leof -> raise (read_error lex "unexpected eof")
+ | x ->
+ let x = read_item lex x in
+ Spair { car = sym; cdr = Spair { car = x; cdr = Snull }}
+;;
+
+let read_expr lex =
+ read_item lex (get_tok lex)
+;;
+
+let read_from_port p =
+ read_expr (make_lexer p "")
+;;
+
+let read_from_string s =
+ read_from_port (Ocs_port.string_input_port s)
+;;
diff --git a/ocs-1.0.3/src/ocs_read.mli b/ocs-1.0.3/src/ocs_read.mli
new file mode 100644
index 0000000..e65bdac
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_read.mli
@@ -0,0 +1,10 @@
+(* Reader of Scheme expressions. *)
+
+open Ocs_types
+open Ocs_lex
+
+val read_expr : lexer -> sval
+
+val read_from_port : Ocs_port.port -> sval
+val read_from_string : string -> sval
+
diff --git a/ocs-1.0.3/src/ocs_string.ml b/ocs-1.0.3/src/ocs_string.ml
new file mode 100644
index 0000000..2330900
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_string.ml
@@ -0,0 +1,153 @@
+(* String primitives *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_env
+
+let make_string =
+ function
+ [| Sint k |] -> Sstring (String.create k)
+ | [| Sint k; Schar c |] -> Sstring (String.make k c)
+ | _ -> raise (Error "make-string: bad args")
+;;
+
+let string_of av =
+ let n = Array.length av in
+ let s = String.create n in
+ for i = 0 to n - 1 do
+ match av.(i) with
+ Schar c -> s.[i] <- c
+ | _ -> raise (Error "string: bad args")
+ done;
+ Sstring s
+;;
+
+let string_length =
+ function
+ Sstring s -> Sint (String.length s)
+ | _ -> raise (Error "string-length: not a string")
+;;
+
+let string_ref s k =
+ match (s, k) with
+ (Sstring s, Sint k) ->
+ if k >= 0 && k < String.length s then
+ Schar s.[k]
+ else
+ raise (Error "string-ref: out of bounds")
+ | _ -> raise (Error "string-ref: bad args")
+;;
+
+let string_set s k c =
+ match (s, k, c) with
+ (Sstring s, Sint k, Schar c) ->
+ if k >= 0 && k < String.length s then
+ begin
+ s.[k] <- c; Sunspec
+ end
+ else
+ raise (Error "string-set!: out of bounds")
+ | _ -> raise (Error "string-set!: bad args")
+;;
+
+let string_cmp op s1 s2 =
+ match (s1, s2) with
+ (Sstring s1, Sstring s2) -> if op s1 s2 then Strue else Sfalse
+ | _ -> raise (Error "bad args")
+;;
+
+let string_eq = string_cmp (=);;
+let string_lt = string_cmp (<);;
+let string_gt = string_cmp (>);;
+let string_le = string_cmp (<=);;
+let string_ge = string_cmp (>=);;
+
+let string_ci_cmp op s1 s2 =
+ match (s1, s2) with
+ (Sstring s1, Sstring s2) ->
+ if op (String.lowercase s1) (String.lowercase s2) then Strue else Sfalse
+ | _ -> raise (Error "bad args")
+;;
+
+let string_ci_eq = string_ci_cmp (=);;
+let string_ci_lt = string_ci_cmp (<);;
+let string_ci_gt = string_ci_cmp (>);;
+let string_ci_le = string_ci_cmp (<=);;
+let string_ci_ge = string_ci_cmp (>=);;
+
+let string_append av =
+ Sstring
+ (Array.fold_left (^) ""
+ (Array.map (function
+ Sstring s -> s
+ | _ -> raise (Error "string-append: bad args")) av))
+;;
+
+let substring s sp ep =
+ match (s, sp, ep) with
+ (Sstring s, Sint sp, Sint ep) ->
+ let n = String.length s in
+ if sp >= 0 && sp <= ep && ep <= n then
+ Sstring (String.sub s sp (ep - sp))
+ else
+ raise (Error "substring: out of bounds")
+ | _ -> raise (Error "substring: bad args")
+;;
+
+let string_to_list =
+ function
+ Sstring s ->
+ begin
+ let rec loop i r =
+ if i < 0 then r
+ else loop (i - 1) (Spair { car = Schar s.[i]; cdr = r })
+ in
+ loop (String.length s - 1) Snull
+ end
+ | _ -> raise (Error "string->list: not a string")
+;;
+
+let string_copy =
+ function
+ Sstring s -> Sstring (String.copy s)
+ | _ -> raise (Error "string-copy: not a string")
+;;
+
+let string_fill s c =
+ match (s, c) with
+ (Sstring s, Schar c) ->
+ String.fill s 0 (String.length s) c; Sunspec
+ | _ -> raise (Error "string-fill!: bad args")
+;;
+
+let init e =
+ set_pfn e make_string "make-string";
+ set_pfn e string_of "string";
+
+ set_pf1 e string_length "string-length";
+
+ set_pf2 e string_ref "string-ref";
+ set_pf3 e string_set "string-set!";
+
+ set_pf2 e string_eq "string=?";
+ set_pf2 e string_lt "string?";
+ set_pf2 e string_le "string<=?";
+ set_pf2 e string_ge "string>=?";
+
+ set_pf2 e string_ci_eq "string-ci=?";
+ set_pf2 e string_ci_lt "string-ci?";
+ set_pf2 e string_ci_le "string-ci<=?";
+ set_pf2 e string_ci_ge "string-ci>=?";
+
+ set_pf3 e substring "substring";
+
+ set_pfn e string_append "string-append";
+
+ set_pf1 e string_to_list "string->list";
+
+ set_pf1 e string_copy "string-copy";
+
+ set_pf2 e string_fill "string-fill!";
+;;
diff --git a/ocs-1.0.3/src/ocs_string.mli b/ocs-1.0.3/src/ocs_string.mli
new file mode 100644
index 0000000..7c7287a
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_string.mli
@@ -0,0 +1,6 @@
+(* String primitives *)
+
+open Ocs_types
+
+val init : env -> unit
+
diff --git a/ocs-1.0.3/src/ocs_sym.ml b/ocs-1.0.3/src/ocs_sym.ml
new file mode 100644
index 0000000..62139ef
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_sym.ml
@@ -0,0 +1,59 @@
+(* Symbol table implementation. *)
+
+open Ocs_types
+open Ocs_error
+
+(* Symbols are stored in a hash table of weak references. This
+ guarantees that they are unique, but they needn't be permanent. *)
+
+module HashSymbol =
+ struct
+ type t = sval
+ let equal a b =
+ match (a, b) with
+ (Ssymbol s1, Ssymbol s2) -> s1 = s2
+ | _ -> false
+ let hash = Hashtbl.hash
+ end
+
+module SymTable = Weak.Make (HashSymbol)
+
+let symt = SymTable.create 307
+
+let get_symbol s =
+ SymTable.merge symt (Ssymbol s)
+;;
+
+let sym_name =
+ function
+ Ssymbol s -> s
+ | _ -> raise (Error "sym_name: not a symbol")
+;;
+
+let sym_quote = get_symbol "quote"
+let sym_lambda = get_symbol "lambda"
+let sym_if = get_symbol "if"
+let sym_set = get_symbol "set!"
+let sym_begin = get_symbol "begin"
+let sym_cond = get_symbol "cond"
+let sym_and = get_symbol "and"
+let sym_or = get_symbol "or"
+let sym_case = get_symbol "case"
+let sym_let = get_symbol "let"
+let sym_letstar = get_symbol "let*"
+let sym_letrec = get_symbol "letrec"
+let sym_do = get_symbol "do"
+let sym_delay = get_symbol "delay"
+let sym_quasiquote = get_symbol "quasiquote"
+let sym_else = get_symbol "else"
+let sym_arrow = get_symbol "=>"
+let sym_define = get_symbol "define"
+let sym_unquote = get_symbol "unquote"
+let sym_unquote_splicing = get_symbol "unquote-splicing"
+
+let sym_define_syntax = get_symbol "define-syntax"
+let sym_let_syntax = get_symbol "let-syntax"
+let sym_letrec_syntax = get_symbol "letrec-syntax"
+let sym_syntax_rules = get_symbol "syntax-rules"
+let sym_ellipsis = get_symbol "..."
+
diff --git a/ocs-1.0.3/src/ocs_sym.mli b/ocs-1.0.3/src/ocs_sym.mli
new file mode 100644
index 0000000..f9a0d2f
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_sym.mli
@@ -0,0 +1,36 @@
+(* Symbol table interface. *)
+
+open Ocs_types
+
+(* get_symbol returns a symbol corresponding to a string. It is
+ created if it doesn't exist. *)
+val get_symbol : string -> sval
+val sym_name : sval -> string
+
+(* Keywords are globally defined for convenience. *)
+val sym_quote : sval
+val sym_lambda : sval
+val sym_if : sval
+val sym_set : sval
+val sym_begin : sval
+val sym_cond : sval
+val sym_and : sval
+val sym_or : sval
+val sym_case : sval
+val sym_let : sval
+val sym_letstar : sval
+val sym_letrec : sval
+val sym_do : sval
+val sym_delay : sval
+val sym_quasiquote : sval
+val sym_else : sval
+val sym_arrow : sval
+val sym_define : sval
+val sym_unquote : sval
+val sym_unquote_splicing : sval
+
+val sym_define_syntax : sval
+val sym_let_syntax : sval
+val sym_letrec_syntax : sval
+val sym_syntax_rules : sval
+val sym_ellipsis : sval
diff --git a/ocs-1.0.3/src/ocs_top.ml b/ocs-1.0.3/src/ocs_top.ml
new file mode 100644
index 0000000..14fc07c
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_top.ml
@@ -0,0 +1,75 @@
+(* Top level, create and initialize the environment. *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_env
+open Ocs_compile
+open Ocs_eval
+open Ocs_print
+open Ocs_macro
+
+(* Create a top-level environment and bind standard primitives. *)
+let make_env () =
+ let e = top_env () in
+ bind_lang e;
+ bind_macro e;
+ Ocs_num.init e;
+ Ocs_numstr.init e;
+ Ocs_prim.init e;
+ Ocs_vector.init e;
+ Ocs_list.init e;
+ Ocs_char.init e;
+ Ocs_string.init e;
+ Ocs_contin.init e;
+ Ocs_io.init e;
+ e
+;;
+
+(* Create a top-level thread. *)
+let make_thread () =
+ { th_display = [| |];
+ th_frame = [| |];
+ th_depth = -1;
+ th_stdin = Sport (Ocs_port.input_port stdin);
+ th_stdout = Sport (Ocs_port.output_port stdout);
+ th_dynext = None }
+;;
+
+let get_port =
+ function
+ Sport p -> p
+ | _ -> failwith "expected port"
+;;
+
+(* Top-level loop for interaction. *)
+let top_loop env th =
+ let inp = get_port th.th_stdin
+ and outp = get_port th.th_stdout
+ and errp = Ocs_port.output_port stderr in
+ let lex = Ocs_lex.make_lexer inp "" in
+ let rec loop () =
+ Ocs_port.puts outp "> ";
+ Ocs_port.flush outp;
+ try
+ match Ocs_read.read_expr lex with
+ Seof -> ()
+ | v ->
+ let c = compile env v in
+ eval th (function Sunspec -> ()
+ | r ->
+ print outp false r;
+ Ocs_port.putc outp '\n') c;
+ loop ()
+ with Error err | ErrorL (_, err) ->
+ Ocs_port.puts errp ("Error: " ^ err ^ "\n");
+ Ocs_port.flush errp;
+ loop ()
+ in
+ loop ()
+;;
+
+(* Simple interface to invoke the interactive Scheme environment. *)
+let interactive () =
+ top_loop (make_env ()) (make_thread ())
+;;
+
diff --git a/ocs-1.0.3/src/ocs_top.mli b/ocs-1.0.3/src/ocs_top.mli
new file mode 100644
index 0000000..4280cb0
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_top.mli
@@ -0,0 +1,10 @@
+(* Create and initialize top level environment. *)
+
+open Ocs_types
+
+val make_env : unit -> env
+val make_thread : unit -> thread
+val top_loop : env -> thread -> unit
+
+val interactive : unit -> unit
+
diff --git a/ocs-1.0.3/src/ocs_types.mli b/ocs-1.0.3/src/ocs_types.mli
new file mode 100644
index 0000000..4203dff
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_types.mli
@@ -0,0 +1,200 @@
+(* Main types used *)
+
+open Ocs_vartable
+
+(* We have to declare most types here to avoid cross-dependencies between
+ compilation units. *)
+
+type sval =
+ (* Global variables are set to Sunbound when referenced but not assigned. *)
+ Sunbound
+
+ (* List terminator. *)
+ | Snull
+
+ (* End-of-file indicator. *)
+ | Seof
+
+ (* Boolean values. This is more compact than Sbool of bool. *)
+ | Strue
+ | Sfalse
+
+ (* String object. *)
+ | Sstring of string
+
+ (* Symbol type. Symbols should not be created directly, but using
+ Ocs_sym.get_symbol, which ensures that they are unique and can be
+ compared using ==. *)
+ | Ssymbol of string
+
+ (* Numeric types. *)
+ | Sint of int
+ | Sreal of float
+ | Scomplex of Complex.t
+ | Sbigint of Big_int.big_int
+ | Srational of Ratio.ratio
+
+ (* Character. *)
+ | Schar of char
+
+ (* A pair (list element). *)
+ | Spair of spair
+
+ (* Vector. *)
+ | Svector of sval array
+
+ (* Port object. *)
+ | Sport of Ocs_port.port
+
+ (* A closure created by combining the process reference with the
+ local environment at that point of execution. *)
+ | Sproc of sproc * sval array array
+
+ (* Primitive function. *)
+ | Sprim of sprim
+
+ (* Delayed expression. *)
+ | Spromise of spromise
+
+ (* A set of values returned by the 'values' primitive,
+ deconstructed into multiple parameters by call-with-values. *)
+ | Svalues of sval array
+
+ (* A symbol explicitly tied to an environment that defines its scope.
+ These symbols are generated by macro expansions and eliminated
+ prior to evaluation. *)
+ | Sesym of env * sval
+
+ (* Wrapped values are stub functions that encapsulate external values
+ of unknown types. *)
+ | Swrapped of (unit -> unit)
+
+ (* An unspecified value. *)
+ | Sunspec
+
+ (* The actual type of a pair (cons cell). *)
+and spair =
+ {
+ mutable car : sval;
+ mutable cdr : sval
+ }
+
+ (* Primitive structure. *)
+and sprim =
+ {
+ prim_fun : primf;
+ prim_name : string
+ }
+
+ (* Primitive function types. *)
+and primf =
+ (* Simple functional interface to primitives with a small, constant
+ number of arguments. *)
+ Pf0 of (unit -> sval)
+ | Pf1 of (sval -> sval)
+ | Pf2 of (sval -> sval -> sval)
+ | Pf3 of (sval -> sval -> sval -> sval)
+
+ (* Functional interface to primitives with a variable number of arguments. *)
+ | Pfn of (sval array -> sval)
+
+ (* Continuation-based interface to primitives, also includes the thread
+ and supports a variable number of arguments. *)
+ | Pfcn of (thread -> (sval -> unit) -> sval array -> unit)
+
+ (* Procedure structure. *)
+and sproc =
+ {
+ proc_body : code;
+ proc_nargs : int;
+ proc_has_rest : bool;
+ proc_frame_size : int;
+ mutable proc_name : string
+ }
+
+ (* Delayed expression. *)
+and spromise =
+ {
+ promise_code : code;
+ mutable promise_val : sval option;
+ mutable promise_th : thread option (* Copy of the thread state *)
+ }
+
+ (* Code types are used to represent analyzed expressions prepared for
+ evaluation. *)
+and code =
+ Cval of sval
+ | Cseq2 of code * code
+ | Cseq3 of code * code * code
+ | Cseqn of code array
+ | Cand2 of code * code
+ | Cand3 of code * code * code
+ | Candn of code array
+ | Cor2 of code * code
+ | Cor3 of code * code * code
+ | Corn of code array
+ | Cif of code * code * code
+ | Csetg of gvar * code
+ | Csetl of int * int * code
+ | Cdefine of gvar * code
+ | Cgetg of gvar
+ | Cgetl of int * int
+ | Capply0 of code
+ | Capply1 of code * code
+ | Capply2 of code * code * code
+ | Capply3 of code * code * code * code
+ | Capplyn of code * code array
+ | Clambda of sproc
+ | Cqqp of code * code
+ | Cqqv of code array
+ | Cqqvs of code list
+ | Cqqspl of code
+ | Ccond of (code * code) array
+ | Ccondspec of code
+ | Ccase of code * (sval array * code) array
+ | Cdelay of code
+
+ (* Global variable slot. *)
+and gvar =
+ {
+ mutable g_sym : sval;
+ mutable g_val : sval
+ }
+
+ (* Thread state, used during evaluation. *)
+and thread =
+ {
+ th_frame : sval array; (* Current local frame. *)
+ th_display : sval array array; (* Current display. *)
+ th_depth : int; (* Display depth. *)
+ th_stdin : sval; (* Default input port. *)
+ th_stdout : sval; (* Default output port. *)
+ th_dynext : dynext option (* Current dynamic extent. *)
+ }
+
+ (* Bindings, used during analysis. *)
+and vbind =
+ Vglob of gvar
+ | Vloc of int * int
+ | Vsyntax of (env -> sval array -> code)
+ | Vmacro of (env -> sval array -> sval)
+ | Vkeyword of string
+
+ (* Environment, used during analysis. *)
+and env =
+ {
+ env_depth : int;
+ env_vartable : vbind vartable;
+ env_frame_size : int ref;
+ mutable env_tagged : (env * sval * vbind) list
+ }
+
+ (* Dynamic extents are associated with threads and continuations. *)
+and dynext =
+ {
+ dynext_parent : dynext option;
+ dynext_depth : int;
+ dynext_before : thread * code;
+ dynext_after : thread * code
+ }
+
diff --git a/ocs-1.0.3/src/ocs_vartable.ml b/ocs-1.0.3/src/ocs_vartable.ml
new file mode 100644
index 0000000..85f1943
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_vartable.ml
@@ -0,0 +1,65 @@
+(* Utility type for variable binding tables. *)
+
+module VarTable = Map.Make (String)
+
+type 'a vartable = {
+ vt_global : 'a vartable option;
+ mutable vt_bindings : 'a VarTable.t
+}
+
+let vt_create () =
+ { vt_global = None;
+ vt_bindings = VarTable.empty }
+;;
+
+let vt_inherit vt =
+ { vt_global =
+ if vt.vt_global = None then Some vt
+ else vt.vt_global;
+ vt_bindings = vt.vt_bindings }
+;;
+
+let vt_global vt =
+ vt.vt_global = None
+;;
+
+let rec vt_copy vt vc =
+ { vt_global =
+ (match vt.vt_global with
+ Some t -> Some (vt_copy t vc)
+ | _ -> None);
+ vt_bindings =
+ VarTable.map vc vt.vt_bindings }
+;;
+
+let var_insert vt key r =
+ vt.vt_bindings <- VarTable.add key r vt.vt_bindings
+;;
+
+let rec var_find vt key =
+ try
+ Some (VarTable.find key vt.vt_bindings)
+ with
+ Not_found ->
+ begin
+ match vt.vt_global with
+ Some x -> var_find x key
+ | _ -> None
+ end
+;;
+
+let rec var_get vt key mkvar =
+ try
+ VarTable.find key vt.vt_bindings
+ with
+ Not_found ->
+ begin
+ match vt.vt_global with
+ Some x -> var_get x key mkvar
+ | _ ->
+ let r = mkvar () in
+ var_insert vt key r;
+ r
+ end
+;;
+
diff --git a/ocs-1.0.3/src/ocs_vartable.mli b/ocs-1.0.3/src/ocs_vartable.mli
new file mode 100644
index 0000000..2c5b946
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_vartable.mli
@@ -0,0 +1,13 @@
+(* Utility type for variable binding tables. *)
+
+type 'a vartable
+
+val vt_create : unit -> 'a vartable
+val vt_inherit : 'a vartable -> 'a vartable
+val vt_global : 'a vartable -> bool
+val vt_copy : 'a vartable -> ('a -> 'a) -> 'a vartable
+
+val var_insert : 'a vartable -> string -> 'a -> unit
+val var_find : 'a vartable -> string -> 'a option
+val var_get : 'a vartable -> string -> (unit -> 'a) -> 'a
+
diff --git a/ocs-1.0.3/src/ocs_vector.ml b/ocs-1.0.3/src/ocs_vector.ml
new file mode 100644
index 0000000..5916f46
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_vector.ml
@@ -0,0 +1,79 @@
+(* Vector primitives. *)
+
+open Ocs_types
+open Ocs_error
+open Ocs_env
+
+let get_int =
+ function
+ Sint i -> i
+ | _ -> raise (Error "bad arg types")
+
+let make_vector av =
+ match Array.length av with
+ (1 | 2) as n ->
+ let size = get_int av.(0)
+ and fill = if n = 2 then av.(1) else Snull in
+ Svector (Array.make size fill)
+ | _ -> raise (Error "make-vector: wrong number of args")
+
+let vector_of v =
+ Svector v
+;;
+
+let vector_length =
+ function
+ Svector v -> Sint (Array.length v)
+ | _ -> raise (Error "vector-length: not a vector")
+;;
+
+let vector_ref sv i =
+ match (sv, i) with
+ (Svector vec, Sint i) -> vec.(i)
+ | _ -> raise (Error "vector-ref: bad arg types")
+;;
+
+let vector_set sv i v =
+ match (sv, i) with
+ (Svector vec, Sint i) -> vec.(i) <- v; Sunspec
+ | _ -> raise (Error "vector-set!: bad arg types")
+;;
+
+let vector_to_list =
+ function
+ Svector v ->
+ begin
+ let rec loop i r =
+ if i < 0 then r
+ else loop (i - 1) (Spair { car = v.(i); cdr = r })
+ in
+ loop (Array.length v - 1) Snull
+ end
+ | _ -> raise (Error "vector->list: bad args")
+;;
+
+let vector_fill sv v =
+ match sv with
+ Svector vec ->
+ for i = 0 to Array.length vec - 1 do
+ vec.(i) <- v
+ done;
+ Sunspec
+ | _ -> raise (Error "vector-fill!: bad args")
+;;
+
+let init e =
+ set_pfn e make_vector "make-vector";
+
+ set_pfn e vector_of "vector";
+
+ set_pf1 e vector_length "vector-length";
+
+ set_pf2 e vector_ref "vector-ref";
+ set_pf3 e vector_set "vector-set!";
+
+ set_pf1 e vector_to_list "vector->list";
+
+ set_pf2 e vector_fill "vector-fill!";
+;;
+
diff --git a/ocs-1.0.3/src/ocs_vector.mli b/ocs-1.0.3/src/ocs_vector.mli
new file mode 100644
index 0000000..4282981
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_vector.mli
@@ -0,0 +1,6 @@
+(* Vector primitives *)
+
+open Ocs_types
+
+val init : env -> unit
+
diff --git a/ocs-1.0.3/src/ocs_wrap.ml b/ocs-1.0.3/src/ocs_wrap.ml
new file mode 100644
index 0000000..1680cd5
--- /dev/null
+++ b/ocs-1.0.3/src/ocs_wrap.ml
@@ -0,0 +1,35 @@
+(* Functor for creating wrap/unwrap functions *)
+
+open Ocs_types
+open Ocs_error
+
+module Make(T: sig type t end) =
+ struct
+ type t = T.t
+
+ exception E of t
+
+ let wrap v =
+ Swrapped (fun () -> raise (E v))
+
+ let unwrap =
+ function
+ Swrapped f ->
+ (try
+ f ();
+ raise (Error "unwrap: internal error")
+ with E v -> v
+ | _ -> raise (Error "unwrap: wrong wrapped type"))
+ | _ -> raise (Error "unwrap: not a wrapped type")
+
+ let try_unwrap =
+ function
+ Swrapped f ->
+ (try
+ f ();
+ None
+ with E v -> Some v
+ | _ -> None)
+ | _ -> None
+ end
+