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

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

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

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

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

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

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

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

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

View File

@ -0,0 +1,11 @@