Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 06:39:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding (chibi io) w/ interface to fgets, fread, fwrite, etc.

Browse source
This commit is contained in:
Alex Shinn 2009-12-31 00:24:19 +09:00
commit d954819775
123 changed files with 17079 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
.hgignore Normal file
View file

@ -0,0 +1,21 @@
syntax: glob
*~
*.i
*.s
*.o
*.so
*.dylib
*.dSYM
*.orig
.hg
junk*
*.tar.gz
*.tar.bz2
*.log
*.err
*.out
gc
gc6.8
chibi-scheme
chibi-scheme-static
include/chibi/install.h

24
COPYING Normal file
View file

@ -0,0 +1,24 @@
Copyright (c) 2009 Alex Shinn
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.
3. The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 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.

193
Makefile Normal file
View file

@ -0,0 +1,193 @@
# -*- makefile-gmake -*-
.PHONY: all libs doc dist clean cleaner test install uninstall
.PRECIOUS: %.c
# install configuration
CC ?= cc
PREFIX ?= /usr/local
BINDIR ?= $(PREFIX)/bin
LIBDIR ?= $(PREFIX)/lib
SOLIBDIR ?= $(PREFIX)/lib
INCDIR ?= $(PREFIX)/include/chibi
MODDIR ?= $(PREFIX)/share/chibi
LIBDIR ?= $(PREFIX)/lib/chibi
MANDIR ?= $(PREFIX)/share/man/man1
DESTDIR ?=
GENSTUBS ?= ./tools/genstubs.scm
########################################################################
# system configuration - if not using GNU make, set PLATFORM and the
# following flags as necessary.
ifndef PLATFORM
ifeq ($(shell uname),Darwin)
PLATFORM=macosx
else
ifeq ($(shell uname -o),Msys)
PLATFORM=mingw
SOLIBDIR = $(BINDIR)
DIFFOPTS = -b
else
PLATFORM=unix
endif
endif
endif
ifeq ($(PLATFORM),macosx)
SO = .dylib
EXE =
CLIBFLAGS = -dynamiclib
STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0
else
ifeq ($(PLATFORM),mingw)
SO = .dll
EXE = .exe
CC = gcc
CLIBFLAGS = -shared
CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL -DSEXP_USE_DEBUG=0
LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a
else
SO = .so
EXE =
CLIBFLAGS = -fPIC -shared
STATICFLAGS = -static -DSEXP_USE_DL=0
endif
endif
ifeq ($(USE_BOEHM),1)
SEXP_USE_BOEHM = 1
endif
ifeq ($(SEXP_USE_BOEHM),1)
GCLDFLAGS := -lgc
XCPPFLAGS := $(CPPFLAGS) -Iinclude -DSEXP_USE_BOEHM=1
else
GCLDFLAGS :=
XCPPFLAGS := $(CPPFLAGS) -Iinclude
endif
ifeq ($(SEXP_USE_DL),0)
XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm
XCFLAGS := -Wall -DSEXP_USE_DL=0 -g3 $(CFLAGS)
else
XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -ldl -lm
XCFLAGS := -Wall -g3 $(CFLAGS)
endif
########################################################################
all: chibi-scheme$(EXE) libs
COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \
lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \
lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \
lib/chibi/io/io$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO)
libs: $(COMPILED_LIBS)
INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h
include/chibi/install.h: Makefile
echo '#define sexp_so_extension "'$(SO)'"' > $@
echo '#define sexp_default_module_dir "'$(MODDIR)'"' >> $@
echo '#define sexp_platform "'$(PLATFORM)'"' >> $@
echo '#define sexp_version "'`cat VERSION`'"' >> $@
echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@
sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
eval.o: eval.c opcodes.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
libchibi-scheme$(SO): eval.o sexp.o
$(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS)
chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
$(CC) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme
chibi-scheme-static$(EXE): main.o eval.o sexp.o
$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS)
%.c: %.stub $(GENSTUBS)
LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) PATH=.:$(PATH) $(GENSTUBS) $<
lib/%$(SO): lib/%.c $(INCLUDES)
-$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme
clean:
rm -f *.o *.i *.s *.8
find lib -name \*$(SO) -exec rm -f '{}' \;
rm -f tests/basic/*.out tests/basic/*.err
cleaner: clean
rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) $(COMPILED_LIBS) *$(SO) *.a include/chibi/install.h
rm -rf *.dSYM
test-basic: chibi-scheme$(EXE)
@for f in tests/basic/*.scm; do \
./chibi-scheme$(EXE) $$f >$${f%.scm}.out 2>$${f%.scm}.err; \
if diff -q $(DIFFOPTS) $${f%.scm}.out $${f%.scm}.res; then \
echo "[PASS] $${f%.scm}"; \
else \
echo "[FAIL] $${f%.scm}"; \
fi; \
done
test-build:
./tests/build/build-tests.sh
test-numbers: chibi-scheme$(EXE)
LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/numeric-tests.scm
test-hash: chibi-scheme$(EXE)
LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/hash-tests.scm
test-match: chibi-scheme$(EXE)
LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/match-tests.scm
test-loop: chibi-scheme$(EXE)
LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/loop-tests.scm
test: chibi-scheme$(EXE)
LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/r5rs-tests.scm
install: chibi-scheme$(EXE)
mkdir -p $(DESTDIR)$(BINDIR)
cp chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
mkdir -p $(DESTDIR)$(MODDIR)
cp lib/init.scm lib/config.scm $(DESTDIR)$(MODDIR)/
cp -r lib/ $(DESTDIR)$(MODDIR)/
mkdir -p $(DESTDIR)$(INCDIR)
cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/
mkdir -p $(DESTDIR)$(LIBDIR)
mkdir -p $(DESTDIR)$(SOLIBDIR)
cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/
cp libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/
-cp libchibi-scheme.a $(DESTDIR)$(LIBDIR)/
mkdir -p $(DESTDIR)$(MANDIR)
cp doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/
if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi
uninstall:
rm -f $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE)
rm -f $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE)
rm -f $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO)
rm -f $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a
cd $(DESTDIR)$(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h
rm -rf $(DESTDIR)$(MODDIR)
dist: cleaner
rm -f chibi-scheme-`cat VERSION`.tgz
mkdir chibi-scheme-`cat VERSION`
for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done
tar cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION`
rm -rf chibi-scheme-`cat VERSION`

424
README Normal file
View file

@ -0,0 +1,424 @@
Chibi-Scheme
--------------
Minimal Scheme Implementation for use as an Extension Language
http://synthcode.com/wiki/chibi-scheme/
Chibi-Scheme is a very small but mostly complete R5RS Scheme
implementation using a reasonably fast custom VM. Chibi-Scheme tries
as much as possible not to trade its small size by cutting corners,
and provides full continuations, both low and high-level hygienic
macros based on syntactic-closures, string ports and exceptions.
Chibi-Scheme is written in highly portable C and supports multiple
simultaneous VM instances to run.
------------------------------------------------------------------------
INSTALLING
To build, just run "make". This will provide a shared library
"libchibi-scheme", as well as a sample "chibi-scheme" command-line
repl. The "chibi-scheme-static" make target builds an equivalent
static executable.
You can edit the file chibi/features.h for a number of settings,
mostly disabling features to make the executable smaller. You can
specify standard options directly as arguments to make, for example
make CFLAGS=-Os CPPFLAGS=-DSEXP_USE_NO_FEATURES=1
to optimize for size, or
make LDFLAGS=-L/usr/local/lib CPPFLAGS=-I/usr/local/include
to compile against a library installed in /usr/local.
By default Chibi uses a custom, precise, non-moving GC. You can link
against the Boehm conservative GC by editing the features.h file, or
directly from make with:
make SEXP_USE_BOEHM=1
------------------------------------------------------------------------
CHIBI-SCHEME LANGUAGE
The default language is mostly compatible with the R5RS, with all
differences made by design, not through difficulty of implementation.
The following procedures are omitted:
transcript-on and transcript-off (because they're silly)
rationalize (pending the addition of rational numbers)
Apart from this, chibi-scheme is case-sensitive, unlike the R5RS.
The default configuration includes fixnums, flonums and bignums
but no exact rationals or complex numbers.
Full continuations are supported, but currently continuations don't
take C code into account. The only higher-order C functions in the
standard environment are LOAD and EVAL.
LOAD is extended to accept an optional environment argument, like
EVAL. You can also LOAD shared libraries in addition to Scheme source
files - in this case the function sexp_init_library is automatically
called with the following signature:
sexp_init_library(sexp context, sexp environment)
SYNTAX-RULES macros are provided by default, with the extensions from
SRFI-46. In addition, low-level hygienic macros are provided with
a syntactic-closures interface, including SC-MACRO-TRANSFORMER,
RSC-MACRO-TRANSFORMER, and ER-MACRO-TRANSFORMER. A good introduction
to syntactic-closures can be found at:
http://community.schemewiki.org/?syntactic-closures
IDENTIFIER?, IDENTIFIER->SYMBOL, IDENTIFIER=?, and
MAKE-SYNTACTIC-CLOSURE and STRIP-SYNTACTIC-CLOSURES are provided.
SRFI-0's COND-EXPAND is provided, with the feature `chibi'.
STRING-CONCATENATE concatenates a list of strings.
------------------------------------------------------------------------
TYPES
You can define new data types with SRFI-9. This is just syntactic
sugar for the following more primitive type constructors:
(register-simple-type <name-string> <num-fields>)
=> <type-id> ; a fixnum
(make-type-predicate <opcode-name-string> <type-id>)
=> <opcode> ; takes 1 arg, returns #t iff that arg is of the type
(make-constructor <constructor-name-string> <type-id>)
=> <opcode> ; takes 0 args, returns a newly allocated instance of type
(make-getter <getter-name-string> <type-id> <field-index>)
=> <opcode> ; takes 1 args, retrieves the field located at the index
(make-setter <setter-name-string> <type-id> <field-index>)
=> <opcode> ; takes 2 args, sets the field located at the index
------------------------------------------------------------------------
MODULE SYSTEM
A configurable module system, in the style of the Scheme48 module
system, is provided by default.
Modules names are hierarchical lists of symbols or numbers. The
definition of the module (foo bar baz) is searched for in the file
foo/bar/baz.module. This file should contain an expression of the
form:
(define-module (foo bar baz)
<module-declarations> ...)
where <module-declarations> can be any of
(export <id> ...) - specify an export list
(import <import-spec> ...) - specify one or more imports
(import-immutable <import-spec> ...) - specify an immutable import
(body <expr> ...) - inline Scheme code
(include <file> ...) - load one or more files
(include-shared <file> ...) - dynamic load a library
<import-spec> can either be a module name or any of
(only <import-spec> <id> ...)
(except <import-spec> <id> ...)
(rename <import-spec> (<from-id> <to-id>) ...)
(prefix <prefix-id> <import-spec>)
The can be composed and perform basic selection and renaming of
individual identifiers from the given module.
Files are loaded relative to the .module file, and are written with
their extension (so you can use whatever suffix you prefer - .scm,
.ss, .sls, etc.).
Shared modules, on the other hand, should be specified _without_ the
extension - the correct suffix will be added portably (e.g. .so for
Unix and .dylib for OS X).
You may also use COND-EXPAND and arbitrary macro expansions in a
module definition to generate <module-declarations>.
------------------------------------------------------------------------
MODULES
The default environment is (scheme) - you almost always want to import
this.
Currently you can load the following SRFIs with (import (srfi N)):
(srfi 0) - cond-expand
(srfi 1) - list library
(srfi 2) - and-let*
(srfi 6) - basic string ports
(srfi 8) - receive
(srfi 9) - define-record-type
(srfi 11) - let-values/let*-values
(srfi 16) - case-lambda
(srfi 22) - running scheme scripts on Unix
(srfi 23) - error reporting mechanism
(srfi 26) - cut/cute partial application
(srfi 27) - sources of random bits
(srfi 33) - bitwise operators
(srfi 39) - prameter objects
(srfi 46) - basic syntax-rules extensions
(srfi 62) - s-expression comments
(srfi 69) - basic hash tables
(srfi 95) - sorting and merging
(srfi 98) - environment access
although 0, 22, 23, 46 and 62 are built into the default environment
so there's no need to import them.
Included non-standard modules are put in the (chibi) module namespace.
The following additional modules are available:
(chibi net) - networking interface
(chibi filesystem) - local filesystem and file descriptor interface
(chibi process) - processes and signals
(chibi system) - host system and user information
(chibi time) - time and date library
(chibi match) - pattern-matching library
(chibi loop) - extensible loop syntax
(chibi pathname) - pathname manipulation utilities
(chibi uri) - URI parsing and construction utilities
(chibi macroexpand) - macro expansion utility
(chibi ast) - interface to the internal Abstract Syntax Tree
(chibi disasm) - disassembly utility for the chibi VM
(chibi heap-stats) - debugging tool to analyze or dump the heap
------------------------------------------------------------------------
C INTERFACE
See the file main.c for an example of using chibi-scheme as a library.
The basic usage involves creating a context for evaluation and loading
or evaluating Scheme source with it. Begin by including the eval.h
header file:
#include <chibi/eval.h>
then call
sexp_scheme_init();
with no parameters to initialize any globals (this actually does
nothing in the standard configuration but is a good idea to call
anyway).
Then you can use the following to create and manipulate contexts:
sexp_make_eval_context(context, stack, environment, heap_size)
Creates a new context with the given stack and environment.
If context is non-NULL, this will be the "parent" context and
the two contexts will share a heap. Otherwise, a new heap
will be allocated with heap_size, or a default size if heap_size
is zero. stack and environment may both also be NULL (and _must_
be NULL if context is NULL) and will be given standard defaults.
Thus the to create your first context you generally call:
sexp_make_eval_context(NULL, NULL, NULL, 0)
You can create as many contexts as you want, and other than those
sharing a heap they are all independent and thread-safe.
sexp_load_standard_env(context, env, version)
Loads the init.scm file in the environment env. Version refers
to the RnRS version number and should always be SEXP_FIVE. The
environment created with sexp_make_eval_context only contains
core syntactic forms and C primitives (thus for example it has
CAR but not CADR or LIST), so to get a full featured
environment, plus a module system with which to load additional
modules, you want to use this.
sexp_destroy_context(context)
Signals that you no longer need context, or any other context
sharing the heap. It will thus free() the context and heap and
all associated memory. Does nothing if using the Boehm GC.
Environments can be handled with the following:
sexp_context_env(context)
A macro returning the default environment associated with context.
sexp_env_define(context, env, symbol, value)
Define a variable in an environment.
sexp_env_ref(env, symbol, dflt)
Fetch the binding for symbol from the environment env,
returning the default dflt if the symbol is unbound.
You can evaluate code with the following utility:
sexp_eval(context, expr, env)
Evaluates an s-expression in an environment.
env can be NULL to use the context's default env.
sexp_eval_string(context, str, env)
Reads an s-expression from str and evaluates it in env.
sexp_load(context, file, env)
Read and eval all top-level forms from file in environment env.
As described in LOAD above, file may be a shared library.
To define new primitive functions from C, use sexp_define_foreign,
which takes a Scheme environment, a name, a number of arguments the C
function takes (not counting the context argument), and a C function.
/* sexp_define_foreign(context, env, name, num_args, f) */
sexp add (sexp context, sexp x, sexp y) {
return sexp_fx_add(x, y);
}
sexp_define_foreign(context, env, "add", 2, add);
You can also define functions with a single optional argument:
sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1));
See the SRFI-69 implementation for more detailed examples of this.
------------------------------------------------------------------------
FFI
Simple C FFI. "genstubs.scm file.stub" will read in the C function
FFI definitions from file.stub and output the appropriate C
wrappers into file.c. You can then compile that file with:
cc -fPIC -shared file.c -lchibi-scheme
(or using whatever flags are appropriate to generate shared libs on
your platform) and then the generated .so file can be loaded
directly with LOAD, or portably using (include-shared "file") in a
module definition (note that include-shared uses no suffix).
The goal of this interface is to make access to C types and
functions easy, without requiring the user to write any C code.
That means the stubber needs to be intelligent about various C
calling conventions and idioms, such as return values passed in
actual parameters. Writing C by hand is still possible, and
several of the core modules provide C interfaces directly without
using the stubber.
================================
Struct Interface
(define-c-struct struct-name
[predicate: predicate-name]
[constructor: constructor-name]
[finalizer: c_finalizer_name]
(type c_field_name getter-name setter-name) ...)
================================
Function Interface
(define-c return-type name-spec (arg-type ...))
where name-space is either a symbol name, or a list of
(scheme-name c_name). If just a symbol, the C name is taken
to be the same with -'s replaced by _'s.
arg-type is a type suitable for input validation and conversion.
================================
Types
Types
Basic Types
void
boolean
char
sexp (no conversions)
Integer Types:
signed-char short int long
unsigned-char unsigned-short unsigned-int unsigned-long size_t pid_t
time_t (in seconds, but using the chibi epoch of 2010/01/01)
errno (as a return type returns #f on error)
Float Types:
float double long-double
String Types:
string - a null-terminated char*
env-string - a VAR=VALUE string represented as a (VAR . VALUE) pair inScheme
in addition you can use (array char) as a string
Port Types:
input-port output-port
Struct Types:
Struct types are by default just referred to by the bare
struct-name from define-c-struct, and it is assumed you want a
pointer to that type. To refer to the full struct, use the struct
modifier, as in (struct struct-name).
Type modifiers
Any type may also be written as a list of modifiers followed by the
type itself. The supported modifiers are:
const: prepends the "const" C type modifier
* as a return or result parameter, makes non-immediates immutable
free: it's Scheme's responsibility to "free" this resource
* as a return or result parameter, registers the freep flag
this causes the type finalizer to be run when GCed
maybe-null: this pointer type may be NULL
* as a result parameter, NULL is translated to #f
normally this would just return a wrapped NULL pointer
* as an input parameter, #f is translated to NULL
normally this would be a type error
pointer: create a pointer to this type
* as a return parameter, wraps the result in a vanilla cpointer
* as a result parameter, boxes then unboxes the value
struct: treat this struct type as a struct, not a pointer
* as an input parameter, dereferences the pointer
* as a type field, indicates a nested struct
link: add a gc link
* as a field getter, link to the parent object, so the
parent won't be GCed so long as we have a reference
to the child. this behavior is automatic for nested
structs.
result: return a result in this parameter
* if there are multiple results (including the return type),
they are all returned in a list
* if there are any result parameters, a return type
of errno returns #f on failure, and as eliminated
from the list of results otherwise
(value <expr>): specify a fixed value
* as an input parameter, this parameter is not provided
in the Scheme API but always passed as <expr>
(default <expr>): specify a default value
* as the final input parameter, makes the Scheme parameter
optional, defaulting to <expr>
(array <type> [<length>]) an array type
* length must be specified for return and result parameters
* if specified, length can be any of
** an integer, for a fixed size
** the symbol null, indicating a NULL-terminated array

1
RELEASE Normal file
View file

@ -0,0 +1 @@
lithium

148
TODO Normal file
View file

@ -0,0 +1,148 @@
-*- org -*-
* compiler
** DONE ast rewrite
- State "DONE" [2009-04-09 Thu 14:32]
** DONE call/cc support
- State "DONE" [2009-04-09 Thu 14:36]
** DONE exceptions
- State "DONE" [2009-04-09 Thu 14:45]
** TODO native x86 backend
** TODO fasl/image files
** DONE shared stack on EVAL
- State "DONE" [2009-12-26 Sat 08:22]
* compiler optimizations
** DONE constant folding
- State "DONE" [2009-12-16 Wed 23:25]
** DONE simplification pass, dead-code elimination
- State "DONE" [2009-12-18 Fri 14:14]
This is important in particular for the output generated by
syntax-rules.
** TODO lambda lift
The current closure representation is not very efficient, so this
would help a lot.
** TODO inlining (and disabling primitive inlining)
Being able to redefine procedures is important though.
** TODO unsafe operations
Possibly, don't want to make things too complicated or unstable.
** TODO plugin infrastructure
** TODO type inference with warnings
* macros
** DONE hygiene
- State "DONE" [2009-04-09 Thu 14:41]
** DONE hygienic nested let-syntax
- State "DONE" [2009-12-08 Tue 14:41]
** DONE macroexpand utility
- State "DONE" [2009-12-08 Tue 14:41]
** DONE SRFI-46 basic syntax-rules extensions
- State "DONE" [2009-12-26 Sat 07:59]
** DONE (... ...) support
- State "DONE" [2009-12-26 Sat 02:06]
** TODO compiler macros
** TODO syntax-rules common pattern reduction
** TODO syntax-rules loop optimization
* garbage collection
** DONE precise gc rewrite
- State "DONE" [2009-06-22 Mon 14:27]
** DONE fix heap growing
- State "DONE" [2009-06-22 Mon 14:29]
** DONE separate gc heaps
- State "DONE" [2009-12-08 Tue 14:29]
** DONE add finalizers
- State "DONE" [2009-12-08 Tue 14:29]
** TODO support weak references
* runtime
** DONE bignums
- State "DONE" [2009-07-07 Tue 14:42]
** TODO unicode
** TODO threads
** TODO virtual ports
** DONE dynamic-wind
- State "DONE" [2009-12-26 Sat 01:51]
Adapted a version from Scheme48.
** DONE recursive disasm
- State "DONE" [2009-12-18 Fri 14:15]
* FFI
** DONE libdl support
- State "DONE" [2009-12-08 Tue 14:45]
** DONE opcode generation interface
- State "DONE" [2009-11-15 Sun 14:45]
** DONE stub generator
- State "DONE" [2009-12-26 Sat 01:50]
*** DONE define-c-struct
- State "DONE" [2009-11-29 Sun 14:48]
*** DONE define-c
- State "DONE" [2009-11-29 Sun 14:48]
*** DONE array return types
- State "DONE" [2009-12-26 Sat 01:49]
*** DONE pre-buffered string types (like getcwd)
- State "DONE" [2009-12-26 Sat 01:49]
* module system
** DONE scheme48-like config language
- State "DONE" [2009-10-13 Tue 14:38]
** DONE shared library includes
- State "DONE" [2009-12-08 Tue 14:39]
** DONE only/except/rename/prefix modifiers
- State "DONE" [2009-12-16 Wed 18:57]
** TODO scheme-complete.el support
** DONE access individual modules from repl
- State "DONE" [2009-12-26 Sat 01:49]
* core modules
** DONE SRFI-0 cond-expand
- State "DONE" [2009-12-16 Wed 20:12]
** DONE SRFI-9 define-record-type
- State "DONE" [2009-12-08 Tue 14:50]
** DONE SRFI-69 hash-tables
- State "DONE" [2009-11-15 Sun 14:50]
** DONE match library
- State "DONE" [2009-12-08 Tue 14:54]
** DONE loop library
- State "DONE" [2009-12-08 Tue 14:54]
** TODO network interface
** TODO posix interface
Splitting this into several parts.
*** DONE filesystem interface
- State "DONE" [2009-12-26 Sat 01:50]
*** DONE process interface
- State "DONE" [2009-12-26 Sat 01:50]
*** DONE time interface
- State "DONE" [2009-12-26 Sat 01:50]
*** TODO host system interface
** DONE pathname library
- State "DONE" [2009-12-16 Wed 18:58]
** DONE uri library
- State "DONE" [2009-12-16 Wed 18:58]
** TODO http library
** TODO show (formatting) library
** TODO zip library
** TODO tar library
** TODO md5sum library
* ports
** DONE basic mingw support
- State "DONE" [2009-06-22 Mon 14:36]
** DONE Plan 9 support
- State "DONE" [2009-08-10 Mon 14:37]
** DONE 64-bit support
- State "DONE" [2009-11-01 Sun 14:37]
** TODO iPhone support
** TODO bare-metal support
* miscellaneous
** TODO overall cleanup
** TODO user documentation
** TODO thorough source documentation
** TODO full test suite for libraries
* distribution
** TODO packaging format
** TODO code repository with fetch+install tool
** TODO translator to/from other implementations

1
VERSION Normal file
View file

@ -0,0 +1 @@
0.3

133
doc/chibi-scheme.1 Normal file
View file

@ -0,0 +1,133 @@
.TH "chibi-scheme" "1" "" ""
.UC 4
.SH NAME
.PP
chibi-scheme \- a tiny Scheme interpreter
.SH SYNOPSIS
.B chibi-scheme
[-qV]
[-I
.I path
]
[-A
.I path
]
[-u
.I module
]
[-l
.I file
]
[-e
.I expr
]
[-p
.I expr
]
[--]
[
.I script argument ...
]
.br
.sp 0.3
.SH DESCRIPTION
.I chibi-scheme
is a sample interactive Scheme interpreter for the
.I chibi-scheme
library. It serves as an example of how to embed
.I chibi-scheme
in applications, and can be useful on its own for writing
scripts and interactive development.
When
.I script
is given, the script will be loaded with SRFI-22 semantics,
calling the procedure
.I main
(if defined) with a single parameter as a list of the
command-line arguments beginning with the script name.
Otherwise, if no script is given and no -e or -p options
are given an interactive repl is entered, reading, evaluating,
then printing expressions until EOF is reached. The repl
provided is very minimal - if you want readline
completion you may want to wrap it with the
.I rlwrap(1)
program. Signals aren't caught either - to enable handling keyboard
interrupts you can use the (chibi process) module.
.SH OPTIONS
.TP 5
.BI -V
Prints the version information and exits.
.TP
.BI -q
Don't load the initialization file. The resulting
environment will only contain the core syntactic forms
and primitives coded in C.
.TP
.BI -h size
Specifies the initial size of the heap, in bytes.
.I size
can be any integer value, optionally suffixed by
"K" for kilobytes, or "M" for megabytes.
.I -h
must be specified before any options which load or
evaluate Scheme code.
.TP
.BI -I path
Inserts
.I path
on front of the load path list.
.TP
.BI -A path
Appends
.I path
to the load path list.
.TP
.BI -m module
Imports
.I module
as though "(import
.I module
)" were evaluated. However, to reduce the need for shell
escapes, modules are written in a dot notation, so that the module
.I (foo bar)
is written as
.I foo.bar
.TP
.BI -l file
Loads the Scheme source from the file
.I file
searched for in the default load path.
.TP
.BI -e expr
Evaluates the Scheme expression
.I expr.
.TP
.BI -p expr
Evaluates the Scheme expression
.I expr
then prints the result to stdout.
.SH ENVIRONMENT
.TP
.B CHIBI_MODULE_PATH
.TQ
A colon separated list of directories to search for module
files, inserted before the system default load paths.
.SH AUTHORS
.PP
Alex Shinn (alexshinn @ gmail . com)
.SH SEE ALSO
.PP
More detailed information can be found in the README file
included in the distribution.
The chibi-scheme home-page:
.br
http://code.google.com/p/chibi-scheme/

2737
eval.c Normal file
View file

File diff suppressed because it is too large Load diff

250
gc.c Normal file
View file

@ -0,0 +1,250 @@
/* gc.c -- simple mark&sweep garbage collector */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include "chibi/sexp.h"
/* These settings are configurable but only recommended for */
/* experienced users, so they're not in config.h. */
/* the initial heap size in bytes */
#ifndef SEXP_INITIAL_HEAP_SIZE
#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024)
#endif
/* the maximum heap size in bytes - if 0 there is no limit */
#ifndef SEXP_MAXIMUM_HEAP_SIZE
#define SEXP_MAXIMUM_HEAP_SIZE 0
#endif
#ifndef SEXP_MINIMUM_HEAP_SIZE
#define SEXP_MINIMUM_HEAP_SIZE 512*1024
#endif
/* if after GC more than this percentage of memory is still in use, */
/* and we've not exceeded the maximum size, grow the heap */
#ifndef SEXP_GROW_HEAP_RATIO
#define SEXP_GROW_HEAP_RATIO 0.75
#endif
#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair))
#if SEXP_64_BIT
#define sexp_heap_align(n) sexp_align(n, 5)
#else
#define sexp_heap_align(n) sexp_align(n, 4)
#endif
#if SEXP_USE_GLOBAL_HEAP
sexp_heap sexp_global_heap;
#endif
#if SEXP_USE_DEBUG_GC
static sexp* stack_base;
#endif
static sexp_heap sexp_heap_last (sexp_heap h) {
while (h->next) h = h->next;
return h;
}
sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) {
sexp_uint_t res;
sexp t;
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
return sexp_heap_align(1);
t = sexp_object_type(ctx, x);
res = sexp_type_size_of_object(t, x);
return res;
}
void sexp_mark (sexp ctx, sexp x) {
sexp_sint_t i, len;
sexp t, *p;
struct sexp_gc_var_t *saves;
loop:
if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x))
return;
sexp_gc_mark(x) = 1;
if (sexp_contextp(x))
for (saves=sexp_context_saves(x); saves; saves=saves->next)
if (saves->var) sexp_mark(ctx, *(saves->var));
t = sexp_object_type(ctx, x);
p = (sexp*) (((char*)x) + sexp_type_field_base(t));
len = sexp_type_num_slots_of_object(t, x) - 1;
if (len >= 0) {
for (i=0; i<len; i++)
sexp_mark(ctx, p[i]);
x = p[len];
goto loop;
}
}
#if SEXP_USE_DEBUG_GC
int stack_references_pointer_p (sexp ctx, sexp x) {
sexp *p;
for (p=(&x)+1; p<stack_base; p++)
if (*p == x)
return 1;
return 0;
}
#else
#define stack_references_pointer_p(ctx, x) 0
#endif
sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
size_t freed, max_freed=0, sum_freed=0, size;
sexp_heap h = sexp_context_heap(ctx);
sexp p;
sexp_free_list q, r, s;
char *end;
sexp_proc2 finalizer;
/* scan over the whole heap */
for ( ; h; h=h->next) {
p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair)));
q = h->free_list;
end = (char*)h->data + h->size;
while (((char*)p) < end) {
/* find the preceding and succeeding free list pointers */
for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
;
if ((char*)r == (char*)p) {
p = (sexp) (((char*)p) + r->size);
continue;
}
size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) {
/* free p */
finalizer = sexp_type_finalize(sexp_object_type(ctx, p));
if (finalizer) finalizer(ctx, p);
sum_freed += size;
if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) {
/* merge q with p */
if (r && ((((char*)p)+size) == (char*)r)) {
/* ... and with r */
q->next = r->next;
freed = q->size + size + r->size;
p = (sexp) (((char*)p) + size + r->size);
} else {
freed = q->size + size;
p = (sexp) (((char*)p)+size);
}
q->size = freed;
} else {
s = (sexp_free_list)p;
if (r && ((((char*)p)+size) == (char*)r)) {
/* merge p with r */
s->size = size + r->size;
s->next = r->next;
q->next = s;
freed = size + r->size;
} else {
s->size = size;
s->next = r;
q->next = s;
freed = size;
}
p = (sexp) (((char*)p)+freed);
}
if (freed > max_freed)
max_freed = freed;
} else {
sexp_gc_mark(p) = 0;
p = (sexp) (((char*)p)+size);
}
}
}
sum_freed_ptr[0] = sum_freed;
return sexp_make_fixnum(max_freed);
}
sexp sexp_gc (sexp ctx, size_t *sum_freed) {
sexp res;
#if SEXP_USE_GLOBAL_SYMBOLS
int i;
for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
sexp_mark(ctx, sexp_symbol_table[i]);
#endif
sexp_mark(ctx, ctx);
res = sexp_sweep(ctx, sum_freed);
return res;
}
sexp_heap sexp_make_heap (size_t size) {
sexp_free_list free, next;
sexp_heap h
= (sexp_heap) malloc(sizeof(struct sexp_heap) + size + sexp_heap_align(1));
if (! h) return NULL;
h->size = size;
h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data));
free = h->free_list = (sexp_free_list) h->data;
h->next = NULL;
next = (sexp_free_list) ((char*)free + sexp_heap_align(sexp_sizeof(pair)));
free->size = 0; /* actually sexp_sizeof(pair) */
free->next = next;
next->size = size - sexp_heap_align(sexp_sizeof(pair));
next->next = NULL;
return h;
}
int sexp_grow_heap (sexp ctx, size_t size) {
size_t cur_size, new_size;
sexp_heap h = sexp_heap_last(sexp_context_heap(ctx));
cur_size = h->size;
new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2);
h->next = sexp_make_heap(new_size);
return (h->next != NULL);
}
void* sexp_try_alloc (sexp ctx, size_t size) {
sexp_free_list ls1, ls2, ls3;
sexp_heap h;
for (h=sexp_context_heap(ctx); h; h=h->next)
for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next)
if (ls2->size >= size) {
if (ls2->size >= (size + SEXP_MINIMUM_OBJECT_SIZE)) {
ls3 = (sexp_free_list) (((char*)ls2)+size); /* the tail after ls2 */
ls3->size = ls2->size - size;
ls3->next = ls2->next;
ls1->next = ls3;
} else { /* take the whole chunk */
ls1->next = ls2->next;
}
memset((void*)ls2, 0, size);
return ls2;
}
return NULL;
}
void* sexp_alloc (sexp ctx, size_t size) {
void *res;
size_t max_freed, sum_freed;
sexp_heap h;
size = sexp_heap_align(size);
res = sexp_try_alloc(ctx, size);
if (! res) {
max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed));
h = sexp_heap_last(sexp_context_heap(ctx));
if (((max_freed < size)
|| ((h->size - sum_freed) > (h->size*SEXP_GROW_HEAP_RATIO)))
&& ((! SEXP_MAXIMUM_HEAP_SIZE) || (h->size < SEXP_MAXIMUM_HEAP_SIZE)))
sexp_grow_heap(ctx, size);
res = sexp_try_alloc(ctx, size);
if (! res)
res = sexp_global(ctx, SEXP_G_OOM_ERROR);
}
return res;
}
void sexp_gc_init (void) {
#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_DEBUG_GC
sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE);
#endif
#if SEXP_USE_GLOBAL_HEAP
sexp_global_heap = sexp_make_heap(size);
#endif
#if SEXP_USE_DEBUG_GC
/* the +32 is a hack, but this is just for debugging anyway */
stack_base = ((sexp*)&size) + 32;
#endif
}

43
include/chibi/bignum.h Normal file
View file

@ -0,0 +1,43 @@
/* bignum.h -- header for bignum utilities */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#ifndef SEXP_BIGNUM_H
#define SEXP_BIGNUM_H
#if (SEXP_64_BIT)
typedef unsigned int uint128_t __attribute__((mode(TI)));
typedef int sint128_t __attribute__((mode(TI)));
typedef uint128_t sexp_luint_t;
typedef sint128_t sexp_lsint_t;
#else
typedef unsigned long long sexp_luint_t;
typedef long long sexp_lsint_t;
#endif
sexp_sint_t sexp_bignum_compare (sexp a, sexp b);
sexp sexp_compare (sexp ctx, sexp a, sexp b);
sexp sexp_make_bignum (sexp ctx, sexp_uint_t len);
sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len);
sexp sexp_bignum_normalize (sexp a);
sexp_uint_t sexp_bignum_hi (sexp a);
sexp sexp_fixnum_to_bignum (sexp ctx, sexp a);
double sexp_bignum_to_double (sexp a);
sexp sexp_double_to_bignum (sexp ctx, double f);
sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b);
sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset);
sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset);
sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b);
sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b);
sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b);
sexp sexp_bignum_div (sexp ctx, sexp dst, sexp a, sexp b);
sexp sexp_bignum_expt (sexp ctx, sexp n, sexp e);
sexp sexp_add (sexp ctx, sexp a, sexp b);
sexp sexp_sub (sexp ctx, sexp a, sexp b);
sexp sexp_mul (sexp ctx, sexp a, sexp b);
sexp sexp_div (sexp ctx, sexp a, sexp b);
sexp sexp_quotient (sexp ctx, sexp a, sexp b);
sexp sexp_remainder (sexp ctx, sexp a, sexp b);
#endif /* ! SEXP_BIGNUM_H */

165
include/chibi/eval.h Normal file
View file

@ -0,0 +1,165 @@
/* eval.h -- headers for eval library */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#ifndef SEXP_EVAL_H
#define SEXP_EVAL_H
#include "chibi/sexp.h"
/************************* additional types ***************************/
#define SEXP_INIT_BCODE_SIZE 128
#define SEXP_INIT_STACK_SIZE 8192
#define sexp_init_file "init.scm"
#define sexp_config_file "config.scm"
enum sexp_core_form_names {
SEXP_CORE_DEFINE = 1,
SEXP_CORE_SET,
SEXP_CORE_LAMBDA,
SEXP_CORE_IF,
SEXP_CORE_BEGIN,
SEXP_CORE_QUOTE,
SEXP_CORE_SYNTAX_QUOTE,
SEXP_CORE_DEFINE_SYNTAX,
SEXP_CORE_LET_SYNTAX,
SEXP_CORE_LETREC_SYNTAX
};
enum sexp_opcode_classes {
SEXP_OPC_GENERIC = 1,
SEXP_OPC_TYPE_PREDICATE,
SEXP_OPC_PREDICATE,
SEXP_OPC_ARITHMETIC,
SEXP_OPC_ARITHMETIC_INV,
SEXP_OPC_ARITHMETIC_CMP,
SEXP_OPC_IO,
SEXP_OPC_CONSTRUCTOR,
SEXP_OPC_ACCESSOR,
SEXP_OPC_PARAMETER,
SEXP_OPC_FOREIGN,
SEXP_OPC_NUM_OP_CLASSES
};
enum sexp_opcode_names {
SEXP_OP_NOOP,
SEXP_OP_RAISE,
SEXP_OP_RESUMECC,
SEXP_OP_CALLCC,
SEXP_OP_APPLY1,
SEXP_OP_TAIL_CALL,
SEXP_OP_CALL,
SEXP_OP_FCALL0,
SEXP_OP_FCALL1,
SEXP_OP_FCALL2,
SEXP_OP_FCALL3,
SEXP_OP_FCALL4,
SEXP_OP_FCALL5,
SEXP_OP_FCALL6,
SEXP_OP_JUMP_UNLESS,
SEXP_OP_JUMP,
SEXP_OP_PUSH,
SEXP_OP_DROP,
SEXP_OP_GLOBAL_REF,
SEXP_OP_GLOBAL_KNOWN_REF,
SEXP_OP_STACK_REF,
SEXP_OP_LOCAL_REF,
SEXP_OP_LOCAL_SET,
SEXP_OP_CLOSURE_REF,
SEXP_OP_VECTOR_REF,
SEXP_OP_VECTOR_SET,
SEXP_OP_VECTOR_LENGTH,
SEXP_OP_STRING_REF,
SEXP_OP_STRING_SET,
SEXP_OP_STRING_LENGTH,
SEXP_OP_MAKE_PROCEDURE,
SEXP_OP_MAKE_VECTOR,
SEXP_OP_MAKE_EXCEPTION,
SEXP_OP_AND,
SEXP_OP_NULLP,
SEXP_OP_FIXNUMP,
SEXP_OP_SYMBOLP,
SEXP_OP_CHARP,
SEXP_OP_EOFP,
SEXP_OP_TYPEP,
SEXP_OP_MAKE,
SEXP_OP_SLOT_REF,
SEXP_OP_SLOT_SET,
SEXP_OP_CAR,
SEXP_OP_CDR,
SEXP_OP_SET_CAR,
SEXP_OP_SET_CDR,
SEXP_OP_CONS,
SEXP_OP_ADD,
SEXP_OP_SUB,
SEXP_OP_MUL,
SEXP_OP_DIV,
SEXP_OP_QUOTIENT,
SEXP_OP_REMAINDER,
SEXP_OP_NEGATIVE,
SEXP_OP_INVERSE,
SEXP_OP_LT,
SEXP_OP_LE,
SEXP_OP_EQN,
SEXP_OP_EQ,
SEXP_OP_FIX2FLO,
SEXP_OP_FLO2FIX,
SEXP_OP_CHAR2INT,
SEXP_OP_INT2CHAR,
SEXP_OP_CHAR_UPCASE,
SEXP_OP_CHAR_DOWNCASE,
SEXP_OP_WRITE_CHAR,
SEXP_OP_NEWLINE,
SEXP_OP_READ_CHAR,
SEXP_OP_PEEK_CHAR,
SEXP_OP_RET,
SEXP_OP_DONE,
SEXP_OP_NUM_OPCODES
};
/**************************** prototypes ******************************/
SEXP_API void sexp_scheme_init (void);
SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size);
SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda);
SEXP_API sexp sexp_analyze (sexp context, sexp x);
SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env);
SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env);
SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env);
SEXP_API sexp sexp_make_env (sexp context);
SEXP_API sexp sexp_make_null_env (sexp context, sexp version);
SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version);
SEXP_API sexp sexp_make_standard_env (sexp context, sexp version);
SEXP_API sexp sexp_load_standard_parameters (sexp context, sexp env);
SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version);
SEXP_API sexp sexp_find_module_file (sexp ctx, char *file);
SEXP_API sexp sexp_load_module_file (sexp ctx, char *file, sexp env);
SEXP_API sexp sexp_add_module_directory (sexp ctx, sexp dir, sexp appendp);
SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value);
SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls, sexp immutp);
SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val);
SEXP_API sexp sexp_env_cell (sexp env, sexp sym);
SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt);
SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt);
SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out);
SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data);
SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, int flags, sexp_proc1 f, sexp data);
#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL)
#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d)
SEXP_API sexp sexp_define_foreign_param (sexp ctx, sexp env, char *name, int num_args, sexp_proc1 f, char *param);
#if SEXP_USE_TYPE_DEFS
SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type);
SEXP_API sexp sexp_make_constructor (sexp ctx, sexp name, sexp type);
SEXP_API sexp sexp_make_getter (sexp ctx, sexp name, sexp type, sexp index);
SEXP_API sexp sexp_make_setter (sexp ctx, sexp name, sexp type, sexp index);
#endif
#endif /* ! SEXP_EVAL_H */

297
include/chibi/features.h Normal file
View file

@ -0,0 +1,297 @@
/* features.h -- general feature configuration */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
/* uncomment this to disable most features */
/* Most features are enabled by default, but setting this */
/* option will disable any not explicitly enabled. */
/* #define SEXP_USE_NO_FEATURES 1 */
/* uncomment this to disable the module system */
/* Currently this just loads the config.scm from main and */
/* sets up an (import (module name)) macro. */
/* #define SEXP_USE_MODULES 0 */
/* uncomment this to disable dynamic loading */
/* If enabled, you can LOAD .so files with a */
/* sexp_init_library(ctx, env) function provided. */
/* #define SEXP_USE_DL 0 */
/* uncomment this to disable a simplifying optimization pass */
/* This performs some simple optimizations such as dead-code */
/* elimination, constant-folding, and directly propagating */
/* non-mutated let values bound to constants or non-mutated */
/* references. More than performance, this is aimed at reducing the */
/* size of the compiled code, especially as the result of macro */
/* expansions, so it's a good idea to leave it enabled. */
/* #define SEXP_USE_SIMPLIFY 0 */
/* uncomment this to disable dynamic type definitions */
/* This enables register-simple-type and related */
/* opcodes for defining types, needed by the default */
/* implementation of (srfi 9). */
/* #define SEXP_USE_TYPE_DEFS 0 */
/* uncomment this to use the Boehm conservative GC */
/* Conservative GCs make it easier to write extensions, */
/* since you don't have to keep track of intermediate */
/* variables, but can leak memory. Boehm is also a */
/* very large library to link in. You may want to */
/* enable this when debugging your own extensions, or */
/* if you suspect a bug in the native GC. */
/* #define SEXP_USE_BOEHM 1 */
/* uncomment this to just malloc manually instead of any GC */
/* Mostly for debugging purposes, this is the no GC option. */
/* You can use just the read/write API and */
/* explicitly free sexps, though. */
/* #define SEXP_USE_MALLOC 1 */
/* uncomment this to add conservative checks to the native GC */
/* Please mail the author if enabling this makes a bug */
/* go away and you're not working on your own C extension. */
/* #define SEXP_USE_DEBUG_GC 1 */
/* uncomment this to make the heap common to all contexts */
/* By default separate contexts can have separate heaps, */
/* and are thus thread-safe and independant. */
/* #define SEXP_USE_GLOBAL_HEAP 1 */
/* uncomment this to make type definitions common to all contexts */
/* By default types are only global if you don't allow user type */
/* definitions, so new types will be local to a given set of */
/* contexts sharing thei heap. */
/* #define SEXP_USE_GLOBAL_TYPES 1 */
/* uncomment this to make the symbol table common to all contexts */
/* Will still be restricted to all contexts sharing the same */
/* heap, of course. */
/* #define SEXP_USE_GLOBAL_SYMBOLS 1 */
/* uncomment this if you don't need flonum support */
/* This is only for EVAL - you'll still be able to read */
/* and write flonums directly through the sexp API. */
/* #define SEXP_USE_FLONUMS 0 */
/* uncomment this to disable reading/writing IEEE infinities */
/* By default you can read/write +inf.0, -inf.0 and +nan.0 */
/* #define SEXP_USE_INFINITIES 0 */
/* uncomment this if you want immediate flonums */
/* This is experimental, enable at your own risk. */
/* #define SEXP_USE_IMMEDIATE_FLONUMS 1 */
/* uncomment this if you don't want bignum support */
/* Bignums are implemented with a small, custom library */
/* in opt/bignum.c. */
/* #define SEXP_USE_BIGNUMS 0 */
/* uncomment this if you don't need extended math operations */
/* This includes the trigonometric and expt functions. */
/* Automatically disabled if you've disabled flonums. */
/* #define SEXP_USE_MATH 0 */
/* uncomment this to disable warning about references to undefined variables */
/* This is something of a hack, but can be quite useful. */
/* It's very fast and doesn't involve any separate analysis */
/* passes. */
/* #define SEXP_USE_WARN_UNDEFS 0 */
/* uncomment this to disable huffman-coded immediate symbols */
/* By default (this may change) small symbols are represented */
/* as immediates using a simple huffman encoding. This keeps */
/* the symbol table small, and minimizes hashing when doing a */
/* lot of reading. */
/* #define SEXP_USE_HUFF_SYMS 0 */
/* uncomment this to just use a single list for hash tables */
/* You can trade off some space in exchange for longer read */
/* times by disabling hashing and just putting all */
/* non-immediate symbols in a single list. */
/* #define SEXP_USE_HASH_SYMS 0 */
/* uncomment this to disable string ports */
/* If disabled some basic functionality such as number->string */
/* will not be available by default. */
/* #define SEXP_USE_STRING_STREAMS 0 */
/* uncomment this to disable automatic closing of ports */
/* If enabled, the underlying FILE* for file ports will be */
/* automatically closed when they're garbage collected. Doesn't */
/* apply to stdin/stdout/stderr. */
/* #define SEXP_USE_AUTOCLOSE_PORTS 0 */
/* uncomment this to use the normal 1970 unix epoch */
/* By default chibi uses an datetime epoch starting at */
/* 2010/01/01 00:00:00 in order to be able to represent */
/* more common times as fixnums. */
/* #define SEXP_USE_2010_EPOCH 0 */
/* uncomment this to disable stack overflow checks */
/* By default stacks are fairly small, so it's good to leave */
/* this enabled. */
/* #define SEXP_USE_CHECK_STACK 0 */
/* #define SEXP_USE_DEBUG_VM 0 */
/* Experts only. */
/* For *very* verbose output on every VM operation. */
/************************************************************************/
/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */
/************************************************************************/
#ifndef SEXP_64_BIT
#if defined(__amd64) || defined(__x86_64)
#define SEXP_64_BIT 1
#else
#define SEXP_64_BIT 0
#endif
#endif
#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
#define SEXP_BSD 1
#else
#define SEXP_BSD 0
#define _GNU_SOURCE
#endif
#ifndef SEXP_USE_NO_FEATURES
#define SEXP_USE_NO_FEATURES 0
#endif
#ifndef SEXP_USE_MODULES
#define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_TYPE_DEFS
#define SEXP_USE_TYPE_DEFS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_MAXIMUM_TYPES
#define SEXP_MAXIMUM_TYPES ((sexp_tag_t)-1)
#endif
#ifndef SEXP_USE_DL
#ifdef PLAN9
#define SEXP_USE_DL 0
#else
#define SEXP_USE_DL ! SEXP_USE_NO_FEATURES
#endif
#endif
#ifndef SEXP_USE_SIMPLIFY
#define SEXP_USE_SIMPLIFY ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_BOEHM
#define SEXP_USE_BOEHM 0
#endif
#ifndef SEXP_USE_MALLOC
#define SEXP_USE_MALLOC 0
#endif
#ifndef SEXP_USE_DEBUG_GC
#define SEXP_USE_DEBUG_GC 0
#endif
#ifndef SEXP_USE_GLOBAL_HEAP
#if SEXP_USE_BOEHM || SEXP_USE_MALLOC
#define SEXP_USE_GLOBAL_HEAP 1
#else
#define SEXP_USE_GLOBAL_HEAP 0
#endif
#endif
#ifndef SEXP_USE_GLOBAL_TYPES
#define SEXP_USE_GLOBAL_TYPES (! SEXP_USE_TYPE_DEFS)
#endif
#ifndef SEXP_USE_GLOBAL_SYMBOLS
#if SEXP_USE_BOEHM || SEXP_USE_MALLOC
#define SEXP_USE_GLOBAL_SYMBOLS 1
#else
#define SEXP_USE_GLOBAL_SYMBOLS 0
#endif
#endif
#ifndef SEXP_USE_FLONUMS
#define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_INFINITIES
#if defined(PLAN9) || ! SEXP_USE_FLONUMS
#define SEXP_USE_INFINITIES 0
#else
#define SEXP_USE_INFINITIES ! SEXP_USE_NO_FEATURES
#endif
#endif
#ifndef SEXP_USE_IMMEDIATE_FLONUMS
#define SEXP_USE_IMMEDIATE_FLONUMS 0
#endif
#ifndef SEXP_USE_BIGNUMS
#define SEXP_USE_BIGNUMS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_MATH
#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_WARN_UNDEFS
#define SEXP_USE_WARN_UNDEFS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_HUFF_SYMS
#define SEXP_USE_HUFF_SYMS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_HASH_SYMS
#define SEXP_USE_HASH_SYMS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_DEBUG_VM
#define SEXP_USE_DEBUG_VM 0
#endif
#ifndef SEXP_USE_STRING_STREAMS
#define SEXP_USE_STRING_STREAMS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_AUTOCLOSE_PORTS
#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_USE_2010_EPOCH
#define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES
#endif
#ifndef SEXP_EPOCH_OFFSET
#if SEXP_USE_2010_EPOCH
#define SEXP_EPOCH_OFFSET 1262271600
#else
#define SEXP_EPOCH_OFFSET 0
#endif
#endif
#ifndef SEXP_USE_CHECK_STACK
#define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES
#endif
#ifdef PLAN9
#define strcasecmp cistrcmp
#define strncasecmp cistrncmp
#define round(x) floor((x)+0.5)
#define trunc(x) floor((x)+0.5*(((x)<0)?1:0))
#endif
#ifdef __MINGW32__
#ifdef BUILDING_DLL
#define SEXP_API __declspec(dllexport)
#else
#define SEXP_API __declspec(dllimport)
#endif
#else
#define SEXP_API
#endif

862
include/chibi/sexp.h Normal file
View file

@ -0,0 +1,862 @@
/* sexp.h -- header for sexp library */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#ifndef SEXP_H
#define SEXP_H
#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH"
#include "chibi/features.h"
#include "chibi/install.h"
#include <ctype.h>
#include <stdio.h>
#if SEXP_USE_DL
#include <dlfcn.h>
#endif
#ifdef PLAN9
#include <u.h>
#include <libc.h>
#include <fcall.h>
#include <thread.h>
#include <9p.h>
typedef unsigned long size_t;
#else
#include <stddef.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <math.h>
#endif
/* tagging system
* bits end in 00: pointer
* 01: fixnum
* 011: immediate flonum (optional)
* 111: immediate symbol (optional)
* 0110: char
* 1110: other immediate object (NULL, TRUE, FALSE)
*/
#define SEXP_FIXNUM_BITS 2
#define SEXP_IMMEDIATE_BITS 3
#define SEXP_EXTENDED_BITS 4
#define SEXP_FIXNUM_MASK 3
#define SEXP_IMMEDIATE_MASK 7
#define SEXP_EXTENDED_MASK 15
#define SEXP_POINTER_TAG 0
#define SEXP_FIXNUM_TAG 1
#define SEXP_ISYMBOL_TAG 7
#define SEXP_IFLONUM_TAG 3
#define SEXP_CHAR_TAG 6
#define SEXP_EXTENDED_TAG 14
#if SEXP_USE_HASH_SYMS
#define SEXP_SYMBOL_TABLE_SIZE 389
#else
#define SEXP_SYMBOL_TABLE_SIZE 1
#endif
enum sexp_types {
SEXP_OBJECT,
SEXP_TYPE,
SEXP_FIXNUM,
SEXP_CHAR,
SEXP_BOOLEAN,
SEXP_PAIR,
SEXP_SYMBOL,
SEXP_STRING,
SEXP_VECTOR,
SEXP_FLONUM,
SEXP_BIGNUM,
SEXP_CPOINTER,
SEXP_IPORT,
SEXP_OPORT,
SEXP_EXCEPTION,
SEXP_PROCEDURE,
SEXP_MACRO,
SEXP_SYNCLO,
SEXP_ENV,
SEXP_BYTECODE,
SEXP_CORE,
SEXP_OPCODE,
SEXP_LAMBDA,
SEXP_CND,
SEXP_REF,
SEXP_SET,
SEXP_SEQ,
SEXP_LIT,
SEXP_STACK,
SEXP_CONTEXT,
SEXP_NUM_CORE_TYPES
};
typedef unsigned long sexp_uint_t;
typedef long sexp_sint_t;
#if SEXP_64_BIT
typedef unsigned int sexp_tag_t;
#else
typedef unsigned short sexp_tag_t;
#endif
typedef struct sexp_struct *sexp;
#define __HALF_MAX_SIGNED(type) ((type)1 << (sizeof(type)*8-2))
#define __MAX_SIGNED(type) (__HALF_MAX_SIGNED(type) - 1 + __HALF_MAX_SIGNED(type))
#define __MIN_SIGNED(type) (-1 - __MAX_SIGNED(type))
#define SEXP_UINT_T_MAX ((sexp_uint_t)-1)
#define SEXP_UINT_T_MIN (0)
#define SEXP_SINT_T_MAX __MAX_SIGNED(sexp_sint_t)
#define SEXP_SINT_T_MIN __MIN_SIGNED(sexp_sint_t)
#define SEXP_MAX_FIXNUM ((((sexp_sint_t)1)<<(sizeof(sexp_sint_t)*8-SEXP_FIXNUM_BITS-1))-1)
#define SEXP_MIN_FIXNUM (-SEXP_MAX_FIXNUM-1)
/* procedure types */
typedef sexp (*sexp_proc0) (void);
typedef sexp (*sexp_proc1) (sexp);
typedef sexp (*sexp_proc2) (sexp, sexp);
typedef sexp (*sexp_proc3) (sexp, sexp, sexp);
typedef sexp (*sexp_proc4) (sexp, sexp, sexp, sexp);
typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp);
typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp);
typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp);
typedef struct sexp_free_list *sexp_free_list;
struct sexp_free_list {
sexp_uint_t size;
sexp_free_list next;
};
typedef struct sexp_heap *sexp_heap;
struct sexp_heap {
sexp_uint_t size;
sexp_free_list free_list;
sexp_heap next;
char *data;
};
struct sexp_gc_var_t {
sexp *var;
/* char *name; */
struct sexp_gc_var_t *next;
};
struct sexp_struct {
sexp_tag_t tag;
char gc_mark;
unsigned int immutablep:1;
unsigned int freep:1;
union {
/* basic types */
double flonum;
struct {
sexp_tag_t tag;
short field_base, field_eq_len_base, field_len_base, field_len_off;
unsigned short field_len_scale;
short size_base, size_off;
unsigned short size_scale;
char *name;
sexp_proc2 finalize;
} type;
struct {
sexp car, cdr;
sexp source;
} pair;
struct {
sexp_uint_t length;
sexp data[];
} vector;
struct {
sexp_uint_t length;
char data[];
} string;
struct {
sexp string;
} symbol;
struct {
FILE *stream;
char *buf;
char openp, sourcep;
sexp_uint_t offset, line;
size_t size;
sexp name;
sexp cookie;
} port;
struct {
sexp kind, message, irritants, procedure, source;
} exception;
struct {
char sign;
sexp_uint_t length;
sexp_uint_t data[];
} bignum;
struct {
sexp_uint_t length;
void *value;
sexp parent;
char body[];
} cpointer;
/* runtime types */
struct {
unsigned int syntacticp:1;
sexp parent, lambda, bindings;
} env;
struct {
sexp_uint_t length;
sexp name, literals;
unsigned char data[];
} bytecode;
struct {
char flags;
unsigned short num_args;
sexp bc, vars;
} procedure;
struct {
sexp proc, env;
} macro;
struct {
sexp env, free_vars, expr;
} synclo;
struct {
unsigned char op_class, code, num_args, flags,
arg1_type, arg2_type, inverse;
char *name;
sexp data, data2, proc;
sexp_proc1 func;
} opcode;
struct {
char code;
char *name;
} core;
/* ast types */
struct {
sexp name, params, body, defs, locals, flags, fv, sv;
} lambda;
struct {
sexp test, pass, fail;
} cnd;
struct {
sexp var, value;
} set;
struct {
sexp name, cell;
} ref;
struct {
sexp ls;
} seq;
struct {
sexp value;
} lit;
/* compiler state */
struct {
sexp_uint_t length, top;
sexp data[];
} stack;
struct {
sexp_heap heap;
struct sexp_gc_var_t *saves;
sexp_uint_t pos, depth, tailp, tracep;
sexp bc, lambda, stack, env, fv, parent, globals;
} context;
} value;
};
#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<<SEXP_EXTENDED_BITS) \
+ SEXP_EXTENDED_TAG))
#define SEXP_NULL SEXP_MAKE_IMMEDIATE(0) /* 14 0x0e */
#define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1) /* 30 0x1e */
#define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2) /* 46 0x2e */
#define SEXP_EOF SEXP_MAKE_IMMEDIATE(3) /* 62 0x3e */
#define SEXP_VOID SEXP_MAKE_IMMEDIATE(4) /* the unspecified value */
#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(5) /* internal use */
#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */
#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */
#if SEXP_USE_BOEHM
#define sexp_gc_var(ctx, x, y) sexp x;
#define sexp_gc_preserve(ctx, x, y)
#define sexp_gc_release(ctx, x, y)
#include "gc/gc.h"
#define sexp_alloc(ctx, size) GC_malloc(size)
#define sexp_alloc_atomic(ctx, size) GC_malloc_atomic(size)
#define sexp_realloc(ctx, x, size) GC_realloc(x, size)
#define sexp_free(ctx, x)
#define sexp_deep_free(ctx, x)
#else
#define sexp_gc_var(ctx, x, y) \
sexp x = SEXP_VOID; \
struct sexp_gc_var_t y = {NULL, NULL};
#define sexp_gc_preserve(ctx, x, y) \
do { \
(y).var = &(x); \
/* (y).name = #x; */ \
(y).next = sexp_context_saves(ctx); \
sexp_context_saves(ctx) = &(y); \
} while (0)
#define sexp_gc_release(ctx, x, y) (sexp_context_saves(ctx) = y.next)
#if SEXP_USE_MALLOC
#define sexp_alloc(ctx, size) malloc(size)
#define sexp_alloc_atomic(ctx, size) malloc(size)
#define sexp_realloc(ctx, x, size) realloc(x, size)
#define sexp_free(ctx, x) free(x)
void sexp_deep_free(sexp ctx, sexp obj);
#else /* native gc */
void *sexp_alloc(sexp ctx, size_t size);
#define sexp_alloc_atomic sexp_alloc
void *sexp_realloc(sexp ctx, sexp x, size_t size);
#define sexp_free(ctx, x)
#define sexp_deep_free(ctx, x)
#endif
#endif
#define sexp_gc_var1(x) sexp_gc_var(ctx, x, __sexp_gc_preserver1)
#define sexp_gc_var2(x, y) sexp_gc_var1(x); sexp_gc_var(ctx, y, __sexp_gc_preserver2)
#define sexp_gc_var3(x, y, z) sexp_gc_var2(x, y); sexp_gc_var(ctx, z, __sexp_gc_preserver3)
#define sexp_gc_var4(x, y, z, w) sexp_gc_var3(x, y, z); sexp_gc_var(ctx, w, __sexp_gc_preserver4)
#define sexp_gc_var5(x, y, z, w, v) sexp_gc_var4(x, y, z, w); sexp_gc_var(ctx, v, __sexp_gc_preserver5)
#define sexp_gc_var6(x, y, z, w, v, u) sexp_gc_var5(x, y, z, w, v); sexp_gc_var(ctx, u, __sexp_gc_preserver6)
#define sexp_gc_preserve1(ctx, x) sexp_gc_preserve(ctx, x, __sexp_gc_preserver1)
#define sexp_gc_preserve2(ctx, x, y) sexp_gc_preserve1(ctx, x); sexp_gc_preserve(ctx, y, __sexp_gc_preserver2)
#define sexp_gc_preserve3(ctx, x, y, z) sexp_gc_preserve2(ctx, x, y); sexp_gc_preserve(ctx, z, __sexp_gc_preserver3)
#define sexp_gc_preserve4(ctx, x, y, z, w) sexp_gc_preserve3(ctx, x, y, z); sexp_gc_preserve(ctx, w, __sexp_gc_preserver4)
#define sexp_gc_preserve5(ctx, x, y, z, w, v) sexp_gc_preserve4(ctx, x, y, z, w); sexp_gc_preserve(ctx, v, __sexp_gc_preserver5)
#define sexp_gc_preserve6(ctx, x, y, z, w, v, u) sexp_gc_preserve5(ctx, x, y, z, w, v); sexp_gc_preserve(ctx, u, __sexp_gc_preserver6)
#define sexp_gc_release1(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
#define sexp_gc_release2(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
#define sexp_gc_release3(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
#define sexp_gc_release4(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
#define sexp_gc_release5(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
#define sexp_gc_release6(ctx) sexp_gc_release(ctx, NULL, __sexp_gc_preserver1)
#define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1)))
#define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \
+ sizeof(((sexp)0)->value.x))
#define sexp_offsetof(type, f) (offsetof(struct sexp_struct, value.type.f))
#define sexp_offsetof_slot0 (offsetof(struct sexp_struct, value))
#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double))
#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag)
#define sexp_alloc_bytecode(ctx, i) sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE)
#if SEXP_USE_BIGNUMS
#include "chibi/bignum.h"
#endif
/***************************** predicates *****************************/
#define sexp_truep(x) ((x) != SEXP_FALSE)
#define sexp_not(x) ((x) == SEXP_FALSE)
#define sexp_nullp(x) ((x) == SEXP_NULL)
#define sexp_pointerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG)
#define sexp_fixnump(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG)
#define sexp_isymbolp(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG)
#define sexp_charp(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG)
#define sexp_booleanp(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE))
#define sexp_pointer_tag(x) ((x)->tag)
#define sexp_gc_mark(x) ((x)->gc_mark)
#define sexp_flags(x) ((x)->flags)
#define sexp_immutablep(x) ((x)->immutablep)
#define sexp_freep(x) ((x)->freep)
#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t)))
#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i])
#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v))
#if SEXP_USE_IMMEDIATE_FLONUMS
union sexp_flonum_conv {
float flonum;
unsigned int bits;
};
#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG)
SEXP_API sexp sexp_flonum_predicate (sexp ctx, sexp x);
#if SEXP_64_BIT
SEXP_API float sexp_flonum_value (sexp x);
SEXP_API sexp sexp_make_flonum(sexp ctx, float f);
#else
#define sexp_make_flonum(ctx, x) ((sexp) ((((union sexp_flonum_conv)((float)(x))).bits & ~SEXP_IMMEDIATE_MASK) + SEXP_IFLONUM_TAG))
#define sexp_flonum_value(x) (((union sexp_flonum_conv)(((unsigned int)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum)
#endif
#else
#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM))
#define sexp_flonum_value(f) ((f)->value.flonum)
sexp sexp_make_flonum(sexp ctx, double f);
#endif
#define sexp_typep(x) (sexp_check_tag(x, SEXP_TYPE))
#define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR))
#define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING))
#define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL))
#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR))
#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT))
#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT))
#define sexp_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM))
#define sexp_cpointerp(x) (sexp_check_tag(x, SEXP_CPOINTER))
#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION))
#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE))
#define sexp_envp(x) (sexp_check_tag(x, SEXP_ENV))
#define sexp_bytecodep(x) (sexp_check_tag(x, SEXP_BYTECODE))
#define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE))
#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE))
#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO))
#define sexp_synclop(x) (sexp_check_tag(x, SEXP_SYNCLO))
#define sexp_lambdap(x) (sexp_check_tag(x, SEXP_LAMBDA))
#define sexp_cndp(x) (sexp_check_tag(x, SEXP_CND))
#define sexp_refp(x) (sexp_check_tag(x, SEXP_REF))
#define sexp_setp(x) (sexp_check_tag(x, SEXP_SET))
#define sexp_seqp(x) (sexp_check_tag(x, SEXP_SEQ))
#define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT))
#define sexp_contextp(x) (sexp_check_tag(x, SEXP_CONTEXT))
#if SEXP_USE_HUFF_SYMS
#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x))
#else
#define sexp_symbolp(x) (sexp_lsymbolp(x))
#endif
#define sexp_idp(x) \
(sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x))))
#define sexp_portp(x) (sexp_iportp(x) || sexp_oportp(x))
/***************************** constructors ****************************/
#define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE)
#define sexp_unbox_boolean(x) (((x) == SEXP_FALSE) ? 0 : 1)
#define sexp_make_fixnum(n) ((sexp) ((((sexp_sint_t)(n))<<SEXP_FIXNUM_BITS) + SEXP_FIXNUM_TAG))
#define sexp_unbox_fixnum(n) (((sexp_sint_t)(n))>>SEXP_FIXNUM_BITS)
#define SEXP_NEG_ONE sexp_make_fixnum(-1)
#define SEXP_ZERO sexp_make_fixnum(0)
#define SEXP_ONE sexp_make_fixnum(1)
#define SEXP_TWO sexp_make_fixnum(2)
#define SEXP_THREE sexp_make_fixnum(3)
#define SEXP_FOUR sexp_make_fixnum(4)
#define SEXP_FIVE sexp_make_fixnum(5)
#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG))
#define sexp_unbox_character(n) ((int) (((sexp_sint_t)(n))>>SEXP_EXTENDED_BITS))
#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x))
#if SEXP_USE_FLONUMS
#define sexp_fp_integerp(x) (sexp_flonum_value(x) == trunc(sexp_flonum_value(x)))
#define _or_integer_flonump(x) || (sexp_flonump(x) && sexp_fp_integerp(x))
#else
#define _or_integer_flonump(x)
#endif
#if SEXP_USE_BIGNUMS
SEXP_API sexp sexp_make_integer(sexp ctx, sexp_lsint_t x);
SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
#define sexp_exact_integerp(x) (sexp_fixnump(x) || sexp_bignump(x))
#else
#define sexp_make_integer(ctx, x) sexp_make_fixnum(x)
#define sexp_make_unsigned_integer(ctx, x) sexp_make_fixnum(x)
#define sexp_exact_integerp(x) sexp_fixnump(x)
#endif
#define sexp_integerp(x) (sexp_exact_integerp(x) _or_integer_flonump(x))
#if SEXP_USE_FLONUMS
#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x)))
#else
#define sexp_fixnum_to_flonum(ctx, x) (x)
#endif
#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS
#define sexp_uint_value(x) ((sexp_uint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_data(x)[0]))
#define sexp_sint_value(x) ((sexp_sint_t)(sexp_fixnump(x) ? sexp_unbox_fixnum(x) : sexp_bignum_sign(x)*sexp_bignum_data(x)[0]))
#else
#define sexp_uint_value(x) ((sexp_uint_t)sexp_unbox_fixnum(x))
#define sexp_sint_value(x) ((sexp_sint_t)sexp_unbox_fixnum(x))
#endif
#define sexp_shift_epoch(x) ((x)-SEXP_EPOCH_OFFSET)
#define sexp_unshift_epoch(x) ((x)+SEXP_EPOCH_OFFSET)
/*************************** field accessors **************************/
#define sexp_vector_length(x) ((x)->value.vector.length)
#define sexp_vector_data(x) ((x)->value.vector.data)
#define sexp_vector_ref(x,i) (sexp_vector_data(x)[sexp_unbox_fixnum(i)])
#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_fixnum(i)]=(v))
#define sexp_procedure_num_args(x) ((x)->value.procedure.num_args)
#define sexp_procedure_flags(x) ((x)->value.procedure.flags)
#define sexp_procedure_variadic_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & 1)
#define sexp_procedure_code(x) ((x)->value.procedure.bc)
#define sexp_procedure_vars(x) ((x)->value.procedure.vars)
#define sexp_string_length(x) ((x)->value.string.length)
#define sexp_string_data(x) ((x)->value.string.data)
#define sexp_string_ref(x, i) (sexp_make_character(sexp_string_data(x)[sexp_unbox_fixnum(i)]))
#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_character(v))
#define sexp_symbol_string(x) ((x)->value.symbol.string)
#define sexp_port_stream(p) ((p)->value.port.stream)
#define sexp_port_name(p) ((p)->value.port.name)
#define sexp_port_line(p) ((p)->value.port.line)
#define sexp_port_openp(p) ((p)->value.port.openp)
#define sexp_port_sourcep(p) ((p)->value.port.sourcep)
#define sexp_port_cookie(p) ((p)->value.port.cookie)
#define sexp_port_buf(p) ((p)->value.port.buf)
#define sexp_port_size(p) ((p)->value.port.size)
#define sexp_port_offset(p) ((p)->value.port.offset)
#define sexp_exception_kind(p) ((p)->value.exception.kind)
#define sexp_exception_message(p) ((p)->value.exception.message)
#define sexp_exception_irritants(p) ((p)->value.exception.irritants)
#define sexp_exception_procedure(p) ((p)->value.exception.procedure)
#define sexp_exception_source(p) ((p)->value.exception.source)
#define sexp_cpointer_freep(p) (sexp_freep(p))
#define sexp_cpointer_length(p) ((p)->value.cpointer.length)
#define sexp_cpointer_body(p) ((p)->value.cpointer.body)
#define sexp_cpointer_parent(p) ((p)->value.cpointer.parent)
#define sexp_cpointer_value(p) ((p)->value.cpointer.value)
#define sexp_cpointer_maybe_null_value(p) (sexp_not(p) ? NULL : sexp_cpointer_value(p))
#define sexp_bytecode_length(x) ((x)->value.bytecode.length)
#define sexp_bytecode_name(x) ((x)->value.bytecode.name)
#define sexp_bytecode_literals(x) ((x)->value.bytecode.literals)
#define sexp_bytecode_data(x) ((x)->value.bytecode.data)
#define sexp_env_syntactic_p(x) ((x)->value.env.syntacticp)
#define sexp_env_parent(x) ((x)->value.env.parent)
#define sexp_env_bindings(x) ((x)->value.env.bindings)
#define sexp_env_local_p(x) (sexp_env_parent(x))
#define sexp_env_global_p(x) (! sexp_env_local_p(x))
#define sexp_env_lambda(x) ((x)->value.env.lambda)
#define sexp_macro_proc(x) ((x)->value.macro.proc)
#define sexp_macro_env(x) ((x)->value.macro.env)
#define sexp_synclo_env(x) ((x)->value.synclo.env)
#define sexp_synclo_free_vars(x) ((x)->value.synclo.free_vars)
#define sexp_synclo_expr(x) ((x)->value.synclo.expr)
#define sexp_core_code(x) ((x)->value.core.code)
#define sexp_core_name(x) ((x)->value.core.name)
#define sexp_opcode_class(x) ((x)->value.opcode.op_class)
#define sexp_opcode_code(x) ((x)->value.opcode.code)
#define sexp_opcode_num_args(x) ((x)->value.opcode.num_args)
#define sexp_opcode_flags(x) ((x)->value.opcode.flags)
#define sexp_opcode_arg1_type(x) ((x)->value.opcode.arg1_type)
#define sexp_opcode_arg2_type(x) ((x)->value.opcode.arg2_type)
#define sexp_opcode_inverse(x) ((x)->value.opcode.inverse)
#define sexp_opcode_name(x) ((x)->value.opcode.name)
#define sexp_opcode_data(x) ((x)->value.opcode.data)
#define sexp_opcode_data2(x) ((x)->value.opcode.data2)
#define sexp_opcode_proc(x) ((x)->value.opcode.proc)
#define sexp_opcode_func(x) ((x)->value.opcode.func)
#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1)
#define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2)
#define sexp_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4)
#define sexp_lambda_name(x) ((x)->value.lambda.name)
#define sexp_lambda_params(x) ((x)->value.lambda.params)
#define sexp_lambda_locals(x) ((x)->value.lambda.locals)
#define sexp_lambda_defs(x) ((x)->value.lambda.defs)
#define sexp_lambda_flags(x) ((x)->value.lambda.flags)
#define sexp_lambda_body(x) ((x)->value.lambda.body)
#define sexp_lambda_fv(x) ((x)->value.lambda.fv)
#define sexp_lambda_sv(x) ((x)->value.lambda.sv)
#define sexp_cnd_test(x) ((x)->value.cnd.test)
#define sexp_cnd_pass(x) ((x)->value.cnd.pass)
#define sexp_cnd_fail(x) ((x)->value.cnd.fail)
#define sexp_set_var(x) ((x)->value.set.var)
#define sexp_set_value(x) ((x)->value.set.value)
#define sexp_ref_name(x) ((x)->value.ref.name)
#define sexp_ref_cell(x) ((x)->value.ref.cell)
#define sexp_ref_loc(x) (sexp_cdr(sexp_ref_cell(x)))
#define sexp_seq_ls(x) ((x)->value.seq.ls)
#define sexp_lit_value(x) ((x)->value.lit.value)
#define sexp_stack_length(x) ((x)->value.stack.length)
#define sexp_stack_top(x) ((x)->value.stack.top)
#define sexp_stack_data(x) ((x)->value.stack.data)
#define sexp_context_env(x) ((x)->value.context.env)
#define sexp_context_stack(x) ((x)->value.context.stack)
#define sexp_context_depth(x) ((x)->value.context.depth)
#define sexp_context_bc(x) ((x)->value.context.bc)
#define sexp_context_fv(x) ((x)->value.context.fv)
#define sexp_context_pos(x) ((x)->value.context.pos)
#define sexp_context_lambda(x) ((x)->value.context.lambda)
#define sexp_context_parent(x) ((x)->value.context.parent)
#define sexp_context_saves(x) ((x)->value.context.saves)
#define sexp_context_tailp(x) ((x)->value.context.tailp)
#define sexp_context_tracep(x) ((x)->value.context.tailp)
#define sexp_context_globals(x) ((x)->value.context.globals)
#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x])
#if SEXP_USE_GLOBAL_HEAP
#if ! SEXP_USE_BOEHM
SEXP_API sexp_heap sexp_global_heap;
#endif
#define sexp_context_heap(ctx) sexp_global_heap
#else
#define sexp_context_heap(ctx) ((ctx)->value.context.heap)
#endif
#if SEXP_USE_GLOBAL_SYMBOLS
#define sexp_context_symbols(ctx) sexp_symbol_table
#else
#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS))
#endif
#if SEXP_USE_GLOBAL_TYPES
SEXP_API struct sexp_struct *sexp_type_specs;
#define sexp_context_types(ctx) sexp_type_specs
#define sexp_type_by_index(ctx,i) (&(sexp_context_types(ctx)[i]))
#define sexp_context_num_types(ctx) sexp_num_types
#define sexp_context_type_array_size(ctx) sexp_type_array_size
#else
#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES))
#define sexp_type_by_index(ctx,i) (sexp_context_types(ctx)[i])
#define sexp_context_num_types(ctx) \
sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES))
#define sexp_context_type_array_size(ctx) \
sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES))
#endif
#define sexp_object_type(ctx,x) (sexp_type_by_index(ctx, ((x)->tag)))
#define sexp_object_type_name(ctx,x) (sexp_type_name(sexp_object_type(ctx, x)))
#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i)))
#define sexp_type_size_of_object(t, x) \
(((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \
* sexp_type_size_scale(t) \
+ sexp_type_size_base(t))
#define sexp_type_num_slots_of_object(t, x) \
(((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \
* sexp_type_field_len_scale(t) \
+ sexp_type_field_len_base(t))
#define sexp_type_num_eq_slots_of_object(t, x) \
(((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \
* sexp_type_field_len_scale(t) \
+ sexp_type_field_eq_len_base(t))
#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x)))
#define sexp_type_tag(x) ((x)->value.type.tag)
#define sexp_type_field_base(x) ((x)->value.type.field_base)
#define sexp_type_field_eq_len_base(x) ((x)->value.type.field_eq_len_base)
#define sexp_type_field_len_base(x) ((x)->value.type.field_len_base)
#define sexp_type_field_len_off(x) ((x)->value.type.field_len_off)
#define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale)
#define sexp_type_size_base(x) ((x)->value.type.size_base)
#define sexp_type_size_off(x) ((x)->value.type.size_off)
#define sexp_type_size_scale(x) ((x)->value.type.size_scale)
#define sexp_type_name(x) ((x)->value.type.name)
#define sexp_type_finalize(x) ((x)->value.type.finalize)
#define sexp_bignum_sign(x) ((x)->value.bignum.sign)
#define sexp_bignum_length(x) ((x)->value.bignum.length)
#define sexp_bignum_data(x) ((x)->value.bignum.data)
/****************************** arithmetic ****************************/
#define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG))
#define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG))
#define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG)))
#define sexp_fx_div(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) / sexp_unbox_fixnum(b)))
#define sexp_fx_rem(a, b) (sexp_make_fixnum(sexp_unbox_fixnum(a) % sexp_unbox_fixnum(b)))
#define sexp_fx_sign(a) (+1 | (((sexp_sint_t)(a)) >> (sizeof(sexp_sint_t)*8 - 1)))
#define sexp_fx_neg(a) (sexp_make_fixnum(-(sexp_unbox_fixnum(a))))
#define sexp_fx_abs(a) ((((sexp_sint_t)a) < 0) ? sexp_fx_neg(a) : a)
#define sexp_fp_add(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) + sexp_flonum_value(b)))
#define sexp_fp_sub(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) - sexp_flonum_value(b)))
#define sexp_fp_mul(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) * sexp_flonum_value(b)))
#define sexp_fp_div(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) / sexp_flonum_value(b)))
/****************************** utilities *****************************/
enum sexp_context_globals {
#if ! SEXP_USE_GLOBAL_SYMBOLS
SEXP_G_SYMBOLS,
#endif
#if ! SEXP_USE_GLOBAL_TYPES
SEXP_G_TYPES,
SEXP_G_NUM_TYPES,
#endif
SEXP_G_OOM_ERROR, /* out of memory exception object */
SEXP_G_OOS_ERROR, /* out of stack exception object */
SEXP_G_OPTIMIZATIONS,
SEXP_G_SIGNAL_HANDLERS,
SEXP_G_CONFIG_ENV,
SEXP_G_MODULE_PATH,
SEXP_G_QUOTE_SYMBOL,
SEXP_G_QUASIQUOTE_SYMBOL,
SEXP_G_UNQUOTE_SYMBOL,
SEXP_G_UNQUOTE_SPLICING_SYMBOL,
SEXP_G_EMPTY_VECTOR,
SEXP_G_CUR_IN_SYMBOL,
SEXP_G_CUR_OUT_SYMBOL,
SEXP_G_CUR_ERR_SYMBOL,
SEXP_G_INTERACTION_ENV_SYMBOL,
SEXP_G_ERR_HANDLER,
SEXP_G_RESUMECC_BYTECODE,
SEXP_G_FINAL_RESUMER,
SEXP_G_NUM_GLOBALS
};
#define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL)
#define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls)))
#define sexp_insert(ctx, ls, x) ((sexp_memq(ctx, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x)))
#define sexp_pair_source(x) ((x)->value.pair.source)
#define sexp_car(x) ((x)->value.pair.car)
#define sexp_cdr(x) ((x)->value.pair.cdr)
#define sexp_caar(x) (sexp_car(sexp_car(x)))
#define sexp_cadr(x) (sexp_car(sexp_cdr(x)))
#define sexp_cdar(x) (sexp_cdr(sexp_car(x)))
#define sexp_cddr(x) (sexp_cdr(sexp_cdr(x)))
#define sexp_caaar(x) (sexp_car(sexp_caar(x)))
#define sexp_caadr(x) (sexp_car(sexp_cadr(x)))
#define sexp_cadar(x) (sexp_car(sexp_cdar(x)))
#define sexp_caddr(x) (sexp_car(sexp_cddr(x)))
#define sexp_cdaar(x) (sexp_cdr(sexp_caar(x)))
#define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x)))
#define sexp_cddar(x) (sexp_cdr(sexp_cdar(x)))
#define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x)))
#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) /* just these two */
#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x)))
/***************************** general API ****************************/
#if SEXP_USE_STRING_STREAMS
#define sexp_read_char(x, p) (getc(sexp_port_stream(p)))
#define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p)))
#define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p)))
#define sexp_write_string(x, s, p) (fputs(s, sexp_port_stream(p)))
#define sexp_printf(x, p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__))
#define sexp_flush(x, p) (fflush(sexp_port_stream(p)))
#else
#define sexp_read_char(x, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? sexp_port_buf(p)[sexp_port_offset(p)++] : sexp_buffered_read_char(x, p)) : getc(sexp_port_stream(p)))
#define sexp_push_char(x, c, p) (sexp_port_buf(p) ? (sexp_port_buf(p)[--sexp_port_offset(p)] = ((char)(c))) : ungetc(c, sexp_port_stream(p)))
#define sexp_write_char(x, c, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? ((((sexp_port_buf(p))[sexp_port_offset(p)++]) = (char)(c)), SEXP_VOID) : sexp_buffered_write_char(x, c, p)) : (putc(c, sexp_port_stream(p)), SEXP_VOID))
#define sexp_write_string(x, s, p) (sexp_port_buf(p) ? sexp_buffered_write_string(x, s, p) : (fputs(s, sexp_port_stream(p)), SEXP_VOID))
#define sexp_flush(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p) : (fflush(sexp_port_stream(p)), SEXP_VOID))
SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p);
SEXP_API sexp sexp_buffered_write_char (sexp ctx, int c, sexp p);
SEXP_API sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p);
SEXP_API sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p);
SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p);
#endif
#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p))
SEXP_API sexp sexp_make_context(sexp ctx, sexp_uint_t size);
SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag);
SEXP_API sexp sexp_cons(sexp ctx, sexp head, sexp tail);
SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b);
SEXP_API sexp sexp_equalp (sexp ctx, sexp a, sexp b);
SEXP_API sexp sexp_listp(sexp ctx, sexp obj);
SEXP_API sexp sexp_reverse(sexp ctx, sexp ls);
SEXP_API sexp sexp_nreverse(sexp ctx, sexp ls);
SEXP_API sexp sexp_append2(sexp ctx, sexp a, sexp b);
SEXP_API sexp sexp_memq(sexp ctx, sexp x, sexp ls);
SEXP_API sexp sexp_assq(sexp ctx, sexp x, sexp ls);
SEXP_API sexp sexp_length(sexp ctx, sexp ls);
SEXP_API sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen);
SEXP_API sexp sexp_make_string(sexp ctx, sexp len, sexp ch);
SEXP_API sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end);
SEXP_API sexp sexp_string_concatenate (sexp ctx, sexp str_ls, sexp sep);
SEXP_API sexp sexp_intern(sexp ctx, char *str);
SEXP_API sexp sexp_string_to_symbol(sexp ctx, sexp str);
SEXP_API sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt);
SEXP_API sexp sexp_list_to_vector(sexp ctx, sexp ls);
SEXP_API sexp sexp_make_cpointer(sexp ctx, sexp_uint_t typeid, void* value, sexp parent, int freep);
SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out);
SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out);
SEXP_API sexp sexp_flush_output(sexp ctx, sexp out);
SEXP_API sexp sexp_read_string(sexp ctx, sexp in);
SEXP_API sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp);
SEXP_API sexp sexp_read_number(sexp ctx, sexp in, int base);
SEXP_API sexp sexp_read_raw(sexp ctx, sexp in);
SEXP_API sexp sexp_read(sexp ctx, sexp in);
SEXP_API sexp sexp_read_from_string(sexp ctx, char *str);
SEXP_API sexp sexp_write_to_string(sexp ctx, sexp obj);
SEXP_API sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name);
SEXP_API sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name);
SEXP_API sexp sexp_make_input_string_port(sexp ctx, sexp str);
SEXP_API sexp sexp_make_output_string_port(sexp ctx);
SEXP_API sexp sexp_get_output_string(sexp ctx, sexp port);
SEXP_API sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source);
SEXP_API sexp sexp_user_exception(sexp ctx, sexp self, char *message, sexp obj);
SEXP_API sexp sexp_type_exception(sexp ctx, char *message, sexp obj);
SEXP_API sexp sexp_range_exception(sexp ctx, sexp obj, sexp start, sexp end);
SEXP_API sexp sexp_print_exception(sexp ctx, sexp exn, sexp out);
SEXP_API void sexp_init(void);
#if SEXP_USE_GLOBAL_HEAP
#define sexp_destroy_context(ctx)
#else
SEXP_API void sexp_destroy_context(sexp ctx);
#endif
#if SEXP_USE_TYPE_DEFS
SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2);
SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots);
SEXP_API sexp sexp_register_c_type (sexp ctx, sexp name);
SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp obj);
#define sexp_register_c_type(ctx, name, finalizer) \
sexp_register_type(ctx, name, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \
SEXP_ZERO, sexp_make_fixnum(sexp_sizeof(cpointer)), \
SEXP_ZERO, SEXP_ZERO, finalizer)
#endif
#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE)
#define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx)))
#endif /* ! SEXP_H */

80
lib/chibi/ast.c Normal file
View file

@ -0,0 +1,80 @@
/* ast.c -- interface to the Abstract Syntax Tree */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include <chibi/eval.h>
static void sexp_define_type_predicate (sexp ctx, sexp env,
char *cname, sexp_uint_t type) {
sexp_gc_var2(name, op);
sexp_gc_preserve2(ctx, name, op);
name = sexp_c_string(ctx, cname, -1);
op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type));
sexp_env_define(ctx, env, name=sexp_intern(ctx, cname), op);
sexp_gc_release2(ctx);
}
static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
sexp_uint_t cindex, char* get, char *set) {
sexp type, index;
sexp_gc_var2(name, op);
sexp_gc_preserve2(ctx, name, op);
type = sexp_make_fixnum(ctype);
index = sexp_make_fixnum(cindex);
op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index);
sexp_env_define(ctx, env, name=sexp_intern(ctx, get), op);
op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index);
sexp_env_define(ctx, env, name=sexp_intern(ctx, set), op);
sexp_gc_release2(ctx);
}
static sexp sexp_get_env_cell (sexp ctx, sexp env, sexp id) {
sexp cell = sexp_env_cell(env, id);
while ((! cell) && sexp_synclop(id)) {
env = sexp_synclo_env(id);
id = sexp_synclo_expr(id);
}
return cell ? cell : SEXP_FALSE;
}
static sexp sexp_get_opcode_name (sexp ctx, sexp op) {
if (! sexp_opcodep(op))
return sexp_type_exception(ctx, "not an opcode", op);
else if (! sexp_opcode_name(op))
return SEXP_FALSE;
else
return sexp_intern(ctx, sexp_opcode_name(op));
}
sexp sexp_init_library (sexp ctx, sexp env) {
sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO);
sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA);
sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND);
sexp_define_type_predicate(ctx, env, "set?", SEXP_SET);
sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF);
sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ);
sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT);
sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE);
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!");
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!");
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 2, "lambda-body", "lambda-body-set!");
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 3, "lambda-defs", "lambda-defs-set!");
sexp_define_accessors(ctx, env, SEXP_CND, 0, "cnd-test", "cnd-test-set!");
sexp_define_accessors(ctx, env, SEXP_CND, 1, "cnd-pass", "cnd-pass-set!");
sexp_define_accessors(ctx, env, SEXP_CND, 2, "cnd-fail", "cnd-fail-set!");
sexp_define_accessors(ctx, env, SEXP_SET, 0, "set-var", "set-var-set!");
sexp_define_accessors(ctx, env, SEXP_SET, 1, "set-value", "set-value-set!");
sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!");
sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!");
sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!");
sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!");
sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze);
sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env);
sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell);
sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name);
return SEXP_VOID;
}

14
lib/chibi/ast.module Normal file
View file

@ -0,0 +1,14 @@
(define-module (chibi ast)
(export analyze env-cell opcode-name
syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode?
syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
lambda-name lambda-params lambda-body lambda-defs
lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set!
cnd-test cnd-pass cnd-fail
cnd-test-set! cnd-pass-set! cnd-fail-set!
set-var set-value set-var-set! set-value-set!
ref-name ref-cell ref-name-set! ref-cell-set!
seq-ls seq-ls-set! lit-value lit-value-set!)
(include-shared "ast"))

116
lib/chibi/disasm.c Normal file
View file

@ -0,0 +1,116 @@
/* disasm.c -- optional debugging utilities */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include "chibi/eval.h"
#define SEXP_DISASM_MAX_DEPTH 8
#define SEXP_DISASM_PAD_WIDTH 4
static const char* reverse_opcode_names[] =
{"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL",
"FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6",
"JUMP-UNLESS", "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF",
"STACK-REF", "LOCAL-REF", "LOCAL-SET",
"CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF",
"STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR",
"MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?",
"EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR",
"SET-CAR", "SET-CDR", "CONS", "ADD", "SUB",
"MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE",
"LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT",
"CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE",
"WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE",
};
static sexp disasm (sexp ctx, sexp bc, sexp out, int depth) {
sexp tmp;
unsigned char *ip, opcode, i;
if (sexp_procedurep(bc)) {
bc = sexp_procedure_code(bc);
} else if (sexp_opcodep(bc)) {
sexp_printf(ctx, out, "%s is a primitive\n", sexp_opcode_name(bc));
return SEXP_VOID;
} else if (! sexp_bytecodep(bc)) {
return sexp_type_exception(ctx, "not a procedure", bc);
}
if (! sexp_oportp(out)) {
return sexp_type_exception(ctx, "not an output-port", out);
}
for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++)
sexp_write_char(ctx, ' ', out);
sexp_write_string(ctx, "-------------- ", out);
if (sexp_truep(sexp_bytecode_name(bc))) {
sexp_write(ctx, sexp_bytecode_name(bc), out);
sexp_write_char(ctx, ' ', out);
}
sexp_printf(ctx, out, "%p\n", bc);
ip = sexp_bytecode_data(bc);
loop:
for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++)
sexp_write_char(ctx, ' ', out);
opcode = *ip++;
if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) {
sexp_printf(ctx, out, " %s ", reverse_opcode_names[opcode]);
} else {
sexp_printf(ctx, out, " <unknown> %d ", opcode);
}
switch (opcode) {
case SEXP_OP_STACK_REF:
case SEXP_OP_LOCAL_REF:
case SEXP_OP_LOCAL_SET:
case SEXP_OP_CLOSURE_REF:
case SEXP_OP_JUMP:
case SEXP_OP_JUMP_UNLESS:
case SEXP_OP_TYPEP:
case SEXP_OP_FCALL0:
case SEXP_OP_FCALL1:
case SEXP_OP_FCALL2:
case SEXP_OP_FCALL3:
case SEXP_OP_FCALL4:
case SEXP_OP_FCALL5:
case SEXP_OP_FCALL6:
sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]);
ip += sizeof(sexp);
break;
case SEXP_OP_SLOT_REF:
case SEXP_OP_SLOT_SET:
case SEXP_OP_MAKE:
ip += sizeof(sexp)*2;
break;
case SEXP_OP_GLOBAL_REF:
case SEXP_OP_GLOBAL_KNOWN_REF:
case SEXP_OP_TAIL_CALL:
case SEXP_OP_CALL:
case SEXP_OP_PUSH:
tmp = ((sexp*)ip)[0];
if (((opcode == SEXP_OP_GLOBAL_REF) || (opcode == SEXP_OP_GLOBAL_KNOWN_REF))
&& sexp_pairp(tmp))
tmp = sexp_car(tmp);
else if ((opcode == SEXP_OP_PUSH) && (sexp_pairp(tmp) || sexp_idp(tmp)))
sexp_write_char(ctx, '\'', out);
sexp_write(ctx, tmp, out);
ip += sizeof(sexp);
break;
}
sexp_write_char(ctx, '\n', out);
if ((opcode == SEXP_OP_PUSH) && (depth < SEXP_DISASM_MAX_DEPTH)
&& (sexp_bytecodep(tmp) || sexp_procedurep(tmp)))
disasm(ctx, tmp, out, depth+1);
if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc))
goto loop;
return SEXP_VOID;
}
static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) {
return disasm(ctx, bc, out, 0);
}
sexp sexp_init_library (sexp ctx, sexp env) {
sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "*current-output-port*");
return SEXP_VOID;
}

5
lib/chibi/disasm.module Normal file
View file

@ -0,0 +1,5 @@
(define-module (chibi disasm)
(export disasm)
(import-immutable (scheme))
(include-shared "disasm"))

27
lib/chibi/filesystem.module Normal file
View file

@ -0,0 +1,27 @@
(define-module (chibi filesystem)
(export open-input-file-descriptor open-output-file-descriptor
duplicate-file-descriptor duplicate-file-descriptor-to
close-file-descriptor renumber-file-descriptor
delete-file link-file symbolic-link-file rename-file
directory-files create-directory delete-directory
file-status
file-device file-inode
file-mode file-num-links
file-owner file-group
file-represented-device file-size
file-block-size file-num-blocks
file-access-time file-modification-time file-change-time
file-regular? file-directory? file-character?
file-block? file-fifo? file-link?
file-socket? file-exists?
get-file-descriptor-flags set-file-descriptor-flags!
get-file-descriptor-status set-file-descriptor-status!
open/read open/write open/read-write
open/create open/exclusive open/truncate
open/append open/non-block
)
(import-immutable (scheme))
(include-shared "filesystem")
(include "filesystem.scm"))

43
lib/chibi/filesystem.scm Normal file
View file

@ -0,0 +1,43 @@
;; filesystem.scm -- additional filesystem utilities
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (directory-fold dir kons knil)
(let ((dir (opendir dir)))
(let lp ((res knil))
(let ((file (readdir dir)))
(if file (lp (kons (dirent-name file) res)) res)))))
(define (directory-files dir)
(directory-fold dir cons '()))
(define (renumber-file-descriptor old new)
(and (duplicate-file-descriptor-to old new)
(close-file-descriptor old)))
(define (file-status file)
(if (string? file) (stat file) (fstat file)))
(define (file-device x) (stat-dev (if (stat? x) x (file-status x))))
(define (file-inode x) (stat-ino (if (stat? x) x (file-status x))))
(define (file-mode x) (stat-mode (if (stat? x) x (file-status x))))
(define (file-num-links x) (stat-nlinks (if (stat? x) x (file-status x))))
(define (file-owner x) (stat-uid (if (stat? x) x (file-status x))))
(define (file-group x) (stat-gid (if (stat? x) x (file-status x))))
(define (file-represented-device x) (stat-rdev (if (stat? x) x (file-status x))))
(define (file-size x) (stat-size (if (stat? x) x (file-status x))))
(define (file-block-size x) (stat-blksize (if (stat? x) x (file-status x))))
(define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x))))
(define (file-access-time x) (stat-atime (if (stat? x) x (file-status x))))
(define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x))))
(define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x))))
(define (file-regular? x) (S_ISREG (file-mode x)))
(define (file-directory? x) (S_ISDIR (file-mode x)))
(define (file-character? x) (S_ISCHR (file-mode x)))
(define (file-block? x) (S_ISBLK (file-mode x)))
(define (file-fifo? x) (S_ISFIFO (file-mode x)))
(define (file-link? x) (S_ISLNK (file-mode x)))
(define (file-socket? x) (S_ISSOCK (file-mode x)))
(define (file-exists? x) (and (file-status x) #t))

115
lib/chibi/filesystem.stub Normal file
View file

@ -0,0 +1,115 @@
(c-system-include "sys/types.h")
(c-system-include "unistd.h")
(c-system-include "dirent.h")
(c-system-include "fcntl.h")
(define-c-type DIR
finalizer: closedir)
(define-c-struct dirent
(string d_name dirent-name))
(define-c-struct stat
predicate: stat?
(dev_t st_dev stat-dev)
(ino_t st_ino stat-ino)
(mode_t st_mode stat-mode)
(nlink_t st_nlink stat-nlinks)
(uid_t st_uid stat-uid)
(gid_t st_gid stat-gid)
(dev_t st_rdev stat-rdev)
(off_t st_size stat-size)
(blksize_t st_blksize stat-blksize)
(blkcnt_t st_blocks stat-blocks)
(time_t st_atime stat-atime)
(time_t st_mtime stat-mtime)
(time_t st_ctime stat-ctime))
(define-c boolean S_ISREG (mode_t))
(define-c boolean S_ISDIR (mode_t))
(define-c boolean S_ISCHR (mode_t))
(define-c boolean S_ISBLK (mode_t))
(define-c boolean S_ISFIFO (mode_t))
(define-c boolean S_ISLNK (mode_t))
(define-c boolean S_ISSOCK (mode_t))
;;(define-c-const int ("S_IFMT"))
(define-c-const int (file/socket "S_IFSOCK"))
(define-c-const int (file/link "S_IFLNK"))
(define-c-const int (file/regular "S_IFREG"))
(define-c-const int (file/block "S_IFBLK"))
(define-c-const int (file/directory "S_IFDIR"))
(define-c-const int (file/character "S_IFCHR"))
(define-c-const int (file/fifo "S_IFIFO"))
(define-c-const int (file/suid "S_ISUID"))
(define-c-const int (file/sgid "S_ISGID"))
(define-c-const int (file/sticky "S_ISVTX"))
;;(define-c-const int ("S_IRWXU"))
(define-c-const int (perm/user-read "S_IRUSR"))
(define-c-const int (perm/user-write "S_IWUSR"))
(define-c-const int (perm/user-execute "S_IXUSR"))
;;(define-c-const int ("S_IRWXG"))
(define-c-const int (perm/group-read "S_IRGRP"))
(define-c-const int (perm/group-write "S_IWGRP"))
(define-c-const int (perm/group-execute "S_IXGRP"))
;;(define-c-const int ("S_IRWXO"))
(define-c-const int (perm/others-read "S_IROTH"))
(define-c-const int (perm/others-write "S_IWOTH"))
(define-c-const int (perm/others-execute "S_IXOTH"))
(define-c errno stat (string (result stat)))
(define-c errno fstat (int (result stat)))
(define-c errno (file-link-status "lstat") (string (result stat)))
(define-c input-port (open-input-file-descriptor "fdopen")
(int (value "r" string)))
(define-c output-port (open-output-file-descriptor "fdopen")
(int (value "w" string)))
(define-c errno (delete-file "unlink") (string))
(define-c errno (link-file "link") (string string))
(define-c errno (symbolic-link-file "symlink") (string string))
(define-c errno (rename-file "rename") (string string))
(define-c non-null-string (current-directory "getcwd")
((result (array char (auto-expand arg1))) (value 256 int)))
(define-c errno (create-directory "mkdir") (string int))
(define-c errno (delete-directory "rmdir") (string))
(define-c (free DIR) opendir (string))
(define-c dirent readdir ((link DIR)))
(define-c int (duplicate-file-descriptor "dup") (int))
(define-c errno (duplicate-file-descriptor-to "dup2") (int int))
(define-c errno (close-file-descriptor "close") (int))
(define-c errno (open-pipe "pipe") ((result (array int 2))))
(define-c errno (make-fifo "mkfifo") (string (default #o644 int)))
(define-c int (get-file-descriptor-flags "fcntl")
(int (value F_GETFD int)))
(define-c errno (set-file-descriptor-flags! "fcntl")
(int (value F_SETFD int) long))
(define-c int (get-file-descriptor-status "fcntl")
(int (value F_GETFL int)))
(define-c errno (set-file-descriptor-status! "fcntl")
(int (value F_SETFL int) long))
;; (define-c int (get-file-descriptor-lock "fcntl")
;; (int (value F_GETLK int) flock))
;; (define-c errno (set-file-descriptor-lock! "fcntl")
;; (int (value F_SETLK int) flock))
;; (define-c errno (try-set-file-descriptor-lock! "fcntl")
;; (int (value F_SETLKW int) flock))
(define-c-const int (open/read "O_RDONLY"))
(define-c-const int (open/write "O_WRONLY"))
(define-c-const int (open/read-write "O_RDWR"))
(define-c-const int (open/create "O_CREAT"))
(define-c-const int (open/exclusive "O_EXCL"))
(define-c-const int (open/truncate "O_TRUNC"))
(define-c-const int (open/append "O_APPEND"))
(define-c-const int (open/non-block "O_NONBLOCK"))

129
lib/chibi/heap-stats.c Normal file
View file

@ -0,0 +1,129 @@
/* heap-stats.c -- count or dump heap objects */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include <chibi/eval.h>
#define SEXP_HEAP_VECTOR_DEPTH 1
#if SEXP_64_BIT
#define sexp_heap_align(n) sexp_align(n, 5)
#else
#define sexp_heap_align(n) sexp_align(n, 4)
#endif
extern sexp sexp_gc (sexp ctx, size_t *sum_freed);
extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x);
#if SEXP_USE_GLOBAL_HEAP
#endif
static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) {
int i;
if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x)
|| sexp_flonump(x) || sexp_bignump(x)) {
sexp_write(ctx, x, out);
} else if (depth <= 0) {
goto print_name;
} else if (sexp_synclop(x)) {
sexp_write_string(ctx, "#<sc ", out);
sexp_print_simple(ctx, sexp_synclo_expr(x), out, depth);
sexp_write_string(ctx, ">", out);
} else if (sexp_pairp(x)) {
sexp_write_char(ctx, '(', out);
sexp_print_simple(ctx, sexp_car(x), out, depth-1);
sexp_write_string(ctx, " . ", out);
sexp_print_simple(ctx, sexp_cdr(x), out, depth-1);
sexp_write_char(ctx, ')', out);
} else if (sexp_vectorp(x)) {
sexp_write_string(ctx, "#(", out);
for (i=0; i<SEXP_HEAP_VECTOR_DEPTH && i<sexp_vector_length(x); i++) {
if (i>0)
sexp_write_char(ctx, ' ', out);
sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1);
}
if (i<sexp_vector_length(x))
sexp_write_string(ctx, " ...", out);
sexp_write_char(ctx, ')', out);
} else {
print_name:
sexp_write_string(ctx, "#<", out);
sexp_write_string(ctx, sexp_object_type_name(ctx, x), out);
sexp_write_string(ctx, ">", out);
}
}
static sexp sexp_heap_walk (sexp ctx, int depth, int printp) {
size_t freed;
sexp_uint_t stats[256], hi_type=0, i;
sexp_heap h = sexp_context_heap(ctx);
sexp p, out=SEXP_FALSE;
sexp_free_list q, r;
char *end;
sexp_gc_var3(res, tmp, name);
if (printp)
out = sexp_env_global_ref(sexp_context_env(ctx),
sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL),
SEXP_FALSE);
/* run gc once to remove unused variables */
sexp_gc(ctx, &freed);
/* initialize stats */
for (i=0; i<256; i++) stats[i]=0;
/* loop over each heap chunk */
for ( ; h; h=h->next) {
p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair)));
q = h->free_list;
end = (char*)h->data + h->size;
while (((char*)p) < end) {
/* find the preceding and succeeding free list pointers */
for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
;
if ((char*)r == (char*)p) { /* this is a free block, skip */
p = (sexp) (((char*)p) + r->size);
continue;
}
/* otherwise maybe print, then increment the stat and continue */
if (sexp_oportp(out)) {
sexp_print_simple(ctx, p, out, depth);
sexp_write_char(ctx, '\n', out);
}
stats[sexp_pointer_tag(p)]++;
if (sexp_pointer_tag(p) > hi_type)
hi_type = sexp_pointer_tag(p);
p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p)));
}
}
/* build and return results */
sexp_gc_preserve3(ctx, res, tmp, name);
res = SEXP_NULL;
for (i=hi_type; i>0; i--)
if (stats[i]) {
name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i));
tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i]));
res = sexp_cons(ctx, tmp, res);
}
sexp_gc_release3(ctx);
return res;
}
static sexp sexp_heap_stats (sexp ctx) {
return sexp_heap_walk(ctx, 0, 0);
}
static sexp sexp_heap_dump (sexp ctx, sexp depth) {
if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0))
return sexp_type_exception(ctx, "bad heap-dump depth", depth);
return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1);
}
sexp sexp_init_library (sexp ctx, sexp env) {
sexp_define_foreign(ctx, env, "heap-stats", 0, sexp_heap_stats);
sexp_define_foreign_opt(ctx, env, "heap-dump", 1, sexp_heap_dump, SEXP_ONE);
return SEXP_VOID;
}

5
lib/chibi/heap-stats.module Normal file
View file

@ -0,0 +1,5 @@
(define-module (chibi heap-stats)
(export heap-stats heap-dump)
(include-shared "heap-stats"))

6
lib/chibi/io.module Normal file
View file

@ -0,0 +1,6 @@
(define-module (chibi io)
(export read-string read-string! write-string read-line write-line)
(import-immutable (scheme))
(include-shared "io/io")
(include "io/io.scm"))

6
lib/chibi/io/io.scm Normal file
View file

@ -0,0 +1,6 @@
(define (write-line str . o)
(let ((out (if (pair? o) (car o) (current-output-port))))
(display str out)
(newline out)))

13
lib/chibi/io/io.stub Normal file
View file

@ -0,0 +1,13 @@
(define-c non-null-string (read-line "fgets")
((result (array char arg1)) int (default (current-input-port) input-port)))
(define-c size_t (read-string "fread")
((result (array char arg1)) size_t (value 1 size_t) (default (current-input-port) input-port)))
(define-c size_t (read-string! "fread")
(string size_t (value 1 size_t) (default (current-input-port) input-port)))
(define-c size_t (write-string "fwrite")
(string size_t (value 1 size_t) (default (current-output-port) output-port)))

9
lib/chibi/loop.module Normal file
View file

@ -0,0 +1,9 @@
(define-module (chibi loop)
(export loop in-list in-lists in-port in-file up-from down-from
listing listing-reverse appending appending-reverse
summing multiplying in-string in-string-reverse
in-vector in-vector-reverse)
(import-immutable (scheme))
(include "loop/loop.scm"))

365
lib/chibi/loop/loop.scm Normal file
View file

@ -0,0 +1,365 @@
;;;; loop.scm - the chibi loop (aka foof-loop)
;;
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;; The loop API is compatible with Taylor Campbell's foof-loop, but
;; the iterator API is different and subject to change. All loop
;; variables may be implicitly destructured with MATCH semantics.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (assoc-pred equal elt ls)
(and (pair? ls)
(if (equal elt (car (car ls)))
(car ls)
(assoc-pred equal elt (cdr ls)))))
(define-syntax let-keyword-form
(syntax-rules ()
((let-keyword-form
((labeled-arg-macro-name (positional-name . params)))
. body)
(let-syntax
((labeled-arg-macro-name
(er-macro-transformer
(lambda (expr rename compare)
(let lp ((ls (cdr expr)) (named '()) (posns '()))
(cond
((pair? ls)
(if (and (list? (car ls)) (compare (caar ls) (rename '=>)))
(lp (cdr ls) (cons (cdar ls) named) posns)
(lp (cdr ls) named (cons (car ls) posns))))
(else
(let lp ((ls (syntax-quote params))
(posns (reverse posns))
(args '()))
(cond
((null? ls)
(if (pair? posns)
(error "let-keyword-form: too many args" expr)
(cons (syntax-quote positional-name) (reverse args))))
((assoc-pred compare (caar ls) named)
=> (lambda (x) (lp (cdr ls) posns (cons (cadr x) args))))
((pair? posns)
(lp (cdr ls) (cdr posns) (cons (car posns) args)))
(else
(lp (cdr ls) posns (cons (cadar ls) args))))))))))))
. body))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax loop
(syntax-rules ()
;; unnamed, implicit recursion
((loop (vars ...) body ...)
(%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop)))
;; named, explicit recursion
((loop name (vars ...) body ...)
(%loop name () () () () () (vars ...) body ...))))
;; Main LOOP macro. Separate the variables from the iterator and
;; parameters, then walk through each parameter expanding the
;; bindings, and build the final form.
(define-syntax %loop
(syntax-rules (=> for with let while until)
;; automatic iteration
((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body)
(iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body))
((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body)
(iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body))
((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body)
(iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body))
((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body)
(iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body))
;; do equivalents, with optional guards
((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body)
(%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body))
((_ name l (vars ...) c r f ((with var init step) rest ...) . body)
(%loop name l (vars ... (var init step)) c r f (rest ...) . body))
((_ name l (vars ...) c r f ((with var init) rest ...) . body)
(%loop name l (vars ... (var init var)) c r f (rest ...) . body))
;; user-specified terminators
((_ name l vars (checks ...) r f ((until expr) rest ...) . body)
(%loop name l vars (checks ... expr) r f (rest ...) . body))
((_ name l vars (checks ...) r f ((while expr) rest ...) . body)
(%loop name l vars (checks ... (not expr)) r f (rest ...) . body))
;; specify a default done?
((_ name l v c r f ())
(%loop name l v c r f () (#f #f)))
((_ name l v c r f () () . body)
(%loop name l v c r f () (#f #f) . body))
;; final expansion
((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
=> result
. body)
(let* (lets ...)
(letrec ((tmp (lambda (var ...)
(if (or checks ...)
(let-keyword-form ((name (tmp (var step) ...)))
(let (finals ...) result))
(let (refs ...)
(let-keyword-form ((name (tmp (var step) ...)))
(if #f #f)
. body))))))
(tmp init ...))))
;; unspecified return value case
((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
. body)
(%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
=> (if #f #f) . body))
))
(define-syntax %loop-next
(syntax-rules ()
((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...)
. rest)
(%loop name (lets ... new-lets ...) (vars ... new-vars ...)
(checks ... new-checks ...) (refs ... new-refs ...)
(finals ... new-finals ...)
. rest))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Iterators
;; Each gets passed two lists, those items left of the <- and those to
;; the right, followed by a NEXT and REST continuation.
;; Should finish with
;;
;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...)
;; (loop-vars ...) (final-vars ...) . rest)
;;
;; OUTER-VARS: bound once outside the loop in a LET*
;; CURSOR-VARS: DO-style bindings of the form (name init update)
;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t
;; LOOP-VARS: inner variables, updated in parallel after the cursors
;; FINAL-VARS: final variables, bound only in the => result
(define-syntax in-list ; called just "IN" in ITER
(syntax-rules ()
((in-list ((var) source) next . rest)
(in-list ((var cursor) source) next . rest))
((in-list ((var cursor) source) next . rest)
(in-list ((var cursor succ) source) next . rest))
((in-list ((var cursor succ) (source)) next . rest)
(next () ; outer let bindings
((cursor source succ)) ; iterator, init, step
((not (pair? cursor))) ; finish tests for iterator vars
;; step variables and values
((var (car cursor))
(succ (cdr cursor)))
() ; final result bindings
. rest))
((in-list ((var cursor succ) (source step)) next . rest)
(next ()
((cursor source succ))
((not (pair? cursor)))
((var (car cursor))
(succ (step cursor)))
()
. rest))))
;; Iterator from Taylor R. Campbell. If you know the number of lists
;; ahead of time it's much more efficient to iterate over each one
;; separately.
(define-syntax in-lists
(syntax-rules ()
((in-lists ((elts) lol) next . rest)
(in-lists ((elts pairs) lol) next . rest))
((in-lists ((elts pairs) lol) next . rest)
(in-lists ((elts pairs succ) lol) next . rest))
((in-lists ((elts pairs succ) (lol)) next . rest)
(in-lists ((elts pairs succ) (lol cdr)) next . rest))
((in-lists ((elts pairs succ) (lol)) next . rest)
(in-lists ((elts pairs succ) (lol cdr)) next . rest))
((in-lists ((elts pairs succ) (lol step)) next . rest)
(in-lists ((elts pairs succ) (lol step null?)) next . rest))
((in-lists ((elts pairs succ) (lol step done?)) next . rest)
(next ()
((pairs lol succ))
((let lp ((ls pairs)) ; an in-lined ANY
(and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls))))))
((elts (map car pairs))
(succ (map step pairs)))
()
. rest))
))
(define-syntax define-in-indexed
(syntax-rules ()
((define-in-indexed in-type in-type-reverse length ref)
(begin
(define-syntax in-type
(syntax-rules ()
((in-type ls next . rest)
(%in-idx >= + 0 (length tmp) ref tmp ls next . rest))))
(define-syntax in-type-reverse
(syntax-rules ()
((in-type-reverse ls next . rest)
(%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest))))
))))
(define-in-indexed in-string in-string-reverse string-length string-ref)
(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
;; helper for the above string and vector iterators
(define-syntax %in-idx
(syntax-rules ()
;; cmp inc start end ref
((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest)
(%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest))
((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest)
(%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest))
((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest)
(%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest))
((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest)
(%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest))
((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest)
(next ((tmp-vec vec) (end to))
((index from (+ index step)))
((ge index end))
((var (r tmp-vec index)))
()
. rest))
))
(define-syntax in-port
(syntax-rules ()
((in-port ((var) source) next . rest)
(in-port ((var p) source) next . rest))
((in-port ((var p) ()) next . rest)
(in-port ((var p) ((current-input-port))) next . rest))
((in-port ((var p) (port)) next . rest)
(in-port ((var p) (port read-char)) next . rest))
((in-port ((var p) (port read-char)) next . rest)
(in-port ((var p) (port read-char eof-object?)) next . rest))
((in-port ((var p) (port reader eof?)) next . rest)
(next ((p port) (r reader) (e? eof?))
((var (r p) (r p)))
((e? var))
()
()
. rest))))
(define-syntax in-file
(syntax-rules ()
((in-file ((var) source) next . rest)
(in-file ((var p) source) next . rest))
((in-file ((var p) (file)) next . rest)
(in-file ((var p) (file read-char)) next . rest))
((in-file ((var p) (file reader)) next . rest)
(in-file ((var p) (file reader eof-object?)) next . rest))
((in-file ((var p) (file reader eof?)) next . rest)
(next ((p (open-input-file file)) (r reader) (e? eof?))
((var (r p) (r p)))
((e? var))
()
((dummy (close-input-port p)))
. rest))))
(define-syntax up-from
(syntax-rules (to by)
((up-from (() . args) next . rest)
(up-from ((var) . args) next . rest))
((up-from ((var) (start (to limit) (by step))) next . rest)
(next ((s start) (l limit) (e step))
((var s (+ var e)))
((>= var l))
()
()
. rest))
((up-from ((var) (start (to limit))) next . rest)
(next ((s start) (l limit))
((var s (+ var 1)))
((>= var l))
()
()
. rest))
((up-from ((var) (start (by step))) next . rest)
(next ((s start) (e step)) ((var s (+ var e))) () () () . rest))
((up-from ((var) (start)) next . rest)
(next ((s start)) ((var s (+ var 1))) () () () . rest))
))
(define-syntax down-from
(syntax-rules (to by)
((down-from (() . args) next . rest)
(down-from ((var) . args) next . rest))
((down-from ((var) (start (to limit) (by step))) next . rest)
(next ((s start) (l limit) (e step))
((var (- s e) (- var e)))
((< var l))
()
()
. rest))
((down-from ((var) (start (to limit))) next . rest)
(next ((s start) (l limit))
((var (- s 1) (- var 1)))
((< var l))
()
()
. rest))
((down-from ((var) (start (by step))) next . rest)
(next ((s start) (e step)) ((var (- s e) (- var e))) () () ()
. rest))
((down-from ((var) (start)) next . rest)
(next ((s start)) ((var (- s 1) (- var 1))) () () ()
. rest))
))
(define-syntax accumulating
(syntax-rules (initial if)
((accumulating (kons final init) ((var) . x) next . rest)
(accumulating (kons final init) ((var cursor) . x) next . rest))
((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest)
(accumulating (kons final i) ((var cursor) x) n . rest))
((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest)
(n ((tmp-kons kons))
((cursor '() (if check (tmp-kons expr cursor) cursor)))
()
()
((var (final cursor)))
. rest))
((accumulating (kons final init) ((var cursor) (expr)) n . rest)
(n ((tmp-kons kons))
((cursor '() (tmp-kons expr cursor)))
()
()
((var (final cursor)))
. rest))))
(define-syntax listing
(syntax-rules ()
((listing args next . rest)
(accumulating (cons reverse '()) args next . rest))))
(define-syntax listing-reverse
(syntax-rules ()
((listing-reverse args next . rest)
(accumulating (cons (lambda (x) x) '()) args next . rest))))
(define (append-reverse rev tail)
(if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
(define-syntax appending
(syntax-rules ()
((appending args next . rest)
(accumulating (append-reverse reverse '()) args next . rest))))
(define-syntax appending-reverse
(syntax-rules ()
((appending-reverse args next . rest)
(accumulating (append-reverse (lambda (x) x) '()) args next . rest))))
(define-syntax summing
(syntax-rules ()
((summing args next . rest)
(accumulating (+ (lambda (x) x) 0) args next . rest))))
(define-syntax multiplying
(syntax-rules ()
((multiplying args next . rest)
(accumulating (* (lambda (x) x) 1) args next . rest))))

6
lib/chibi/macroexpand.module Normal file
View file

@ -0,0 +1,6 @@
(define-module (chibi macroexpand)
(import-immutable (scheme))
(import (chibi ast))
(export macroexpand)
(include "macroexpand.scm"))

85
lib/chibi/macroexpand.scm Normal file
View file

@ -0,0 +1,85 @@
;; macroexpand.scm -- macro expansion utility
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;; This actually analyzes the expression then reverse-engineers an
;; sexp from the result, generating a minimal amount of renames.
(define (macroexpand x)
(ast->sexp (analyze x)))
(define (ast-renames ast)
(define i 0)
(define renames '())
(define (rename-symbol id)
(set! i (+ i 1))
(string->symbol
(string-append (symbol->string (identifier->symbol id))
"." (number->string i))))
(define (rename-lambda lam)
(or (assq lam renames)
(let ((res (list lam)))
(set! renames (cons res renames))
res)))
(define (rename! id lam)
(let ((cell (rename-lambda lam)))
(set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell)))))
(define (check-ref id lam env)
(let ((sym (identifier->symbol id)))
(let lp1 ((ls env))
(cond
((pair? ls)
(let lp2 ((ls2 (car ls)) (found? #f))
(cond
((null? ls2)
(if (not found?) (lp1 (cdr ls))))
((and (eq? id (caar ls2)) (eq? lam (cdar ls2)))
(lp2 (cdr ls2) #t))
((eq? sym (identifier->symbol (caar ls2)))
(rename! (caar ls2) (cdar ls2))
(lp2 (cdr ls2) found?))
(else
(lp2 (cdr ls2) found?)))))))))
(define (flatten-dot x)
(cond ((pair? x) (cons (car x) (flatten-dot (cdr x))))
((null? x) x)
(else (list x))))
(define (extend-env lam env)
(cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env))
(let lp ((x ast) (env '()))
(cond
((lambda? x) (lp (lambda-body x) (extend-env x env)))
((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env))
((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env))
((set? x) (lp (set-var x) env) (lp (set-value x) env))
((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x)))
((pair? x) (for-each (lambda (x) (lp x env)) x))))
renames)
(define (get-rename id lam renames)
(let ((ls (assq lam renames)))
(if (not ls)
(identifier->symbol id)
(cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id))))))
(define (ast->sexp ast)
(let ((renames (ast-renames ast)))
(let a2s ((x ast))
(cond
((lambda? x)
`(lambda ,(map (lambda (id) (get-rename id x renames)) (lambda-params x))
,@(map (lambda (d) `(define ,(identifier->symbol (cadr d)) #f)) (lambda-defs x))
,@(if (seq? (lambda-body x))
(map a2s (seq-ls (lambda-body x)))
(list (a2s (lambda-body x))))))
((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x))))
((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x))))
((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames))
((seq? x) `(begin ,@(map a2s (seq-ls x))))
((lit? x)
(let ((v (lit-value x)))
(if (or (pair? v) (null? v) (symbol? v)) `',v v)))
((pair? x) (cons (a2s (car x)) (a2s (cdr x))))
((opcode? x) (or (opcode-name x) x))
(else x)))))

6
lib/chibi/match.module Normal file
View file

@ -0,0 +1,6 @@
(define-module (chibi match)
(export match match-lambda match-lambda* match-let match-letrec match-let*)
(import-immutable (scheme))
(include "match/match.scm"))

670
lib/chibi/match/match.scm Normal file
View file

@ -0,0 +1,670 @@
;;;; match.scm -- portable hygienic pattern matcher
;;
;; This code is written by Alex Shinn and placed in the
;; Public Domain. All warranties are disclaimed.
;; This is a full superset of the popular MATCH package by Andrew
;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks
;; in R6RS SYNTAX-RULES), and thus preserving hygiene.
;; This is a simple generative pattern matcher - each pattern is
;; expanded into the required tests, calling a failure continuation if
;; the tests fail. This makes the logic easy to follow and extend,
;; but produces sub-optimal code in cases where you have many similar
;; clauses due to repeating the same tests. Nonetheless a smart
;; compiler should be able to remove the redundant tests. For
;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
;; hit.
;; The original version was written on 2006/11/29 and described in the
;; following Usenet post:
;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
;; and is still available at
;; http://synthcode.com/scheme/match-simple.scm
;; It's just 80 lines for the core MATCH, and an extra 40 lines for
;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar.
;;
;; A variant of this file which uses COND-EXPAND in a few places for
;; performance can be found at
;; http://synthcode.com/scheme/match-cond-expand.scm
;;
;; 2009/11/25 - adding `***' tree search patterns
;; 2008/03/20 - fixing bug where (a ...) matched non-lists
;; 2008/03/15 - removing redundant check in vector patterns
;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
;; 2007/09/04 - fixing quasiquote patterns
;; 2007/07/21 - allowing ellipse patterns in non-final list positions
;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
;; (thanks to Taylor Campbell)
;; 2007/04/08 - clean up, commenting
;; 2006/12/24 - bugfixes
;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; force compile-time syntax errors with useful messages
(define-syntax match-syntax-error
(syntax-rules ()
((_) (match-syntax-error "invalid match-syntax-error usage"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The basic interface. MATCH just performs some basic syntax
;; validation, binds the match expression to a temporary variable `v',
;; and passes it on to MATCH-NEXT. It's a constant throughout the
;; code below that the binding `v' is a direct variable reference, not
;; an expression.
(define-syntax match
(syntax-rules ()
((match)
(match-syntax-error "missing match expression"))
((match atom)
(match-syntax-error "no match clauses"))
((match (app ...) (pat . body) ...)
(let ((v (app ...)))
(match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
((match #(vec ...) (pat . body) ...)
(let ((v #(vec ...)))
(match-next v (v (set! v)) (pat . body) ...)))
((match atom (pat . body) ...)
(match-next atom (atom (set! atom)) (pat . body) ...))
))
;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
;; clauses. `g+s' is a list of two elements, the get! and set!
;; expressions respectively.
(define-syntax match-next
(syntax-rules (=>)
;; no more clauses, the match failed
((match-next v g+s)
(error 'match "no matching pattern"))
;; named failure continuation
((match-next v g+s (pat (=> failure) . body) . rest)
(let ((failure (lambda () (match-next v g+s . rest))))
;; match-one analyzes the pattern for us
(match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
;; anonymous failure continuation, give it a dummy name
((match-next v g+s (pat . body) . rest)
(match-next v g+s (pat (=> failure) . body) . rest))))
;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
;; MATCH-TWO.
(define-syntax match-one
(syntax-rules ()
;; If it's a list of two or more values, check to see if the
;; second one is an ellipse and handle accordingly, otherwise go
;; to MATCH-TWO.
((match-one v (p q . r) g+s sk fk i)
(match-check-ellipse
q
(match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())
(match-two v (p q . r) g+s sk fk i)))
;; Go directly to MATCH-TWO.
((match-one . x)
(match-two . x))))
;; This is the guts of the pattern matcher. We are passed a lot of
;; information in the form:
;;
;; (match-two var pattern getter setter success-k fail-k (ids ...))
;;
;; usually abbreviated
;;
;; (match-two v p g+s sk fk i)
;;
;; where VAR is the symbol name of the current variable we are
;; matching, PATTERN is the current pattern, getter and setter are the
;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
;; continuation (which is just a thunk call and is thus safe to expand
;; multiple times) and IDS are the list of identifiers bound in the
;; pattern so far.
(define-syntax match-two
(syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
((match-two v () g+s (sk ...) fk i)
(if (null? v) (sk ... i) fk))
((match-two v (quote p) g+s (sk ...) fk i)
(if (equal? v 'p) (sk ... i) fk))
((match-two v (quasiquote p) . x)
(match-quasiquote v p . x))
((match-two v (and) g+s (sk ...) fk i) (sk ... i))
((match-two v (and p q ...) g+s sk fk i)
(match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
((match-two v (or) g+s sk fk i) fk)
((match-two v (or p) . x)
(match-one v p . x))
((match-two v (or p ...) g+s sk fk i)
(match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
((match-two v (not p) g+s (sk ...) fk i)
(match-one v p g+s (match-drop-ids fk) (sk ... i) i))
((match-two v (get! getter) (g s) (sk ...) fk i)
(let ((getter (lambda () g))) (sk ... i)))
((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
(let ((setter (lambda (x) (s ... x)))) (sk ... i)))
((match-two v (? pred . p) g+s sk fk i)
(if (pred v) (match-one v (and . p) g+s sk fk i) fk))
((match-two v (= proc p) . x)
(let ((w (proc v))) (match-one w p . x)))
((match-two v (p ___ . r) g+s sk fk i)
(match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
((match-two v (p) g+s sk fk i)
(if (and (pair? v) (null? (cdr v)))
(let ((w (car v)))
(match-one w p ((car v) (set-car! v)) sk fk i))
fk))
((match-two v (p *** q) g+s sk fk i)
(match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
((match-two v (p *** . q) g+s sk fk i)
(match-syntax-error "invalid use of ***" (p *** . q)))
((match-two v (p . q) g+s sk fk i)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
(match-one w p ((car v) (set-car! v))
(match-one x q ((cdr v) (set-cdr! v)) sk fk)
fk
i))
fk))
((match-two v #(p ...) g+s . x)
(match-vector v 0 () (p ...) . x))
((match-two v _ g+s (sk ...) fk i) (sk ... i))
;; Not a pair or vector or special literal, test to see if it's a
;; new symbol, in which case we just bind it, or if it's an
;; already bound symbol or some other literal, in which case we
;; compare it with EQUAL?.
((match-two v x g+s (sk ...) fk (id ...))
(let-syntax
((new-sym?
(syntax-rules (id ...)
((new-sym? x sk2 fk2) sk2)
((new-sym? y sk2 fk2) fk2))))
(new-sym? random-sym-to-match
(let ((x v)) (sk ... (id ... x)))
(if (equal? v x) (sk ... (id ...)) fk))))
))
;; QUASIQUOTE patterns
(define-syntax match-quasiquote
(syntax-rules (unquote unquote-splicing quasiquote)
((_ v (unquote p) g+s sk fk i)
(match-one v p g+s sk fk i))
((_ v ((unquote-splicing p) . rest) g+s sk fk i)
(if (pair? v)
(match-one v
(p . tmp)
(match-quasiquote tmp rest g+s sk fk)
fk
i)
fk))
((_ v (quasiquote p) g+s sk fk i . depth)
(match-quasiquote v p g+s sk fk i #f . depth))
((_ v (unquote p) g+s sk fk i x . depth)
(match-quasiquote v p g+s sk fk i . depth))
((_ v (unquote-splicing p) g+s sk fk i x . depth)
(match-quasiquote v p g+s sk fk i . depth))
((_ v (p . q) g+s sk fk i . depth)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
(match-quasiquote
w p g+s
(match-quasiquote-step x q g+s sk fk depth)
fk i . depth))
fk))
((_ v #(elt ...) g+s sk fk i . depth)
(if (vector? v)
(let ((ls (vector->list v)))
(match-quasiquote ls (elt ...) g+s sk fk i . depth))
fk))
((_ v x g+s sk fk i . depth)
(match-one v 'x g+s sk fk i))))
(define-syntax match-quasiquote-step
(syntax-rules ()
((match-quasiquote-step x q g+s sk fk depth i)
(match-quasiquote x q g+s sk fk i . depth))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utilities
;; Takes two values and just expands into the first.
(define-syntax match-drop-ids
(syntax-rules ()
((_ expr ids ...) expr)))
(define-syntax match-drop-first-arg
(syntax-rules ()
((_ arg expr) expr)))
;; To expand an OR group we try each clause in succession, passing the
;; first that succeeds to the success continuation. On failure for
;; any clause, we just try the next clause, finally resorting to the
;; failure continuation fk if all clauses fail. The only trick is
;; that we want to unify the identifiers, so that the success
;; continuation can refer to a variable from any of the OR clauses.
(define-syntax match-gen-or
(syntax-rules ()
((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
(let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
(match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
(define-syntax match-gen-or-step
(syntax-rules ()
((_ v () g+s sk fk . x)
;; no OR clauses, call the failure continuation
fk)
((_ v (p) . x)
;; last (or only) OR clause, just expand normally
(match-one v p . x))
((_ v (p . q) g+s sk fk i)
;; match one and try the remaining on failure
(match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
))
;; We match a pattern (p ...) by matching the pattern p in a loop on
;; each element of the variable, accumulating the bound ids into lists.
;; Look at the body of the simple case - it's just a named let loop,
;; matching each element in turn to the same pattern. The only trick
;; is that we want to keep track of the lists of each extracted id, so
;; when the loop recurses we cons the ids onto their respective list
;; variables, and on success we bind the ids (what the user input and
;; expects to see in the success body) to the reversed accumulated
;; list IDs.
(define-syntax match-gen-ellipses
(syntax-rules ()
((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
(match-check-identifier p
;; simplest case equivalent to (p ...), just bind the list
(let ((p v))
(if (list? p)
(sk ... i)
fk))
;; simple case, match all elements of the list
(let loop ((ls v) (id-ls '()) ...)
(cond
((null? ls)
(let ((id (reverse id-ls)) ...) (sk ... i)))
((pair? ls)
(let ((w (car ls)))
(match-one w p ((car ls) (set-car! ls))
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
fk i)))
(else
fk)))))
((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
;; general case, trailing patterns to match, keep track of the
;; remaining list length so we don't need any backtracking
(match-verify-no-ellipses
r
(let* ((tail-len (length 'r))
(ls v)
(len (length ls)))
(if (< len tail-len)
fk
(let loop ((ls ls) (n len) (id-ls '()) ...)
(cond
((= n tail-len)
(let ((id (reverse id-ls)) ...)
(match-one ls r (#f #f) (sk ... i) fk i)))
((pair? ls)
(let ((w (car ls)))
(match-one w p ((car ls) (set-car! ls))
(match-drop-ids
(loop (cdr ls) (- n 1) (cons id id-ls) ...))
fk
i)))
(else
fk)))))))))
;; This is just a safety check. Although unlike syntax-rules we allow
;; trailing patterns after an ellipses, we explicitly disable multiple
;; ellipses at the same level. This is because in the general case
;; such patterns are exponential in the number of ellipses, and we
;; don't want to make it easy to construct very expensive operations
;; with simple looking patterns. For example, it would be O(n^2) for
;; patterns like (a ... b ...) because we must consider every trailing
;; element for every possible break for the leading "a ...".
(define-syntax match-verify-no-ellipses
(syntax-rules ()
((_ (x . y) sk)
(match-check-ellipse
x
(match-syntax-error
"multiple ellipse patterns not allowed at same level")
(match-verify-no-ellipses y sk)))
((_ () sk)
sk)
((_ x sk)
(match-syntax-error "dotted tail not allowed after ellipse" x))))
;; Matching a tree search pattern is only slightly more complicated.
;; Here we allow patterns of the form
;;
;; (x *** y)
;;
;; to represent the pattern y located somewhere in a tree where the
;; path from the current object to y can be seen as a list of the form
;; (X ...). Y can immediately match the current object in which case
;; the path is the empty list. In a sense it's a 2-dimensional
;; version of the ... pattern.
;;
;; As a common case the pattern (_ *** y) can be used to search for Y
;; anywhere in a tree, regardless of the path used.
;;
;; To implement the search, we use two recursive procedures. TRY
;; attempts to match Y once, and on success it calls the normal SK on
;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we
;; call NEXT which first checks if the current value is a list
;; beginning with X, then calls TRY on each remaining element of the
;; list. Since TRY will recursively call NEXT again on failure, this
;; effects a full depth-first search.
;;
;; The failure continuation throughout is a jump to the next step in
;; the tree search, initialized with the original failure continuation
;; FK.
(define-syntax match-gen-search
(syntax-rules ()
((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
(letrec ((try (lambda (w fail id-ls ...)
(match-one w q g+s
(match-drop-ids
(let ((id (reverse id-ls)) ...)
sk))
(next w fail id-ls ...) i)))
(next (lambda (w fail id-ls ...)
(if (not (pair? w))
(fail)
(let ((u (car w)))
(match-one
u p ((car w) (set-car! w))
(match-drop-ids
;; accumulate the head variables from
;; the p pattern, and loop over the tail
(let ((id-ls (cons id id-ls)) ...)
(let lp ((ls (cdr w)))
(if (pair? ls)
(try (car ls)
(lambda () (lp (cdr ls)))
id-ls ...)
(fail)))))
(fail) i))))))
;; the initial id-ls binding here is a dummy to get the right
;; number of '()s
(let ((id-ls '()) ...)
(try v (lambda () fk) id-ls ...))))))
;; Vector patterns are just more of the same, with the slight
;; exception that we pass around the current vector index being
;; matched.
(define-syntax match-vector
(syntax-rules (___)
((_ v n pats (p q) . x)
(match-check-ellipse q
(match-gen-vector-ellipses v n pats p . x)
(match-vector-two v n pats (p q) . x)))
((_ v n pats (p ___) sk fk i)
(match-gen-vector-ellipses v n pats p sk fk i))
((_ . x)
(match-vector-two . x))))
;; Check the exact vector length, then check each element in turn.
(define-syntax match-vector-two
(syntax-rules ()
((_ v n ((pat index) ...) () sk fk i)
(if (vector? v)
(let ((len (vector-length v)))
(if (= len n)
(match-vector-step v ((pat index) ...) sk fk i)
fk))
fk))
((_ v n (pats ...) (p . q) . x)
(match-vector v (+ n 1) (pats ... (p n)) q . x))))
(define-syntax match-vector-step
(syntax-rules ()
((_ v () (sk ...) fk i) (sk ... i))
((_ v ((pat index) . rest) sk fk i)
(let ((w (vector-ref v index)))
(match-one w pat ((vector-ref v index) (vector-set! v index))
(match-vector-step v rest sk fk)
fk i)))))
;; With a vector ellipse pattern we first check to see if the vector
;; length is at least the required length.
(define-syntax match-gen-vector-ellipses
(syntax-rules ()
((_ v n ((pat index) ...) p sk fk i)
(if (vector? v)
(let ((len (vector-length v)))
(if (>= len n)
(match-vector-step v ((pat index) ...)
(match-vector-tail v p n len sk fk)
fk i)
fk))
fk))))
(define-syntax match-vector-tail
(syntax-rules ()
((_ v p n len sk fk i)
(match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
(define-syntax match-vector-tail-two
(syntax-rules ()
((_ v p n len (sk ...) fk i ((id id-ls) ...))
(let loop ((j n) (id-ls '()) ...)
(if (>= j len)
(let ((id (reverse id-ls)) ...) (sk ... i))
(let ((w (vector-ref v j)))
(match-one w p ((vector-ref v j) (vetor-set! v j))
(match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
fk i)))))))
;; Extract all identifiers in a pattern. A little more complicated
;; than just looking for symbols, we need to ignore special keywords
;; and non-pattern forms (such as the predicate expression in ?
;; patterns), and also ignore previously bound identifiers.
;;
;; Calls the continuation with all new vars as a list of the form
;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
;; pair with the original variable (e.g. it's used in the ellipse
;; generation for list variables).
;;
;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
(define-syntax match-extract-vars
(syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
((match-extract-vars (? pred . p) . x)
(match-extract-vars p . x))
((match-extract-vars ($ rec . p) . x)
(match-extract-vars p . x))
((match-extract-vars (= proc p) . x)
(match-extract-vars p . x))
((match-extract-vars (quote x) (k ...) i v)
(k ... v))
((match-extract-vars (quasiquote x) k i v)
(match-extract-quasiquote-vars x k i v (#t)))
((match-extract-vars (and . p) . x)
(match-extract-vars p . x))
((match-extract-vars (or . p) . x)
(match-extract-vars p . x))
((match-extract-vars (not . p) . x)
(match-extract-vars p . x))
;; A non-keyword pair, expand the CAR with a continuation to
;; expand the CDR.
((match-extract-vars (p q . r) k i v)
(match-check-ellipse
q
(match-extract-vars (p . r) k i v)
(match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
((match-extract-vars (p . q) k i v)
(match-extract-vars p (match-extract-vars-step q k i v) i ()))
((match-extract-vars #(p ...) . x)
(match-extract-vars (p ...) . x))
((match-extract-vars _ (k ...) i v) (k ... v))
((match-extract-vars ___ (k ...) i v) (k ... v))
((match-extract-vars *** (k ...) i v) (k ... v))
;; This is the main part, the only place where we might add a new
;; var if it's an unbound symbol.
((match-extract-vars p (k ...) (i ...) v)
(let-syntax
((new-sym?
(syntax-rules (i ...)
((new-sym? p sk fk) sk)
((new-sym? x sk fk) fk))))
(new-sym? random-sym-to-match
(k ... ((p p-ls) . v))
(k ... v))))
))
;; Stepper used in the above so it can expand the CAR and CDR
;; separately.
(define-syntax match-extract-vars-step
(syntax-rules ()
((_ p k i v ((v2 v2-ls) ...))
(match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
))
(define-syntax match-extract-quasiquote-vars
(syntax-rules (quasiquote unquote unquote-splicing)
((match-extract-quasiquote-vars (quasiquote x) k i v d)
(match-extract-quasiquote-vars x k i v (#t . d)))
((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
(match-extract-quasiquote-vars (unquote x) k i v d))
((match-extract-quasiquote-vars (unquote x) k i v (#t))
(match-extract-vars x k i v))
((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
(match-extract-quasiquote-vars x k i v d))
((match-extract-quasiquote-vars (x . y) k i v (#t . d))
(match-extract-quasiquote-vars
x
(match-extract-quasiquote-vars-step y k i v d) i ()))
((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
(match-extract-quasiquote-vars (x ...) k i v d))
((match-extract-quasiquote-vars x (k ...) i v (#t . d))
(k ... v))
))
(define-syntax match-extract-quasiquote-vars-step
(syntax-rules ()
((_ x k i v d ((v2 v2-ls) ...))
(match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Gimme some sugar baby.
(define-syntax match-lambda
(syntax-rules ()
((_ clause ...) (lambda (expr) (match expr clause ...)))))
(define-syntax match-lambda*
(syntax-rules ()
((_ clause ...) (lambda expr (match expr clause ...)))))
(define-syntax match-let
(syntax-rules ()
((_ (vars ...) . body)
(match-let/helper let () () (vars ...) . body))
((_ loop . rest)
(match-named-let loop () . rest))))
(define-syntax match-letrec
(syntax-rules ()
((_ vars . body) (match-let/helper letrec () () vars . body))))
(define-syntax match-let/helper
(syntax-rules ()
((_ let ((var expr) ...) () () . body)
(let ((var expr) ...) . body))
((_ let ((var expr) ...) ((pat tmp) ...) () . body)
(let ((var expr) ...)
(match-let* ((pat tmp) ...)
. body)))
((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
(match-let/helper
let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
(match-let/helper
let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
((_ let (v ...) (p ...) ((a expr) . rest) . body)
(match-let/helper let (v ... (a expr)) (p ...) rest . body))))
(define-syntax match-named-let
(syntax-rules ()
((_ loop ((pat expr var) ...) () . body)
(let loop ((var expr) ...)
(match-let ((pat var) ...)
. body)))
((_ loop (v ...) ((pat expr) . rest) . body)
(match-named-let loop (v ... (pat expr tmp)) rest . body))))
(define-syntax match-let*
(syntax-rules ()
((_ () . body)
(begin . body))
((_ ((pat expr) . rest) . body)
(match expr (pat (match-let* rest . body))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Otherwise COND-EXPANDed bits.
;; This *should* work, but doesn't :(
;; (define-syntax match-check-ellipse
;; (syntax-rules (...)
;; ((_ ... sk fk) sk)
;; ((_ x sk fk) fk)))
;; This is a little more complicated, and introduces a new let-syntax,
;; but should work portably in any R[56]RS Scheme. Taylor Campbell
;; originally came up with the idea.
(define-syntax match-check-ellipse
(syntax-rules ()
;; these two aren't necessary but provide fast-case failures
((match-check-ellipse (a . b) success-k failure-k) failure-k)
((match-check-ellipse #(a ...) success-k failure-k) failure-k)
;; matching an atom
((match-check-ellipse id success-k failure-k)
(let-syntax ((ellipse? (syntax-rules ()
;; iff `id' is `...' here then this will
;; match a list of any length
((ellipse? (foo id) sk fk) sk)
((ellipse? other sk fk) fk))))
;; this list of three elements will only many the (foo id) list
;; above if `id' is `...'
(ellipse? (a b c) success-k failure-k)))))
;; This is portable but can be more efficient with non-portable
;; extensions. This trick was originally discovered by Oleg Kiselyov.
(define-syntax match-check-identifier
(syntax-rules ()
;; fast-case failures, lists and vectors are not identifiers
((_ (x . y) success-k failure-k) failure-k)
((_ #(x ...) success-k failure-k) failure-k)
;; x is an atom
((_ x success-k failure-k)
(let-syntax
((sym?
(syntax-rules ()
;; if the symbol `abracadabra' matches x, then x is a
;; symbol
((sym? x sk fk) sk)
;; otherwise x is a non-symbol datum
((sym? y sk fk) fk))))
(sym? abracadabra success-k failure-k)))))

10
lib/chibi/net.module Normal file
View file

@ -0,0 +1,10 @@
(define-module (chibi net)
(export sockaddr? address-info? get-address-info socket connect with-net-io
address-info-family address-info-socket-type address-info-protocol
address-info-address address-info-address-length address-info-next)
(import-immutable (scheme))
(import (chibi filesystem))
(include-shared "net")
(include "net.scm"))

23
lib/chibi/net.scm Normal file
View file

@ -0,0 +1,23 @@
;; net.scm -- the high-level network interface
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (with-net-io host service proc)
(let lp ((addr (get-address-info host service #f)))
(if (not addr)
(error "couldn't find address" host service)
(let ((sock (socket (address-info-family addr)
(address-info-socket-type addr)
(address-info-protocol addr))))
(if (negative? sock)
(lp (address-info-next addr))
(if (negative?
(connect sock
(address-info-address addr)
(address-info-address-length addr)))
(lp (address-info-next addr))
(let ((in (open-input-file-descriptor sock))
(out (open-output-file-descriptor sock)))
(let ((res (proc in out)))
(close-input-port in)
res))))))))

25
lib/chibi/net.stub Normal file
View file

@ -0,0 +1,25 @@
(c-system-include "sys/types.h")
(c-system-include "sys/socket.h")
(c-system-include "netdb.h")
(define-c-struct sockaddr
predicate: sockaddr?)
(define-c-struct addrinfo
finalizer: freeaddrinfo
predicate: address-info?
(int ai_family address-info-family)
(int ai_socktype address-info-socket-type)
(int ai_protocol address-info-protocol)
((link sockaddr) ai_addr address-info-address)
(size_t ai_addrlen address-info-address-length)
((link addrinfo) ai_next address-info-next))
(define-c errno (get-address-info getaddrinfo)
(string string (maybe-null addrinfo) (result free addrinfo)))
(define-c int bind (int sockaddr int))
(define-c int listen (int int))
(define-c int socket (int int int))
(define-c int connect (int sockaddr int))

7
lib/chibi/pathname.module Normal file
View file

@ -0,0 +1,7 @@
(define-module (chibi pathname)
(export path-strip-directory path-directory path-extension-pos
path-extension path-strip-extension path-replace-extension
path-absolute? path-relative? path-normalize make-path)
(import-immutable (scheme))
(include "pathname.scm"))

180
lib/chibi/pathname.scm Normal file
View file

@ -0,0 +1,180 @@
;; pathname.scm -- a general, non-host-specific path lib
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (string-scan c str . o)
(let ((limit (string-length str)))
(let lp ((i (if (pair? o) (car o) 0)))
(cond ((>= i limit) #f)
((eqv? c (string-ref str i)) i)
(else (lp (+ i 1)))))))
(define (string-scan-right c str . o)
(let lp ((i (if (pair? o) (car o) (- (string-length str) 1))))
(cond ((negative? i) #f)
((eqv? c (string-ref str i)) i)
(else (lp (- i 1))))))
(define (string-skip c str . o)
(let ((limit (string-length str)))
(let lp ((i (if (pair? o) (car o) 0)))
(cond ((>= i limit) #f)
((not (eqv? c (string-ref str i))) i)
(else (lp (+ i 1)))))))
(define (string-skip-right c str . o)
(let lp ((i (if (pair? o) (car o) (- (string-length str) 1))))
(cond ((negative? i) #f)
((not (eqv? c (string-ref str i))) i)
(else (lp (- i 1))))))
;; POSIX basename
;; (define (path-strip-directory path)
;; (if (string=? path "")
;; path
;; (let ((end (string-skip-right #\/ path)))
;; (if (not end)
;; "/"
;; (let ((start (string-scan-right #\/ path (- end 1))))
;; (substring path (if start (+ start 1) 0) (+ end 1)))))))
;; GNU basename
(define (path-strip-directory path)
(if (string=? path "")
path
(let ((len (string-length path)))
(if (eqv? #\/ (string-ref path (- len 1)))
""
(let ((slash (string-scan-right #\/ path)))
(if (not slash)
path
(substring path (+ slash 1) len)))))))
(define (path-directory path)
(if (string=? path "")
"."
(let ((end (string-skip-right #\/ path)))
(if (not end)
"/"
(let ((start (string-scan-right #\/ path (- end 1))))
(if (not start)
"."
(let ((start (string-skip-right #\/ path start)))
(if (not start) "/" (substring path 0 (+ start 1))))))))))
(define (path-extension-pos path) (string-scan-right #\. path))
(define (path-extension path)
(let ((i (path-extension-pos path)))
(and i
(let ((start (+ i 1)) (end (string-length path)))
(and (< start end) (substring path start end))))))
(define (path-strip-extension path)
(let ((i (path-extension-pos path)))
(if (and i (< (+ i 1) (string-length path)))
(substring path 0 i)
path)))
(define (path-replace-extension path ext)
(string-append (path-strip-extension path) "." ext))
(define (path-absolute? path)
(and (not (string=? "" path)) (eqv? #\/ (string-ref path 0))))
(define (path-relative? path) (not (path-absolute? path)))
;; This looks big and hairy, but it's mutation-free and guarantees:
;; (string=? s (path-normalize s)) <=> (eq? s (path-normalize s))
;; i.e. fast and simple for already normalized paths.
(define (path-normalize path)
(let* ((len (string-length path)) (len-1 (- len 1)))
(define (collect i j res)
(if (>= i j) res (cons (substring path i j) res)))
(define (finish i res)
(if (zero? i)
path
(apply string-append (reverse (collect i len res)))))
;; loop invariants:
;; - res is a list such that (string-concatenate-reverse res)
;; is always the normalized string up to j
;; - the tail of the string from j onward can be concatenated to
;; the above value to get a partially normalized path referring
;; to the same location as the original path
(define (inside i j res)
(if (>= j len)
(finish i res)
(if (eqv? #\/ (string-ref path j))
(boundary i (+ j 1) res)
(inside i (+ j 1) res))))
(define (boundary i j res)
(if (>= j len-1)
(finish i res)
(case (string-ref path j)
((#\.)
(case (string-ref path (+ j 1))
((#\.)
(if (or (>= j (- len 2)) (eqv? #\/ (string-ref path (+ j 2))))
(if (>= i (- j 1))
(if (null? res)
(backup j "" '())
(backup j (car res) (cdr res)))
(backup j (substring path i j) res))
(inside i (+ j 2) res)))
((#\/)
(if (= i j)
(boundary (+ j 2) (+ j 2) res)
(let ((s (substring path i j)))
(boundary (+ j 2) (+ j 2) (cons s res)))))
(else (inside i (+ j 1) res))))
((#\/) (boundary (+ j 1) (+ j 1) (collect i j res)))
(else (inside i (+ j 1) res)))))
(define (backup j s res)
(let ((pos (+ j 3)))
(cond
;; case 1: we're reduced to accumulating parents of the cwd
((or (string=? s "/..") (string=? s ".."))
(boundary pos pos (cons "/.." (cons s res))))
;; case 2: the string isn't a component itself, skip it
((or (string=? s "") (string=? s ".") (string=? s "/"))
(if (pair? res)
(backup j (car res) (cdr res))
(boundary pos pos (if (string=? s "/") '("/") '("..")))))
;; case3: just take the directory of the string
(else
(let ((d (path-directory s)))
(cond
((string=? d "/")
(boundary pos pos (if (null? res) '("/") res)))
((string=? d ".")
(boundary pos pos res))
(else (boundary pos pos (cons "/" (cons d res))))))))))
;; start with boundary if abs path, otherwise inside
(if (zero? len)
path
((if (eqv? #\/ (string-ref path 0)) boundary inside) 0 1 '()))))
(define (make-path . args)
(define (x->string x)
(cond ((string? x) x)
((symbol? x) (symbol->string x))
((number? x) (number->string x))
(else (error "not a valid path component" x))))
(define (trim-trailing-slash s)
(let ((i (string-skip-right #\/ s)))
(if i (substring s 0 (+ i 1)) "")))
(if (null? args)
""
(let ((start (trim-trailing-slash (x->string (car args)))))
(let lp ((ls (cdr args))
(res (if (string=? "" start) '() (list start))))
(cond
((null? ls)
(apply string-append (reverse res)))
((pair? (car ls))
(lp (append (car ls) (cdr ls)) res))
(else
(let ((x (trim-trailing-slash (x->string (car ls)))))
(lp (cdr ls)
(if (string=? x "") res (cons x (cons "/" res)))))))))))

17
lib/chibi/process.module Normal file
View file

@ -0,0 +1,17 @@
(define-module (chibi process)
(export exit sleep alarm fork kill execute waitpid
set-signal-action! make-signal-set signal-set-contains?
signal-set-fill! signal-set-add! signal-set-delete!
current-signal-mask
signal-mask-block! signal-mask-unblock! signal-mask-set!
signal/hang-up signal/interrupt signal/quit
signal/illegal signal/abort signal/fpe
signal/kill signal/segv signal/pipe
signal/alarm signal/term signal/user1
signal/user2 signal/child signal/continue
signal/stop signal/tty-stop signal/tty-input
signal/tty-output)
(import-immutable (scheme))
(include-shared "process"))

72
lib/chibi/process.stub Normal file
View file

@ -0,0 +1,72 @@
(c-system-include "sys/types.h")
(c-system-include "sys/wait.h")
(c-system-include "signal.h")
(c-system-include "unistd.h")
(define-c-type siginfo_t
predicate: signal-info?
(int si_signo signal-number)
(int si_errno signal-error-number)
(int si_code signal-code)
(pid_t si_pid signal-pid)
(uid_t si_uid signal-uid)
(int si_status signal-status)
;;(clock_t si_utime signal-user-time)
;;(clock_t si_stime signal-system-time)
)
(define-c-type sigset_t
predicate: signal-set?)
(define-c-const int (signal/hang-up "SIGHUP"))
(define-c-const int (signal/interrupt "SIGINT"))
(define-c-const int (signal/quit "SIGQUIT"))
(define-c-const int (signal/illegal "SIGILL"))
(define-c-const int (signal/abort "SIGABRT"))
(define-c-const int (signal/fpe "SIGFPE"))
(define-c-const int (signal/kill "SIGKILL"))
(define-c-const int (signal/segv "SIGSEGV"))
(define-c-const int (signal/pipe "SIGPIPE"))
(define-c-const int (signal/alarm "SIGALRM"))
(define-c-const int (signal/term "SIGTERM"))
(define-c-const int (signal/user1"SIGUSR1"))
(define-c-const int (signal/user2 "SIGUSR2"))
(define-c-const int (signal/child "SIGCHLD"))
(define-c-const int (signal/continue "SIGCONT"))
(define-c-const int (signal/stop "SIGSTOP"))
(define-c-const int (signal/tty-stop "SIGTSTP"))
(define-c-const int (signal/tty-input "SIGTTIN"))
(define-c-const int (signal/tty-output "SIGTTOU"))
(c-include "signal.c")
(define-c sexp (set-signal-action! "sexp_set_signal_action")
((value ctx sexp) sexp sexp))
(define-c errno (make-signal-set "sigemptyset") ((result sigset_t)))
(define-c errno (signal-set-fill! "sigfillset") (sigset_t))
(define-c errno (signal-set-add! "sigaddset") (sigset_t int))
(define-c errno (signal-set-delete! "sigaddset") (sigset_t int))
(define-c boolean (signal-set-contains? "sigismember") (sigset_t int))
(define-c errno (signal-mask-block! "sigprocmask")
((value SIG_BLOCK int) sigset_t (value NULL sigset_t)))
(define-c errno (signal-mask-unblock! "sigprocmask")
((value SIG_UNBLOCK int) sigset_t (value NULL sigset_t)))
(define-c errno (signal-mask-set! "sigprocmask")
((value SIG_SETMASK int) sigset_t (value NULL sigset_t)))
(define-c errno (current-signal-mask "sigprocmask")
((value SIG_BLOCK int) (value NULL sigset_t) (result sigset_t)))
(define-c unsigned-int alarm (unsigned-int))
(define-c unsigned-int sleep (unsigned-int))
(define-c pid_t fork ())
;;(define-c pid_t wait ((result int)))
(define-c pid_t waitpid (int (result int) int))
(define-c errno kill (int int))
;;(define-c errno raise (int))
(define-c void exit (int))
(define-c int (execute execvp) (string (array string)))

62
lib/chibi/signal.c Normal file
View file

@ -0,0 +1,62 @@
/* signal.c -- process signals interface */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#define SEXP_MAX_SIGNUM 32
static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM];
static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) {
sexp ctx, sigctx, handler;
sexp_gc_var1(args);
ctx = sexp_signal_contexts[signum];
if (ctx) {
handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS),
sexp_make_fixnum(signum));
if (sexp_truep(handler)) {
sigctx = sexp_make_child_context(ctx, NULL);
sexp_gc_preserve1(sigctx, args);
args = sexp_cons(sigctx, SEXP_FALSE, SEXP_NULL);
sexp_car(args)
= sexp_make_cpointer(sigctx, sexp_siginfo_t_type_id, info, SEXP_FALSE, 0);
args = sexp_cons(sigctx, SEXP_FALSE, args);
sexp_car(args) = sexp_make_fixnum(signum);
sexp_apply(sigctx, handler, args);
sexp_gc_release1(sigctx);
}
}
}
static struct sigaction call_sigaction = {
.sa_sigaction = sexp_call_sigaction,
.sa_flags = SA_SIGINFO | SA_NODEFER
};
static struct sigaction call_sigdefault = {.sa_handler = SIG_DFL};
static struct sigaction call_sigignore = {.sa_handler = SIG_IGN};
static sexp sexp_set_signal_action (sexp ctx, sexp signum, sexp newaction) {
int res;
sexp oldaction;
if (! (sexp_fixnump(signum) && sexp_unbox_fixnum(signum) > 0
&& sexp_unbox_fixnum(signum) < SEXP_MAX_SIGNUM))
return sexp_type_exception(ctx, "not a valid signal number", signum);
if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction)
|| sexp_booleanp(newaction)))
return sexp_type_exception(ctx, "not a procedure", newaction);
if (! sexp_vectorp(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS)))
sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS)
= sexp_make_vector(ctx, sexp_make_fixnum(SEXP_MAX_SIGNUM), SEXP_FALSE);
oldaction = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum);
res = sigaction(sexp_unbox_fixnum(signum),
(sexp_booleanp(newaction) ?
(sexp_truep(newaction) ? &call_sigdefault : &call_sigignore)
: &call_sigaction),
NULL);
if (res)
return sexp_user_exception(ctx, SEXP_FALSE, "couldn't set signal", signum);
sexp_vector_set(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), signum, newaction);
sexp_signal_contexts[sexp_unbox_fixnum(signum)] = ctx;
return oldaction;
}

15
lib/chibi/system.module Normal file
View file

@ -0,0 +1,15 @@
(define-module (chibi system)
(export user-information user-name user-password
user-id user-group-id user-gecos user-home user-shell
current-user-id current-group-id
current-effective-user-id current-effective-group-id
set-current-user-id! set-current-effective-user-id!
set-current-group-id! set-current-effective-group-id!
current-session-id create-session
set-root-directory!)
(import-immutable (scheme))
(include-shared "system")
;;(include "system.scm")
)

34
lib/chibi/system.stub Normal file
View file

@ -0,0 +1,34 @@
(c-system-include "unistd.h")
(c-system-include "pwd.h")
(c-system-include "sys/types.h")
(define-c-struct passwd
predicate: user?
(string pw_name user-name)
(string pw_passwd user-password)
(uid_t pw_uid user-id)
(gid_t pw_gid user-group-id)
(string pw_gecos user-gecos)
(string pw_dir user-home)
(string pw_shell user-shell))
(define-c uid_t (current-user-id "getuid") ())
(define-c gid_t (current-group-id "getgid") ())
(define-c uid_t (current-effective-user-id "geteuid") ())
(define-c gid_t (current-effective-group-id "getegid") ())
(define-c errno (set-current-user-id! "setuid") (uid_t))
(define-c errno (set-current-effective-user-id! "seteuid") (uid_t))
(define-c errno (set-current-group-id! "setgid") (gid_t))
(define-c errno (set-current-effective-group-id! "setegid") (gid_t))
(define-c pid_t (current-session-id "getsid") ((default 0 pid_t)))
(define-c pid_t (create-session "setsid") ())
(define-c errno (set-root-directory! "chroot") (string))
;; (define-c errno getpwuid_r
;; (uid_t (result passwd) (result (array char arg3))
;; (value 256 int) (result pointer passwd)))

11
lib/chibi/time.module Normal file
View file

@ -0,0 +1,11 @@
(define-module (chibi time)
(export current-seconds get-time-of-day set-time-of-day!
seconds->time seconds->string time->seconds time->string
timeval-seconds timeval-microseconds
timezone-offset timezone-dst-time
time-second time-minute time-hour time-day time-month time-year
time-day-of-week time-day-of-year time-dst?)
(import-immutable (scheme))
(include-shared "time"))

45
lib/chibi/time.stub Normal file
View file

@ -0,0 +1,45 @@
(c-system-include "time.h")
(c-system-include "sys/time.h")
(define-c-struct tm
(int tm_sec time-second)
(int tm_min time-minute)
(int tm_hour time-hour)
(int tm_mday time-day)
(int tm_mon time-month)
(int tm_year time-year)
(int tm_wday time-day-of-week)
(int tm_yday time-day-of-year)
(int tm_isdst time-dst?))
(define-c-struct timeval
predicate: timeval?
(time_t tv_sec timeval-seconds)
(int tv_usec timeval-microseconds))
(define-c-struct timezone
predicate: timezone?
(int tz_minuteswest timezone-offset)
(int tz_dsttime timezone-dst-time))
(define-c time_t (current-seconds "time") ((value NULL)))
(define-c errno (get-time-of-day "gettimeofday")
((result timeval) (result timezone)))
(define-c errno (set-time-of-day! "settimeofday")
(timeval (maybe-null default NULL timezone)))
(define-c non-null-pointer (seconds->time "localtime_r")
((pointer time_t) (result tm)))
(define-c time_t (time->seconds "mktime")
(tm))
(define-c non-null-string (seconds->string "ctime_r")
((pointer time_t) (result (array char 64))))
(define-c non-null-string (time->string "asctime_r")
(tm (result (array char 64))))

10
lib/chibi/uri.module Normal file
View file

@ -0,0 +1,10 @@
(define-module (chibi uri)
(export uri->string make-uri string->uri
uri-scheme uri-user uri-host uri-path uri-query uri-fragment
uri-with-scheme uri-with-user uri-with-host uri-with-path
uri-with-query uri-with-fragment
uri-encode uri-decode uri-query->alist uri-alist->query)
(import-immutable (scheme)
(srfi 9))
(include "uri.scm"))

306
lib/chibi/uri.scm Normal file
View file

@ -0,0 +1,306 @@
;; uri.scm -- URI parsing library
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; URI representation
(define-record-type uri
(%make-uri scheme user host port path query fragment)
uri?
(scheme uri-scheme)
(user uri-user)
(host uri-host)
(port uri-port)
(path uri-path)
(query uri-query)
(fragment uri-fragment))
;; (make-uri scheme [user host port path query fragment])
(define (make-uri scheme . o)
(let* ((user (if (pair? o) (car o) #f))
(o (if (pair? o) (cdr o) '()))
(host (if (pair? o) (car o) #f))
(o (if (pair? o) (cdr o) '()))
(port (if (pair? o) (car o) #f))
(o (if (pair? o) (cdr o) '()))
(path (if (pair? o) (car o) #f))
(o (if (pair? o) (cdr o) '()))
(query (if (pair? o) (car o) #f))
(o (if (pair? o) (cdr o) '()))
(fragment (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) #f)))
(%make-uri scheme user host port path query fragment)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; string utils (don't feel like using SRFI-13 and these are more
;; specialised)
(define (string-scan str ch . o)
(let ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
(let lp ((i start))
(and (< i end)
(if (eqv? ch (string-ref str i))
i
(lp (+ i 1)))))))
(define (string-scan-right str ch . o)
(let ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
(let lp ((i (- end 1)))
(and (>= i start)
(if (eqv? ch (string-ref str i))
i
(lp (- i 1)))))))
(define (string-index-of str pred . o)
(let ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
(let lp ((i start))
(cond ((>= i end) #f)
((pred (string-ref str i)) i)
(else (lp (+ i 1)))))))
(define (string-downcase->symbol str)
(let ((len (string-length str)))
(let lp ((i 0))
(cond
((= i len)
(string->symbol str))
((char-upper-case? (string-ref str i))
(let ((res (make-string len)))
(do ((j 0 (+ j 1)))
((= j i))
(string-set! res j (string-ref str j)))
(string-set! res i (char-downcase (string-ref str i)))
(do ((j (+ i 1) (+ j 1)))
((= j len))
(string-set! res j (char-downcase (string-ref str j))))
(string->symbol res)))
(else
(lp (+ i 1)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; functional updaters (uses as much shared state as possible)
(define (uri-with-scheme u scheme)
(%make-uri scheme (uri-user u) (uri-host u) (uri-port u)
(uri-path u) (uri-query u) (uri-fragment u)))
(define (uri-with-user u user)
(%make-uri (uri-scheme u) user (uri-host u) (uri-port u)
(uri-path u) (uri-query u) (uri-fragment u)))
(define (uri-with-host u host)
(%make-uri (uri-scheme u) (uri-user u) host (uri-port u)
(uri-path u) (uri-query u) (uri-fragment u)))
(define (uri-with-port u port)
(%make-uri (uri-scheme u) (uri-user u) (uri-host u) port
(uri-path u) (uri-query u) (uri-fragment u)))
(define (uri-with-path u path)
(%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u)
path (uri-query u) (uri-fragment u)))
(define (uri-with-query u query)
(%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u)
(uri-path u) query (uri-fragment u)))
(define (uri-with-fragment u fragment)
(%make-uri (uri-scheme u) (uri-user u) (uri-host u) (uri-port u)
(uri-path u) (uri-query u) fragment))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parsing - without :// we just split into scheme & path
(define (char-uri-scheme-unsafe? ch)
(not (or (char-alphabetic? ch) (char-numeric? ch) (memv ch '(#\_ #\-)))))
(define (string->path-uri scheme str . o)
(define decode? (and (pair? o) (car o)))
(define decode (if decode? uri-decode (lambda (x) x)))
(define decode-query
(if (and (pair? o) (pair? (cdr o)) (cadr o))
uri-query->alist
decode))
(if (pair? str)
str
(let* ((len (string-length str))
(colon0 (string-scan str #\:))
(colon
(and (not (string-index-of str char-uri-scheme-unsafe?
0 (or colon0 len)))
colon0)))
(if (or (not colon) (zero? colon))
(and scheme
(let* ((quest (string-scan str #\? 0))
(pound (string-scan str #\# (or quest 0))))
(make-uri scheme #f #f #f
(decode (substring str 0 (or quest pound len)))
(and quest
(decode-query
(substring str (+ quest 1) (or pound len))))
(and pound
(decode (substring str (+ pound 1) len))))))
(let ((sc1 (+ colon 1))
(scheme (string-downcase->symbol (substring str 0 colon))))
(if (= sc1 len)
(make-uri scheme)
(if (or (>= (+ sc1 1) len)
(not (and (eqv? #\/ (string-ref str sc1))
(eqv? #\/ (string-ref str (+ sc1 1))))))
(make-uri scheme #f #f #f (substring str sc1 len))
(if (>= (+ sc1 2) len)
(make-uri scheme #f "")
(let* ((sc2 (+ sc1 2))
(slash (string-scan str #\/ sc2))
(sc3 (or slash len))
(at (string-scan-right str #\@ sc2 sc3))
(colon3 (string-scan str #\: (or at sc2) sc3))
(quest (string-scan str #\? sc3))
(pound (string-scan str #\# (or quest sc3))))
(%make-uri
scheme
(and at (decode (substring str sc2 at)))
(decode
(substring str
(if at (+ at 1) sc2)
(or colon3 sc3)))
(and colon3
(string->number
(substring str (+ colon3 1) sc3)))
(and slash
(decode
(substring str slash (or quest pound len))))
(and quest
(decode-query
(substring str (+ quest 1)
(or pound len))))
(and pound
(decode (substring str (+ pound 1) len)))
))))))))))
(define (string->uri str . o)
(apply string->path-uri #f str o))
(define (uri->string uri . o)
(define encode? (and (pair? o) (car o)))
(define encode (if encode? uri-encode (lambda (x) x)))
(if (string? uri)
uri
(let ((fragment (uri-fragment uri))
(query (uri-query uri))
(path (uri-path uri))
(port (uri-port uri))
(host (uri-host uri))
(user (uri-user uri)))
(string-append
(symbol->string (uri-scheme uri)) ":"
(if (or user host port) "//" "")
(if user (encode user) "") (if user "@" "")
(or host "") ; host shouldn't need encoding
(if port ":" "") (if port (number->string port) "")
(if path (encode path) "")
(if query "?" "")
(if (pair? query) (uri-alist->query query) (or query ""))
(if fragment "#" "") (if fragment (encode fragment) "")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; query encoding and decoding
(define (uri-safe-char? ch)
(or (char-alphabetic? ch)
(char-numeric? ch)
(case ch
((#\- #\_ #\. #\! #\~ #\* #\' #\( #\)) #t)
(else #f))))
(define (collect str from to res)
(if (>= from to)
res
(cons (substring str from to) res)))
(define (uri-encode str . o)
(define (encode-1-space ch)
(if (eqv? ch #\space)
"+"
(encode-1-normal ch)))
(define (encode-1-normal ch)
(let* ((i (char->integer ch))
(hex (number->string i 16)))
(if (< i 16)
(string-append "%0" hex)
(string-append "%" hex))))
(let ((start 0)
(end (string-length str))
(encode-1 (if (and (pair? o) (car o))
encode-1-space
encode-1-normal)))
(let lp ((from start) (to start) (res '()))
(if (>= to end)
(if (zero? from)
str
(string-concatenate (reverse (collect str from to res))))
(let* ((ch (string-ref str to))
(next (+ to 1)))
(if (uri-safe-char? ch)
(lp from next res)
(lp next next (cons (encode-1 ch)
(collect str from to res)))))))))
(define (uri-decode str . o)
(let ((space-as-plus? (and (pair? o) (car o)))
(start 0)
(end (string-length str)))
(let lp ((from start) (to start) (res '()))
(if (>= to end)
(if (zero? from)
str
(string-concatenate (reverse (collect str from to res))))
(let* ((ch (string-ref str to))
(next (+ to 1)))
(cond
((eqv? ch #\%)
(if (>= next end)
(lp next next (collect str from to res))
(let ((next2 (+ next 1)))
(if (>= next2 end)
(lp next2 next2 (collect str from to res))
(let* ((next3 (+ next2 1))
(hex (substring str next next3))
(i (string->number hex 16)))
(lp next3 next3 (cons (string (integer->char i))
(collect str from to res))))))))
((and space-as-plus? (eqv? ch #\+))
(lp next next (cons " " (collect str from to res))))
(else
(lp from next res))))))))
(define (uri-query->alist str . o)
(define (split-char? c) (if (eqv? c #\&) #t (eqv? c #\;)))
(let ((len (string-length str))
(plus? (and (pair? o) (car o))))
(let lp ((i 0) (res '()))
(if (>= i len)
(reverse res)
(let* ((j (or (string-index-of str split-char? i) len))
(k (string-scan str #\= i j))
(cell (if k
(cons (uri-decode (substring str i k) plus?)
(uri-decode (substring str (+ k 1) j) plus?))
(cons (uri-decode (substring str i j) plus?) #f))))
(lp (+ j 1) (cons cell res)))))))
(define (uri-alist->query ls . o)
(define plus? (and (pair? o) (car o)))
(define (encode key val res)
(let ((res (cons (uri-encode key plus?) res)))
(if val (cons (uri-encode val plus?) (cons "=" res)) res)))
(if (null? ls)
""
(let lp ((x (car ls)) (ls (cdr ls)) (res '()))
(let ((res (encode (car x) (cdr x) res)))
(if (null? ls)
(string-concatenate (reverse res))
(lp (car ls) (cdr ls) (cons "&" res)))))))

174
lib/config.scm Normal file
View file

@ -0,0 +1,174 @@
;; config.scm -- configuration module
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; modules
(define *this-module* '())
(define (make-module exports env meta) (vector exports env meta))
(define (%module-exports mod) (vector-ref mod 0))
(define (module-env mod) (vector-ref mod 1))
(define (module-meta-data mod) (vector-ref mod 2))
(define (module-env-set! mod env) (vector-set! mod 1 env))
(define (module-exports mod)
(or (%module-exports mod) (env-exports (module-env mod))))
(define (module-name->strings ls res)
(if (null? ls)
res
(let ((str (cond ((symbol? (car ls)) (symbol->string (car ls)))
((number? (car ls)) (number->string (car ls)))
((string? (car ls)) (car ls))
(else (error "invalid module name" (car ls))))))
(module-name->strings (cdr ls) (cons "/" (cons str res))))))
(define (module-name->file name)
(string-concatenate
(reverse (cons ".module" (cdr (module-name->strings name '()))))))
(define (module-name-prefix name)
(string-concatenate (reverse (cdr (cdr (module-name->strings name '()))))))
(define (load-module-definition name)
(let* ((file (module-name->file name))
(path (find-module-file file)))
(if path (load path *config-env*))))
(define (find-module name)
(cond
((assoc name *modules*) => cdr)
(else
(load-module-definition name)
(cond ((assoc name *modules*) => cdr)
(else #f)))))
(define (symbol-append a b)
(string->symbol (string-append (symbol->string a) (symbol->string b))))
(define (to-id id) (if (pair? id) (car id) id))
(define (from-id id) (if (pair? id) (cdr id) id))
(define (id-filter pred ls)
(cond ((null? ls) '())
((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls))))
(else (id-filter pred (cdr ls)))))
(define (resolve-import x)
(cond
((not (and (pair? x) (list? x)))
(error "invalid module syntax" x))
((and (pair? (cdr x)) (pair? (cadr x)))
(if (memq (car x) '(only except rename))
(let* ((mod-name+imports (resolve-import (cadr x)))
(imp-ids (cdr mod-name+imports))
(imp-ids (if (and (not imp-ids) (not (eq? 'only (car x))))
(begin
(set-cdr! mod-name+imports
(module-exports
(find-module (car mod-name+imports))))
(cdr mod-name+imports))
imp-ids)))
(cons (car mod-name+imports)
(case (car x)
((only)
(if (not imp-ids)
(cddr x)
(id-filter (lambda (i) (memq i (cddr x))) imp-ids)))
((except)
(id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids))
((rename)
(map (lambda (i)
(let ((rename (assq (to-id i) (cddr x))))
(if rename (cons (cdr rename) (from-id i)) i)))
imp-ids)))))
(error "invalid import modifier" x)))
((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x)))
(let ((mod-name+imports (resolve-import (caddr x))))
(cons (car mod-name+imports)
(map (lambda (i)
(cons (symbol-append (cadr x) (if (pair? i) (car i) i))
(if (pair? i) (cdr i) i)))
(cdr mod-name+imports)))))
((find-module x)
=> (lambda (mod) (cons x (%module-exports mod))))
(else
(error "couldn't find import" x))))
(define (eval-module name mod)
(let ((env (make-environment))
(dir (module-name-prefix name)))
(for-each
(lambda (x)
(case (and (pair? x) (car x))
((import import-immutable)
(for-each
(lambda (m)
(let* ((mod2-name+imports (resolve-import m))
(mod2 (load-module (car mod2-name+imports))))
(%env-copy! env (module-env mod2) (cdr mod2-name+imports)
(eq? (car x) 'import-immutable))))
(cdr x)))
((include include-shared)
(for-each
(lambda (f)
(let ((f (string-append
dir f
(if (eq? (car x) 'include) "" *shared-object-extension*))))
(cond
((find-module-file f) => (lambda (x) (load x env)))
(else (error "couldn't find include" f)))))
(cdr x)))
((body)
(for-each (lambda (expr) (eval expr env)) (cdr x)))))
(module-meta-data mod))
env))
(define (load-module name)
(let ((mod (find-module name)))
(if (and mod (not (module-env mod)))
(module-env-set! mod (eval-module name mod)))
mod))
(define-syntax define-module
(er-macro-transformer
(lambda (expr rename compare)
(let ((name (cadr expr))
(body (cddr expr)))
`(let ((tmp *this-module*))
(set! *this-module* '())
,@body
(set! *this-module* (reverse *this-module*))
(let ((exports
(cond ((assq 'export *this-module*) => cdr)
(else '()))))
(set! *modules*
(cons (cons ',name (make-module exports #f *this-module*))
*modules*)))
(set! *this-module* tmp))))))
(define-syntax define-config-primitive
(er-macro-transformer
(lambda (expr rename compare)
`(define-syntax ,(cadr expr)
(er-macro-transformer
(lambda (expr rename compare)
`(set! *this-module* (cons ',expr *this-module*))))))))
(define-config-primitive import)
(define-config-primitive import-immutable)
(define-config-primitive export)
(define-config-primitive include)
(define-config-primitive include-shared)
(define-config-primitive body)
(define *modules*
(list (cons '(scheme) (make-module #f (interaction-environment) '()))
(cons '(srfi 0) (make-module (list 'cond-expand)
(interaction-environment)
(list (list 'export 'cond-expand))))
(cons '(srfi 46) (make-module (list 'syntax-rules)
(interaction-environment)
(list (list 'export 'syntax-rules))))))

881
lib/init.scm Normal file
View file

@ -0,0 +1,881 @@
;; init.scm -- R5RS library procedures
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;; provide c[ad]{2,4}r
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))
(define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
;; basic utils
(define (procedure? x) (if (closure? x) #t (opcode? x)))
(define (list . args) args)
(define (list-tail ls k)
(if (eq? k 0)
ls
(list-tail (cdr ls) (- k 1))))
(define (list-ref ls k) (car (list-tail ls k)))
(define (append-helper ls res)
(if (null? ls)
res
(append-helper (cdr ls) (append2 (car ls) res))))
(define (append . o)
(if (null? o)
'()
((lambda (lol)
(append-helper (cdr lol) (car lol)))
(reverse o))))
(define (apply proc . args)
(if (null? args)
(proc)
((lambda (lol)
(apply1 proc (append2 (reverse (cdr lol)) (car lol))))
(reverse args))))
;; map with a fast-path for single lists
(define (map proc ls . lol)
(define (map1 proc ls res)
(if (pair? ls)
(map1 proc (cdr ls) (cons (proc (car ls)) res))
(reverse res)))
(define (mapn proc lol res)
(if (null? (car lol))
(reverse res)
(mapn proc
(map1 cdr lol '())
(cons (apply1 proc (map1 car lol '())) res))))
(if (null? lol)
(map1 proc ls '())
(mapn proc (cons ls lol) '())))
(define (for-each f ls . lol)
(define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls)))))
(if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f))))
(define (any pred ls)
(if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f))
(define (every pred ls)
(if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t))
(define (delq x ls)
(if (pair? ls)
(if (eq? x (car ls)) (delq x (cdr ls)) (cons (car ls) (delq x (cdr ls))))
'()))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syntax
(define sc-macro-transformer
(lambda (f)
(lambda (expr use-env mac-env)
(make-syntactic-closure mac-env '() (f expr use-env)))))
(define rsc-macro-transformer
(lambda (f)
(lambda (expr use-env mac-env)
(f expr mac-env))))
(define er-macro-transformer
(lambda (f)
(lambda (expr use-env mac-env)
((lambda (rename compare) (f expr rename compare))
((lambda (renames)
(lambda (identifier)
((lambda (cell)
(if cell
(cdr cell)
((lambda (name)
(set! renames (cons (cons identifier name) renames))
name)
(make-syntactic-closure mac-env '() identifier))))
(assq identifier renames))))
'())
(lambda (x y) (identifier=? use-env x use-env y))))))
(define-syntax cond
(er-macro-transformer
(lambda (expr rename compare)
(if (null? (cdr expr))
#f
((lambda (cl)
(if (compare (rename 'else) (car cl))
(if (pair? (cddr expr))
(error "non-final else in cond" expr)
(cons (rename 'begin) (cdr cl)))
(if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl)))
(list (list (rename 'lambda) (list (rename 'tmp))
(list (rename 'if) (rename 'tmp)
(if (null? (cdr cl))
(rename 'tmp)
(list (caddr cl) (rename 'tmp)))
(cons (rename 'cond) (cddr expr))))
(car cl))
(list (rename 'if)
(car cl)
(cons (rename 'begin) (cdr cl))
(cons (rename 'cond) (cddr expr))))))
(cadr expr))))))
(define-syntax or
(er-macro-transformer
(lambda (expr rename compare)
(cond ((null? (cdr expr)) #f)
((null? (cddr expr)) (cadr expr))
(else
(list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
(list (rename 'if) (rename 'tmp)
(rename 'tmp)
(cons (rename 'or) (cddr expr)))))))))
(define-syntax and
(er-macro-transformer
(lambda (expr rename compare)
(cond ((null? (cdr expr)))
((null? (cddr expr)) (cadr expr))
(else (list (rename 'if) (cadr expr)
(cons (rename 'and) (cddr expr))
#f))))))
(define-syntax quasiquote
(er-macro-transformer
(lambda (expr rename compare)
(define (qq x d)
(cond
((pair? x)
(cond
((compare (rename 'unquote) (car x))
(if (<= d 0)
(cadr x)
(list (rename 'list) (list (rename 'quote) 'unquote)
(qq (cadr x) (- d 1)))))
((compare (rename 'unquote-splicing) (car x))
(if (<= d 0)
(list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
(list (rename 'list) (list (rename 'quote) 'unquote-splicing)
(qq (cadr x) (- d 1)))))
((compare (rename 'quasiquote) (car x))
(list (rename 'list) (list (rename 'quote) 'quasiquote)
(qq (cadr x) (+ d 1))))
((and (<= d 0) (pair? (car x)) (compare (rename 'unquote-splicing) (caar x)))
(if (null? (cdr x))
(cadar x)
(list (rename 'append) (cadar x) (qq (cdr x) d))))
(else
(list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
((symbol? x) (list (rename 'quote) x))
(else x)))
(qq (cadr expr) 0))))
(define-syntax letrec
(er-macro-transformer
(lambda (expr rename compare)
((lambda (defs)
`((,(rename 'lambda) () ,@defs ,@(cddr expr))))
(map (lambda (x) (cons (rename 'define) x)) (cadr expr))))))
(define-syntax let
(er-macro-transformer
(lambda (expr rename compare)
(if (null? (cdr expr)) (error "empty let" expr))
(if (null? (cddr expr)) (error "no let body" expr))
((lambda (bindings)
(if (list? bindings) #f (error "bad let bindings"))
(if (every (lambda (x)
(if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
bindings)
(if (identifier? (cadr expr))
`(,(rename 'letrec) ((,(cadr expr)
(,(rename 'lambda) ,(map car bindings)
,@(cdddr expr))))
,(cons (cadr expr) (map cadr bindings)))
`((,(rename 'lambda) ,(map car bindings) ,@(cddr expr))
,@(map cadr bindings)))
(error "bad let syntax" expr)))
(if (identifier? (cadr expr)) (caddr expr) (cadr expr))))))
(define-syntax let*
(er-macro-transformer
(lambda (expr rename compare)
(if (null? (cdr expr)) (error "empty let*" expr))
(if (null? (cddr expr)) (error "no let* body" expr))
(if (null? (cadr expr))
`(,(rename 'let) () ,@(cddr expr))
(if (if (list? (cadr expr))
(every
(lambda (x)
(if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
(cadr expr))
#f)
`(,(rename 'let) (,(caadr expr))
(,(rename 'let*) ,(cdadr expr) ,@(cddr expr)))
(error "bad let* syntax"))))))
(define-syntax case
(er-macro-transformer
(lambda (expr rename compare)
(define (clause ls)
(cond
((null? ls) #f)
((compare (rename 'else) (caar ls))
`(,(rename 'begin) ,@(cdar ls)))
(else
(if (and (pair? (caar ls)) (null? (cdaar ls)))
`(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) ',(caaar ls))
(,(rename 'begin) ,@(cdar ls))
,(clause (cdr ls)))
`(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) ',(caar ls))
(,(rename 'begin) ,@(cdar ls))
,(clause (cdr ls)))))))
`(let ((,(rename 'tmp) ,(cadr expr)))
,(clause (cddr expr))))))
(define-syntax do
(er-macro-transformer
(lambda (expr rename compare)
(let* ((body
`(,(rename 'begin)
,@(cdddr expr)
(,(rename 'lp)
,@(map (lambda (x) (if (pair? (cddr x)) (caddr x) (car x)))
(cadr expr)))))
(check (caddr expr))
(wrap
(if (null? (cdr check))
`(,(rename 'let) ((,(rename 'tmp) ,(car check)))
(,(rename 'if) ,(rename 'tmp)
,(rename 'tmp)
,body))
`(,(rename 'if) ,(car check)
(,(rename 'begin) ,@(cdr check))
,body))))
`(,(rename 'let) ,(rename 'lp)
,(map (lambda (x) (list (car x) (cadr x))) (cadr expr))
,wrap)))))
(define-syntax delay
(er-macro-transformer
(lambda (expr rename compare)
`(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; promises
(define (make-promise thunk)
(lambda ()
(let ((computed? #f) (result #f))
(if (not computed?)
(begin
(set! result (thunk))
(set! computed? #t)))
result)))
(define (force x) (if (procedure? x) (x) x))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exceptions
(define (error msg . args)
(raise (make-exception 'user msg args #f #f)))
(define (with-exception-handler handler thunk)
(letrec ((orig-handler (current-exception-handler))
(self (lambda (exn)
(current-exception-handler orig-handler)
(let ((res (handler exn)))
(current-exception-handler self)
res))))
(current-exception-handler self)
(let ((res (thunk)))
(current-exception-handler orig-handler)
res)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; library functions
;; booleans
(define (not x) (if x #f #t))
(define (boolean? x) (if (eq? x #t) #t (eq? x #f)))
;; char utils
(define (char-alphabetic? ch) (<= 65 (char->integer (char-upcase ch)) 90))
(define (char-numeric? ch) (<= 48 (char->integer ch) 57))
(define (char-whitespace? ch)
(if (eq? ch #\space)
#t
(if (eq? ch #\tab) #t (if (eq? ch #\newline) #t (eq? ch #\return)))))
(define (char-upper-case? ch) (<= 65 (char->integer ch) 90))
(define (char-lower-case? ch) (<= 97 (char->integer ch) 122))
(define (char=? a b) (= (char->integer a) (char->integer b)))
(define (char<? a b) (< (char->integer a) (char->integer b)))
(define (char>? a b) (> (char->integer a) (char->integer b)))
(define (char<=? a b) (<= (char->integer a) (char->integer b)))
(define (char>=? a b) (>= (char->integer a) (char->integer b)))
(define (char-ci=? a b)
(= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char-ci<? a b)
(< (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char-ci>? a b)
(> (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char-ci<=? a b)
(<= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char-ci>=? a b)
(>= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
;; string utils
(define (symbol->string sym)
(call-with-output-string (lambda (out) (write sym out))))
(define (list->string ls)
(let ((str (make-string (length ls) #\space)))
(let lp ((ls ls) (i 0))
(if (pair? ls)
(begin
(string-set! str i (car ls))
(lp (cdr ls) (+ i 1)))))
str))
(define (string->list str)
(let lp ((i (- (string-length str) 1)) (res '()))
(if (< i 0) res (lp (- i 1) (cons (string-ref str i) res)))))
(define (string-fill! str ch)
(let lp ((i (- (string-length str) 1)))
(if (>= i 0) (begin (string-set! str i ch) (lp (- i 1))))))
(define (string . args) (list->string args))
(define (string-append . args) (string-concatenate args))
(define (string-copy s) (substring s 0 (string-length s)))
(define (string=? s1 s2) (eq? (string-cmp s1 s2 #f) 0))
(define (string<? s1 s2) (< (string-cmp s1 s2 #f) 0))
(define (string<=? s1 s2) (<= (string-cmp s1 s2 #f) 0))
(define (string>? s1 s2) (> (string-cmp s1 s2 #f) 0))
(define (string>=? s1 s2) (>= (string-cmp s1 s2 #f) 0))
(define (string-ci=? s1 s2) (eq? (string-cmp s1 s2 #t) 0))
(define (string-ci<? s1 s2) (< (string-cmp s1 s2 #t) 0))
(define (string-ci<=? s1 s2) (<= (string-cmp s1 s2 #t) 0))
(define (string-ci>? s1 s2) (> (string-cmp s1 s2 #t) 0))
(define (string-ci>=? s1 s2) (>= (string-cmp s1 s2 #t) 0))
;; list utils
(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b))))
(define (member obj ls . o)
(let ((eq (if (pair? o) (car o) equal?)))
(let lp ((ls ls))
(and (pair? ls) (if (eq obj (car ls)) ls (lp (cdr ls)))))))
(define memv member)
(define (assoc obj ls)
(if (null? ls)
#f
(if (equal? obj (caar ls))
(car ls)
(assoc obj (cdr ls)))))
(define assv assoc)
;; math utils
(define (number? x) (if (fixnum? x) #t (if (bignum? x) #t (flonum? x))))
(define complex? number?)
(define rational? number?)
(define real? number?)
(define exact? fixnum?)
(define inexact? flonum?)
(define (integer? x)
(if (fixnum? x) #t (if (bignum? x) #t (and (flonum? x) (= x (truncate x))))))
(define (zero? x) (= x 0))
(define (positive? x) (> x 0))
(define (negative? x) (< x 0))
(define (even? n) (= (remainder n 2) 0))
(define (odd? n) (= (remainder n 2) 1))
(define (abs x) (if (< x 0) (- x) x))
(define (numerator x)
(if (integer? x) x (numerator (* x 10))))
(define (denominator x)
(if (exact? x)
1
(let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10))))))
(define (modulo a b)
(let ((res (remainder a b)))
(if (< b 0)
(if (<= res 0) res (+ res b))
(if (>= res 0) res (+ res b)))))
(define (gcd a b)
(if (= b 0)
(abs a)
(gcd b (remainder a b))))
(define (lcm a b)
(abs (quotient (* a b) (gcd a b))))
(define (max x . rest)
(let lp ((hi x) (ls rest))
(if (null? ls)
hi
(lp (if (> (car ls) hi) (car ls) hi) (cdr ls)))))
(define (min x . rest)
(let lp ((lo x) (ls rest))
(if (null? ls)
lo
(lp (if (< (car ls) lo) (car ls) lo) (cdr ls)))))
(define (real-part z) z)
(define (imag-part z) 0.0)
(define magnitude abs)
(define (angle z) (if (< z 0) 3.141592653589793 0))
(define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o)))))
(define (digit-char n)
(if (<= n 9)
(integer->char (+ n (char->integer #\0)))
(integer->char (+ (- n 10) (char->integer #\A)))))
(define (digit-value ch)
(if (char-numeric? ch)
(- (char->integer ch) (char->integer #\0))
(and (<= 65 (char->integer (char-upcase ch)) 70)
(- (char->integer (char-upcase ch)) 55))))
(define (number->string n . o)
(if (if (null? o) #t (eq? 10 (car o)))
(call-with-output-string (lambda (out) (write n out)))
(let lp ((n n) (d (car o)) (res '()))
(if (> n 0)
(lp (quotient n d) d (cons (digit-char (remainder n d)) res))
(if (null? res) "0" (list->string res))))))
(define (string->number str . o)
(let ((res
(if (if (null? o) #t (eq? 10 (car o)))
(call-with-input-string str (lambda (in) (read in)))
(let ((len (string-length str)))
(let lp ((i 0) (d (car o)) (acc 0))
(if (>= i len)
acc
(let ((v (digit-value (string-ref str i))))
(and v (lp (+ i 1) d (+ (* acc d) v))))))))))
(and (number? res) res)))
;; vector utils
(define (list->vector ls)
(let ((vec (make-vector (length ls) #f)))
(let lp ((ls ls) (i 0))
(if (pair? ls)
(begin
(vector-set! vec i (car ls))
(lp (cdr ls) (+ i 1)))))
vec))
(define (vector->list vec)
(let lp ((i (- (vector-length vec) 1)) (res '()))
(if (< i 0) res (lp (- i 1) (cons (vector-ref vec i) res)))))
(define (vector-fill! str ch)
(let lp ((i (- (vector-length str) 1)))
(if (>= i 0) (begin (vector-set! str i ch) (lp (- i 1))))))
(define (vector . args) (list->vector args))
;; I/O utils
(define (char-ready? . o)
(not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port))))))
(define (call-with-input-string str proc)
(let* ((in (open-input-string str))
(res (proc in)))
(close-input-port in)
res))
(define (call-with-output-string proc)
(let ((out (open-output-string)))
(proc out)
(let ((res (get-output-string out)))
(close-output-port out)
res)))
(define (call-with-input-file file proc)
(let* ((in (open-input-file file))
(res (proc in)))
(close-input-port in)
res))
(define (call-with-output-file file proc)
(let* ((out (open-output-file file))
(res (proc out)))
(close-output-port out)
res))
(define (with-input-from-file file thunk)
(let ((old-in (current-input-port))
(tmp-in (open-input-file file)))
(current-input-port tmp-in)
(let ((res (thunk)))
(current-input-port old-in)
res)))
(define (with-output-to-file file thunk)
(let ((old-out (current-output-port))
(tmp-out (open-output-file file)))
(current-output-port tmp-out)
(let ((res (thunk)))
(current-output-port old-out)
res)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; values
(define *values-tag* (list 'values))
(define (values . ls)
(if (and (pair? ls) (null? (cdr ls)))
(car ls)
(cons *values-tag* ls)))
(define (call-with-values producer consumer)
(let ((res (producer)))
(if (and (pair? res) (eq? *values-tag* (car res)))
(apply consumer (cdr res))
(consumer res))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; dynamic-wind
(define *dk* (list #f))
(define (dynamic-wind before thunk after)
(let ((dk *dk*))
(set-dk! (cons (cons before after) dk))
(let ((res (thunk))) (set-dk! dk) res)))
(define (set-dk! dk)
(if (not (eq? dk *dk*))
(begin
(set-dk! (cdr dk))
(let ((before (car (car dk))) (dk dk))
(set-car! *dk* (cons (cdr (car dk)) before))
(set-cdr! *dk* dk)
(set-car! dk #f)
(set-cdr! dk '())
(set! *dk* dk)
(before)))))
(define (call-with-current-continuation proc)
(let ((dk *dk*))
(%call/cc (lambda (k) (proc (lambda (x) (set-dk! dk) (k x)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syntax-rules
(define-syntax syntax-rules
(er-macro-transformer
(lambda (expr rename compare)
(let ((ellipse-specified? (identifier? (cadr expr)))
(count 0)
(_er-macro-transformer (rename 'er-macro-transformer))
(_lambda (rename 'lambda)) (_let (rename 'let))
(_begin (rename 'begin)) (_if (rename 'if))
(_and (rename 'and)) (_or (rename 'or))
(_eq? (rename 'eq?)) (_equal? (rename 'equal?))
(_car (rename 'car)) (_cdr (rename 'cdr))
(_cons (rename 'cons)) (_pair? (rename 'pair?))
(_null? (rename 'null?)) (_expr (rename 'expr))
(_rename (rename 'rename)) (_compare (rename 'compare))
(_quote (rename 'syntax-quote)) (_apply (rename 'apply))
(_append (rename 'append)) (_map (rename 'map))
(_vector? (rename 'vector?)) (_list? (rename 'list?))
(_lp (rename 'lp)) (_reverse (rename 'reverse))
(_len (rename'len)) (_length (rename 'length))
(_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error))
(_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
(_vector->list (rename 'vector->list))
(_list->vector (rename 'list->vector)))
(define ellipse (rename (if ellipse-specified? (cadr expr) '...)))
(define lits (if ellipse-specified? (caddr expr) (cadr expr)))
(define forms (if ellipse-specified? (cdddr expr) (cddr expr)))
(define (next-v)
(set! count (+ count 1))
(rename (string->symbol (string-append "v." (number->string count)))))
(define (expand-pattern pat tmpl)
(let lp ((p (cdr pat))
(x (list _cdr _expr))
(dim 0)
(vars '())
(k (lambda (vars)
(or (expand-template tmpl vars)
(list _begin #f)))))
(let ((v (next-v)))
(list
_let (list (list v x))
(cond
((identifier? p)
(if (any (lambda (l) (compare p l)) lits)
(list _and (list _compare v (list _quote p)) (k vars))
(list _let (list (list p v)) (k (cons (cons p dim) vars)))))
((ellipse? p)
(cond
((not (null? (cddr p)))
(cond
((not (list? (cddr p)))
(error "dotted ellipse" p))
((any (lambda (x) (and (identifier? x) (compare x ellipse)))
(cddr p))
(error "multiple ellipses" p))
(else
(let ((len (length (cdr (cdr p)))))
`(,_let ((,_len (,_length ,v)))
(,_and (,_>= ,_len ,len)
(,_let ,_lp ((,_ls ,v)
(,_i (,_- ,_len ,len))
(,_res (,_quote ())))
(,_if (,_>= 0 ,_i)
,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p)))
`(,_append ,_ls (,_reverse ,_res))
dim
vars
k)
(,_lp (,_cdr ,_ls)
(,_- ,_i 1)
(,_cons (,_car ,_ls) ,_res))))))))))
((identifier? (car p))
(list _and (list _list? v)
(list _let (list (list (car p) v))
(k (cons (cons (car p) (+ 1 dim)) vars)))))
(else
(let* ((w (next-v))
(new-vars (all-vars (car p) (+ dim 1)))
(ls-vars (map (lambda (x)
(rename
(string->symbol
(string-append
(symbol->string
(identifier->symbol (car x)))
"-ls"))))
new-vars))
(once
(lp (car p) (list _car w) (+ dim 1) '()
(lambda (_)
(cons
_lp
(cons
(list _cdr w)
(map (lambda (x l)
(list _cons (car x) l))
new-vars
ls-vars)))))))
(list
_let
_lp (cons (list w v)
(map (lambda (x) (list x '())) ls-vars))
(list _if (list _null? w)
(list _let (map (lambda (x l)
(list (car x) (list _reverse l)))
new-vars
ls-vars)
(k (append new-vars vars)))
(list _and (list _pair? w) once)))))))
((pair? p)
(list _and (list _pair? v)
(lp (car p)
(list _car v)
dim
vars
(lambda (vars)
(lp (cdr p) (list _cdr v) dim vars k)))))
((vector? p)
(list _and
(list _vector? v)
(lp (vector->list p) (list _vector->list v) dim vars k)))
((null? p) (list _and (list _null? v) (k vars)))
(else (list _and (list _equal? v p) (k vars))))))))
(define (ellipse-escape? x) (and (pair? x) (compare ellipse (car x))))
(define (ellipse? x)
(and (pair? x) (pair? (cdr x)) (compare ellipse (cadr x))))
(define (ellipse-depth x)
(if (ellipse? x)
(+ 1 (ellipse-depth (cdr x)))
0))
(define (ellipse-tail x)
(if (ellipse? x)
(ellipse-tail (cdr x))
(cdr x)))
(define (all-vars x dim)
(let lp ((x x) (dim dim) (vars '()))
(cond ((identifier? x)
(if (any (lambda (lit) (compare x lit)) lits)
vars
(cons (cons x dim) vars)))
((ellipse? x) (lp (car x) (+ dim 1) vars))
((pair? x) (lp (car x) dim (lp (cdr x) dim vars)))
((vector? x) (lp (vector->list x) dim vars))
(else vars))))
(define (free-vars x vars dim)
(let lp ((x x) (free '()))
(cond
((identifier? x)
(if (and (not (memq x free))
(cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
(else #f)))
(cons x free)
free))
((pair? x) (lp (car x) (lp (cdr x) free)))
((vector? x) (lp (vector->list x) free))
(else free))))
(define (expand-template tmpl vars)
(let lp ((t tmpl) (dim 0))
(cond
((identifier? t)
(cond
((any (lambda (v) (compare t (car v))) vars)
=> (lambda (cell)
(if (<= (cdr cell) dim)
t
(error "too few ...'s"))))
(else
(list _rename (list _quote t)))))
((pair? t)
(cond
((ellipse-escape? t)
(if (pair? (cdr t))
(if (pair? (cddr t)) (cddr t) (cadr t))
(cdr t)))
((ellipse? t)
(let* ((depth (ellipse-depth t))
(ell-dim (+ dim depth))
(ell-vars (free-vars (car t) vars ell-dim)))
(if (null? ell-vars)
(error "too many ...'s")
(let* ((once (lp (car t) ell-dim))
(nest (if (and (null? (cdr ell-vars))
(identifier? once)
(eq? once (car vars)))
once ;; shortcut
(cons _map
(cons (list _lambda ell-vars once)
ell-vars))))
(many (do ((d depth (- d 1))
(many nest
(list _apply _append many)))
((= d 1) many))))
(if (null? (ellipse-tail t))
many ;; shortcut
(list _append many (lp (ellipse-tail t) dim)))))))
(else (list _cons (lp (car t) dim) (lp (cdr t) dim)))))
((vector? t) (list _list->vector (lp (vector->list t) dim)))
((null? t) (list _quote '()))
(else t))))
(list
_er-macro-transformer
(list _lambda (list _expr _rename _compare)
(cons
_or
(append
(map
(lambda (clause) (expand-pattern (car clause) (cadr clause)))
forms)
(list (list _error "no expansion for"
(list (rename 'strip-syntactic-closures) _expr)))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; modules
(define *config-env* #f)
(define-syntax import
(er-macro-transformer
(lambda (expr rename compare)
(let lp ((ls (cdr expr)) (res '()))
(cond
((null? ls)
(cons 'begin (reverse res)))
(else
(let ((mod+imps (eval `(resolve-import ',(car ls)) *config-env*)))
(if (pair? mod+imps)
(lp (cdr ls)
(cons `(%env-copy!
#f
(vector-ref
(eval '(load-module ',(car mod+imps)) *config-env*)
1)
',(cdr mod+imps)
#f)
res))
(error "couldn't find module" (car ls))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SRFI-0
(define-syntax cond-expand
(er-macro-transformer
(lambda (expr rename compare)
(define (check x)
(if (pair? x)
(case (car x)
((and) (every check (cdr x)))
((or) (any check (cdr x)))
((not) (not (check (cadr x))))
(else (error "cond-expand: bad feature" x)))
(memq (identifier->symbol x) *features*)))
(let expand ((ls (cdr expr)))
(cond ((null? ls) (error "cond-expand: no expansions" expr))
((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls)))
((eq? 'else (identifier->symbol (caar ls)))
(if (pair? (cdr ls))
(error "cond-expand: else in non-final position")
`(,(rename 'begin) ,@(cdar ls))))
((check (caar ls)) `(,(rename 'begin) ,@(cdar ls)))
(else (expand (cdr ls))))))))

31
lib/srfi/1.module Normal file
View file

@ -0,0 +1,31 @@
(define-module (srfi 1)
(export
xcons cons* make-list list-tabulate list-copy circular-list iota
proper-list? circular-list? dotted-list? not-pair? null-list? list=
first second third fourth fifth sixth seventh eighth ninth tenth
car+cdr take drop take-right drop-right take! drop-right! split-at split-at!
last last-pair length+ concatenate append! concatenate! reverse!
append-reverse append-reverse!
zip unzip1 unzip2 unzip3 unzip4 unzip5 count
fold unfold pair-fold reduce fold-right unfold-right
pair-fold-right reduce-right
append-map append-map! map! pair-for-each filter-map map-in-order
filter partition remove filter! partition! remove! find find-tail any every
list-index take-while drop-while take-while! span break span! break!
delete delete-duplicates delete! delete-duplicates!
alist-cons alist-copy alist-delete alist-delete!
lset<= lset= lset-adjoin lset-union lset-union! lset-intersection
lset-intersection! lset-difference lset-difference! lset-xor lset-xor!
lset-diff+intersection lset-diff+intersection!)
(import (scheme))
(include "1/predicates.scm"
"1/selectors.scm"
"1/search.scm"
"1/misc.scm"
"1/constructors.scm"
"1/fold.scm"
"1/deletion.scm"
"1/alists.scm"
"1/lset.scm"))

14
lib/srfi/1/alists.scm Normal file
View file

@ -0,0 +1,14 @@
;; alist.scm -- association list utilities
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (alist-cons key value ls) (cons (cons key value) ls))
(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls))
(define (alist-delete key ls . o)
(let ((eq (if (pair? o) (car o) equal?)))
(remove (lambda (x) (eq (car x) key)) ls)))
(define alist-delete! alist-delete)

36
lib/srfi/1/constructors.scm Normal file
View file

@ -0,0 +1,36 @@
;; constructors.scm -- list construction utilities
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (xcons a b) (cons b a))
(define (cons* x . args)
(let lp ((rev '()) (x x) (ls args))
(if (null? ls)
(append-reverse rev x)
(lp (cons x rev) (car ls) (cdr ls)))))
(define (make-list n . o)
(let ((default (if (pair? o) (car o))))
(let lp ((n n) (res '()))
(if (<= n 0) res (lp (- n 1) (cons default res))))))
(define (list-tabulate n proc)
(let lp ((n n) (res '()))
(if (< n 0) res (lp (- n 1) (cons (proc n) res)))))
(define (list-copy ls) (reverse! (reverse ls)))
(define (circular-list x . args)
(let ((res (cons x args)))
(set-cdr! (last-pair res) res)
res))
(define (iota count . o)
(let ((start (if (pair? o) (car o) count))
(step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1)))
(let lp ((i count) (n (- start step)) (res '()))
(if (<= i 0)
res
(lp (- i 1) (- n step) (cons n res))))))

25
lib/srfi/1/deletion.scm Normal file
View file

@ -0,0 +1,25 @@
;; deletion.scm -- list deletion utilities
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (delete x ls . o)
(let ((eq (if (pair? o) (car o) equal?)))
(if (eq? eq eq?)
(let lp ((ls ls) (rev '())) ;; fast path for delq
(let ((tail (memq x ls)))
(if tail
(lp (cdr tail) (take-up-to-reverse ls tail rev))
(if (pair? rev) (append-reverse! rev ls) ls))))
(filter (lambda (y) (eq x y)) ls))))
(define delete! delete)
(define (delete-duplicates ls . o)
(let ((eq (if (pair? o) (car o) equal?)))
(let lp ((ls ls) (res '()))
(if (pair? ls)
(lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res)))
(reverse! res)))))
(define delete-duplicates! delete-duplicates)

115
lib/srfi/1/fold.scm Normal file
View file

@ -0,0 +1,115 @@
;; fold.scm -- list fold/reduce utilities
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (fold kons knil ls . lists)
(if (null? lists)
(let lp ((ls ls) (acc knil))
(if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc))
(let lp ((lists (cons ls lists)) (acc knil))
(if (every pair? lists)
(lp (map cdr lists) (apply kons (map-onto car lists (list acc))))
acc))))
(define (fold-right kons knil ls . lists)
(if (null? lists)
(let lp ((ls ls))
(if (pair? ls) (kons (car ls) (lp (cdr ls))) knil))
(let lp ((lists (cons ls lists)))
(if (every pair? lists)
(apply kons (map-onto car lists (lp (map cdr lists))))
knil))))
(define (pair-fold kons knil ls . lists)
(if (null? lists)
(let lp ((ls ls) (acc knil))
(if (pair? ls) (lp (cdr ls) (kons ls acc)) acc))
(let lp ((lists (cons ls lists)) (acc knil))
(if (every pair? lists)
(lp (map cdr lists) (apply kons (append lists (list acc))))
acc))))
(define (pair-fold-right kons knil ls . lists)
(if (null? lists)
(let lp ((ls ls))
(if (pair? ls) (kons (car ls) (lp (cdr ls))) knil))
(let lp ((lists (cons ls lists)))
(if (every pair? lists)
(apply kons (append lists (lp (map cdr lists))))
knil))))
(define (reduce f identity ls)
(if (null? ls) identity (fold f (car ls) (cdr ls))))
(define (reduce-right f identity ls)
(if (null? ls) identity (fold-right f (car ls) (cdr ls))))
(define (unfold p f g seed . o)
(let lp ((seed seed))
(if (p seed)
(if (pair? o) ((car o) seed) '())
(cons (f seed) (lp (g seed))))))
(define (unfold-right p f g seed . o)
(let lp ((seed seed) (res (if (pair? o) (car o) '())))
(if (p seed) res (lp (g seed) (cons (f seed) res)))))
(define (append-map-helper append f ls lists)
(if (null? lists)
(if (null? ls)
'()
(let ((rev-ls (reverse ls)))
(let lp ((ls (cdr rev-ls)) (res (car rev-ls)))
(if (null? ls) res (lp (cdr ls) (append (f (car ls) res))))
)))
(if (and (pair? ls) (every pair? lists))
(let lp ((lists (cons ls lists)))
(let ((vals (apply f (map car lists)))
(cdrs (map cdr lists)))
(if (every pair? cdrs) (append vals (lp cdrs)) vals)))
'())))
(define (append-map f ls . lists)
(append-map-helper append f ls lists))
(define (append-map! f ls . lists)
(append-map-helper append! f ls lists))
(define map! map)
(define map-in-order map)
(define (pair-for-each f ls . lists)
(apply pair-fold (lambda (x _) (f x)) ls lists))
(define (filter-map f ls . lists)
(if (null? lists)
(let lp ((ls ls) (res '()))
(if (pair? ls)
(let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res)))
(reverse! res)))
(filter (lambda (x) x) (apply map f ls lists))))
(define (take-up-to-reverse from to init)
(if (eq? from to)
init
(take-up-to-reverse (cdr from) to (cons (car from) init))))
(define (remove pred ls)
(let lp ((ls ls) (rev '()))
(let ((tail (find-tail pred ls)))
(if tail
(lp (cdr tail) (take-up-to-reverse ls tail rev))
(if (pair? rev) (append-reverse! rev ls) ls)))))
(define (filter pred ls) (remove (lambda (x) (not (pred x))) ls))
(define (partition pred ls)
(let lp ((ls ls) (good '()) (bad '()))
(cond ((null? ls) (values (reverse! good) (reverse! bad)))
((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad))
(else (lp (cdr ls) good (cons (car ls) bad))))))
(define filter! filter)
(define remove! remove)
(define partition! partition)

51
lib/srfi/1/lset.scm Normal file
View file

@ -0,0 +1,51 @@
;; lset.scm -- list set library
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (lset<= eq . sets)
(if (null? sets)
#t
(let lp1 ((set1 (car sets)) (sets (cdr sets)))
(if (null? sets)
#t
(let ((set2 (car sets)))
(let lp2 ((ls set1))
(if (pair? ls)
(and (member (car set1) set2 eq) (lp2 (cdr ls)))
(lp1 set2 (cdr sets)))))))))
(define (lset= eq . sets)
(and (apply lset<= eq sets) (apply lset<= eq (reverse sets))))
(define (lset-adjoin eq set . elts)
(lset-union2 eq elts set))
(define (lset-union2 eq a b)
(if (null? b)
a
(lset-union2 (cdr b) (if (member (car b) a eq) a (cons (car b) a)))))
(define (lset-union eq . sets)
(reduce (lambda (a b) (lset-union2 eq a b)) '() sets))
(define (lset-intersection eq . sets)
(reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets))
(define (lset-difference eq . sets)
(reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets))
(define (lset-xor eq . sets)
(reduce (lambda (a b)
(append (filter (lambda (x) (member x b eq)) a)
(filter (lambda (x) (member x a eq)) b)))
'()
sets))
(define (lset-diff+intersection eq . sets)
(values (apply lset-difference eq sets) (apply lset-intersection eq sets)))
(define lset-diff+intersection! lset-diff+intersection)
(define lset-xor! lset-xor)
(define lset-difference! lset-difference)
(define lset-intersection! lset-intersection)
(define lset-union! lset-union)

54
lib/srfi/1/misc.scm Normal file
View file

@ -0,0 +1,54 @@
;; misc.scm -- miscellaneous list utilities
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (map-onto proc ls init)
(let lp ((ls ls) (res init))
(if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res)))))
(define (append! . lists) (concatenate! lists))
(define (concatenate lists)
(let lp ((ls (reverse lists)) (res '()))
(if (null? ls) res (lp (cdr ls) (append (car ls) res)))))
(define (concatenate! lists)
(if (null? lists)
'()
(let lp ((ls lists))
(cond ((not (pair? (cdr ls)))
lists)
(else
(set-cdr! (last-pair (car ls)) (cadr ls))
(lp (cdr ls)))))))
(define (append-reverse rev tail)
(if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
(define (append-reverse! rev tail)
(if (null? rev)
tail
(let ((head (reverse! rev)))
(set-cdr! rev tail)
head)))
(define (zip . lists) (apply map list lists))
(define (unzip1 ls) (map car ls))
(define (unzip2 ls) (values (map car ls) (map cadr ls)))
(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls)))
(define (unzip4 ls)
(values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls)))
(define (unzip5 ls)
(values (map car ls) (map cadr ls) (map caddr ls)
(map cadddr ls) (map (lambda (x) (car (cddddr x))) ls)))
(define (count pred ls . lists)
(if (null? lists)
(let lp ((ls ls) (res 0))
(if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res))
(let lp ((lists (cons ls lists)) (res 0))
(if (every pair? lists)
(lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res))
res))))

42
lib/srfi/1/predicates.scm Normal file
View file

@ -0,0 +1,42 @@
;; predicates.scm -- list prediates
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (proper-list? x)
(cond ((null? x) #t)
((pair? x) (proper-list? (cdr x)))
(else #f)))
(define (circular-list? x)
(and (pair? x) (pair? (cdr x))
(let race ((hare (cdr x)) (tortoise x))
(or (eq? hare tortoise)
(and (pair? hare) (pair? (cdr hare))
(race (cddr hare) (cdr tortoise)))))))
(define (dotted-list? x)
(not (proper-list? x)))
(define (not-pair? x) (not (pair? x)))
(define (null-list? x) (null? x)) ; no error
(define (list= eq . lists)
(let lp1 ((lists lists))
(or (null? lists)
(null? (cdr lists))
(let lp2 ((ls1 (car lists)) (ls2 (cadr lists)))
(if (null? ls1)
(and (null? ls2)
(lp1 (cdr lists)))
(and (eq (car ls1) (car ls2))
(lp2 (cdr ls1) (cdr ls2))))))))
(define (length+ x)
(if (not (pair? x))
0
(let lp ((hare (cdr x)) (tortoise x) (res 0))
(and (not (eq? hare tortoise))
(if (pair? hare)
(lp (cddr hare) (cdr tortoise) (+ res 1))
res)))))

54
lib/srfi/1/search.scm Normal file
View file

@ -0,0 +1,54 @@
;; search.scm -- list searching and splitting
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (find pred ls)
(cond ((find-tail pred ls) => car) (else #f)))
(define (find-tail pred ls)
(and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls)))))
(define (take-while pred ls)
(let lp ((ls ls) (res '()))
(if (and (pair? ls) (pred (car ls)))
(lp (cdr ls) (cons (car ls) res))
(reverse! res))))
(define take-while! take-while)
(define (drop-while pred ls)
(or (find-tail (lambda (x) (not (pred x))) ls) '()))
(define (span pred ls)
(let lp ((ls ls) (res '()))
(if (and (pair? ls) (pred (car ls)))
(lp (cdr ls) (cons (car ls) res))
(values (reverse! res) ls))))
(define span! span)
(define (break pred ls) (span (lambda (x) (not (pred x))) ls))
(define break! break)
(define (any pred ls . lists)
(if (null? lists)
(let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls)))))
(let lp ((lists (cons ls lists)))
(and (every pair? lists)
(let ((args (map car lists)))
(if (apply pred args) args (lp (map cdr lists))))))))
(define (every pred ls . lists)
(if (null? lists)
(let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t))
(not (apply any (lambda (x) (not (pred x))) ls lists))))
(define (list-index pred ls . lists)
(if (null? lists)
(let lp ((ls ls) (n 0))
(and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1)))))
(let lp ((lists (cons ls lists)) (n 0))
(and (every pair? lists)
(if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1)))
))))

59
lib/srfi/1/selectors.scm Normal file
View file

@ -0,0 +1,59 @@
;; selectors.scm -- extended list selectors
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define (fifth ls) (car (cdr (cdr (cdr (cdr ls))))))
(define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls)))))))
(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))
(define (eighth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))
(define (ninth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))
(define (tenth ls) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))))
(define (car+cdr x) (values (car x) (cdr x)))
(define (take ls i)
(let lp ((i i) (ls ls) (res '()))
(if (<= i 0)
(reverse! res)
(lp (- i 1) (cdr ls) (cons (car ls) res)))))
(define (take! ls i)
(if (<= i 0)
'()
(let ((tail (list-tail ls (- i 1))))
(set-cdr! tail '())
ls)))
(define (drop ls i)
(if (<= i 0) ls (drop (cdr ls) (- i 1))))
(define (take-right ls i)
(drop ls (- (length+ ls) i)))
(define (drop-right ls i)
(take ls (- (length+ ls) i)))
(define (drop-right! ls i)
(take! ls (- (length+ ls) i)))
(define (split-at ls i)
(let lp ((i i) (ls ls) (res '()))
(if (<= i 0)
(values (reverse! res) ls)
(lp (- i 1) (cdr ls) (cons (car ls) res)))))
(define (split-at! ls i)
(if (<= i 0)
(values '() ls)
(let* ((tail (list-tail ls (- i 1)))
(right (cdr tail)))
(set-cdr! tail '())
(values ls right))))
(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls))))
(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls))))

28
lib/srfi/11.module Normal file
View file

@ -0,0 +1,28 @@
(define-module (srfi 11)
(export let-values let*-values)
(import-immutable (scheme))
(body
(define-syntax let*-values
(syntax-rules ()
((let*-values () . body)
(begin . body))
((let*-values (((a) expr) . rest) . body)
(let ((a expr)) (let*-values rest . body)))
((let*-values ((params expr) . rest) . body)
(call-with-values (lambda () expr)
(lambda params (let*-values rest . body))))))
(define-syntax let-values
(syntax-rules ()
((let-values ("step") (binds ...) bind expr maps () () . body)
(let*-values (binds ... (bind expr)) (let maps . body)))
((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body)
(let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body))
((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body)
(let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body))
((let-values ("step") binds (bind ...) expr (maps ...) x rest . body)
(let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body))
((let-values ((params expr) . rest) . body)
(let-values ("step") () () expr () params rest . body))
))))

24
lib/srfi/16.module Normal file
View file

@ -0,0 +1,24 @@
(define-module (srfi 16)
(export case-lambda)
(import-immutable (scheme))
(body
(define-syntax %case
(syntax-rules ()
((%case args len n p ((params ...) . body) . rest)
(if (= len (length '(params ...)))
(apply (lambda (params ...) . body) args)
(%case args len 0 () . rest)))
((%case args len n (p ...) ((x . y) . body) . rest)
(%case args len (+ n 1) (p ... x) (y . body) . rest))
((%case args len n (p ...) (y . body) . rest)
(if (>= len n)
(apply (lambda (p ... y) . body) args)
(%case args len 0 () . rest)))
((%case args len n p)
(error "case-lambda: no cases matched"))))
(define-syntax case-lambda
(syntax-rules ()
((case-lambda . clauses)
(lambda args (let ((len (length args))) (%case args len 0 () . clauses))))))))

16
lib/srfi/2.module Normal file
View file

@ -0,0 +1,16 @@
(define-module (srfi 2)
(export and-let*)
(import-immutable (scheme))
(body
(define-syntax and-let*
(syntax-rules ()
((and-let* () . body)
(begin . body))
((and-let* ((var expr) . rest) . body)
(let ((var expr))
(and var (and-let* rest . body))))
((and-let* ((expr) . rest) . body)
(let ((tmp expr))
(and tmp (and-let* rest . body))))))))

24
lib/srfi/26.module Normal file
View file

@ -0,0 +1,24 @@
(define-module (srfi 26)
(export cut cute)
(import-immutable (scheme))
(body
(define-syntax %cut
(syntax-rules (<> <...>)
((%cut e? params args)
(lambda params args))
((%cut e? (params ...) (args ...) <> . rest)
(%cut e? (params ... tmp) (args ... tmp) . rest))
((%cut e? (params ...) (args ...) <...>)
(%cut e? (params ... . tmp) (apply args ... tmp)))
((%cut e? (params ...) (args ...) <...> . rest)
(error "cut: non-terminal <...>"))
((%cut #t (params ...) (args ...) x . rest)
(let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest)))
((%cut #f (params ...) (args ...) x . rest)
(%cut #t (params ...) (args ... x) . rest))))
(define-syntax cut
(syntax-rules () ((cut args ...) (%cut #f () () args ...))))
(define-syntax cute
(syntax-rules () ((cute args ...) (%cut #t () () args ...))))))

11
lib/srfi/27.module Normal file
View file

@ -0,0 +1,11 @@
(define-module (srfi 27)
(export random-integer random-real default-random-source
make-random-source random-source?
random-source-state-ref random-source-state-set!
random-source-randomize! random-source-pseudo-randomize!
random-source-make-integers random-source-make-reals)
(import-immutable (scheme))
(include-shared "27/rand")
(include "27/constructors.scm"))

10
lib/srfi/27/constructors.scm Normal file
View file

@ -0,0 +1,10 @@
;; constructors.scm -- random function constructors
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (random-source-make-integers rs)
(lambda (n) (%random-integer rs n)))
(define (random-source-make-reals rs . o)
(lambda () (%random-real rs)))

204
lib/srfi/27/rand.c Normal file
View file

@ -0,0 +1,204 @@
/* rand.c -- rand_r/random_r interface */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include <time.h>
#include <chibi/eval.h>
#define SEXP_RANDOM_STATE_SIZE 128
#define ZERO sexp_make_fixnum(0)
#define ONE sexp_make_fixnum(1)
#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE)
#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id)
#define sexp_random_init(x, seed) \
initstate_r(seed, \
sexp_string_data(sexp_random_state(x)), \
SEXP_RANDOM_STATE_SIZE, \
sexp_random_data(x))
#if SEXP_BSD
typedef unsigned int sexp_random_t;
#define sexp_call_random(rs, dst) ((dst) = rand_r(sexp_random_data(rs)))
#define sexp_seed_random(n, rs) *sexp_random_data(rs) = (n)
#else
typedef struct random_data sexp_random_t;
#define sexp_call_random(rs, dst) random_r(sexp_random_data(rs), &dst)
#define sexp_seed_random(n, rs) srandom_r(n, sexp_random_data(rs))
#endif
#define sexp_random_state(x) (sexp_slot_ref((x), 0))
#define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1)))
#define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp))
static sexp_uint_t rs_type_id;
static sexp default_random_source;
static sexp sexp_rs_random_integer (sexp ctx, sexp rs, sexp bound) {
sexp res;
int32_t n;
#if SEXP_USE_BIGNUMS
int32_t hi, mod, len, i, *data;
#endif
if (! sexp_random_source_p(rs))
res = sexp_type_exception(ctx, "not a random-source", rs);
if (sexp_fixnump(bound)) {
sexp_call_random(rs, n);
res = sexp_make_fixnum(n % sexp_unbox_fixnum(bound));
#if SEXP_USE_BIGNUMS
} else if (sexp_bignump(bound)) {
hi = sexp_bignum_hi(bound);
len = hi * sizeof(sexp_uint_t) / sizeof(int32_t);
res = sexp_make_bignum(ctx, hi);
data = (int32_t*) sexp_bignum_data(res);
for (i=0; i<len-1; i++) {
sexp_call_random(rs, n);
data[i] = n;
}
sexp_call_random(rs, n);
mod = sexp_bignum_data(bound)[hi-1] * sizeof(int32_t) / sizeof(sexp_uint_t);
if (mod)
data[i] = n % mod;
#endif
} else {
res = sexp_type_exception(ctx, "random-integer: not an integer", bound);
}
return res;
}
static sexp sexp_random_integer (sexp ctx, sexp bound) {
return sexp_rs_random_integer(ctx, default_random_source, bound);
}
static sexp sexp_rs_random_real (sexp ctx, sexp rs) {
int32_t res;
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, "not a random-source", rs);
sexp_call_random(rs, res);
return sexp_make_flonum(ctx, (double)res / (double)RAND_MAX);
}
static sexp sexp_random_real (sexp ctx) {
return sexp_rs_random_real(ctx, default_random_source);
}
#if SEXP_BSD
static sexp sexp_make_random_source (sexp ctx) {
sexp res;
res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id);
*sexp_random_data(res) = 1;
return res;
}
static sexp sexp_random_source_state_ref (sexp ctx, sexp rs) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, "not a random-source", rs);
else
return sexp_make_integer(ctx, *sexp_random_data(rs));
}
static sexp sexp_random_source_state_set (sexp ctx, sexp rs, sexp state) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, "not a random-source", rs);
else if (sexp_fixnump(state))
*sexp_random_data(rs) = sexp_unbox_fixnum(state);
#if SEXP_USE_BIGNUMS
else if (sexp_bignump(state))
*sexp_random_data(rs)
= sexp_bignum_data(state)[0]*sexp_bignum_sign(state);
#endif
else
return sexp_type_exception(ctx, "not a valid random-state", state);
return SEXP_VOID;
}
#else
static sexp sexp_make_random_source (sexp ctx) {
sexp res;
sexp_gc_var1(state);
sexp_gc_preserve1(ctx, state);
state = sexp_make_string(ctx, STATE_SIZE, SEXP_UNDEF);
res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id);
sexp_random_state(res) = state;
sexp_random_init(res, 1);
sexp_gc_release1(ctx);
return res;
}
static sexp sexp_random_source_state_ref (sexp ctx, sexp rs) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, "not a random-source", rs);
else
return sexp_substring(ctx, sexp_random_state(rs), ZERO, STATE_SIZE);
}
static sexp sexp_random_source_state_set (sexp ctx, sexp rs, sexp state) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, "not a random-source", rs);
else if (! (sexp_stringp(state)
&& (sexp_string_length(state) == SEXP_RANDOM_STATE_SIZE)))
return sexp_type_exception(ctx, "not a valid random-state", state);
sexp_random_state(rs) = state;
sexp_random_init(rs, 1);
return SEXP_VOID;
}
#endif
static sexp sexp_random_source_randomize (sexp ctx, sexp rs) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, "not a random-source", rs);
sexp_seed_random(time(NULL), rs);
return SEXP_VOID;
}
static sexp sexp_random_source_pseudo_randomize (sexp ctx, sexp rs, sexp seed) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, "not a random-source", rs);
if (! sexp_fixnump(seed))
return sexp_type_exception(ctx, "not an integer", seed);
sexp_seed_random(sexp_unbox_fixnum(seed), rs);
return SEXP_VOID;
}
sexp sexp_init_library (sexp ctx, sexp env) {
sexp_gc_var2(name, op);
sexp_gc_preserve2(ctx, name, op);
name = sexp_c_string(ctx, "random-source", -1);
rs_type_id
= sexp_unbox_fixnum(sexp_register_type(ctx, name,
sexp_make_fixnum(sexp_offsetof_slot0),
ONE, ONE, ZERO, ZERO,
sexp_make_fixnum(sexp_sizeof_random),
ZERO, ZERO, NULL));
name = sexp_c_string(ctx, "random-source?", -1);
op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(rs_type_id));
name = sexp_intern(ctx, "random-source?");
sexp_env_define(ctx, env, name, op);
sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source);
sexp_define_foreign(ctx, env, "%random-integer", 2, sexp_rs_random_integer);
sexp_define_foreign(ctx, env, "random-integer", 1, sexp_random_integer);
sexp_define_foreign(ctx, env, "%random-real", 1, sexp_rs_random_real);
sexp_define_foreign(ctx, env, "random-real", 0, sexp_random_real);
sexp_define_foreign(ctx, env, "random-source-state-ref", 1, sexp_random_source_state_ref);
sexp_define_foreign(ctx, env, "random-source-state-set!", 2, sexp_random_source_state_set);
sexp_define_foreign(ctx, env, "random-source-randomize!", 1, sexp_random_source_randomize);
sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 2, sexp_random_source_pseudo_randomize);
default_random_source = op = sexp_make_random_source(ctx);
name = sexp_intern(ctx, "default-random-source");
sexp_env_define(ctx, env, name, default_random_source);
sexp_random_source_randomize(ctx, default_random_source);
sexp_gc_release2(ctx);
return SEXP_VOID;
}

17
lib/srfi/33.module Normal file
View file

@ -0,0 +1,17 @@
(define-module (srfi 33)
(export bitwise-not
bitwise-and bitwise-ior
bitwise-xor bitwise-eqv
bitwise-nand bitwise-nor
bitwise-andc1 bitwise-andc2
bitwise-orc1 bitwise-orc2
arithmetic-shift bit-count integer-length
bitwise-merge
bit-set? any-bits-set? all-bits-set?
first-set-bit
extract-bit-field test-bit-field? clear-bit-field
replace-bit-field copy-bit-field)
(import-immutable (scheme))
(include-shared "33/bit")
(include "33/bitwise.scm"))

303
lib/srfi/33/bit.c Normal file
View file

@ -0,0 +1,303 @@
/* bit.c -- bitwise operators */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include <chibi/eval.h>
#include <limits.h>
#if SEXP_USE_BIGNUMS
#include <chibi/bignum.h>
#else
#define sexp_bignum_normalize(x) x
#endif
static sexp sexp_bit_and (sexp ctx, sexp x, sexp y) {
sexp res;
#if SEXP_USE_BIGNUMS
sexp_sint_t len, i;
#endif
if (sexp_fixnump(x)) {
if (sexp_fixnump(y))
res = (sexp) ((sexp_uint_t)x & (sexp_uint_t)y);
#if SEXP_USE_BIGNUMS
else if (sexp_bignump(y))
res = sexp_bit_and(ctx, y, x);
#endif
else
res = sexp_type_exception(ctx, "bitwise-and: not an integer", y);
#if SEXP_USE_BIGNUMS
} else if (sexp_bignump(x)) {
if (sexp_fixnump(y)) {
res = sexp_make_fixnum(sexp_unbox_fixnum(y) & sexp_bignum_data(x)[0]);
} else if (sexp_bignump(y)) {
if (sexp_bignum_length(x) < sexp_bignum_length(y))
res = sexp_copy_bignum(ctx, NULL, x, 0);
else
res = sexp_copy_bignum(ctx, NULL, y, 0);
for (i=0, len=sexp_bignum_length(res); i<len; i++)
sexp_bignum_data(res)[i]
= sexp_bignum_data(x)[i] & sexp_bignum_data(y)[i];
} else {
res = sexp_type_exception(ctx, "bitwise-and: not an integer", y);
}
#endif
} else {
res = sexp_type_exception(ctx, "bitwise-and: not an integer", x);
}
return sexp_bignum_normalize(res);
}
static sexp sexp_bit_ior (sexp ctx, sexp x, sexp y) {
sexp res;
#if SEXP_USE_BIGNUMS
sexp_sint_t len, i;
#endif
if (sexp_fixnump(x)) {
if (sexp_fixnump(y))
res = (sexp) ((sexp_uint_t)x | (sexp_uint_t)y);
#if SEXP_USE_BIGNUMS
else if (sexp_bignump(y))
res = sexp_bit_ior(ctx, y, x);
#endif
else
res = sexp_type_exception(ctx, "bitwise-ior: not an integer", y);
#if SEXP_USE_BIGNUMS
} else if (sexp_bignump(x)) {
if (sexp_fixnump(y)) {
res = sexp_copy_bignum(ctx, NULL, x, 0);
sexp_bignum_data(x)[0] |= sexp_unbox_fixnum(y);
} else if (sexp_bignump(y)) {
if (sexp_bignum_length(x) >= sexp_bignum_length(y)) {
res = sexp_copy_bignum(ctx, NULL, x, 0);
len = sexp_bignum_length(y);
} else {
res = sexp_copy_bignum(ctx, NULL, y, 0);
len = sexp_bignum_length(x);
}
for (i=0; i<len; i++)
sexp_bignum_data(res)[i]
= sexp_bignum_data(x)[i] | sexp_bignum_data(y)[i];
} else {
res = sexp_type_exception(ctx, "bitwise-ior: not an integer", y);
}
#endif
} else {
res = sexp_type_exception(ctx, "bitwise-ior: not an integer", x);
}
return sexp_bignum_normalize(res);
}
static sexp sexp_bit_xor (sexp ctx, sexp x, sexp y) {
sexp res;
#if SEXP_USE_BIGNUMS
sexp_sint_t len, i;
#endif
if (sexp_fixnump(x)) {
if (sexp_fixnump(y))
res = sexp_make_fixnum(sexp_unbox_fixnum(x) ^ sexp_unbox_fixnum(y));
#if SEXP_USE_BIGNUMS
else if (sexp_bignump(y))
res = sexp_bit_xor(ctx, y, x);
#endif
else
res = sexp_type_exception(ctx, "bitwise-xor: not an integer", y);
#if SEXP_USE_BIGNUMS
} else if (sexp_bignump(x)) {
if (sexp_fixnump(y)) {
res = sexp_copy_bignum(ctx, NULL, x, 0);
sexp_bignum_data(x)[0] ^= sexp_unbox_fixnum(y);
} else if (sexp_bignump(y)) {
if (sexp_bignum_length(x) >= sexp_bignum_length(y)) {
res = sexp_copy_bignum(ctx, NULL, x, 0);
len = sexp_bignum_length(y);
} else {
res = sexp_copy_bignum(ctx, NULL, y, 0);
len = sexp_bignum_length(x);
}
for (i=0; i<len; i++)
sexp_bignum_data(res)[i]
= sexp_bignum_data(x)[i] ^ sexp_bignum_data(y)[i];
} else {
res = sexp_type_exception(ctx, "bitwise-xor: not an integer", y);
}
#endif
} else {
res = sexp_type_exception(ctx, "bitwise-xor: not an integer", x);
}
return sexp_bignum_normalize(res);
}
/* should probably split into left and right shifts, that's a better */
/* interface anyway */
static sexp sexp_arithmetic_shift (sexp ctx, sexp i, sexp count) {
sexp_uint_t tmp;
sexp_sint_t c;
#if SEXP_USE_BIGNUMS
sexp_sint_t len, offset, bit_shift, j;
sexp_gc_var1(res);
#else
sexp res;
#endif
if (! sexp_fixnump(count))
return sexp_type_exception(ctx, "arithmetic-shift: not an integer", count);
c = sexp_unbox_fixnum(count);
if (c == 0) return i;
if (sexp_fixnump(i)) {
if (c < 0) {
res = sexp_make_fixnum(sexp_unbox_fixnum(i) >> -c);
} else {
tmp = (sexp_uint_t)sexp_unbox_fixnum(i) << c;
#if SEXP_USE_BIGNUMS
if (((tmp >> c) == sexp_unbox_fixnum(i))
&& (tmp < SEXP_MAX_FIXNUM) && (tmp > SEXP_MIN_FIXNUM)) {
#endif
res = sexp_make_fixnum(tmp);
#if SEXP_USE_BIGNUMS
} else {
sexp_gc_preserve1(ctx, res);
res = sexp_fixnum_to_bignum(ctx, i);
res = sexp_arithmetic_shift(ctx, res, count);
sexp_gc_release1(ctx);
}
#endif
}
#if SEXP_USE_BIGNUMS
} else if (sexp_bignump(i)) {
len = sexp_bignum_hi(i);
if (c < 0) {
c = -c;
offset = c / (sizeof(sexp_uint_t)*CHAR_BIT);
bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT);
if (len < offset) {
res = sexp_make_fixnum(sexp_bignum_sign(i) > 0 ? 0 : -1);
} else {
res = sexp_make_bignum(ctx, len - offset + 1);
for (j=len-offset, tmp=0; j>=0; j--) {
sexp_bignum_data(res)[j]
= (sexp_bignum_data(i)[j+offset] >> bit_shift)+ tmp;
tmp = sexp_bignum_data(i)[j+offset]
<< (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift);
}
}
} else {
offset = c / (sizeof(sexp_uint_t)*CHAR_BIT);
bit_shift = c - offset*(sizeof(sexp_uint_t)*CHAR_BIT);
res = sexp_make_bignum(ctx, len + offset + 1);
for (j=tmp=0; j<len; j++) {
sexp_bignum_data(res)[j+offset]
= (sexp_bignum_data(i)[j] << bit_shift) + tmp;
tmp = sexp_bignum_data(i)[j] >> (sizeof(sexp_uint_t)*CHAR_BIT-bit_shift);
}
sexp_bignum_data(res)[len+offset] = tmp;
}
#endif
} else {
res = sexp_type_exception(ctx, "arithmetic-shift: not an integer", i);
}
return sexp_bignum_normalize(res);
}
/* bit-count and integer-length were adapted from: */
/* http://graphics.stanford.edu/~seander/bithacks.html */
static sexp_uint_t bit_count (sexp_uint_t i) {
i -= ((i >> 1) & (sexp_uint_t)~(sexp_uint_t)0/3);
i = ((i & (sexp_uint_t)~(sexp_uint_t)0/15*3)
+ ((i >> 2) & (sexp_uint_t)~(sexp_uint_t)0/15*3));
i = (i + (i >> 4)) & (sexp_uint_t)~(sexp_uint_t)0/255*15;
return ((sexp_uint_t)(i * ((sexp_uint_t)~(sexp_uint_t)0/255))
>> (sizeof(i) - 1) * CHAR_BIT);
}
static sexp sexp_bit_count (sexp ctx, sexp x) {
sexp res;
sexp_sint_t i;
#if SEXP_USE_BIGNUMS
sexp_uint_t count;
#endif
if (sexp_fixnump(x)) {
i = sexp_unbox_fixnum(x);
res = sexp_make_fixnum(bit_count(i<0 ? ~i : i));
#if SEXP_USE_BIGNUMS
} else if (sexp_bignump(x)) {
for (i=count=0; i<sexp_bignum_length(x); i++)
count += bit_count(sexp_bignum_data(x)[i]);
res = sexp_make_fixnum(count);
#endif
} else {
res = sexp_type_exception(ctx, "bit-count: not an integer", x);
}
return res;
}
static const char log_table_256[256] =
{
#define LT(n) n, n, n, n, n, n, n, n, n, n, n, n, n, n, n, n
0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4,
LT(5), LT(6), LT(7), LT(7), LT(7), LT(7), LT(7),
LT(8), LT(8), LT(8), LT(8), LT(8), LT(8), LT(8), LT(8)
};
static sexp_uint_t integer_log2 (sexp_uint_t x) {
sexp_uint_t t, tt;
#if SEXP_64_BIT
if ((tt = x >> 32))
return integer_log2(tt) + 32;
else
#endif
if ((tt = x >> 16))
return (t = tt >> 8) ? 24 + log_table_256[t] : 16 + log_table_256[tt];
else
return (t = x >> 8) ? 8 + log_table_256[t] : log_table_256[x];
}
static sexp sexp_integer_length (sexp ctx, sexp x) {
sexp_sint_t tmp;
#if SEXP_USE_BIGNUMS
sexp_sint_t hi;
#endif
if (sexp_fixnump(x)) {
tmp = sexp_unbox_fixnum(x);
return sexp_make_fixnum(integer_log2(tmp < 0 ? -tmp-1 : tmp));
#if SEXP_USE_BIGNUMS
} else if (sexp_bignump(x)) {
hi = sexp_bignum_hi(x);
return sexp_make_fixnum(integer_log2(sexp_bignum_data(x)[hi])
+ hi*sizeof(sexp_uint_t));
#endif
} else {
return sexp_type_exception(ctx, "integer-length: not an integer", x);
}
}
static sexp sexp_bit_set_p (sexp ctx, sexp i, sexp x) {
#if SEXP_USE_BIGNUMS
sexp_uint_t pos;
#endif
if (! sexp_fixnump(i))
return sexp_type_exception(ctx, "bit-set?: not an integer", i);
if (sexp_fixnump(x)) {
return sexp_make_boolean(sexp_unbox_fixnum(x) & (1<<sexp_unbox_fixnum(i)));
#if SEXP_USE_BIGNUMS
} else if (sexp_bignump(x)) {
pos = sexp_unbox_fixnum(i) / (sizeof(sexp_uint_t)*CHAR_BIT);
return sexp_make_boolean((pos < sexp_bignum_length(x))
&& (sexp_bignum_data(x)[pos]
& (1<<(sexp_unbox_fixnum(i)
- pos*sizeof(sexp_uint_t)*CHAR_BIT))));
#endif
} else {
return sexp_type_exception(ctx, "bit-set?: not an integer", x);
}
}
sexp sexp_init_library (sexp ctx, sexp env) {
sexp_define_foreign(ctx, env, "bit-and", 2, sexp_bit_and);
sexp_define_foreign(ctx, env, "bit-ior", 2, sexp_bit_ior);
sexp_define_foreign(ctx, env, "bit-xor", 2, sexp_bit_xor);
sexp_define_foreign(ctx, env, "arithmetic-shift", 2, sexp_arithmetic_shift);
sexp_define_foreign(ctx, env, "bit-count", 1, sexp_bit_count);
sexp_define_foreign(ctx, env, "integer-length", 1, sexp_integer_length);
sexp_define_foreign(ctx, env, "bit-set?", 2, sexp_bit_set_p);
return SEXP_VOID;
}

61
lib/srfi/33/bitwise.scm Normal file
View file

@ -0,0 +1,61 @@
;; bitwise.scm -- high-level bitwise functions
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (bitwise-not i) (- (+ i 1)))
(define (bitwise-complement f) (lambda args (bitwise-not (apply f args))))
(define (make-nary proc2 default)
(lambda args
(if (null? args)
default
(let lp ((i (car args)) (ls (cdr args)))
(if (null? ls)
i
(lp (proc2 i (car ls)) (cdr ls)))))))
(define bitwise-and (make-nary bit-and -1))
(define bitwise-ior (make-nary bit-ior 0))
(define bitwise-xor (make-nary bit-xor 0))
(define bitwise-eqv (bitwise-complement (make-nary bit-xor -1)))
(define bitwise-nand (bitwise-complement (make-nary bit-and 0)))
(define bitwise-nor (bitwise-complement (make-nary bit-ior -1)))
(define (bitwise-andc1 i j) (bit-and (bitwise-not i) j))
(define (bitwise-andc2 i j) (bit-and i (bitwise-not j)))
(define (bitwise-orc1 i j) (bit-ior (bitwise-not i) j))
(define (bitwise-orc2 i j) (bit-ior i (bitwise-not j)))
(define (any-bits-set? test-bits i)
(not (zero? (bitwise-and test-bits i))))
(define (all-bits-set? test-bits i)
(= test-bits (bitwise-and test-bits i)))
(define (first-set-bit i)
(if (zero? i)
-1
(integer-length (- i (bit-and i (- i 1))))))
(define (mask len) (bitwise-not (arithmetic-shift -1 len)))
(define (bitwise-merge mask n m)
(bit-ior (bit-and mask n) (bit-and (bitwise-not mask) m)))
(define (extract-bit-field size position n)
(bit-and (arithmetic-shift n (- position)) (mask size)))
(define (test-bit-field? size position n)
(not (zero? (bit-and (arithmetic-shift n (- position)) (mask size)))))
(define (replace-bit-field size position newfield n)
(bit-ior (bit-and n (bitwise-not (arithmetic-shift (mask size) position)))
(arithmetic-shift newfield position)))
(define (clear-bit-field size position n)
(replace-bit-field size position 0 n))
(define (copy-bit-field size position from to)
(bitwise-merge (arithmetic-shift (mask size) position) to from))

25
lib/srfi/39.module Normal file
View file

@ -0,0 +1,25 @@
(define-module (srfi 39)
(export make-parameter parameterize)
(import-immutable (scheme))
(body
(define (make-parameter value . o)
(if (pair? o)
(let ((converter (car o)))
(lambda args
(if (null? args)
value
(set! value (converter (car args))))))
(lambda args (if (null? args) value (set! value (car args))))))
(define-syntax parameterize
(syntax-rules ()
((parameterize ("step") ((param value tmp1 tmp2) ...) () body)
(let ((tmp1 value) ...)
(let ((tmp2 (param)) ...)
(dynamic-wind (lambda () (param tmp1) ...)
(lambda () . body)
(lambda () (param tmp2) ...)))))
((parameterize ("step") args ((param value) . rest) body)
(parameterize ("step") ((param value tmp1 tmp2) . args) rest body))
((parameterize ((param value) ...) . body)
(parameterize ("step") () ((param value) ...) body))))))

5
lib/srfi/6.module Normal file
View file

@ -0,0 +1,5 @@
(define-module (srfi 6)
(export open-input-string open-output-string get-output-string)
(import-immutable (scheme)))

17
lib/srfi/69.module Normal file
View file

@ -0,0 +1,17 @@
(define-module (srfi 69)
(export
make-hash-table hash-table? alist->hash-table
hash-table-equivalence-function hash-table-hash-function
hash-table-ref hash-table-ref/default hash-table-set!
hash-table-delete! hash-table-exists?
hash-table-update! hash-table-update!/default
hash-table-size hash-table-keys hash-table-values
hash-table-walk hash-table-fold hash-table->alist
hash-table-copy hash-table-merge!
hash string-hash string-ci-hash hash-by-identity)
(import-immutable (scheme)
(srfi 9))
(include-shared "69/hash")
(include "69/type.scm" "69/interface.scm"))

242
lib/srfi/69/hash.c Normal file
View file

@ -0,0 +1,242 @@
/* hash.c -- type-general hashing */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include <chibi/eval.h>
#define HASH_DEPTH 5
#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM)
#define FNV_PRIME 16777619
#define FNV_OFFSET_BASIS 2166136261uL
#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0)
#define sexp_hash_table_size(x) sexp_slot_ref(x, 1)
#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2)
#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3)
#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2))
static sexp_uint_t string_hash (char *str, sexp_uint_t bound) {
sexp_uint_t acc = FNV_OFFSET_BASIS;
while (*str) {acc *= FNV_PRIME; acc ^= *str++;}
return acc % bound;
}
static sexp sexp_string_hash (sexp ctx, sexp str, sexp bound) {
if (! sexp_stringp(str))
return sexp_type_exception(ctx, "string-hash: not a string", str);
else if (! sexp_integerp(bound))
return sexp_type_exception(ctx, "string-hash: not an integer", bound);
return sexp_make_fixnum(string_hash(sexp_string_data(str),
sexp_unbox_fixnum(bound)));
}
static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) {
sexp_uint_t acc = FNV_OFFSET_BASIS;
while (*str) {acc *= FNV_PRIME; acc ^= tolower(*str++);}
return acc % bound;
}
static sexp sexp_string_ci_hash (sexp ctx, sexp str, sexp bound) {
if (! sexp_stringp(str))
return sexp_type_exception(ctx, "string-ci-hash: not a string", str);
else if (! sexp_integerp(bound))
return sexp_type_exception(ctx, "string-ci-hash: not an integer", bound);
return sexp_make_fixnum(string_ci_hash(sexp_string_data(str),
sexp_unbox_fixnum(bound)));
}
static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) {
sexp_uint_t acc = FNV_OFFSET_BASIS, size;
sexp_sint_t i, len;
sexp t, *p;
char *p0;
loop:
#if SEXP_USE_FLONUMS
if (sexp_flonump(obj))
acc ^= (sexp_sint_t) sexp_flonum_value(obj);
else
#endif
if (sexp_pointerp(obj)) {
if (depth) {
t = sexp_object_type(ctx, obj);
p = (sexp*) (((char*)obj) + sexp_type_field_base(t));
p0 = ((char*)obj) + offsetof(struct sexp_struct, value);
if ((sexp)p == obj) p=(sexp*)p0;
/* hash trailing non-object data */
size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value);
p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp));
if (((char*)obj + size) > p0)
for (i=0; i<size; i++) {acc *= FNV_PRIME; acc ^= p0[i];}
/* hash eq-object slots */
len = sexp_type_num_eq_slots_of_object(t, obj);
if (len > 0) {
depth--;
for (i=0; i<len-1; i++) {
acc *= FNV_PRIME;
acc ^= hash_one(ctx, p[i], 0, depth);
}
/* tail-recurse on the last value */
obj = p[len-1]; goto loop;
}
} else {
acc ^= sexp_pointer_tag(obj);
}
} else {
acc ^= (sexp_uint_t)obj;
}
return (bound ? acc % bound : acc);
}
static sexp sexp_hash (sexp ctx, sexp obj, sexp bound) {
if (! sexp_exact_integerp(bound))
return sexp_type_exception(ctx, "hash: not an integer", bound);
return sexp_make_fixnum(hash_one(ctx, obj, sexp_unbox_fixnum(bound), HASH_DEPTH));
}
static sexp sexp_hash_by_identity (sexp ctx, sexp obj, sexp bound) {
if (! sexp_exact_integerp(bound))
return sexp_type_exception(ctx, "hash-by-identity: not an integer", bound);
return sexp_make_fixnum((sexp_uint_t)obj % sexp_unbox_fixnum(bound));
}
static sexp sexp_get_bucket (sexp ctx, sexp buckets, sexp hash_fn, sexp obj) {
sexp_gc_var1(args);
sexp res;
sexp_uint_t len = sexp_vector_length(buckets);
if (hash_fn == sexp_make_fixnum(1))
res = sexp_hash_by_identity(ctx, obj, sexp_make_fixnum(len));
else if (hash_fn == sexp_make_fixnum(2))
res = sexp_hash(ctx, obj, sexp_make_fixnum(len));
else {
sexp_gc_preserve1(ctx, args);
args = sexp_list2(ctx, obj, sexp_make_fixnum(len));
res = sexp_apply(ctx, hash_fn, args);
if (sexp_exceptionp(res)) {
args = sexp_eval_string(ctx, "(current-error-port)", sexp_context_env(ctx));
sexp_print_exception(ctx, res, args);
res = sexp_make_fixnum(0);
}
sexp_gc_release1(ctx);
}
return res;
}
static sexp sexp_scan_bucket (sexp ctx, sexp ls, sexp obj, sexp eq_fn) {
sexp_gc_var1(res);
sexp p;
res = SEXP_FALSE;
if ((eq_fn == sexp_make_fixnum(1))
|| ((eq_fn == sexp_make_fixnum(2))
&& (sexp_pointerp(obj) ?
(sexp_pointer_tag(obj) == SEXP_SYMBOL) : ! sexp_fixnump(obj)))) {
for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
if (sexp_caar(p) == obj) {
res = p;
break;
}
}
} else if (eq_fn == sexp_make_fixnum(2)) {
for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
if (sexp_truep(sexp_equalp(ctx, sexp_caar(p), obj))) {
res = p;
break;
}
}
} else {
sexp_gc_preserve1(ctx, res);
for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
res = sexp_list2(ctx, sexp_caar(p), obj);
if (sexp_truep(sexp_apply(ctx, eq_fn, res))) {
res = p;
break;
} else {
res = SEXP_FALSE;
}
}
sexp_gc_release1(ctx);
}
return res;
}
static void sexp_regrow_hash_table (sexp ctx, sexp ht, sexp oldbuckets, sexp hash_fn) {
sexp ls, *oldvec, *newvec;
int i, j, oldsize=sexp_vector_length(oldbuckets), newsize=oldsize*2;
sexp_gc_var1(newbuckets);
sexp_gc_preserve1(ctx, newbuckets);
newbuckets = sexp_make_vector(ctx, sexp_make_fixnum(newsize), SEXP_NULL);
if (newbuckets) {
oldvec = sexp_vector_data(oldbuckets);
newvec = sexp_vector_data(newbuckets);
for (i=0; i<oldsize; i++) {
for (ls=oldvec[i]; sexp_pairp(ls); ls=sexp_cdr(ls)) {
j = sexp_unbox_fixnum(sexp_get_bucket(ctx, newbuckets, hash_fn, sexp_caar(ls)));
sexp_push(ctx, newvec[j], sexp_car(ls));
}
}
sexp_hash_table_buckets(ht) = newbuckets;
}
sexp_gc_release1(ctx);
}
static sexp sexp_hash_table_cell (sexp ctx, sexp ht, sexp obj, sexp createp) {
sexp buckets, eq_fn, hash_fn, i;
sexp_uint_t size;
sexp_gc_var1(res);
if (! sexp_pointerp(ht))
return sexp_type_exception(ctx, "not a hash-table", ht);
buckets = sexp_hash_table_buckets(ht);
eq_fn = sexp_hash_table_eq_fn(ht);
hash_fn = sexp_hash_table_hash_fn(ht);
i = sexp_get_bucket(ctx, buckets, hash_fn, obj);
res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn);
if (sexp_truep(res)) {
res = sexp_car(res);
} else if (sexp_truep(createp)) {
sexp_gc_preserve1(ctx, res);
size = sexp_unbox_fixnum(sexp_hash_table_size(ht));
if (sexp_hash_resize_check(size, sexp_vector_length(buckets))) {
sexp_regrow_hash_table(ctx, ht, buckets, hash_fn);
buckets = sexp_hash_table_buckets(ht);
i = sexp_get_bucket(ctx, buckets, hash_fn, obj);
}
res = sexp_cons(ctx, obj, createp);
sexp_vector_set(buckets, i, sexp_cons(ctx, res, sexp_vector_ref(buckets, i)));
sexp_hash_table_size(ht) = sexp_make_fixnum(size+1);
sexp_gc_release1(ctx);
}
return res;
}
static sexp sexp_hash_table_delete (sexp ctx, sexp ht, sexp obj) {
sexp buckets=sexp_hash_table_buckets(ht), eq_fn=sexp_hash_table_eq_fn(ht),
hash_fn=sexp_hash_table_hash_fn(ht), i, p, res;
i = sexp_get_bucket(ctx, buckets, hash_fn, obj);
res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn);
if (sexp_pairp(res)) {
sexp_hash_table_size(ht)
= sexp_fx_sub(sexp_hash_table_size(ht), sexp_make_fixnum(1));
if (res == sexp_vector_ref(buckets, i)) {
sexp_vector_set(buckets, i, sexp_cdr(res));
} else {
for (p=sexp_vector_ref(buckets, i); sexp_cdr(p)!=res; p=sexp_cdr(p))
;
sexp_cdr(p) = sexp_cdr(res);
}
}
return SEXP_VOID;
}
sexp sexp_init_library (sexp ctx, sexp env) {
sexp_define_foreign_opt(ctx, env, "string-hash", 2, sexp_string_hash, HASH_BOUND);
sexp_define_foreign_opt(ctx, env, "string-ci-hash", 2, sexp_string_ci_hash, HASH_BOUND);
sexp_define_foreign_opt(ctx, env, "hash", 2, sexp_hash, HASH_BOUND);
sexp_define_foreign_opt(ctx, env, "hash-by-identity", 2, sexp_hash_by_identity, HASH_BOUND);
sexp_define_foreign(ctx, env, "hash-table-cell", 3, sexp_hash_table_cell);
sexp_define_foreign(ctx, env, "hash-table-delete!", 2, sexp_hash_table_delete);
return SEXP_VOID;
}

115
lib/srfi/69/interface.scm Normal file
View file

@ -0,0 +1,115 @@
;; interface.scm -- hash-table interface
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;; the non-exported hash-table-cell is the heart of the implemenation
(define (make-hash-table . o)
(let ((eq-fn (if (pair? o) (car o) equal?))
(hash-fn (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) hash)))
(cond
((not (procedure? eq-fn))
(error "make-hash-table: bad equivalence function" eq-fn))
((not (procedure? hash-fn))
(error "make-hash-table: bad hash function" hash-fn))
(else
(%make-hash-table
(make-vector 23 '())
0
(if (eq? hash-fn hash-by-identity) 1 (if (eq? hash-fn hash) 2 hash-fn))
(if (eq? eq-fn eq?) 1 (if (eq? eq-fn equal?) 2 eq-fn)))))))
(define (hash-table-hash-function table)
(let ((f (%hash-table-hash-function table)))
(case f ((1) hash-by-identity) ((2) hash) (else f))))
(define (hash-table-equivalence-function table)
(let ((f (%hash-table-equivalence-function table)))
(case f ((1) eq?) ((2) equal?) (else f))))
(define-syntax assert-hash-table
(syntax-rules ()
((assert-hash-table from obj)
(if (not (hash-table? obj))
(error (string-append from ": not a hash-table") obj)))))
(define (hash-table-ref table key . o)
(assert-hash-table "hash-table-ref" table)
(let ((cell (hash-table-cell table key #f)))
(cond (cell (cdr cell))
((pair? o) ((car o)))
(else (error "hash-table-ref: key not found" key)))))
(define (hash-table-ref/default table key default)
(assert-hash-table "hash-table-ref/default" table)
(let ((cell (hash-table-cell table key #f)))
(if cell (cdr cell) default)))
(define (hash-table-set! table key value)
(assert-hash-table "hash-table-set!" table)
(let ((cell (hash-table-cell table key #t)))
(set-cdr! cell value)))
(define (hash-table-exists? table key)
(assert-hash-table "hash-table-exists?" table)
(and (hash-table-cell table key #f) #t))
(define hash-table-update!
(let ((not-found (cons 'not-found '())))
(lambda (table key func . o)
(assert-hash-table "hash-table-update!" table)
(let ((cell (hash-table-cell table key not-found)))
(set-cdr! cell (if (eq? not-found (cdr cell))
(if (pair? o)
(func ((car o)))
(error "hash-table-update!: key not found" key))
(func (cdr cell))))))))
(define hash-table-update!/default
(let ((not-found (cons 'not-found '())))
(lambda (table key func default)
(assert-hash-table "hash-table-update!/default" table)
(let ((cell (hash-table-cell table key not-found)))
(set-cdr! cell (func (if (eq? not-found (cdr cell)) default (cdr cell))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (hash-table-fold table kons knil)
(assert-hash-table "hash-table-fold" table)
(let ((vec (hash-table-buckets table)))
(let lp1 ((i (- (vector-length vec) 1)) (acc knil))
(if (< i 0)
acc
(let lp2 ((ls (vector-ref vec i)) (acc acc))
(if (null? ls)
(lp1 (- i 1) acc)
(lp2 (cdr ls) (kons (car (car ls)) (cdr (car ls)) acc))))))))
(define (hash-table-walk table proc)
(hash-table-fold table (lambda (k v a) (proc k v)) #f)
(if #f #f))
(define (hash-table->alist table)
(hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '()))
(define (hash-table-keys table)
(hash-table-fold table (lambda (k v a) (cons k a)) '()))
(define (hash-table-values table)
(hash-table-fold table (lambda (k v a) (cons v a)) '()))
(define (alist->hash-table ls . o)
(let ((res (apply make-hash-table o)))
(for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls)
res))
(define (hash-table-merge! a b)
(hash-table-walk b (lambda (k v) (hash-table-set! a k v)))
a)
(define (hash-table-copy table)
(assert-hash-table "hash-table-copy" table)
(let ((res (make-hash-table (hash-table-equivalence-function table))))
(hash-table-merge! res table)
res))

12
lib/srfi/69/type.scm Normal file
View file

@ -0,0 +1,12 @@
;; types.scm -- the hash-table record type
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define-record-type hash-table
(%make-hash-table buckets size hash-fn eq-fn)
hash-table?
(buckets hash-table-buckets hash-table-buckets-set!)
(size hash-table-size hash-table-size-set!)
(hash-fn %hash-table-hash-function)
(eq-fn %hash-table-equivalence-function))

10
lib/srfi/8.module Normal file
View file

@ -0,0 +1,10 @@
(define-module (srfi 8)
(export receive)
(import-immutable (scheme))
(body
(define-syntax receive
(syntax-rules ()
((receive params expr . body)
(call-with-values (lambda () expr) (lambda params . body)))))))

82
lib/srfi/9.module Normal file
View file

@ -0,0 +1,82 @@
(define-module (srfi 9)
(export define-record-type)
(import-immutable (scheme))
(body
(define-syntax define-record-type
(er-macro-transformer
(lambda (expr rename compare)
(let* ((name (cadr expr))
(make (caaddr expr))
(make-fields (cdaddr expr))
(pred (cadddr expr))
(fields (cddddr expr))
(num-fields (length fields))
(index (register-simple-type (symbol->string name) num-fields))
(_define (rename 'define))
(_lambda (rename 'lambda))
(_let (rename 'let)))
(define (index-of field ls)
(let lp ((ls ls) (i 0))
(if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1)))))
`(,(rename 'begin)
(,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string pred)
,index))
,@(let lp ((ls fields) (i 0) (res '()))
(if (null? ls)
res
(let ((res
(cons `(,_define ,(cadar ls)
(,(rename 'make-getter)
,(symbol->string (cadar ls))
,index
,i))
res)))
(lp (cdr ls)
(+ i 1)
(if (pair? (cddar ls))
(cons
`(,_define ,(caddar ls)
(,(rename 'make-setter)
,(symbol->string (caddar ls))
,index
,i))
res)
res)))))
(,_define ,make
,(let lp ((ls make-fields) (sets '()) (set-defs '()))
(cond
((null? ls)
`(,_let ((%make (,(rename 'make-constructor)
,(symbol->string make)
,index))
,@set-defs)
(,_lambda ,make-fields
(,_let ((res (%make)))
,@sets
res))))
(else
(let ((field (assq (car ls) fields)))
(cond
((not field)
(error "unknown record field in constructor" (car ls)))
((pair? (cddr field))
(lp (cdr ls)
(cons (list (caddr field) 'res (car ls)) sets)
set-defs))
(else
(let* ((setter-name
(string-append "%" (symbol->string name) "-"
(symbol->string (car ls)) "-set!"))
(setter (rename (string->symbol setter-name)))
(i (index-of (car ls) fields)))
(lp (cdr ls)
(cons (list setter 'res (car ls)) sets)
(cons (list setter
(list (rename 'make-setter)
setter-name
index
(index-of (car ls) fields)))
set-defs)))))))))))))))))

7
lib/srfi/95.module Normal file
View file

@ -0,0 +1,7 @@
(define-module (srfi 95)
(export sorted? merge merge! sort sort!)
(import-immutable (scheme))
(include-shared "95/qsort")
(include "95/sort.scm"))

170
lib/srfi/95/qsort.c Normal file
View file

@ -0,0 +1,170 @@
/* qsort.c -- quicksort implementation */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include "chibi/eval.h"
#define swap(tmp_var, a, b) (tmp_var=a, a=b, b=tmp_var)
static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) {
sexp_sint_t i;
sexp ls, *data=sexp_vector_data(vec);
for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls))
sexp_car(ls) = data[i];
return seq;
}
static sexp sexp_vector_nreverse (sexp ctx, sexp vec) {
int i, j;
sexp tmp, *data=sexp_vector_data(vec);
for (i=0, j=sexp_vector_length(vec)-1; i<j; i++, j--)
swap(tmp, data[i], data[j]);
return vec;
}
static int sexp_basic_comparator (sexp op) {
if (sexp_not(op))
return 1;
if (! sexp_opcodep(op))
return 0;
if (sexp_opcode_class(op) == SEXP_OPC_ARITHMETIC_CMP)
return 1;
return 0;
}
static int sexp_object_compare (sexp ctx, sexp a, sexp b) {
int res;
if (sexp_pointerp(a)) {
if (sexp_pointerp(b)) {
if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) {
res = sexp_pointer_tag(a) - sexp_pointer_tag(b);
} else {
switch (sexp_pointer_tag(a)) {
case SEXP_FLONUM:
res = sexp_flonum_value(a) - sexp_flonum_value(b);
break;
case SEXP_BIGNUM:
res = sexp_bignum_compare(a, b);
break;
case SEXP_STRING:
res = strcmp(sexp_string_data(a), sexp_string_data(b));
break;
default:
res = 0;
break;
}
}
} else {
res = 1;
}
} else if (sexp_pointerp(b)) {
res = -1;
} else {
res = (sexp_sint_t)a - (sexp_sint_t)b;
}
return res;
}
static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) {
sexp_sint_t mid, i, j;
sexp tmp, tmp2;
loop:
if (lo < hi) {
mid = lo + (hi-lo)/2;
swap(tmp, vec[mid], vec[hi]);
for (i=j=lo; i < hi; i++)
if (sexp_object_compare(ctx, vec[i], tmp) < 0)
swap(tmp2, vec[i], vec[j]), j++;
swap(tmp, vec[j], vec[hi]);
if ((hi-lo) > 2) {
sexp_qsort(ctx, vec, lo, j-1);
lo = j+1;
goto loop;
}
}
}
static sexp sexp_qsort_less (sexp ctx, sexp *vec,
sexp_sint_t lo, sexp_sint_t hi,
sexp less, sexp key) {
sexp_sint_t mid, i, j;
sexp tmp, res, args1;
sexp_gc_var3(a, b, args2);
sexp_gc_preserve3(ctx, a, b, args2);
args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID);
args1 = sexp_cdr(args2);
loop:
if (lo >= hi) {
res = SEXP_VOID;
} else {
mid = lo + (hi-lo)/2;
swap(tmp, vec[mid], vec[hi]);
sexp_car(args1) = tmp;
b = sexp_apply(ctx, key, args1);
for (i=j=lo; i < hi; i++) {
sexp_car(args1) = vec[i];
a = sexp_apply(ctx, key, args1);
sexp_car(args2) = a;
sexp_car(args1) = b;
res = sexp_apply(ctx, less, args2);
if (sexp_exceptionp(res))
goto done;
else if (sexp_truep(res))
swap(res, vec[i], vec[j]), j++;
}
swap(tmp, vec[j], vec[hi]);
if ((hi-lo) > 2) {
res = sexp_qsort_less(ctx, vec, lo, j-1, less, key);
if (sexp_exceptionp(res))
goto done;
lo = j+1;
goto loop;
}
}
done:
sexp_gc_release3(ctx);
return res;
}
static sexp sexp_sort_x (sexp ctx, sexp seq, sexp less, sexp key) {
sexp_sint_t len;
sexp res, *data;
sexp_gc_var1(vec);
if (sexp_nullp(seq)) return seq;
sexp_gc_preserve1(ctx, vec);
vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq);
if (! sexp_vectorp(vec)) {
res = sexp_type_exception(ctx, "sort: not a vector", vec);
} else {
data = sexp_vector_data(vec);
len = sexp_vector_length(vec);
if (sexp_not(key) && sexp_basic_comparator(less)) {
sexp_qsort(ctx, data, 0, len-1);
if (sexp_opcodep(less) && sexp_opcode_inverse(less))
sexp_vector_nreverse(ctx, vec);
} else if (! (sexp_procedurep(less) || sexp_opcodep(less))) {
res = sexp_type_exception(ctx, "sort: not a procedure", less);
} else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) {
res = sexp_type_exception(ctx, "sort: not a procedure", less);
} else {
res = sexp_qsort_less(ctx, data, 0, len-1, less, key);
}
}
if (sexp_pairp(seq))
res = sexp_vector_copy_to_list(ctx, vec, seq);
else if (! sexp_exceptionp(res))
res = vec;
sexp_gc_release1(ctx);
return res;
}
sexp sexp_init_library (sexp ctx, sexp env) {
sexp_define_foreign_opt(ctx, env, "sort!", 3, sexp_sort_x, SEXP_FALSE);
return SEXP_VOID;
}

70
lib/srfi/95/sort.scm Normal file
View file

@ -0,0 +1,70 @@
;; sort.scm -- SRFI-95 sorting utilities
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (copy seq)
(if (vector? seq)
(let* ((len (vector-length seq))
(res (make-vector len)))
(do ((i (- len 1) (- i 1)))
((< i 0) res)
(vector-set! res i (vector-ref seq i))))
(map (lambda (x) x) seq)))
(define (sort seq . o)
(let ((less (and (pair? o) (car o)))
(key (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
(sort! (copy seq) less key)))
(define (sorted? seq less . o)
(let ((key (if (pair? o) (car o) (lambda (x) x))))
(cond
((vector? seq)
(let ((len (- (vector-length seq) 1)))
(let lp ((i 0))
(cond
((>= i len) #t)
((less (key (vector-ref seq (+ i 1))) (key (vector-ref seq i))) #f)
(else (lp (+ i 1)))))))
((null? seq)
#f)
(else
(let lp ((ls1 seq) (ls2 (cdr seq)))
(cond ((null? ls2) #t)
((less (key (car ls2)) (key (car ls1))) #f)
(else (lp ls2 (cdr ls2)))))))))
(define (merge! ls1 ls2 less . o)
(let ((key (if (pair? o) (car o) (lambda (x) x))))
(define (lp prev ls1 ls2 a b less key)
(cond
((less a b)
(if (null? (cdr ls1))
(set-cdr! ls1 ls2)
(lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key)))
(else
(set-cdr! prev ls2)
(if (null? (cdr ls2))
(set-cdr! ls2 ls1)
(lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key)))))
(cond
((null? ls1) ls2)
((null? ls2) ls1)
(else
(let ((a (key (car ls1)))
(b (key (car ls2))))
(cond
((less a b)
(if (null? (cdr ls1))
(set-cdr! ls1 ls2)
(lp ls1 (cdr ls1) ls2 (key (car (cdr ls1))) b less key))
ls1)
(else
(if (null? (cdr ls2))
(set-cdr! ls2 ls1)
(lp ls2 (cdr ls2) ls1 (key (car (cdr ls2))) a less key))
ls2)))))))
(define (merge ls1 ls2 less . o)
(let ((key (if (pair? o) (car o) (lambda (x) x))))
(merge! (copy ls1) (copy ls2) less key)))

5
lib/srfi/98.module Normal file
View file

@ -0,0 +1,5 @@
(define-module (srfi 98)
(export get-environment-variable get-environment-variables)
(include-shared "98/env"))

48
lib/srfi/98/env.c Normal file
View file

@ -0,0 +1,48 @@
/* env.c -- SRFI-98 environment interface */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#ifdef __APPLE__
#include <crt_externs.h>
#define environ (*_NSGetEnviron())
#else
extern char **environ;
#endif
#include <chibi/eval.h>
sexp sexp_get_environment_variable (sexp ctx, sexp str) {
char *cstr;
if (! sexp_stringp(str))
return sexp_type_exception(ctx, "get-environment-variable: not a string", str);
cstr = getenv(sexp_string_data(str));
return cstr ? sexp_c_string(ctx, cstr, -1) : SEXP_FALSE;
}
sexp sexp_get_environment_variables (sexp ctx) {
int i;
char **env, *cname, *cval;
sexp_gc_var3(res, name, val);
sexp_gc_preserve3(ctx, res, name, val);
res = SEXP_NULL;
env = environ;
for (i=0; env[i]; i++) {
cname = env[i];
cval = strchr(cname, '=');
if (cval) {
name = sexp_c_string(ctx, cname, cval-cname);
val = sexp_c_string(ctx, cval+1, -1);
val = sexp_cons(ctx, name, val);
res = sexp_cons(ctx, val, res);
}
}
sexp_gc_release3(ctx);
return res;
}
sexp sexp_init_library (sexp ctx, sexp env) {
sexp_define_foreign(ctx, env, "get-environment-variable", 1, sexp_get_environment_variable);
sexp_define_foreign(ctx, env, "get-environment-variables", 0, sexp_get_environment_variables);
return SEXP_VOID;
}

193
main.c Normal file
View file

@ -0,0 +1,193 @@
/* main.c -- chibi-scheme command-line app */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include "chibi/eval.h"
#define sexp_argv_symbol "*command-line-arguments*"
#define sexp_argv_proc "(define (command-line-arguments) "sexp_argv_symbol")"
#define sexp_import_prefix "(import ("
#define sexp_import_suffix "))"
#ifdef PLAN9
#define exit_failure() exits("ERROR")
#else
#define exit_failure() exit(70)
#endif
static void repl (sexp ctx) {
sexp in, out, err;
sexp_gc_var4(obj, tmp, res, env);
sexp_gc_preserve4(ctx, obj, tmp, res, env);
env = sexp_context_env(ctx);
sexp_context_tracep(ctx) = 1;
in = sexp_eval_string(ctx, "(current-input-port)", env);
out = sexp_eval_string(ctx, "(current-output-port)", env);
err = sexp_eval_string(ctx, "(current-error-port)", env);
sexp_port_sourcep(in) = 1;
while (1) {
sexp_write_string(ctx, "> ", out);
sexp_flush(ctx, out);
obj = sexp_read(ctx, in);
if (obj == SEXP_EOF)
break;
if (sexp_exceptionp(obj)) {
sexp_print_exception(ctx, obj, err);
} else {
tmp = sexp_env_bindings(env);
sexp_context_top(ctx) = 0;
res = sexp_eval(ctx, obj, env);
if (sexp_exceptionp(res)) {
sexp_print_exception(ctx, res, err);
} else {
#if SEXP_USE_WARN_UNDEFS
sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, err);
#endif
if (res != SEXP_VOID) {
sexp_write(ctx, res, out);
sexp_write_char(ctx, '\n', out);
}
}
}
}
sexp_gc_release4(ctx);
}
static sexp check_exception (sexp ctx, sexp res) {
sexp err;
if (res && sexp_exceptionp(res)) {
err = sexp_current_error_port(ctx);
if (! sexp_oportp(err))
err = sexp_make_output_port(ctx, stderr, SEXP_FALSE);
sexp_print_exception(ctx, res, err);
exit_failure();
}
return res;
}
#define init_context() if (! ctx) do { \
ctx = sexp_make_eval_context(NULL, NULL, NULL, heap_size); \
env = sexp_context_env(ctx); \
sexp_gc_preserve2(ctx, tmp, args); \
} while (0)
#define load_init() if (! init_loaded++) do { \
init_context(); \
check_exception(ctx, sexp_load_standard_env(ctx, env, SEXP_FIVE)); \
} while (0)
void run_main (int argc, char **argv) {
char *arg, *impmod, *p;
sexp env, out=SEXP_FALSE, res=SEXP_VOID, ctx=NULL;
sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0;
sexp_uint_t heap_size=0;
sexp_gc_var2(tmp, args);
args = SEXP_NULL;
/* parse options */
for (i=1; i < argc && argv[i][0] == '-'; i++) {
switch (argv[i][1]) {
case 'e':
case 'p':
load_init();
print = (argv[i][1] == 'p');
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
res = check_exception(ctx, sexp_read_from_string(ctx, arg));
res = check_exception(ctx, sexp_eval(ctx, res, env));
if (print) {
if (! sexp_oportp(out))
out = sexp_eval_string(ctx, "(current-output-port)", env);
sexp_write(ctx, res, out);
sexp_write_char(ctx, '\n', out);
}
quit = 1;
i++;
break;
case 'l':
load_init();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_exception(ctx, sexp_load_module_file(ctx, argv[++i], env));
break;
case 'm':
load_init();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
len = strlen(arg)+strlen(sexp_import_prefix)+strlen(sexp_import_suffix);
impmod = (char*) malloc(len+1);
strcpy(impmod, sexp_import_prefix);
strcpy(impmod+strlen(sexp_import_prefix), arg);
strcpy(impmod+len-+strlen(sexp_import_suffix), sexp_import_suffix);
impmod[len] = '\0';
for (p=impmod; *p; p++)
if (*p == '.') *p=' ';
check_exception(ctx, sexp_eval_string(ctx, impmod, env));
free(impmod);
break;
case 'q':
init_context();
if (! init_loaded++) sexp_load_standard_parameters(ctx, env);
break;
case 'A':
init_context();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE);
break;
case 'I':
init_context();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE);
break;
case '-':
i++;
goto done_options;
case 'h':
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
heap_size = atol(arg);
len = strlen(arg);
if (heap_size && isalpha(arg[len-1])) {
switch (tolower(arg[len-1])) {
case 'k': heap_size *= 1024; break;
case 'm': heap_size *= (1024*1024); break;
}
}
break;
case 'V':
printf("chibi-scheme 0.3\n");
return;
default:
fprintf(stderr, "unknown option: %s\n", argv[i]);
exit_failure();
}
}
done_options:
if (! quit) {
load_init();
if (i < argc)
for (j=argc-1; j>i; j--)
args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args);
else
args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args);
sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol), args);
sexp_eval_string(ctx, sexp_argv_proc, env);
if (i < argc) { /* script usage */
check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env));
tmp = sexp_intern(ctx, "main");
tmp = sexp_env_ref(env, tmp, SEXP_FALSE);
if (sexp_procedurep(tmp)) {
args = sexp_list1(ctx, args);
check_exception(ctx, sexp_apply(ctx, tmp, args));
}
} else {
repl(ctx);
}
}
sexp_gc_release2(ctx);
}
int main (int argc, char **argv) {
sexp_scheme_init();
run_main(argc, argv);
return 0;
}

26
mkfile Normal file
View file

@ -0,0 +1,26 @@
</$objtype/mkfile
BIN=/$objtype/bin
TARG=chibi-scheme
MODDIR=/sys/lib/chibi-scheme
CPPFLAGS= -Iinclude -DPLAN9 '-DSEXP_USE_STRING_STREAMS=0' '-DSEXP_USE_DEBUG=0' '-DSEXP_USE_MODULES=0'
CFLAGS= -p $CPPFLAGS
OFILES=sexp.$O eval.$O main.$O
HFILES=include/chibi/sexp.h include/chibi/eval.h include/chibi/features.h include/chibi/install.h
</sys/src/cmd/mkone
include/chibi/install.h: mkfile
echo '#define sexp_default_module_dir "'$MODDIR'"' > include/chibi/install.h
echo '#define sexp_platform "plan9"' >> include/chibi/install.h
install:V: $BIN/$TARG
test -d $MODDIR || mkdir -p $MODDIR
cp -r lib/* $MODDIR/
test:V:
./$O.out tests/r5rs-tests.scm
sexp.c:N: gc.c opt/bignum.c

153
opcodes.c Normal file
View file

@ -0,0 +1,153 @@
#define _OP(c,o,n,m,t,u,i,s,d,f) \
{.tag=SEXP_OPCODE, \
.value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}}
#define _FN(o,n,m,t,u,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f)
#define _FN0(s, d, f) _FN(SEXP_OP_FCALL0, 0, 0, 0, 0, s, d, f)
#define _FN1(t, s, d, f) _FN(SEXP_OP_FCALL1, 1, 0, t, 0, s, d, f)
#define _FN1OPT(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 1, t, u, s, d, f)
#define _FN1OPTP(t, s, d, f) _FN(SEXP_OP_FCALL1, 0, 3, t, 0, s, d, f)
#define _FN2(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 2, 0, t, u, s, d, f)
#define _FN2OPT(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 1, t, u, s, d, f)
#define _FN2OPTP(t, u, s, d, f) _FN(SEXP_OP_FCALL2, 1, 3, t, u, s, d, f)
#define _FN3(t, u, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, t, u, s, d, f)
#define _FN4(t, u, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, t, u, s, d, f)
#define _FN5(t, u, s, d, f) _FN(SEXP_OP_FCALL5, 5, 0, t, u, s, d, f)
#define _FN6(t, u, s, d, f) _FN(SEXP_OP_FCALL6, 6, 0, t, u, s, d, f)
#define _PARAM(n, a, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_NOOP, 0, 3, t, 0, 0, n, a, 0)
static struct sexp_struct opcodes[] = {
_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL),
_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL),
_OP(SEXP_OPC_ACCESSOR, SEXP_OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL),
_OP(SEXP_OPC_ACCESSOR, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL),
_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL),
_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL),
_OP(SEXP_OPC_ACCESSOR, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL),
_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL),
_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL),
_OP(SEXP_OPC_ACCESSOR, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL),
_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_fixnum(0), NULL),
_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_fixnum(1), NULL),
_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_SUB, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_NEGATIVE, "-", 0, NULL),
_OP(SEXP_OPC_ARITHMETIC_INV, SEXP_OP_DIV, 0, 1, SEXP_FIXNUM, 0, SEXP_OP_INVERSE, "/", 0, NULL),
_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL),
_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL),
_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL),
_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL),
_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LT, 2, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL),
_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_LE, 2, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL),
_OP(SEXP_OPC_ARITHMETIC_CMP, SEXP_OP_EQN, 2, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL),
_OP(SEXP_OPC_PREDICATE, SEXP_OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL),
_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL),
_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL),
_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL),
_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP, 1, 0, 0, 0, 0, "fixnum?", NULL, 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "pair?", sexp_make_fixnum(SEXP_PAIR), 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "string?", sexp_make_fixnum(SEXP_STRING), 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "vector?", sexp_make_fixnum(SEXP_VECTOR), 0),
#if SEXP_USE_IMMEDIATE_FLONUMS
_FN1(0, "flonum?", 0, sexp_flonum_predicate),
#else
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", sexp_make_fixnum(SEXP_FLONUM), 0),
#endif
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "bignum?", sexp_make_fixnum(SEXP_BIGNUM), 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "closure?", sexp_make_fixnum(SEXP_PROCEDURE), 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", sexp_make_fixnum(SEXP_OPCODE), 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", sexp_make_fixnum(SEXP_IPORT), 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixnum(SEXP_OPORT), 0),
_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "%call/cc", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL),
_OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL),
_OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL),
_OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL),
_OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL),
_FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read),
_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write),
_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display),
_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output),
_FN2(0, 0, "equal?", 0, sexp_equalp),
_FN1(0, "list?", 0, sexp_listp),
_FN1(0, "identifier?", 0, sexp_identifierp),
_FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr),
_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq),
_FN1(SEXP_PAIR, "length", 0, sexp_length),
_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse),
_FN1(SEXP_PAIR, "reverse!", 0, sexp_nreverse),
_FN2(SEXP_PAIR, SEXP_PAIR, "append2", 0, sexp_append2),
_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector),
_FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file),
_FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file),
_FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port),
_FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port),
_FN0("make-environment", 0, sexp_make_env),
_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env),
_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env),
_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval),
_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load),
_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy),
_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception),
_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func),
_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string),
_FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp),
_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring),
_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol),
_FN2OPT(SEXP_PAIR, SEXP_STRING, "string-concatenate", SEXP_FALSE, sexp_string_concatenate),
_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq),
_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq),
_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo),
_FN1(0, "strip-syntactic-closures", 0, sexp_strip_synclos),
_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT),
_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT),
_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT),
_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE),
_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV),
_FN0("open-output-string", 0, sexp_make_output_string_port),
_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port),
_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string),
#if SEXP_USE_MATH
_FN1(0, "exp", 0, sexp_exp),
_FN1(0, "log", 0, sexp_log),
_FN1(0, "sin", 0, sexp_sin),
_FN1(0, "cos", 0, sexp_cos),
_FN1(0, "tan", 0, sexp_tan),
_FN1(0, "asin", 0, sexp_asin),
_FN1(0, "acos", 0, sexp_acos),
_FN1(0, "atan1", 0, sexp_atan),
_FN1(0, "sqrt", 0, sexp_sqrt),
_FN1(0, "round", 0, sexp_round),
_FN1(0, "truncate", 0, sexp_trunc),
_FN1(0, "floor", 0, sexp_floor),
_FN1(0, "ceiling", 0, sexp_ceiling),
#endif
_FN2(0, 0, "expt", 0, sexp_expt),
#if SEXP_USE_TYPE_DEFS
_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type),
_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate),
_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor),
_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter),
_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter),
#endif
#if PLAN9
#include "opt/plan9-opcodes.c"
#endif
#if SEXP_USE_MODULES
_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports),
_FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op),
_FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op),
_FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory),
#endif
};

751
opt/bignum.c Normal file
View file

@ -0,0 +1,751 @@
/* bignum.c -- bignum support */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#define SEXP_INIT_BIGNUM_SIZE 2
#define sexp_negate(x) \
if (sexp_bignump(x)) \
sexp_bignum_sign(x) = -sexp_bignum_sign(x); \
else if (sexp_fixnump(x)) \
x = sexp_fx_neg(x);
sexp sexp_make_bignum (sexp ctx, sexp_uint_t len) {
sexp_uint_t size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t);
sexp res = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM);
sexp_bignum_length(res) = len;
sexp_bignum_sign(res) = 1;
return res;
}
sexp sexp_fixnum_to_bignum (sexp ctx, sexp a) {
sexp res = sexp_make_bignum(ctx, 1);
sexp_bignum_data(res)[0] = sexp_unbox_fixnum(sexp_fx_abs(a));
sexp_bignum_sign(res) = sexp_fx_sign(a);
return res;
}
sexp sexp_make_integer (sexp ctx, sexp_lsint_t x) {
sexp res;
if ((SEXP_MIN_FIXNUM < x) && (x < SEXP_MAX_FIXNUM)) {
res = sexp_make_fixnum(x);
} else {
res = sexp_make_bignum(ctx, 1);
if (x < 0) {
sexp_bignum_sign(res) = -1;
sexp_bignum_data(res)[0] = -x;
} else {
sexp_bignum_sign(res) = 1;
sexp_bignum_data(res)[0] = x;
}
}
return res;
}
sexp sexp_make_unsigned_integer (sexp ctx, sexp_luint_t x) {
sexp res;
if (x < SEXP_MAX_FIXNUM) {
res = sexp_make_fixnum(x);
} else {
res = sexp_make_bignum(ctx, 1);
sexp_bignum_sign(res) = 1;
sexp_bignum_data(res)[0] = x;
}
return res;
}
#define double_trunc_10s_digit(f) (trunc((f)/10.0)*10.0)
#define double_10s_digit(f) ((f)-double_trunc_10s_digit(f))
sexp sexp_double_to_bignum (sexp ctx, double f) {
int sign;
sexp_gc_var3(res, scale, tmp);
sexp_gc_preserve3(ctx, res, scale, tmp);
res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0));
scale = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1));
sign = (f < 0 ? -1 : 1);
for (f=fabs(f); f >= 1.0; f=trunc(f/10)) {
tmp = sexp_bignum_fxmul(ctx, NULL, scale, double_10s_digit(f), 0);
res = sexp_bignum_add(ctx, res, res, tmp);
scale = sexp_bignum_fxmul(ctx, NULL, scale, 10, 0);
}
sexp_bignum_sign(res) = sign;
sexp_gc_release3(ctx);
return res;
}
sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len0) {
sexp_uint_t len = (len0 > 0) ? len0 : sexp_bignum_length(a), size;
size = sexp_sizeof(bignum) + len*sizeof(sexp_uint_t);
if (! dst || sexp_bignum_length(dst) < len) {
dst = sexp_alloc_tagged(ctx, size, SEXP_BIGNUM);
memcpy(dst, a, size);
sexp_bignum_length(dst) = len;
} else {
memset(dst->value.bignum.data, 0,
sexp_bignum_length(dst)*sizeof(sexp_uint_t));
memcpy(dst->value.bignum.data, a->value.bignum.data,
sexp_bignum_length(a)*sizeof(sexp_uint_t));
}
return dst;
}
int sexp_bignum_zerop (sexp a) {
int i;
sexp_uint_t *data = sexp_bignum_data(a);
for (i=sexp_bignum_length(a)-1; i>=0; i--)
if (data[i])
return 0;
return 1;
}
sexp_uint_t sexp_bignum_hi (sexp a) {
sexp_uint_t i=sexp_bignum_length(a)-1;
while ((i>0) && ! sexp_bignum_data(a)[i])
i--;
return i+1;
}
sexp_sint_t sexp_bignum_compare_abs (sexp a, sexp b) {
int ai=sexp_bignum_hi(a), bi=sexp_bignum_hi(b);
sexp_uint_t *adata=sexp_bignum_data(a), *bdata=sexp_bignum_data(b);
if (ai != bi)
return ai - bi;
for (--ai; ai >= 0; ai--) {
if (adata[ai] > bdata[ai])
return 1;
else if (adata[ai] < bdata[ai])
return -1;
}
return 0;
}
sexp_sint_t sexp_bignum_compare (sexp a, sexp b) {
if (sexp_bignum_sign(a) != sexp_bignum_sign(b))
return sexp_bignum_sign(a);
return sexp_bignum_compare_abs(a, b);
}
sexp sexp_bignum_normalize (sexp a) {
sexp_uint_t *data;
if ((! sexp_bignump(a)) || (sexp_bignum_hi(a)>1))
return a;
data = sexp_bignum_data(a);
if ((data[0] > SEXP_MAX_FIXNUM)
&& ! ((sexp_bignum_sign(a) == -1) && (data[0] == SEXP_MAX_FIXNUM+1)))
return a;
return sexp_make_fixnum((sexp_sint_t)data[0] * sexp_bignum_sign(a));
}
double sexp_bignum_to_double (sexp a) {
double res = 0;
sexp_uint_t i, *data=sexp_bignum_data(a);
for (i=0; i<sexp_bignum_length(a); i++)
res = res * ((double)SEXP_UINT_T_MAX+1) + data[i];
return res;
}
sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b) {
sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a),
carry=b, i=0, n;
do { n = data[i];
data[i] += carry;
carry = (n > (SEXP_UINT_T_MAX - carry));
} while (++i<len && carry);
if (carry) {
a = sexp_copy_bignum(ctx, NULL, a, len+1);
sexp_bignum_data(a)[len] = 1;
}
return a;
}
sexp sexp_bignum_fxsub (sexp ctx, sexp a, sexp_uint_t b) {
sexp_uint_t *data=sexp_bignum_data(a), borrow, i=0, n;
for (borrow=b; borrow; i++) {
n = data[i];
data[i] -= borrow;
borrow = (n < borrow);
}
return a;
}
sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset) {
sexp_uint_t len=sexp_bignum_length(a), *data, *adata=sexp_bignum_data(a),
carry=0, i;
sexp_luint_t n;
if ((! d) || (sexp_bignum_length(d)+offset < len))
d = sexp_make_bignum(ctx, len);
data = sexp_bignum_data(d);
for (i=0; i<len; i++) {
n = (sexp_luint_t)adata[i]*b + carry;
data[i+offset] = (sexp_uint_t)n;
carry = n >> (sizeof(sexp_uint_t)*8);
}
if (carry) {
if (sexp_bignum_length(d)+offset <= len)
d = sexp_copy_bignum(ctx, NULL, d, len+offset+1);
sexp_bignum_data(d)[len+offset] = carry;
}
return d;
}
sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset) {
sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, r=0;
int i;
sexp_luint_t n = 0;
for (i=len-1; i>=offset; i--) {
n = (n << sizeof(sexp_uint_t)*8) + data[i];
q = n / b;
r = n - (sexp_luint_t)q * b;
data[i] = q;
n = r;
}
return r;
}
sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init,
char sign, sexp_uint_t base) {
int c, digit;
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_make_bignum(ctx, SEXP_INIT_BIGNUM_SIZE);
sexp_bignum_sign(res) = sign;
sexp_bignum_data(res)[0] = init;
for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) {
digit = digit_value(c);
if ((digit < 0) || (digit >= base))
break;
res = sexp_bignum_fxmul(ctx, res, res, base, 0);
res = sexp_bignum_fxadd(ctx, res, digit);
}
if (c=='.' || c=='e' || c=='E') {
if (base != 10)
res = sexp_read_error(ctx, "found non-base 10 float", SEXP_NULL, in);
if (c!='.') sexp_push_char(ctx, c, in);
res = sexp_read_float_tail(ctx, in, sexp_bignum_to_double(res), (sign==-1));
} else if ((c!=EOF) && ! is_separator(c)) {
res = sexp_read_error(ctx, "invalid numeric syntax",
sexp_make_character(c), in);
}
sexp_push_char(ctx, c, in);
sexp_gc_release1(ctx);
return sexp_bignum_normalize(res);
}
static int log2i(int v) {
int i;
for (i = 0; i < sizeof(v)*8; i++)
if ((1<<(i+1)) > v)
break;
return i;
}
sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base) {
int i, str_len, lg_base = log2i(base);
char *data;
sexp_gc_var2(b, str);
sexp_gc_preserve2(ctx, b, str);
b = sexp_copy_bignum(ctx, NULL, a, 0);
sexp_bignum_sign(b) = 1;
i = str_len = (sexp_bignum_length(b)*sizeof(sexp_uint_t)*8 + lg_base - 1)
/ lg_base + 1;
str = sexp_make_string(ctx, sexp_make_fixnum(str_len),
sexp_make_character(' '));
data = sexp_string_data(str);
while (! sexp_bignum_zerop(b))
data[--i] = hex_digit(sexp_bignum_fxdiv(ctx, b, base, 0));
if (i == str_len)
data[--i] = '0';
else if (sexp_bignum_sign(a) == -1)
data[--i] = '-';
sexp_write_string(ctx, data + i, out);
sexp_gc_release2(ctx);
return SEXP_VOID;
}
/****************** bignum arithmetic *************************/
sexp sexp_bignum_add_fixnum (sexp ctx, sexp a, sexp b) {
sexp_gc_var1(c);
sexp_gc_preserve1(ctx, c);
c = sexp_copy_bignum(ctx, NULL, a, 0);
if (sexp_bignum_sign(c) == sexp_fx_sign(b))
c = sexp_bignum_fxadd(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b)));
else
c = sexp_bignum_fxsub(ctx, c, sexp_unbox_fixnum(sexp_fx_abs(b)));
sexp_gc_release1(ctx);
return c;
}
sexp sexp_bignum_sub_digits (sexp ctx, sexp dst, sexp a, sexp b) {
sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b),
borrow=0, i, *adata, *bdata, *cdata;
sexp_gc_var1(c);
if ((alen < blen) || ((alen == blen) && (sexp_bignum_compare_abs(a, b) < 0)))
return sexp_bignum_sub_digits(ctx, dst, b, a);
sexp_gc_preserve1(ctx, c);
c = ((dst && sexp_bignum_hi(dst) >= alen)
? dst : sexp_copy_bignum(ctx, NULL, a, 0));
adata = sexp_bignum_data(a);
bdata = sexp_bignum_data(b);
cdata = sexp_bignum_data(c);
for (i=0; i<blen; i++) {
cdata[i] = adata[i] - bdata[i] - borrow;
borrow = (adata[i] < bdata[i] ? 1 : 0);
}
for ( ; borrow && (i<alen); i++) {
borrow = (cdata[i] == 0 ? 1 : 0);
cdata[i]--;
}
sexp_gc_release1(ctx);
return c;
}
sexp sexp_bignum_add_digits (sexp ctx, sexp dst, sexp a, sexp b) {
sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b),
carry=0, i, n, *adata, *bdata, *cdata;
sexp_gc_var1(c);
if (alen < blen) return sexp_bignum_add_digits(ctx, dst, b, a);
sexp_gc_preserve1(ctx, c);
c = ((dst && sexp_bignum_hi(dst) >= alen)
? dst : sexp_copy_bignum(ctx, NULL, a, 0));
adata = sexp_bignum_data(a);
bdata = sexp_bignum_data(b);
cdata = sexp_bignum_data(c);
for (i=0; i<blen; i++) {
n = adata[i];
cdata[i] = n + bdata[i] + carry;
carry = (n > (SEXP_UINT_T_MAX - bdata[i]) ? 1 : 0);
}
for ( ; carry && (i<alen); i++) {
carry = (cdata[i] == SEXP_UINT_T_MAX-1 ? 1 : 0);
cdata[i]++;
}
if (carry) {
c = sexp_copy_bignum(ctx, NULL, c, alen+1);
sexp_bignum_data(c)[alen] = 1;
}
sexp_gc_release1(ctx);
return c;
}
sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b) {
sexp res;
if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) {
res = sexp_bignum_add_digits(ctx, dst, a, b);
sexp_bignum_sign(res) = sexp_bignum_sign(a);
} else {
res = sexp_bignum_sub_digits(ctx, dst, a, b);
sexp_bignum_sign(res)
= sexp_bignum_sign(sexp_bignum_compare_abs(a, b) >= 0 ? a : b);
}
return res;
}
sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) {
sexp res;
if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) {
res = sexp_bignum_sub_digits(ctx, dst, a, b);
sexp_bignum_sign(res)
= (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a)
: -sexp_bignum_sign(a));
} else {
res = sexp_bignum_add_digits(ctx, dst, a, b);
sexp_bignum_sign(res) = sexp_bignum_sign(a);
}
return res;
}
sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b) {
sexp_uint_t alen=sexp_bignum_hi(a), blen=sexp_bignum_hi(b), i,
*bdata=sexp_bignum_data(b);
sexp_gc_var2(c, d);
if (alen < blen) return sexp_bignum_mul(ctx, dst, b, a);
sexp_gc_preserve2(ctx, c, d);
c = (dst ? dst : sexp_make_bignum(ctx, alen+blen+1));
d = sexp_make_bignum(ctx, alen+blen+1);
for (i=0; i<blen; i++) {
d = sexp_bignum_fxmul(ctx, d, a, bdata[i], i);
c = sexp_bignum_add_digits(ctx, NULL, c, d);
sexp_bignum_data(d)[i] = 0;
}
sexp_bignum_sign(c) = sexp_bignum_sign(a) * sexp_bignum_sign(b);
sexp_gc_release2(ctx);
return c;
}
static sexp sexp_bignum_double (sexp ctx, sexp a) {
return sexp_bignum_fxmul(ctx, NULL, a, 2, 0);
}
static sexp quot_step (sexp ctx, sexp *rem, sexp a, sexp b, sexp k, sexp i) {
sexp res;
sexp_gc_var5(x, prod, diff, k2, i2);
if (sexp_bignum_compare(k, a) > 0) {
*rem = a;
return sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(0));
}
sexp_gc_preserve5(ctx, x, prod, diff, k2, i2);
k2 = sexp_bignum_double(ctx, k);
i2 = sexp_bignum_double(ctx, i);
x = quot_step(ctx, rem, a, b, k2, i2);
prod = sexp_bignum_mul(ctx, NULL, x, b);
diff = sexp_bignum_sub_digits(ctx, NULL, a, prod);
if (sexp_bignum_compare(diff, k) >= 0) {
*rem = sexp_bignum_sub_digits(ctx, NULL, diff, k);
res = sexp_bignum_add_digits(ctx, NULL, x, i);
} else {
*rem = diff;
res = x;
}
sexp_gc_release5(ctx);
return res;
}
sexp sexp_bignum_quot_rem (sexp ctx, sexp *rem, sexp a, sexp b) {
sexp res;
sexp_gc_var4(k, i, a1, b1);
sexp_gc_preserve4(ctx, k, i, a1, b1);
a1 = sexp_copy_bignum(ctx, NULL, a, 0);
sexp_bignum_sign(a1) = 1;
b1 = sexp_copy_bignum(ctx, NULL, b, 0);
sexp_bignum_sign(b1) = 1;
k = sexp_copy_bignum(ctx, NULL, b1, 0);
i = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1));
res = quot_step(ctx, rem, a1, b1, k, i);
sexp_bignum_sign(res) = sexp_bignum_sign(a) * sexp_bignum_sign(b);
if (sexp_bignum_sign(a) < 0) {
sexp_negate(*rem);
}
sexp_gc_release4(ctx);
return res;
}
sexp sexp_bignum_quotient (sexp ctx, sexp a, sexp b) {
sexp res;
sexp_gc_var1(rem);
sexp_gc_preserve1(ctx, rem);
res = sexp_bignum_quot_rem(ctx, &rem, a, b);
sexp_gc_release1(ctx);
return res;
}
sexp sexp_bignum_remainder (sexp ctx, sexp a, sexp b) {
sexp rem;
sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */
return rem;
}
sexp sexp_bignum_expt (sexp ctx, sexp a, sexp b) {
sexp_sint_t e = sexp_unbox_fixnum(sexp_fx_abs(b));
sexp_gc_var2(res, acc);
sexp_gc_preserve2(ctx, res, acc);
res = sexp_fixnum_to_bignum(ctx, sexp_make_fixnum(1));
acc = sexp_copy_bignum(ctx, NULL, a, 0);
for (; e; e>>=1, acc=sexp_bignum_mul(ctx, NULL, acc, acc))
if (e & 1)
res = sexp_bignum_mul(ctx, NULL, res, acc);
sexp_gc_release2(ctx);
return res;
}
/****************** generic arithmetic ************************/
enum sexp_number_types {
SEXP_NUM_NOT = 0,
SEXP_NUM_FIX,
SEXP_NUM_FLO,
SEXP_NUM_BIG
};
enum sexp_number_combs {
SEXP_NUM_NOT_NOT = 0,
SEXP_NUM_NOT_FIX,
SEXP_NUM_NOT_FLO,
SEXP_NUM_NOT_BIG,
SEXP_NUM_FIX_NOT,
SEXP_NUM_FIX_FIX,
SEXP_NUM_FIX_FLO,
SEXP_NUM_FIX_BIG,
SEXP_NUM_FLO_NOT,
SEXP_NUM_FLO_FIX,
SEXP_NUM_FLO_FLO,
SEXP_NUM_FLO_BIG,
SEXP_NUM_BIG_NOT,
SEXP_NUM_BIG_FIX,
SEXP_NUM_BIG_FLO,
SEXP_NUM_BIG_BIG
};
static int sexp_number_types[] =
{0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0, 0};
static int sexp_number_type (sexp a) {
return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)&15]
#if SEXP_USE_IMMEDIATE_FLONUMS
: sexp_flonump(a) ? 2
#endif
: sexp_fixnump(a);
}
sexp sexp_add (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b), t;
sexp r=SEXP_VOID;
if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;}
switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
r = sexp_type_exception(ctx, "+: not a number", a);
break;
case SEXP_NUM_FIX_FIX:
r = sexp_fx_add(a, b); /* VM catches this case */
break;
case SEXP_NUM_FIX_FLO:
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)+sexp_flonum_value(b));
break;
case SEXP_NUM_FIX_BIG:
r = sexp_bignum_normalize(sexp_bignum_add_fixnum(ctx, b, a));
break;
case SEXP_NUM_FLO_FLO:
r = sexp_fp_add(ctx, a, b);
break;
case SEXP_NUM_FLO_BIG:
r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_bignum_to_double(b));
break;
case SEXP_NUM_BIG_BIG:
r = sexp_bignum_normalize(sexp_bignum_add(ctx, NULL, b, a));
break;
}
return r;
}
sexp sexp_sub (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b);
sexp r=SEXP_VOID;
switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
r = sexp_type_exception(ctx, "-: not a number", a);
break;
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
r = sexp_type_exception(ctx, "-: not a number", b);
break;
case SEXP_NUM_FIX_FIX:
r = sexp_fx_sub(a, b); /* VM catches this case */
break;
case SEXP_NUM_FIX_FLO:
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)-sexp_flonum_value(b));
break;
case SEXP_NUM_FIX_BIG:
r = sexp_bignum_sub(ctx, NULL, b, sexp_fixnum_to_bignum(ctx, a));
sexp_negate(r);
r = sexp_bignum_normalize(r);
break;
case SEXP_NUM_FLO_FIX:
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)+sexp_flonum_value(a));
break;
case SEXP_NUM_FLO_FLO:
r = sexp_fp_sub(ctx, a, b);
break;
case SEXP_NUM_FLO_BIG:
r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_bignum_to_double(b));
break;
case SEXP_NUM_BIG_FIX:
r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, sexp_fixnum_to_bignum(ctx, b)));
break;
case SEXP_NUM_BIG_FLO:
r = sexp_make_flonum(ctx, sexp_flonum_value(b) - sexp_bignum_to_double(a));
case SEXP_NUM_BIG_BIG:
r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b));
break;
}
return r;
}
sexp sexp_mul (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b), t;
sexp r=SEXP_VOID;
if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;}
switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
r = sexp_type_exception(ctx, "*: not a number", a);
break;
case SEXP_NUM_FIX_FIX:
r = sexp_fx_mul(a, b);
break;
case SEXP_NUM_FIX_FLO:
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)*sexp_flonum_value(b));
break;
case SEXP_NUM_FIX_BIG:
r = sexp_bignum_fxmul(ctx, NULL, b, sexp_unbox_fixnum(sexp_fx_abs(a)), 0);
sexp_bignum_sign(r) = sexp_fx_sign(a) * sexp_bignum_sign(b);
break;
case SEXP_NUM_FLO_FLO:
r = sexp_fp_mul(ctx, a, b);
break;
case SEXP_NUM_FLO_BIG:
r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_bignum_to_double(b));
break;
case SEXP_NUM_BIG_BIG:
r = sexp_bignum_mul(ctx, NULL, a, b);
break;
}
return r;
}
sexp sexp_div (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b);
double f;
sexp r=SEXP_VOID, rem;
switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
r = sexp_type_exception(ctx, "/: not a number", a);
break;
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
r = sexp_type_exception(ctx, "/: not a number", b);
break;
case SEXP_NUM_FIX_FIX:
f = sexp_fixnum_to_double(a) / sexp_fixnum_to_double(b);
r = ((f == trunc(f)) ? sexp_make_fixnum((sexp_sint_t)f)
: sexp_make_flonum(ctx, f));
break;
case SEXP_NUM_FIX_FLO:
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_flonum_value(b));
break;
case SEXP_NUM_FIX_BIG:
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b));
break;
case SEXP_NUM_FLO_FIX:
r = sexp_make_flonum(ctx, sexp_fixnum_to_double(b)/sexp_flonum_value(a));
break;
case SEXP_NUM_FLO_FLO:
r = sexp_fp_div(ctx, a, b);
break;
case SEXP_NUM_FLO_BIG:
r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_bignum_to_double(b));
break;
case SEXP_NUM_BIG_FIX:
b = sexp_fixnum_to_bignum(ctx, b);
/* ... FALLTHROUGH ... */
case SEXP_NUM_BIG_BIG:
r = sexp_bignum_quot_rem(ctx, &rem, a, b);
if (sexp_bignum_normalize(rem) != sexp_make_fixnum(0))
r = sexp_make_flonum(ctx, sexp_bignum_to_double(a)
/ sexp_fixnum_to_double(b));
else
r = sexp_bignum_normalize(r);
break;
case SEXP_NUM_BIG_FLO:
r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b));
break;
}
return r;
}
sexp sexp_quotient (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b);
sexp r=SEXP_VOID;
switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
r = sexp_type_exception(ctx, "quotient: not a number", a);
break;
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
r = sexp_type_exception(ctx, "quotient: not a number", b);
break;
case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG:
r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", a);
break;
case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO:
r = sexp_type_exception(ctx, "quotient: can't take quotient of inexact", b);
break;
case SEXP_NUM_FIX_FIX:
r = sexp_fx_div(a, b);
break;
case SEXP_NUM_FIX_BIG:
r = sexp_make_fixnum(0);
break;
case SEXP_NUM_BIG_FIX:
b = sexp_fixnum_to_bignum(ctx, b);
/* ... FALLTHROUGH ... */
case SEXP_NUM_BIG_BIG:
r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b));
break;
}
return r;
}
sexp sexp_remainder (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b);
sexp r=SEXP_VOID;
switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
r = sexp_type_exception(ctx, "remainder: not a number", a);
break;
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
r = sexp_type_exception(ctx, "remainder: not a number", b);
break;
case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG:
r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", a);
break;
case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO:
r = sexp_type_exception(ctx, "remainder: can't take quotient of inexact", b);
break;
case SEXP_NUM_FIX_FIX:
r = sexp_fx_rem(a, b);
break;
case SEXP_NUM_FIX_BIG:
r = a;
break;
case SEXP_NUM_BIG_FIX:
b = sexp_fixnum_to_bignum(ctx, b);
/* ... FALLTHROUGH ... */
case SEXP_NUM_BIG_BIG:
r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b));
break;
}
return r;
}
sexp sexp_compare (sexp ctx, sexp a, sexp b) {
int at=sexp_number_type(a), bt=sexp_number_type(b);
sexp r=SEXP_VOID;
double f;
if (at > bt) {
r = sexp_compare(ctx, b, a);
sexp_negate(r);
} else {
switch ((at << 2) + bt) {
case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX:
case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG:
r = sexp_type_exception(ctx, "compare: not a number", a);
break;
case SEXP_NUM_FIX_FIX:
r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b));
break;
case SEXP_NUM_FIX_FLO:
f = sexp_fixnum_to_double(a) - sexp_flonum_value(b);
r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1);
break;
case SEXP_NUM_FIX_BIG:
r = sexp_make_fixnum(-1);
break;
case SEXP_NUM_FLO_FLO:
f = sexp_flonum_value(a) - sexp_flonum_value(b);
r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1);
break;
case SEXP_NUM_FLO_BIG:
f = sexp_flonum_value(a) - sexp_bignum_to_double(b);
r = sexp_make_fixnum(f > 0.0 ? 1 : f == 0.0 ? 0 : -1);
break;
case SEXP_NUM_BIG_BIG:
r = sexp_make_fixnum(sexp_bignum_compare(a, b));
break;
}
}
return r;
}

19
opt/plan9-opcodes.c Normal file
View file

@ -0,0 +1,19 @@
_FN0("random-integer", 0, sexp_rand),
_FN1(SEXP_FIXNUM, "random-seed", 0, sexp_srand),
_FN0("current-directory", 0, sexp_getwd),
_FN0("current-user", 0, sexp_getuser),
_FN0("system-name", 0, sexp_sysname),
_FN1(SEXP_IPORT, "port-fileno", 0, sexp_fileno),
_FN2(SEXP_FIXNUM, SEXP_STRING, "fileno->port", 0, sexp_fdopen),
_FN0("fork", 0, sexp_fork),
_FN2(SEXP_STRING, SEXP_PAIR, "exec", 0, sexp_exec),
_FN1(SEXP_STRING, "exits", 0, sexp_exits),
_FN2(SEXP_FIXNUM, SEXP_FIXNUM, "dup", 0, sexp_dup),
_FN0("pipe", 0, sexp_pipe),
_FN1(SEXP_FIXNUM, "sleep", 0, sexp_sleep),
_FN1(SEXP_STRING, "getenv", 0, sexp_getenv),
_FN1(SEXP_STRING, "change-directory", 0, sexp_chdir),
_FN0("wait", 0, sexp_wait),
_FN2(SEXP_FIXNUM, SEXP_STRING, "post-note", 0, sexp_postnote),
_FN4(SEXP_PAIR, SEXP_STRING, "%postmountsrv", 0, sexp_postmountsrv),
_FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p),

351
opt/plan9.c Normal file
View file

@ -0,0 +1,351 @@
/* plan9.c -- extended Plan 9 system utils */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
sexp sexp_rand (sexp ctx) {
return sexp_make_fixnum(rand());
}
sexp sexp_srand (sexp ctx, sexp seed) {
srand(sexp_unbox_fixnum(seed));
return SEXP_VOID;
}
sexp sexp_file_exists_p (sexp ctx, sexp path) {
int res;
uchar statbuf[STATMAX];
if (! sexp_stringp(path))
return sexp_type_exception(ctx, "file-exists?: not a string", path);
res = stat(sexp_string_data(path), statbuf, sizeof(statbuf));
return (res < 0) ? SEXP_FALSE : SEXP_TRUE;
}
sexp sexp_fdopen (sexp ctx, sexp fd, sexp mode) {
FILE *f;
if (! sexp_integerp(fd))
return sexp_type_exception(ctx, "fdopen: not an integer", fd);
if (! sexp_stringp(mode))
return sexp_type_exception(ctx, "fdopen: not a mode string", mode);
f = fdopen(sexp_unbox_fixnum(fd), sexp_string_data(mode));
if (! f)
return sexp_user_exception(ctx, SEXP_FALSE, "fdopen failed", fd);
/* maybe use fd2path to get the name of the fd */
if (sexp_string_data(mode)[0] == 'w')
return sexp_make_output_port(ctx, f, SEXP_FALSE);
else
return sexp_make_input_port(ctx, f, SEXP_FALSE);
}
sexp sexp_fileno (sexp ctx, sexp port) {
if (! sexp_portp(port))
return sexp_type_exception(ctx, "fileno: not a port", port);
return sexp_make_fixnum(fileno(sexp_port_stream(port)));
}
sexp sexp_fork (sexp ctx) {
return sexp_make_fixnum(fork());
}
sexp sexp_exec (sexp ctx, sexp name, sexp args) {
int i, len = sexp_unbox_fixnum(sexp_length(ctx, args));
char **argv = malloc((len+1)*sizeof(char*));
for (i=0; i<len; i++, args=sexp_cdr(args))
argv[i] = sexp_string_data(sexp_car(args));
argv[len] = NULL;
exec(sexp_string_data(name), argv);
return SEXP_VOID; /* won't really return */
}
void sexp_exits (sexp ctx, sexp msg) {
exits(sexp_string_data(sexp_stringp(msg)
? msg : sexp_write_to_string(ctx, msg)));
}
sexp sexp_dup (sexp ctx, sexp oldfd, sexp newfd) {
return sexp_make_fixnum(dup(sexp_unbox_fixnum(oldfd),
sexp_unbox_fixnum(newfd)));
}
sexp sexp_pipe (sexp ctx) {
int fds[2];
pipe(fds);
return sexp_list2(ctx, sexp_make_fixnum(fds[0]), sexp_make_fixnum(fds[1]));
}
sexp sexp_sleep (sexp ctx, sexp msecs) {
if (! sexp_integerp(msecs))
return sexp_type_exception(ctx, "sleep: not an integer", msecs);
sleep(sexp_unbox_fixnum(msecs));
return SEXP_VOID;
}
sexp sexp_getenv (sexp ctx, sexp name) {
char *value;
if (! sexp_stringp(name))
return sexp_type_exception(ctx, "getenv: not a string", name);
value = getenv(sexp_string_data(name));
return ((! value) ? SEXP_FALSE : sexp_c_string(ctx, value, -1));
}
sexp sexp_getwd (sexp ctx) {
char buf[512];
getwd(buf, 512);
return sexp_c_string(ctx, buf, -1);
}
sexp sexp_chdir (sexp ctx, sexp path) {
if (! sexp_stringp(path))
return sexp_type_exception(ctx, "chdir: not a string", path);
chdir(sexp_string_data(path));
return SEXP_VOID;
}
sexp sexp_getuser (sexp ctx) {
return sexp_c_string(ctx, getuser(), -1);
}
sexp sexp_sysname (sexp ctx) {
return sexp_c_string(ctx, sysname(), -1);
}
sexp sexp_wait (sexp ctx) { /* just return (pid msg) */
Waitmsg *wmsg;
sexp res;
sexp_gc_var(ctx, msg, s_msg);
sexp_gc_preserve(ctx, msg, s_msg);
wmsg = wait();
msg = sexp_c_string(ctx, wmsg->msg, -1);
res = sexp_list2(ctx, sexp_make_fixnum(wmsg->pid), msg);
sexp_gc_release(ctx, msg, s_msg);
return res;
}
sexp sexp_postnote (sexp ctx, sexp pid, sexp note) {
if (! sexp_integerp(pid))
return sexp_type_exception(ctx, "postnote: not an integer", pid);
if (! sexp_stringp(note))
return sexp_type_exception(ctx, "postnote: not a string", note);
postnote(PNPROC, sexp_unbox_fixnum(pid), sexp_string_data(note));
return SEXP_VOID;
}
/**********************************************************************/
/* 9p interface */
typedef struct sexp_plan9_srv {
sexp context, auth, attach, walk, walk1, clone, open, create, remove,
read, write, stat, wstat, flush, destroyfid, destroyreq, end;
} *sexp_plan9_srv;
void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) {
s->context = ctx;
s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open
= s->create = s->remove = s->read = s->write = s->stat = s->wstat
= s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE;
for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) {
if (sexp_car(ls) == sexp_intern(ctx, "auth:")) {
s->auth = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "attach:")) {
s->attach = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "walk:")) {
s->walk = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "walk1:")) {
s->walk1 = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "clone:")) {
s->clone = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "open:")) {
s->open = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "create:")) {
s->create = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "remove:")) {
s->remove = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "read:")) {
s->read = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "write:")) {
s->write = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "stat:")) {
s->stat = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "wstat:")) {
s->wstat = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "flush:")) {
s->flush = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:")) {
s->destroyfid = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:")) {
s->destroyreq = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "end:")) {
s->end = sexp_cadr(ls);
}
}
}
void sexp_run_9p_handler (Req *r, sexp handler) {
sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux;
sexp ctx = s->context;
sexp_gc_var(ctx, ptr, s_ptr);
sexp_gc_var(ctx, args, s_args);
sexp_gc_preserve(ctx, ptr, s_ptr);
sexp_gc_preserve(ctx, args, s_args);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, SEXP_NULL);
sexp_apply(ctx, handler, args);
sexp_gc_release(ctx, ptr, s_ptr);
}
#define sexp_def_9p_handler(name, field) \
void name (Req *r) { \
sexp_run_9p_handler(r, ((sexp_plan9_srv)r->srv->aux)->field); \
}
sexp_def_9p_handler(sexp_9p_auth, auth)
sexp_def_9p_handler(sexp_9p_attach, attach)
sexp_def_9p_handler(sexp_9p_walk, walk)
sexp_def_9p_handler(sexp_9p_open, open)
sexp_def_9p_handler(sexp_9p_create, create)
sexp_def_9p_handler(sexp_9p_remove, remove)
sexp_def_9p_handler(sexp_9p_read, read)
sexp_def_9p_handler(sexp_9p_write, write)
sexp_def_9p_handler(sexp_9p_stat, stat)
sexp_def_9p_handler(sexp_9p_wstat, wstat)
sexp_def_9p_handler(sexp_9p_flush, flush)
char* sexp_9p_walk1 (Fid *fid, char *name, Qid *qid) {
sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux;
sexp res, ctx = s->context;
sexp_gc_var(ctx, ptr, s_ptr);
sexp_gc_var(ctx, args, s_args);
sexp_gc_preserve(ctx, ptr, s_ptr);
sexp_gc_preserve(ctx, args, s_args);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, qid, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, SEXP_NULL);
ptr = sexp_c_string(ctx, name, -1);
args = sexp_cons(ctx, ptr, args);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, args);
res = sexp_apply(ctx, s->walk1, args);
sexp_gc_release(ctx, ptr, s_ptr);
return sexp_stringp(res) ? sexp_string_data(res) : nil;
}
char* sexp_9p_clone (Fid *oldfid, Fid *newfid) {
sexp_plan9_srv s = (sexp_plan9_srv)oldfid->pool->srv->aux;
sexp res, ctx = s->context;
sexp_gc_var(ctx, ptr, s_ptr);
sexp_gc_var(ctx, args, s_args);
sexp_gc_preserve(ctx, ptr, s_ptr);
sexp_gc_preserve(ctx, args, s_args);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, oldfid, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, SEXP_NULL);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, newfid, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, args);
res = sexp_apply(ctx, s->clone, args);
sexp_gc_release(ctx, ptr, s_ptr);
return sexp_stringp(res) ? sexp_string_data(res) : nil;
}
void sexp_9p_destroyfid (Fid *fid) {
sexp_plan9_srv s = (sexp_plan9_srv)fid->pool->srv->aux;
sexp ctx = s->context;
sexp_gc_var(ctx, ptr, s_ptr);
sexp_gc_var(ctx, args, s_args);
sexp_gc_preserve(ctx, ptr, s_ptr);
sexp_gc_preserve(ctx, args, s_args);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, fid, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, SEXP_NULL);
sexp_apply(ctx, s->destroyfid, args);
sexp_gc_release(ctx, ptr, s_ptr);
}
void sexp_9p_destroyreq (Req *r) {
sexp_plan9_srv s = (sexp_plan9_srv)r->srv->aux;
sexp ctx = s->context;
sexp_gc_var(ctx, ptr, s_ptr);
sexp_gc_var(ctx, args, s_args);
sexp_gc_preserve(ctx, ptr, s_ptr);
sexp_gc_preserve(ctx, args, s_args);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, r, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, SEXP_NULL);
sexp_apply(ctx, s->destroyreq, args);
sexp_gc_release(ctx, ptr, s_ptr);
}
void sexp_9p_end (Srv *srv) {
sexp_plan9_srv s = (sexp_plan9_srv)srv->aux;
sexp ctx = s->context;
sexp_gc_var(ctx, ptr, s_ptr);
sexp_gc_var(ctx, args, s_args);
sexp_gc_preserve(ctx, ptr, s_ptr);
sexp_gc_preserve(ctx, args, s_args);
ptr = sexp_make_cpointer(ctx, SEXP_CPOINTER, srv, SEXP_FALSE, 0);
args = sexp_cons(ctx, ptr, SEXP_NULL);
sexp_apply(ctx, s->end, args);
sexp_gc_release(ctx, ptr, s_ptr);
}
sexp sexp_postmountsrv (sexp ctx, sexp ls, sexp name, sexp mtpt, sexp flags) {
Srv s;
struct sexp_plan9_srv p9s;
if (! sexp_listp(ctx, ls))
return sexp_type_exception(ctx, "postmountsrv: not a list", ls);
if (! sexp_stringp(name))
return sexp_type_exception(ctx, "postmountsrv: not a string", name);
if (! sexp_stringp(mtpt))
return sexp_type_exception(ctx, "postmountsrv: not a string", mtpt);
if (! sexp_integerp(flags))
return sexp_type_exception(ctx, "postmountsrv: not an integer", flags);
sexp_build_srv(ctx, &p9s, ls);
s.aux = &p9s;
s.auth = &sexp_9p_auth;
s.attach = &sexp_9p_attach;
s.walk = &sexp_9p_walk;
s.walk1 = &sexp_9p_walk1;
s.clone = &sexp_9p_clone;
s.open = &sexp_9p_open;
s.create = &sexp_9p_create;
s.remove = &sexp_9p_remove;
s.read = &sexp_9p_read;
s.write = &sexp_9p_write;
s.stat = &sexp_9p_stat;
s.wstat = &sexp_9p_wstat;
s.flush = &sexp_9p_flush;
s.destroyfid = &sexp_9p_destroyfid;
s.destroyreq = &sexp_9p_destroyreq;
s.end = &sexp_9p_end;
postmountsrv(&s, sexp_string_data(name), sexp_string_data(mtpt),
sexp_unbox_fixnum(flags));
return SEXP_UNDEF;
}
sexp sexp_9p_req_offset (sexp ctx, sexp req) {
return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.offset);
}
sexp sexp_9p_req_count (sexp ctx, sexp req) {
return sexp_make_integer(ctx, ((Req*)sexp_cpointer_value(req))->ifcall.count);
}
#if 0
sexp sexp_9p_req_path (sexp ctx, sexp req) {
return sexp_c_string(ctx, ((Req*)sexp_cpointer_value(req))->fid->qid.path, -1);
}
#endif
sexp sexp_9p_req_fid (sexp ctx, sexp req) {
return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->fid, SEXP_FALSE, 0);
}
sexp sexp_9p_req_newfid (sexp ctx, sexp req) {
return sexp_make_cpointer(ctx, SEXP_CPOINTER, ((Req*)sexp_cpointer_value(req))->newfid, SEXP_FALSE, 0);
}
sexp sexp_9p_respond (sexp ctx, sexp req, sexp err) {
char *cerr = sexp_stringp(err) ? sexp_string_data(err) : nil;
respond(sexp_cpointer_value(req), cerr);
return SEXP_VOID;
}
sexp sexp_9p_responderror (sexp ctx, sexp req) {
responderror(sexp_cpointer_value(req));
return SEXP_VOID;
}

128
opt/sexp-huff.c Normal file
View file

@ -0,0 +1,128 @@
{12, 0x0C00}, /* '\x00' */
{15, 0x0000}, /* '\x01' */
{15, 0x4000}, /* '\x02' */
{15, 0x2000}, /* '\x03' */
{15, 0x6000}, /* '\x04' */
{15, 0x0800}, /* '\x05' */
{15, 0x4800}, /* '\x06' */
{15, 0x2800}, /* '\x07' */
{15, 0x6800}, /* '\x08' */
{15, 0x1800}, /* '\x09' */
{15, 0x5800}, /* '\x0a' */
{15, 0x3800}, /* '\x0b' */
{15, 0x7800}, /* '\x0c' */
{15, 0x0100}, /* '\x0d' */
{15, 0x4100}, /* '\x0e' */
{15, 0x2100}, /* '\x0f' */
{15, 0x6100}, /* '\x10' */
{15, 0x1100}, /* '\x11' */
{15, 0x5100}, /* '\x12' */
{15, 0x3100}, /* '\x13' */
{15, 0x7100}, /* '\x14' */
{15, 0x0900}, /* '\x15' */
{15, 0x4900}, /* '\x16' */
{15, 0x2900}, /* '\x17' */
{15, 0x6900}, /* '\x18' */
{15, 0x1900}, /* '\x19' */
{15, 0x5900}, /* '\x1a' */
{15, 0x3900}, /* '\x1b' */
{15, 0x7900}, /* '\x1c' */
{15, 0x0500}, /* '\x1d' */
{15, 0x4500}, /* '\x1e' */
{15, 0x2500}, /* '\x1f' */
{15, 0x6500}, /* '\x20' */
{ 8, 0x0040}, /* '!' */
{15, 0x1500}, /* '"' */
{15, 0x5500}, /* '#' */
{15, 0x3500}, /* '$' */
{15, 0x7500}, /* '%' */
{15, 0x0D00}, /* '&' */
{15, 0x4D00}, /* '\'' */
{15, 0x2D00}, /* '(' */
{15, 0x6D00}, /* ')' */
{11, 0x0300}, /* '*' */
{10, 0x0180}, /* '+' */
{15, 0x1D00}, /* ',' */
{ 4, 0x000D}, /* '-' */
{15, 0x5D00}, /* '.' */
{10, 0x0380}, /* '/' */
{15, 0x3D00}, /* '0' */
{15, 0x7D00}, /* '1' */
{14, 0x0080}, /* '2' */
{14, 0x2080}, /* '3' */
{14, 0x1080}, /* '4' */
{14, 0x3080}, /* '5' */
{14, 0x0880}, /* '6' */
{14, 0x2880}, /* '7' */
{14, 0x1880}, /* '8' */
{14, 0x3880}, /* '9' */
{14, 0x0480}, /* ':' */
{14, 0x2480}, /* ';' */
{ 7, 0x0050}, /* '<' */
{ 7, 0x0042}, /* '=' */
{ 7, 0x0022}, /* '>' */
{ 5, 0x0009}, /* '?' */
{14, 0x1480}, /* '@' */
{14, 0x3480}, /* 'A' */
{14, 0x0C80}, /* 'B' */
{14, 0x2C80}, /* 'C' */
{14, 0x1C80}, /* 'D' */
{14, 0x3C80}, /* 'E' */
{14, 0x0280}, /* 'F' */
{14, 0x2280}, /* 'G' */
{14, 0x1280}, /* 'H' */
{14, 0x3280}, /* 'I' */
{14, 0x0A80}, /* 'J' */
{14, 0x2A80}, /* 'K' */
{14, 0x1A80}, /* 'L' */
{14, 0x3A80}, /* 'M' */
{14, 0x0680}, /* 'N' */
{14, 0x2680}, /* 'O' */
{14, 0x1680}, /* 'P' */
{14, 0x3680}, /* 'Q' */
{14, 0x0E80}, /* 'R' */
{14, 0x2E80}, /* 'S' */
{14, 0x1E80}, /* 'T' */
{14, 0x3E80}, /* 'U' */
{14, 0x0200}, /* 'V' */
{14, 0x2200}, /* 'W' */
{14, 0x1200}, /* 'X' */
{14, 0x3200}, /* 'Y' */
{14, 0x0A00}, /* 'Z' */
{14, 0x2A00}, /* '[' */
{14, 0x1A00}, /* '\\' */
{14, 0x3A00}, /* ']' */
{14, 0x0600}, /* '^' */
{14, 0x2600}, /* '_' */
{14, 0x1600}, /* '`' */
{ 3, 0x0007}, /* 'a' */
{ 7, 0x0020}, /* 'b' */
{ 4, 0x0004}, /* 'c' */
{ 5, 0x001A}, /* 'd' */
{ 4, 0x0006}, /* 'e' */
{ 7, 0x0002}, /* 'f' */
{ 5, 0x0011}, /* 'g' */
{ 6, 0x0012}, /* 'h' */
{ 4, 0x000C}, /* 'i' */
{12, 0x0400}, /* 'j' */
{ 8, 0x00C0}, /* 'k' */
{ 5, 0x0018}, /* 'l' */
{ 6, 0x0032}, /* 'm' */
{ 4, 0x0005}, /* 'n' */
{ 5, 0x000A}, /* 'o' */
{ 5, 0x0001}, /* 'p' */
{ 7, 0x0070}, /* 'q' */
{ 3, 0x0003}, /* 'r' */
{ 5, 0x0008}, /* 's' */
{ 4, 0x000E}, /* 't' */
{ 5, 0x0019}, /* 'u' */
{ 7, 0x0062}, /* 'v' */
{ 7, 0x0030}, /* 'w' */
{ 7, 0x0060}, /* 'x' */
{ 7, 0x0010}, /* 'y' */
{11, 0x0700}, /* 'z' */
{14, 0x3600}, /* '{' */
{14, 0x0E00}, /* '|' */
{14, 0x2E00}, /* '}' */
{14, 0x1E00}, /* '~' */
{14, 0x3E00}, /* '\x7f' */

92
opt/sexp-hufftabs.c Normal file
View file

@ -0,0 +1,92 @@
/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
char _huff_tab21[] = {
'\x01', '\x00', '\x03', '\x00', '\x02', '\x00', '\x04', '\x00',
};
char _huff_tab19[] = {
'\x01', 'j', '\x01', '\x00',
};
char _huff_tab20[] = {
'\x05', '\x09', '\x07', '\x0b', '\x06', '\x0a', '\x08', '\x0c',
};
char _huff_tab18[] = {
'2', ':', '6', 'B', '4', '@', '8', 'D',
'3', ';', '7', 'C', '5', 'A', '9', 'E',
};
char _huff_tab17[] = {
'\x0d', '\x1d', '\x15', '&', '\x11', '"', '\x19', ',',
'\x0f', '\x1f', '\x17', '(', '\x13', '$', '\x1b', '0',
'\x0e', '\x1e', '\x16', '\'', '\x12', '#', '\x1a', '.',
'\x10', '\x20', '\x18', ')', '\x14', '%', '\x1c', '1',
};
char _huff_tab16[] = {
'V', '^', 'Z', '|', 'X', '`', '\\', '~',
'W', '_', '[', '}', 'Y', '{', ']', '\x7f',
};
char _huff_tab15[] = {
'F', 'N', 'J', 'R', 'H', 'P', 'L', 'T',
'G', 'O', 'K', 'S', 'I', 'Q', 'M', 'U',
};
char _huff_tab13[] = {
'\x00', '\x00', '\x00', '+', '\x00', '\x00', '\x00', '/',
};
char _huff_tab14[] = {
'*', 'z',
};
char _huff_tab11[] = {
'\x00', 'b', '\x00', 'x',
};
char _huff_tab12[] = {
'!', 'k',
};
char _huff_tab9[] = {
'\x00', 's', '\x00', 'l',
};
char _huff_tab10[] = {
'y', 'w', '<', 'q',
};
char _huff_tab8[] = {
'p', '?', 'g', 'u',
};
char _huff_tab7[] = {
'f', '>', '=', 'v',
};
char _huff_tab5[] = {
'\x00', 'o', '\x00', 'd',
};
char _huff_tab6[] = {
'h', 'm',
};
char _huff_tab4[] = {
'c', 'i',
};
char _huff_tab3[] = {
'n', '-',
};
char _huff_tab1[] = {
'\x00', '\x00', '\x00', 'r', '\x00', '\x00', '\x00', 'a',
};
char _huff_tab2[] = {
'e', 't',
};

71
opt/sexp-unhuff.c Normal file
View file

@ -0,0 +1,71 @@
/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
res = c & 7;
c = c >> 3;
if (res == 0) {
res = c & 3;
c = c >> 2;
if (res == 0) {
res = c & 3;
c = c >> 2;
if (res == 0) {
res = c & 7;
c = c >> 3;
if (res == 0) {
res = c & 3;
c = c >> 2;
if (res == 0) {
res = _huff_tab21[c & 7];
c = c >> 3;
} else if ((res = _huff_tab19[res]) == '\x01') {
res = _huff_tab20[c & 7];
c = c >> 3;
}
} else if (res == 1) {
res = _huff_tab18[c & 15];
c = c >> 4;
} else if (res == 2) {
res = _huff_tab17[c & 31];
c = c >> 5;
} else if (res == 4) {
res = _huff_tab16[c & 15];
c = c >> 4;
} else if (res == 5) {
res = _huff_tab15[c & 15];
c = c >> 4;
} else if ((res = _huff_tab13[res]) == '\x00') {
res = _huff_tab14[c & 1];
c = c >> 1;
}
} else if ((res = _huff_tab11[res]) == '\x00') {
res = _huff_tab12[c & 1];
c = c >> 1;
}
} else if ((res = _huff_tab9[res]) == '\x00') {
res = _huff_tab10[c & 3];
c = c >> 2;
}
} else if (res == 1) {
res = _huff_tab8[c & 3];
c = c >> 2;
} else if (res == 2) {
res = c & 3;
c = c >> 2;
if (res == 0) {
res = _huff_tab7[c & 3];
c = c >> 2;
} else if ((res = _huff_tab5[res]) == '\x00') {
res = _huff_tab6[c & 1];
c = c >> 1;
}
} else if (res == 4) {
res = _huff_tab4[c & 1];
c = c >> 1;
} else if (res == 5) {
res = _huff_tab3[c & 1];
c = c >> 1;
} else if ((res = _huff_tab1[res]) == '\x00') {
res = _huff_tab2[c & 1];
c = c >> 1;
}

135
opt/simplify.c Normal file
View file

@ -0,0 +1,135 @@
/* simplify.c -- basic simplification pass */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#define simplify_it(it) ((it) = simplify(ctx, it, substs, lambda))
static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) {
int check;
sexp ls1, ls2, p1, p2, sv, ctx2;
sexp_gc_var4(res, substs, tmp, app);
sexp_gc_preserve4(ctx, res, substs, tmp, app);
res = ast; /* return the ast as-is by default */
substs = init_substs;
loop:
switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) {
case SEXP_PAIR:
/* don't simplify the operator if it's a lambda because we
simplify that as a special case below, with the appropriate
substs list */
app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res)
: (tmp=simplify(ctx, sexp_car(res), substs, lambda)));
for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1))
sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda));
app = sexp_nreverse(ctx, app);
if (sexp_opcodep(sexp_car(app))) {
if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) {
for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) {
check = 0;
break;
}
}
if (check) {
ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0);
generate(ctx2, app);
app = finalize_bytecode(ctx2);
if (! sexp_exceptionp(app)) {
tmp = sexp_make_vector(ctx2, 0, SEXP_VOID);
app = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, app, tmp);
if (! sexp_exceptionp(app))
app = sexp_apply(ctx2, app, SEXP_NULL);
}
}
}
} else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */
p1 = NULL;
p2 = sexp_lambda_params(sexp_car(app));
ls1 = app;
ls2 = sexp_cdr(app);
sv = sexp_lambda_sv(sexp_car(app));
for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) {
if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv))
&& (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2))
|| (sexp_refp(sexp_car(ls2))
&& sexp_lambdap(sexp_ref_loc(sexp_car(ls2)))))) {
tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2));
tmp = sexp_cons(ctx, sexp_car(p2), tmp);
sexp_push(ctx, substs, tmp);
sexp_cdr(ls1) = sexp_cdr(ls2);
if (p1)
sexp_cdr(p1) = sexp_cdr(p2);
else
sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2);
} else {
p1 = p2;
ls1 = ls2;
}
}
sexp_lambda_body(sexp_car(app))
= simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app));
if (sexp_nullp(sexp_cdr(app))
&& sexp_nullp(sexp_lambda_params(sexp_car(app)))
&& sexp_nullp(sexp_lambda_defs(sexp_car(app))))
app = sexp_lambda_body(sexp_car(app));
}
res = app;
break;
case SEXP_LAMBDA:
sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res);
break;
case SEXP_CND:
tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda);
if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) {
res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp))
? sexp_cnd_fail(res) : sexp_cnd_pass(res);
goto loop;
} else {
sexp_cnd_test(res) = tmp;
simplify_it(sexp_cnd_pass(res));
simplify_it(sexp_cnd_fail(res));
}
break;
case SEXP_REF:
tmp = sexp_ref_name(res);
for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1))
if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) {
res = sexp_cddar(ls1);
break;
}
break;
case SEXP_SET:
simplify_it(sexp_set_value(res));
break;
case SEXP_SEQ:
app = SEXP_NULL;
for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) {
tmp = simplify(ctx, sexp_car(ls2), substs, lambda);
if (! (sexp_pairp(sexp_cdr(ls2))
&& (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp)
|| sexp_lambdap(tmp))))
sexp_push(ctx, app, tmp);
}
if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app)))
res = sexp_car(app);
else
sexp_seq_ls(res) = sexp_nreverse(ctx, app);
break;
}
sexp_gc_release4(ctx);
return res;
}
sexp sexp_simplify (sexp ctx, sexp ast) {
return simplify(ctx, ast, SEXP_NULL, NULL);
}

1685
sexp.c Normal file
View file

File diff suppressed because it is too large Load diff

1
tests/basic/test00-fact-3.res Normal file
View file

@ -0,0 +1 @@
(fact 3) => 6

14
tests/basic/test00-fact-3.scm Normal file
View file

@ -0,0 +1,14 @@
(define (fact-helper x res)
(if (= x 0)
res
(fact-helper (- x 1) (* res x))))
(define (fact x)
(fact-helper x 1))
(display "(fact 3) => ")
(write (fact 3))
(newline)

8
tests/basic/test01-apply.res Normal file
View file

@ -0,0 +1,8 @@
11
(11 10 9 8 7 6 5 4 3 2 1)
(1 2 3 4)
100
100
100
100
100

18
tests/basic/test01-apply.scm Normal file
View file

@ -0,0 +1,18 @@
(define foo
(lambda (a b c d e f g h)
(+ (+ (* a b) (* c d)) (+ (* e f) (* g h)))))
(define (writeln x)
(write x)
(newline))
(writeln (length (reverse (list 1 2 3 4 5 6 7 8 9 10 11))))
(writeln (reverse (list 1 2 3 4 5 6 7 8 9 10 11)))
(writeln (append (list 1 2) (list 3 4)))
(writeln (foo 1 2 3 4 5 6 7 8))
(writeln (apply foo (list 1 2 3 4 5 6 7 8)))
(writeln (apply foo 1 (list 2 3 4 5 6 7 8)))
(writeln (apply foo 1 2 3 4 (list 5 6 7 8)))
(writeln (apply foo 1 2 3 4 5 (list 6 7 8)))

6
tests/basic/test02-closure.res Normal file
View file

@ -0,0 +1,6 @@
1
2
101
102
3
103

16
tests/basic/test02-closure.scm Normal file
View file

@ -0,0 +1,16 @@
(define (make-counter n)
(lambda ()
(set! n (+ n 1))
n))
(define f (make-counter 0))
(define g (make-counter 100))
(write (f)) (newline)
(write (f)) (newline)
(write (g)) (newline)
(write (g)) (newline)
(write (f)) (newline)
(write (g)) (newline)

1
tests/basic/test03-nested-closure.res Normal file
View file

@ -0,0 +1 @@
11357

8
tests/basic/test03-nested-closure.scm Normal file
View file

@ -0,0 +1,8 @@
((lambda (a b)
((lambda (c d e)
(write (+ e (* c 1000) (* a 100) (* b 10) d))
(newline))
(- a 2) (+ b 2) 10000))
3 5)

Some files were not shown because too many files have changed in this diff Show more