neale
/
irc-bot
mirror of https://github.com/nealey/irc-bot
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Import OCS, add COPYING file

This commit is contained in:
Neale Pickett 2009-03-02 18:49:21 -07:00
parent 9e247dd246
commit 341d20ad8d
57 changed files with 5995 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
COPYING Normal file
View File

@ -0,0 +1,61 @@
GPLv3 for all my stuff (everything but ocs and cdb.ml).
------------------------------------------------------------------------
ocs was downloaded from <http://will.iki.fi/software/ocs/> 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
<http://bleu.west.spy.net/~dustin/projects/ocaml/>. 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.

76
ocs-1.0.3/CHANGES Normal file
View File

@ -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 <var> ...) forms where <var> 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.

25
ocs-1.0.3/COPYING Normal file
View File

@ -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.

136
ocs-1.0.3/README Normal file
View File

@ -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

107
ocs-1.0.3/src/.depend Normal file
View File

@ -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

57
ocs-1.0.3/src/Makefile Normal file
View File

@ -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

21
ocs-1.0.3/src/Makefile.common Normal file
View File

@ -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 $<

153
ocs-1.0.3/src/ocs_char.ml Normal file
View File

@ -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_gt "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_gt "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";
;;

9
ocs-1.0.3/src/ocs_char.mli Normal file
View File

@ -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

487
ocs-1.0.3/src/ocs_compile.ml Normal file
View File

@ -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 = "#<unknown>#" }
;;
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");
;;

13
ocs-1.0.3/src/ocs_compile.mli Normal file
View File

@ -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

44
ocs-1.0.3/src/ocs_complex.ml Normal file
View File

@ -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 }
;;

11
ocs-1.0.3/src/ocs_complex.mli Normal file
View File

@ -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

114
ocs-1.0.3/src/ocs_contin.ml Normal file
View File

@ -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 = "<continuation>" }
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";
;;

6
ocs-1.0.3/src/ocs_contin.mli Normal file
View File

@ -0,0 +1,6 @@
(* Continuations *)
open Ocs_types
val init : env -> unit

143
ocs-1.0.3/src/ocs_env.ml Normal file
View File

@ -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

30
ocs-1.0.3/src/ocs_env.mli Normal file
View File

@ -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

11
ocs-1.0.3/src/ocs_error.ml Normal file
View File

@ -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

339
ocs-1.0.3/src/ocs_eval.ml Normal file
View File

@ -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")
;;

6
ocs-1.0.3/src/ocs_eval.mli Normal file
View File

@ -0,0 +1,6 @@
(* Evaluation *)
open Ocs_types
val eval : thread -> (sval -> unit) -> code -> unit

224
ocs-1.0.3/src/ocs_io.ml Normal file
View File

@ -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";
;;

11
ocs-1.0.3/src/ocs_io.mli Normal file
View File

@ -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

279
ocs-1.0.3/src/ocs_lex.ml Normal file
View File

@ -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
;;

22
ocs-1.0.3/src/ocs_lex.mli Normal file
View File

@ -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

302
ocs-1.0.3/src/ocs_list.ml Normal file
View File

@ -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";
;;

6
ocs-1.0.3/src/ocs_list.mli Normal file
View File

@ -0,0 +1,6 @@
(* List functionality. *)
open Ocs_types
val init : env -> unit

438
ocs-1.0.3/src/ocs_macro.ml Normal file
View File

@ -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
| _ -> "<not a symbol>"
;;
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 "...")
;;

6
ocs-1.0.3/src/ocs_macro.mli Normal file
View File

@ -0,0 +1,6 @@
(* Syntax definitions and expansions. *)
open Ocs_types
val bind_macro : env -> unit

28
ocs-1.0.3/src/ocs_main.ml Normal file
View File

@ -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 ();;

77
ocs-1.0.3/src/ocs_misc.ml Normal file
View File

@ -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
;;

12
ocs-1.0.3/src/ocs_misc.mli Normal file
View File

@ -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

633
ocs-1.0.3/src/ocs_num.ml Normal file
View File

@ -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";
;;

13
ocs-1.0.3/src/ocs_num.mli Normal file
View File

@ -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

201
ocs-1.0.3/src/ocs_numaux.ml Normal file
View File

@ -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))))
;;

29
ocs-1.0.3/src/ocs_numaux.mli Normal file
View File

@ -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

403
ocs-1.0.3/src/ocs_numstr.ml Normal file
View File

@ -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";
;;

11
ocs-1.0.3/src/ocs_numstr.mli Normal file
View File

@ -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

223
ocs-1.0.3/src/ocs_port.ml Normal file
View File

@ -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
;;

33
ocs-1.0.3/src/ocs_port.mli Normal file
View File

@ -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

269
ocs-1.0.3/src/ocs_prim.ml Normal file
View File

@ -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";
;;

8
ocs-1.0.3/src/ocs_prim.mli Normal file
View File

@ -0,0 +1,8 @@
(* Miscellaneous primitives. *)
open Ocs_types
val load_file : env -> thread -> string -> unit
val init : env -> unit

75
ocs-1.0.3/src/ocs_print.ml Normal file
View File

@ -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 "#<eof>"
| 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 "#<port>"
| Sproc _ -> Ocs_port.puts p "#<procedure>"
| Sprim { prim_fun = _; prim_name = n } ->
Ocs_port.puts p "#<primitive:"; Ocs_port.puts p n; Ocs_port.putc p '>'
| Spromise _ -> Ocs_port.puts p "#<promise>"
| Sesym (_, s) -> print p disp s
| Swrapped _ -> Ocs_port.puts p "#<wrapped>"
| Sunspec -> Ocs_port.puts p "#<unspecified>"
| _ -> Ocs_port.puts p "#<unknown>"
;;

9
ocs-1.0.3/src/ocs_print.mli Normal file
View File

@ -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

87
ocs-1.0.3/src/ocs_read.ml Normal file
View File

@ -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)
;;

10
ocs-1.0.3/src/ocs_read.mli Normal file
View File

@ -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

153
ocs-1.0.3/src/ocs_string.ml Normal file
View File

@ -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_gt "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_gt "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!";
;;

6
ocs-1.0.3/src/ocs_string.mli Normal file
View File

@ -0,0 +1,6 @@
(* String primitives *)
open Ocs_types
val init : env -> unit

59
ocs-1.0.3/src/ocs_sym.ml Normal file
View File

@ -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 "..."

36
ocs-1.0.3/src/ocs_sym.mli Normal file
View File

@ -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

75
ocs-1.0.3/src/ocs_top.ml Normal file
View File

@ -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 ())
;;

10
ocs-1.0.3/src/ocs_top.mli Normal file
View File

@ -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

200
ocs-1.0.3/src/ocs_types.mli Normal file
View File

@ -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
}

65
ocs-1.0.3/src/ocs_vartable.ml Normal file
View File

@ -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
;;

13
ocs-1.0.3/src/ocs_vartable.mli Normal file
View File

@ -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

79
ocs-1.0.3/src/ocs_vector.ml Normal file
View File

@ -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!";
;;

6
ocs-1.0.3/src/ocs_vector.mli Normal file
View File

@ -0,0 +1,6 @@
(* Vector primitives *)
open Ocs_types
val init : env -> unit

35
ocs-1.0.3/src/ocs_wrap.ml Normal file
View File

@ -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