Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 22:29:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

64-bit fixes

Browse source
This commit is contained in:
Alex Shinn 2010-06-22 22:48:09 +09:00
commit 09a9970f26
142 changed files with 20448 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
.hgignore Normal file
View file

@ -0,0 +1,28 @@
syntax: glob
*~
*.i
*.s
*.o
*.so
*.dylib
*.dSYM
*.orig
.hg
junk*
*.tar.gz
*.tar.bz2
*.log
*.err
*.out
gc
gc6.8
clibs.c
chibi-scheme
chibi-scheme-static
include/chibi/install.h
lib/chibi/filesystem.c
lib/chibi/io/io.c
lib/chibi/net.c
lib/chibi/process.c
lib/chibi/system.c
lib/chibi/time.c

24
AUTHORS Normal file
View file

@ -0,0 +1,24 @@
Alex Shinn wrote the initial version of chibi-scheme and all
distributed modules.
The `dynamic-wind' implementation is adapted from the implementation
in the appendix to the Scheme48 reference manual, reportedly first
written by Chris Hanson and John Lamping.
Thanks to the following people for patches:
* Andreas Rottman
* Bruno Deferrari
* Derrick Eddington
* Felix Winkelmann
* Gregor Klinke
* John Cowan
* John Samsa
* Lars J Aas
* Lorenzo Campedelli
* sladegen
If you would prefer not to be listed, or are one of the users listed
without a full name, please contact me. If you've made a contribution
and are not listed, please accept my apologies and contact me
immediately!

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.

215
Makefile Normal file
View file

@ -0,0 +1,215 @@
# -*- 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
GENSTATIC ?= ./tools/genstatic.scm
########################################################################
# system configuration - if not using GNU make, set PLATFORM and the
# following flags as necessary.
#
LIBDL = -ldl
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
STATICFLAGS = -DSEXP_USE_DL=0
LIBDL =
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) $(LIBDL) -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/stty$(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/bignum.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 vm.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-sexp$(SO): sexp.o
$(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS)
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 $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm
clibs.c: $(GENSTATIC) lib lib/chibi lib/srfi
make chibi-scheme$(EXE)
make libs
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" PATH=".:$(PATH)" $(GENSTATIC) $< > $@
%.c: %.stub $(GENSTUBS)
make chibi-scheme$(EXE)
-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 \
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./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-flonums: chibi-scheme$(EXE)
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/flonum-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-sort: chibi-scheme$(EXE)
LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-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)/
cp tools/genstubs.scm $(DESTDIR)$(BINDIR)/
mkdir -p $(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`

440
README Normal file
View file

@ -0,0 +1,440 @@
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
To compile a static executable, use
make chibi-scheme-static SEXP_USE_DL=0
To compile a static executable with all C libraries statically
included, first you need to create a clibs.c file, which can be done
with:
make clibs.c
or edited manually. Be sure to run this with a non-static
chibi-scheme. Then you can make the static executable with:
make cleaner
make chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS
------------------------------------------------------------------------
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

150
TODO Normal file
View file

@ -0,0 +1,150 @@
-*- 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
** DONE virtual ports
- State "DONE" [2010-01-02 Sat 20:12]
** 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]
*** DONE host system interface
- State "DONE" [2010-01-02 Sat 20:12]
** 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
]
[-m
.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/

1579
eval.c Normal file
View file

File diff suppressed because it is too large Load diff

354
gc.c Normal file
View file

@ -0,0 +1,354 @@
/* gc.c -- simple mark&sweep garbage collector */
/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include "chibi/sexp.h"
#if SEXP_USE_MMAP_GC
#include <sys/mman.h>
#endif
#if SEXP_64_BIT
#define sexp_heap_align(n) sexp_align(n, 5)
#else
#define sexp_heap_align(n) sexp_align(n, 4)
#endif
#define SEXP_MINIMUM_OBJECT_SIZE (sexp_heap_align(sexp_sizeof(pair)))
#define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1))
#if SEXP_USE_GLOBAL_HEAP
sexp_heap sexp_global_heap;
#endif
#if SEXP_USE_CONSERVATIVE_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;
}
#if SEXP_USE_SAFE_GC_MARK
static int sexp_in_heap(sexp ctx, sexp_uint_t x) {
sexp_heap h;
if (x & (sexp_heap_align(1)-1)) {
fprintf(stderr, "invalid heap alignment: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x));
return 0;
}
for (h=sexp_context_heap(ctx); h; h=h->next)
if (((sexp_uint_t)h < x) && (x < (sexp_uint_t)(h->data + h->size)))
return 1;
fprintf(stderr, "invalid object outside heap: %p %d\n", (sexp)x, sexp_pointer_tag((sexp)x));
return 0;
}
#endif
#if SEXP_USE_DEBUG_GC
#include "opt/gc_debug.c"
#endif
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;
#if SEXP_USE_SAFE_GC_MARK
if (! sexp_in_heap(ctx, (sexp_uint_t)x))
return;
#endif
#if SEXP_USE_HEADER_MAGIC
if (sexp_pointer_magic(x) != SEXP_POINTER_MAGIC && sexp_pointer_tag(x) != SEXP_TYPE
&& sexp_pointer_tag(x) != SEXP_OPCODE && sexp_pointer_tag(x) != SEXP_CORE
&& sexp_pointer_tag(x) != SEXP_STACK)
return;
#endif
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_CONSERVATIVE_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, end;
sexp_free_list q, r, s;
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 = (sexp) ((char*)h->data + h->size - sexp_heap_align(sexp_sizeof(pair)));
while (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 it */
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 sexp_api_pass(NULL, 1), 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);
}
}
}
if (sum_freed_ptr) *sum_freed_ptr = 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);
#if SEXP_USE_DEBUG_GC
sexp_sweep_stats(ctx, 2, NULL, "* \x1B[31mFREE:\x1B[0m ");
#endif
res = sexp_sweep(ctx, sum_freed);
return res;
}
sexp_heap sexp_make_heap (size_t size) {
sexp_free_list free, next;
sexp_heap h;
#if SEXP_USE_MMAP_GC
h = mmap(NULL, sexp_heap_pad_size(size), PROT_READ|PROT_WRITE|PROT_EXEC,
MAP_ANON|MAP_PRIVATE, 0, 0);
#else
h = malloc(sexp_heap_pad_size(size));
#endif
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, total_size;
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));
for (total_size=0, h=sexp_context_heap(ctx); h->next; h=h->next)
total_size += h->size;
total_size += h->size;
if (((max_freed < size)
|| ((total_size > sum_freed)
&& (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO)))
&& ((!SEXP_MAXIMUM_HEAP_SIZE) || (total_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;
}
#if ! SEXP_USE_GLOBAL_HEAP
sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) {
sexp_sint_t i, off, len, freep;
sexp_heap to, from = sexp_context_heap(ctx);
sexp_free_list q;
sexp p, p2, t, end, *v;
freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP);
/* validate input, creating a new heap if needed */
if (from->next) {
return sexp_user_exception(ctx, NULL, "can't copy a non-contiguous heap", ctx);
} else if (! dst || sexp_not(dst)) {
to = sexp_make_heap(from->size);
dst = (sexp) ((char*)ctx + ((char*)to - (char*)from));
} else if (! sexp_contextp(dst)) {
return sexp_type_exception(ctx, NULL, SEXP_CONTEXT, dst);
} else if (sexp_context_heap(dst)->size < from->size) {
return sexp_user_exception(ctx, NULL, "destination context too small", dst);
} else {
to = sexp_context_heap(dst);
}
/* copy the raw data */
off = (char*)to - (char*)from;
memcpy(to, from, sexp_heap_pad_size(from->size));
to->free_list = (sexp_free_list) ((char*)to->free_list + off);
to->data += off;
end = (sexp) (from->data + from->size);
/* adjust the free list */
for (q=to->free_list; q->next; q=q->next)
q->next = (sexp_free_list) ((char*)q->next + off);
/* adjust if the destination is larger */
if (from->size < to->size) {
if (((char*)q + q->size - off) >= (char*)end) {
q->size += (to->size - from->size);
} else {
q->next = (sexp_free_list) ((char*)end + off);
q->next->next = NULL;
q->next->size = (to->size - from->size);
}
}
/* adjust data by traversing over the _original_ heap */
p = (sexp) (from->data + sexp_heap_align(sexp_sizeof(pair)));
q = from->free_list;
while (p < end) {
/* find the next free list pointer */
for ( ; q && ((char*)q < (char*)p); q=q->next)
;
if ((char*)q == (char*)p) { /* this is a free block, skip it */
p = (sexp) (((char*)p) + q->size);
} else {
t = sexp_object_type(ctx, p);
len = sexp_type_num_slots_of_object(t, p);
p2 = (sexp)((char*)p + off);
v = (sexp*) ((char*)p2 + sexp_type_field_base(t));
/* offset any pointers in the _destination_ heap */
for (i=0; i<len; i++)
if (v[i] && sexp_pointerp(v[i]))
v[i] = (sexp) ((char*)v[i] + off);
/* don't free unless specified - only the original cleans up */
if (! freep)
sexp_freep(p2) = 0;
/* adjust context heaps, don't copy saved sexp_gc_vars */
if (sexp_contextp(p2)) {
sexp_context_saves(p2) = NULL;
if (sexp_context_heap(p2) == from)
sexp_context_heap(p2) = to;
}
p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
}
}
return dst;
}
#endif
void sexp_gc_init (void) {
#if SEXP_USE_GLOBAL_HEAP || SEXP_USE_CONSERVATIVE_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_CONSERVATIVE_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 */

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

@ -0,0 +1,192 @@
/* eval.h -- headers for eval library */
/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#ifndef SEXP_EVAL_H
#define SEXP_EVAL_H
#ifdef __cplusplus
extern "C" {
#endif
#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_CMP,
SEXP_OPC_IO,
SEXP_OPC_CONSTRUCTOR,
SEXP_OPC_GETTER,
SEXP_OPC_SETTER,
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_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_compile_error (sexp ctx, const char *message, sexp obj);
SEXP_API sexp sexp_analyze (sexp context, sexp x);
SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv);
SEXP_API int sexp_param_index (sexp lambda, sexp name);
SEXP_API sexp sexp_eval_op (sexp context sexp_api_params(self, n), sexp obj, sexp env);
SEXP_API sexp sexp_eval_string (sexp context, const char *str, sexp_sint_t len, sexp env);
SEXP_API sexp sexp_load_op (sexp context sexp_api_params(self, n), sexp expr, sexp env);
SEXP_API sexp sexp_make_env_op (sexp context sexp_api_params(self, n));
SEXP_API sexp sexp_make_null_env_op (sexp context sexp_api_params(self, n), sexp version);
SEXP_API sexp sexp_make_primitive_env (sexp context, sexp version);
SEXP_API sexp sexp_make_standard_env_op (sexp context sexp_api_params(self, n), 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, const char *file);
SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env);
SEXP_API sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp);
SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value);
SEXP_API sexp sexp_env_copy_op (sexp context sexp_api_params(self, n), 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_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
SEXP_API sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp flags, sexp num_args, sexp bc, sexp vars);
SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data);
SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const 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, const char *name, int num_args, sexp_proc1 f, const char *param);
#if SEXP_USE_TYPE_DEFS
SEXP_API sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type);
SEXP_API sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type);
SEXP_API sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index);
SEXP_API sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index);
#endif
/* simplify primitive API interface */
#define sexp_make_synclo(ctx, a, b, c) sexp_make_synclo_op(ctx sexp_api_pass(NULL, 3) a, b, c)
#define sexp_make_procedure(ctx, f, n, b, v) sexp_make_procedure_op(ctx sexp_api_pass(NULL, 4), f, n, b, v)
#define sexp_make_env(ctx) sexp_make_env_op(ctx sexp_api_pass(NULL, 0))
#define sexp_make_null_env(ctx, v) sexp_make_null_env_op(ctx sexp_api_pass(NULL, 0), v)
#define sexp_make_standard_env(ctx) sexp_make_standard_env_op(ctx sexp_api_pass(NULL, 0))
#define sexp_add_module_directory(ctx, d, a) sexp_add_module_directory_op(ctx sexp_api_pass(NULL, 1), d, a)
#define sexp_eval(ctx, x, e) sexp_eval_op(ctx sexp_api_pass(NULL, 2), x, e)
#define sexp_load(ctx, f, e) sexp_load_op(ctx sexp_api_pass(NULL, 2), f, e)
#define sexp_env_copy(ctx, a, b, c, d) sexp_env_copy_op(ctx sexp_api_pass(NULL, 4), a, b, c, d)
#define sexp_identifierp(ctx, x) sexp_identifier_op(ctx sexp_api_pass(NULL, 1), x)
#define sexp_identifier_to_symbol(ctx, x) sexp_syntactic_closure_expr(ctx sexp_api_pass(NULL, 1), x)
#define sexp_identifier_eq(ctx, a, b, c, d) sexp_identifier_eq_op(ctx sexp_api_pass(NULL, 4), a, b, c, d)
#define sexp_open_input_file(ctx, x) sexp_open_input_file_op(ctx sexp_api_pass(NULL, 1), x)
#define sexp_open_output_file(ctx, x) sexp_open_output_file_op(ctx sexp_api_pass(NULL, 1), x)
#define sexp_close_port(ctx, x) sexp_close_port_op(ctx sexp_api_pass(NULL, 1), x)
#ifdef __cplusplus
} /* extern "C" */
#endif
#endif /* ! SEXP_EVAL_H */

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

@ -0,0 +1,403 @@
/* features.h -- general feature configuration */
/* Copyright (c) 2009-2010 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 enable the experimental native x86 backend */
/* #define SEXP_USE_NATIVE_X86 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 statically compile all C libs */
/* If set, this will statically include the clibs.c file */
/* into the standard environment, so that you can have */
/* access to a predefined set of C libraries without */
/* needing dynamic loading. The clibs.c file is generated */
/* automatically by searching the lib directory for */
/* modules with include-shared, but can be hand-tailored */
/* to your needs. */
/* #define SEXP_USE_STATIC_LIBS 1 */
/* 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 allocate heaps with mmap instead of malloc */
/* #define SEXP_USE_MMAP_GC 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_CONSERVATIVE_GC 1 */
/* uncomment this to add additional native checks to only mark objects in the heap */
/* #define SEXP_USE_SAFE_GC_MARK 1 */
/* uncomment this to add additional native gc checks to verify a magic header */
/* #define SEXP_USE_HEADER_MAGIC 1 */
/* uncomment this to add very verbose debugging stats to the native GC */
/* #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 the self and n parameters to primitives */
/* This is the old style API. */
/* #define SEXP_USE_SELF_PARAMETER 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. */
/* uncomment this to make the VM adhere to alignment rules */
/* This is required on some platforms, e.g. ARM */
/* #define SEXP_USE_ALIGNED_BYTECODE */
/************************************************************************/
/* These settings are configurable but only recommended for */
/* experienced users, and only apply when using the native GC. */
/************************************************************************/
/* 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 8*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
/************************************************************************/
/* 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
#ifndef _GNU_SOURCE
#define _GNU_SOURCE
#endif
#endif
#ifndef SEXP_USE_NO_FEATURES
#define SEXP_USE_NO_FEATURES 0
#endif
#ifndef SEXP_USE_NATIVE_X86
#define SEXP_USE_NATIVE_X86 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_STATIC_LIBS
#define SEXP_USE_STATIC_LIBS 0
#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_MMAP_GC
#define SEXP_USE_MMAP_GC 0
#endif
#ifndef SEXP_USE_DEBUG_GC
#define SEXP_USE_DEBUG_GC 0
#endif
#ifndef SEXP_USE_SAFE_GC_MARK
#define SEXP_USE_SAFE_GC_MARK 0
#endif
#ifndef SEXP_USE_CONSERVATIVE_GC
#define SEXP_USE_CONSERVATIVE_GC 0
#endif
#ifndef SEXP_USE_HEADER_MAGIC
#define SEXP_USE_HEADER_MAGIC 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_SELF_PARAMETER
#define SEXP_USE_SELF_PARAMETER 1
#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
#if SEXP_USE_NATIVE_X86
#undef SEXP_USE_BOEHM
#define SEXP_USE_BOEHM 1
#undef SEXP_USE_FLONUMS
#define SEXP_USE_FLONUMS 0
#undef SEXP_USE_BIGNUMS
#define SEXP_USE_BIGNUMS 0
#undef SEXP_USE_SIMPLIFY
#define SEXP_USE_SIMPLIFY 0
#endif
#ifndef SEXP_USE_ALIGNED_BYTECODE
#if defined(__arm__)
#define SEXP_USE_ALIGNED_BYTECODE 1
#else
#define SEXP_USE_ALIGNED_BYTECODE 0
#endif
#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

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

@ -0,0 +1,966 @@
/* sexp.h -- header for sexp library */
/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#ifndef SEXP_H
#define SEXP_H
#ifdef __cplusplus
extern "C" {
#endif
#define SEXP_MODULE_PATH_VAR "CHIBI_MODULE_PATH"
#include "chibi/features.h"
#include "chibi/install.h"
#if SEXP_USE_DL
#ifndef __MINGW32__
#include <dlfcn.h>
#endif
#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
#include <ctype.h>
#include <stdio.h>
/* tagging system
* bits end in 00: pointer
* 01: fixnum
* 011: immediate flonum (optional)
* 111: immediate symbol (optional)
* 000110: char
* 001110: unique immediate (NULL, TRUE, FALSE)
*/
#define SEXP_FIXNUM_BITS 2
#define SEXP_IMMEDIATE_BITS 3
#define SEXP_EXTENDED_BITS 6
#define SEXP_FIXNUM_MASK 3
#define SEXP_IMMEDIATE_MASK 7
#define SEXP_EXTENDED_MASK 63
#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
#ifndef SEXP_POINTER_MAGIC
#define SEXP_POINTER_MAGIC 0xFDCA9764uL /* arbitrary */
#endif
#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_NUMBER,
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
};
#if SEXP_64_BIT
typedef unsigned int sexp_tag_t;
typedef unsigned long sexp_uint_t;
typedef long sexp_sint_t;
#else
typedef unsigned short sexp_tag_t;
typedef unsigned int sexp_uint_t;
typedef int sexp_sint_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)
#if SEXP_USE_SELF_PARAMETER
#define sexp_api_params(self, n) , sexp self, long n
#define sexp_api_pass(self, n) , self, n
#else
#define sexp_api_params(self, n)
#define sexp_api_pass(self, n)
#endif
/* procedure types */
typedef sexp (*sexp_proc1) (sexp sexp_api_params(self, n));
typedef sexp (*sexp_proc2) (sexp sexp_api_params(self, n), sexp);
typedef sexp (*sexp_proc3) (sexp sexp_api_params(self, n), sexp, sexp);
typedef sexp (*sexp_proc4) (sexp sexp_api_params(self, n), sexp, sexp, sexp);
typedef sexp (*sexp_proc5) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp);
typedef sexp (*sexp_proc6) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp);
typedef sexp (*sexp_proc7) (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp);
typedef struct sexp_free_list_t *sexp_free_list;
struct sexp_free_list_t {
sexp_uint_t size;
sexp_free_list next;
};
typedef struct sexp_heap_t *sexp_heap;
struct sexp_heap_t {
sexp_uint_t size;
sexp_free_list free_list;
sexp_heap next;
/* note this must be aligned on a proper heap boundary, */
/* so we can't just use char data[] */
char *data;
};
struct sexp_gc_var_t {
sexp *var;
#if SEXP_USE_CONSERVATIVE_GC
char *name;
#endif
struct sexp_gc_var_t *next;
};
struct sexp_struct {
sexp_tag_t tag;
char gc_mark;
unsigned int immutablep:1;
unsigned int freep:1;
#if SEXP_USE_HEADER_MAGIC
unsigned int magic;
#endif
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, no_closep, sourcep;
sexp_uint_t offset, line;
size_t size;
sexp name;
sexp cookie;
} port;
struct {
sexp kind, message, irritants, procedure, source;
} exception;
struct {
signed 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;
const char *name;
sexp data, data2, proc;
sexp_proc1 func;
} opcode;
struct {
char code;
const 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_FALSE SEXP_MAKE_IMMEDIATE(0) /* 14 0x0e */
#define SEXP_TRUE SEXP_MAKE_IMMEDIATE(1) /* 30 0x1e */
#define SEXP_NULL 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};
#if SEXP_USE_CONSERVATIVE_GC
#define sexp_gc_preserve_name(ctx, x, y) (y).name = #x
#else
#define sexp_gc_preserve_name(ctx, x, y)
#endif
#define sexp_gc_preserve(ctx, x, y) \
do { \
sexp_gc_preserve_name(ctx, x, y); \
(y).var = &(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)))
#if SEXP_64_BIT
#define sexp_word_align(n) sexp_align((n), 3)
#else
#define sexp_word_align(n) sexp_align((n), 2)
#endif
#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_pointer_magic(x) ((x)->magic)
#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_SIX sexp_make_fixnum(6)
#define SEXP_SEVEN sexp_make_fixnum(7)
#define SEXP_EIGHT sexp_make_fixnum(8)
#define SEXP_NINE sexp_make_fixnum(9)
#define SEXP_TEN sexp_make_fixnum(10)
#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)))
#define sexp_numberp(x) (sexp_exact_integerp(x) || sexp_flonump(x))
#else
#define sexp_fixnum_to_flonum(ctx, x) (x)
#define sexp_numberp(x) sexp_exact_integerp(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((unsigned char)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_no_closep(p) ((p)->value.port.no_closep)
#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)
#if SEXP_USE_ALIGNED_BYTECODE
#define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx))
#else
#define sexp_context_align_pos(ctx)
#endif
#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, const char *str, sexp_uint_t len, sexp p);
SEXP_API sexp sexp_buffered_write_string (sexp ctx, const 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, size_t size);
SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag);
SEXP_API sexp sexp_cons_op(sexp ctx sexp_api_params(self, n), sexp head, sexp tail);
SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b);
SEXP_API sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b);
SEXP_API sexp sexp_listp_op(sexp ctx sexp_api_params(self, n), sexp obj);
SEXP_API sexp sexp_reverse_op(sexp ctx sexp_api_params(self, n), sexp ls);
SEXP_API sexp sexp_nreverse_op(sexp ctx sexp_api_params(self, n), sexp ls);
SEXP_API sexp sexp_copy_list_op(sexp ctx sexp_api_params(self, n), sexp ls);
SEXP_API sexp sexp_append2_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b);
SEXP_API sexp sexp_memq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls);
SEXP_API sexp sexp_assq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls);
SEXP_API sexp sexp_length_op(sexp ctx sexp_api_params(self, n), sexp ls);
SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen);
SEXP_API sexp sexp_make_string_op(sexp ctx sexp_api_params(self, n), sexp len, sexp ch);
SEXP_API sexp sexp_substring_op (sexp ctx sexp_api_params(self, n), sexp str, sexp start, sexp end);
SEXP_API sexp sexp_string_concatenate_op (sexp ctx sexp_api_params(self, n), sexp str_ls, sexp sep);
SEXP_API sexp sexp_intern (sexp ctx, const char *str, sexp_sint_t len);
SEXP_API sexp sexp_string_to_symbol_op (sexp ctx sexp_api_params(self, n), sexp str);
SEXP_API sexp sexp_string_to_number_op (sexp ctx sexp_api_params(self, n), sexp str, sexp b);
SEXP_API sexp sexp_make_vector_op (sexp ctx sexp_api_params(self, n), sexp len, sexp dflt);
SEXP_API sexp sexp_list_to_vector_op (sexp ctx sexp_api_params(self, n), sexp ls);
SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep);
SEXP_API sexp sexp_write_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out);
SEXP_API sexp sexp_display_op (sexp ctx sexp_api_params(self, n), sexp obj, sexp out);
SEXP_API sexp sexp_flush_output_op (sexp ctx sexp_api_params(self, n), 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_op (sexp ctx sexp_api_params(self, n), sexp in);
SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len);
SEXP_API sexp sexp_write_to_string (sexp ctx, sexp obj);
SEXP_API sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port);
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_op (sexp ctx sexp_api_params(self, n), sexp str);
SEXP_API sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n));
SEXP_API sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), 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, const char *msg, sexp x);
SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x);
SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x);
SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
SEXP_API sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp out);
SEXP_API void sexp_init(void);
#define sexp_assert_type(ctx, pred, type_id, obj) if (! pred(obj)) return sexp_type_exception(ctx, self, type_id, obj)
#define SEXP_COPY_DEFAULT SEXP_ZERO
#define SEXP_COPY_FREEP SEXP_ONE
#if SEXP_USE_GLOBAL_HEAP
#define sexp_destroy_context(ctx)
#else
SEXP_API void sexp_destroy_context (sexp ctx);
SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags);
#endif
#if SEXP_USE_TYPE_DEFS
SEXP_API sexp sexp_register_type_op (sexp sexp_api_params(self, n), sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2);
SEXP_API sexp sexp_register_simple_type_op (sexp ctx sexp_api_params(self, n), 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_api_params(self, n), 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, (sexp_proc2)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)))
/* simplify primitive API interface */
#define sexp_read(ctx, in) sexp_read_op(ctx sexp_api_pass(NULL, 1), in)
#define sexp_write(ctx, obj, out) sexp_write_op(ctx sexp_api_pass(NULL, 2), obj, out)
#define sexp_display(ctx, obj, out) sexp_display_op(ctx sexp_api_pass(NULL, 2), obj, out)
#define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx sexp_api_pass(NULL, 2), e, out)
#define sexp_flush_output(ctx, obj, out) sexp_flush_output_op(ctx sexp_api_pass(NULL, 1), out)
#define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_listp(ctx, x) sexp_listp_op(ctx sexp_api_pass(NULL, 1), x)
#define sexp_length(ctx, x) sexp_length_op(ctx sexp_api_pass(NULL, 1), x)
#define sexp_reverse(ctx, x) sexp_reverse_op(ctx sexp_api_pass(NULL, 1), x)
#define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx sexp_api_pass(NULL, 1), x)
#define sexp_copy_list(ctx, x) sexp_copy_list_op(ctx sexp_api_pass(NULL, 1), x)
#define sexp_cons(ctx, a, b) sexp_cons_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_append2(ctx, a, b) sexp_append2_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx sexp_api_pass(NULL, 2), a, b);
#define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx sexp_api_pass(NULL, 1), x)
#define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx sexp_api_pass(NULL, 1), x)
#define sexp_string_to_number(ctx, s, b) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), s, b)
#define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx sexp_api_pass(NULL, 2), l, c)
#define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx sexp_api_pass(NULL, 3), a, b, c)
#define sexp_substring(ctx, a, b, c) sexp_substring_op(ctx sexp_api_pass(NULL, 3), a, b, c)
#define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx sexp_api_pass(NULL, 2), ls, s)
#define sexp_memq(ctx, a, b) sexp_memq_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_assq(ctx, a, b) sexp_assq_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_make_output_string_port(ctx) sexp_make_output_string_port_op(ctx sexp_api_pass(NULL, 0))
#define sexp_make_input_string_port(ctx, s) sexp_make_input_string_port_op(ctx sexp_api_pass(NULL, 1), s)
#define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx sexp_api_pass(NULL, 1), out)
#define sexp_expt(ctx, a, b) sexp_expt_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_register_simple_type(ctx, a, b) sexp_register_simple_type_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j) sexp_register_type_op(ctx sexp_api_pass(NULL, 10), a, b, c, d, e, f, g, h, i, j)
#define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx sexp_api_pass(NULL, 2), a, b)
#define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c)
#define sexp_make_setter(ctx, a, b, c) sexp_make_getter_op(ctx sexp_api_pass(NULL, 3), a, b, c)
#ifdef __cplusplus
} /* extern "C" */
#endif
#endif /* ! SEXP_H */

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

@ -0,0 +1,79 @@
/* ast.c -- interface to the Abstract Syntax Tree */
/* Copyright (c) 2009-2010 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, -1), 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, -1), 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, -1), op);
sexp_gc_release2(ctx);
}
static sexp sexp_get_env_cell (sexp ctx sexp_api_params(self, n), 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_api_params(self, n), sexp op) {
if (! sexp_opcodep(op))
return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
else if (! sexp_opcode_name(op))
return SEXP_FALSE;
else
return sexp_intern(ctx, sexp_opcode_name(op), -1);
}
sexp sexp_init_library (sexp ctx sexp_api_params(self, n), 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;
}

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

@ -0,0 +1,15 @@
(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!)
(import-immutable (scheme))
(include-shared "ast"))

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

@ -0,0 +1,7 @@
(define-module (chibi base64)
(export base64-encode base64-encode-string
base64-decode base64-decode-string
base64-encode-header)
(import-immutable (scheme) (srfi 33) (chibi io))
(include "base64.scm"))

351
lib/chibi/base64.scm Normal file
View file

@ -0,0 +1,351 @@
;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;; Procedure: base64-encode-string str
;; Return a base64 encoded representation of string according to the
;; official base64 standard as described in RFC3548.
;; Procedure: base64-decode-string str
;; Return a base64 decoded representation of string, also interpreting
;; the alternate 62 & 63 valued characters as described in RFC3548.
;; Other out-of-band characters are silently stripped, and = signals
;; the end of the encoded string. No errors will be raised.
;; Procedure: base64-encode [port]
;; Procedure: base64-decode [port]
;; Variations of the above which read and write to ports.
;; Procedure: base64-encode-header enc str [start-col max-col nl]
;; Return a base64 encoded representation of string as above,
;; wrapped in =?ENC?B?...?= as per RFC1522, split across multiple
;; MIME-header lines as needed to keep each lines length less than
;; MAX-COL. The string is encoded as is, and the encoding ENC is
;; just used for the prefix, i.e. you are responsible for ensuring
;; STR is already encoded according to ENC. The optional argument
;; NL is the newline separator, defaulting to CRLF.
;; This API is compatible with the Gauche library rfc.base64.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; string utils
(define (string-chop str n)
(let ((len (string-length str)))
(let lp ((i 0) (res '()))
(let ((j (+ i n)))
(if (>= j len)
(reverse (cons (substring str i len) res))
(lp j (cons (substring str i j) res)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; constants and tables
(define *default-max-col* 76)
(define *outside-char* 99) ; luft-balloons
(define *pad-char* 101) ; dalmations
(define *base64-decode-table*
(let ((res (make-vector #x100 *outside-char*)))
(let lp ((i 0)) ; map letters
(cond
((<= i 25)
(vector-set! res (+ i 65) i)
(vector-set! res (+ i 97) (+ i 26))
(lp (+ i 1)))))
(let lp ((i 0)) ; map numbers
(cond
((<= i 9)
(vector-set! res (+ i 48) (+ i 52))
(lp (+ i 1)))))
;; extras (be liberal for different common base64 formats)
(vector-set! res (char->integer #\+) 62)
(vector-set! res (char->integer #\-) 62)
(vector-set! res (char->integer #\/) 63)
(vector-set! res (char->integer #\_) 63)
(vector-set! res (char->integer #\~) 63)
(vector-set! res (char->integer #\=) *pad-char*)
res))
(define (base64-decode-char c)
(vector-ref *base64-decode-table* (char->integer c)))
(define *base64-encode-table*
(let ((res (make-vector 64)))
(let lp ((i 0)) ; map letters
(cond
((<= i 25)
(vector-set! res i (integer->char (+ i 65)))
(vector-set! res (+ i 26) (integer->char (+ i 97)))
(lp (+ i 1)))))
(let lp ((i 0)) ; map numbers
(cond
((<= i 9)
(vector-set! res (+ i 52) (integer->char (+ i 48)))
(lp (+ i 1)))))
(vector-set! res 62 #\+)
(vector-set! res 63 #\/)
res))
(define (enc i)
(vector-ref *base64-encode-table* i))
;; try to match common boundaries
(define decode-src-length
(lcm 76 78))
(define decode-dst-length
(* 3 (arithmetic-shift (+ 3 decode-src-length) -2)))
(define encode-src-length
(* 3 1024))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; decoding
;; Create a result buffer with the maximum possible length for the
;; input, and pass it to the internal base64-decode-string! utility.
;; If the resulting length used is exact, we can return that buffer,
;; otherwise we return the appropriate substring.
(define (base64-decode-string src)
(let* ((len (string-length src))
(dst-len (* 3 (arithmetic-shift (+ 3 len) -2)))
(dst (make-string dst-len)))
(base64-decode-string!
src 0 len dst
(lambda (src-offset res-len b1 b2 b3)
(let ((res-len (base64-decode-finish dst res-len b1 b2 b3)))
(if (= res-len dst-len)
dst
(substring dst 0 res-len)))))))
;; This is a little funky.
;;
;; We want to skip over "outside" characters (e.g. newlines inside
;; base64-encoded data, as would be passed in mail clients and most
;; large base64 data). This would normally mean two nested loops -
;; one for overall processing the input, and one for looping until
;; we get to a valid character. However, many Scheme compilers are
;; really bad about optimizing nested loops of primitives, so we
;; flatten this into a single loop, using conditionals to determine
;; which character is currently being read.
(define (base64-decode-string! src start end dst kont)
(let lp ((i start)
(j 0)
(b1 *outside-char*)
(b2 *outside-char*)
(b3 *outside-char*))
(if (>= i end)
(kont i j b1 b2 b3)
(let ((c (base64-decode-char (string-ref src i))))
(cond
((eqv? c *pad-char*)
(kont i j b1 b2 b3))
((eqv? c *outside-char*)
(lp (+ i 1) j b1 b2 b3))
((eqv? b1 *outside-char*)
(lp (+ i 1) j c b2 b3))
((eqv? b2 *outside-char*)
(lp (+ i 1) j b1 c b3))
((eqv? b3 *outside-char*)
(lp (+ i 1) j b1 b2 c))
(else
(string-set! dst
j
(integer->char
(bitwise-ior (arithmetic-shift b1 2)
(extract-bit-field 2 4 b2))))
(string-set! dst
(+ j 1)
(integer->char
(bitwise-ior
(arithmetic-shift (extract-bit-field 4 0 b2) 4)
(extract-bit-field 4 2 b3))))
(string-set! dst
(+ j 2)
(integer->char
(bitwise-ior
(arithmetic-shift (extract-bit-field 2 0 b3) 6)
c)))
(lp (+ i 1) (+ j 3)
*outside-char* *outside-char* *outside-char*)))))))
;; If requested, account for any "partial" results (i.e. trailing 2 or
;; 3 chars) by writing them into the destination (additional 1 or 2
;; bytes) and returning the adjusted offset for how much data we've
;; written.
(define (base64-decode-finish dst j b1 b2 b3)
(cond
((eqv? b1 *outside-char*)
j)
((eqv? b2 *outside-char*)
(string-set! dst j (integer->char (arithmetic-shift b1 2)))
(+ j 1))
(else
(string-set! dst
j
(integer->char
(bitwise-ior (arithmetic-shift b1 2)
(extract-bit-field 2 4 b2))))
(cond
((eqv? b3 *outside-char*)
(+ j 1))
(else
(string-set! dst
(+ j 1)
(integer->char
(bitwise-ior
(arithmetic-shift (extract-bit-field 4 0 b2) 4)
(extract-bit-field 4 2 b3))))
(+ j 2))))))
;; General port decoder: work in single blocks at a time to avoid
;; allocating memory (crucial for Scheme implementations that don't
;; allow large strings).
(define (base64-decode . o)
(let ((in (if (pair? o) (car o) (current-input-port)))
(out (if (and (pair? o) (pair? (cdr o)))
(cadr o)
(current-output-port))))
(let ((src (make-string decode-src-length))
(dst (make-string decode-dst-length)))
(let lp ((offset 0))
(let ((src-len (+ offset
(read-string! decode-src-length src in offset))))
(cond
((= src-len decode-src-length)
;; read a full chunk: decode, write and loop
(base64-decode-string!
src 0 decode-src-length dst
(lambda (src-offset dst-len b1 b2 b3)
(cond
((and (< src-offset src-len)
(eqv? #\= (string-ref src src-offset)))
;; done
(let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
(write-string dst dst-len out)))
((eqv? b1 *outside-char*)
(write-string dst dst-len out)
(lp 0))
(else
(write-string dst dst-len out)
;; one to three chars left in buffer
(string-set! src 0 (enc b1))
(cond
((eqv? b2 *outside-char*)
(lp 1))
(else
(string-set! src 1 (enc b2))
(cond
((eqv? b3 *outside-char*)
(lp 2))
(else
(string-set! src 2 (enc b3))
(lp 3))))))))))
(else
;; end of source - just decode and write once
(base64-decode-string!
src 0 src-len dst
(lambda (src-offset dst-len b1 b2 b3)
(let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
(write-string dst dst-len out)))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; encoding
(define (base64-encode-string str)
(let* ((len (string-length str))
(quot (quotient len 3))
(rem (- len (* quot 3)))
(res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2))
(res (make-string res-len)))
(base64-encode-string! str 0 len res)
res))
(define (base64-encode-string! str start end res)
(let* ((res-len (string-length res))
(limit (- end 2)))
(let lp ((i start) (j 0))
(if (>= i limit)
(case (- end i)
((1)
(let ((b1 (char->integer (string-ref str i))))
(string-set! res j (enc (arithmetic-shift b1 -2)))
(string-set! res
(+ j 1)
(enc (arithmetic-shift (bitwise-and #b11 b1) 4)))
(string-set! res (+ j 2) #\=)
(string-set! res (+ j 3) #\=)))
((2)
(let ((b1 (char->integer (string-ref str i)))
(b2 (char->integer (string-ref str (+ i 1)))))
(string-set! res j (enc (arithmetic-shift b1 -2)))
(string-set! res
(+ j 1)
(enc (bitwise-ior
(arithmetic-shift (bitwise-and #b11 b1) 4)
(extract-bit-field 4 4 b2))))
(string-set! res
(+ j 2)
(enc (arithmetic-shift (extract-bit-field 4 0 b2)
2)))
(string-set! res (+ j 3) #\=))))
(let ((b1 (char->integer (string-ref str i)))
(b2 (char->integer (string-ref str (+ i 1))))
(b3 (char->integer (string-ref str (+ i 2)))))
(string-set! res j (enc (arithmetic-shift b1 -2)))
(string-set! res
(+ j 1)
(enc (bitwise-ior
(arithmetic-shift (bitwise-and #b11 b1) 4)
(extract-bit-field 4 4 b2))))
(string-set! res
(+ j 2)
(enc (bitwise-ior
(arithmetic-shift (extract-bit-field 4 0 b2) 2)
(extract-bit-field 2 6 b3))))
(string-set! res (+ j 3) (enc (bitwise-and #b111111 b3)))
(lp (+ i 3) (+ j 4)))))))
(define (base64-encode . o)
(let ((in (if (pair? o) (car o) (current-input-port)))
(out (if (and (pair? o) (pair? (cdr o)))
(cadr o)
(current-output-port))))
(let ((src (make-string encode-src-length))
(dst (make-string
(arithmetic-shift (quotient encode-src-length 3) 2))))
(let lp ()
(let ((n (read-string! 2048 src in)))
(base64-encode-string! src 0 n dst)
(write-string dst (* 3 (quotient (+ n 3) 4)) out)
(if (= n 2048)
(lp)))))))
(define (base64-encode-header encoding str . o)
(define (round4 i) (arithmetic-shift (arithmetic-shift i -2) 2))
(let ((start-col (if (pair? o) (car o) 0))
(max-col (if (and (pair? o) (pair? (cdr o)))
(car (cdr o))
*default-max-col*))
(nl (if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o))))
(car (cdr (cdr o)))
"\r\n")))
(let* ((prefix (string-append "=?" encoding "?B?"))
(prefix-length (+ 2 (string-length prefix)))
(effective-max-col (round4 (- max-col prefix-length)))
(first-max-col (round4 (- effective-max-col start-col)))
(str (base64-encode-string str))
(len (string-length str)))
(if (<= len first-max-col)
(string-append prefix str "?=")
(string-append
(if (positive? first-max-col)
(string-append
prefix (substring str 0 first-max-col) "?=" nl "\t" prefix)
"")
(string-concatenate (string-chop (substring str first-max-col len)
effective-max-col)
(string-append "?=" nl "\t" prefix))
"?=")))))

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

@ -0,0 +1,116 @@
/* disasm.c -- optional debugging utilities */
/* Copyright (c) 2009-2010 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",
"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 self, 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, self, SEXP_BYTECODE, bc);
}
if (! sexp_oportp(out)) {
return sexp_type_exception(ctx, self, SEXP_OPORT, 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", (long) ((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, self, 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_api_params(self, n), sexp bc, sexp out) {
return disasm(ctx, self, bc, out, 0);
}
sexp sexp_init_library (sexp ctx sexp_api_params(self, n), 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 directory-fold 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
is-a-tty?)
(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))

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

@ -0,0 +1,118 @@
(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"))
(define-c boolean (is-a-tty? "isatty") (port-or-fd))

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-2010 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), -1);
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 sexp_api_params(self, n)) {
return sexp_heap_walk(ctx, 0, 0);
}
static sexp sexp_heap_dump (sexp ctx sexp_api_params(self, n), sexp depth) {
if (! sexp_fixnump(depth) || (sexp_unbox_fixnum(depth) < 0))
return sexp_xtype_exception(ctx, self, "bad heap-dump depth", depth);
return sexp_heap_walk(ctx, sexp_unbox_fixnum(depth), 1);
}
sexp sexp_init_library (sexp ctx sexp_api_params(self, n), 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;
}

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

@ -0,0 +1,6 @@
(define-module (chibi heap-stats)
(export heap-stats heap-dump)
(import-immutable (scheme))
(include-shared "heap-stats"))

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

@ -0,0 +1,13 @@
(define-module (chibi io)
(export read-string read-string! write-string read-line write-line
port-fold port-fold-right port-map
port->list port->string-list port->sexp-list port->string
file-position set-file-position! seek/set seek/cur seek/end
make-custom-input-port make-custom-output-port
make-null-output-port make-broadcast-port make-concatenated-port
make-generated-input-port make-filtered-output-port
make-filtered-input-port)
(import-immutable (scheme))
(include-shared "io/io")
(include "io/io.scm"))

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

@ -0,0 +1,170 @@
;; io.scm -- various input/output utilities
;; Copyright (c) 2010 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utilities
(define eof
(call-with-input-string " "
(lambda (in) (read-char in) (read-char in))))
(define (string-copy! dst start src from to)
(do ((i from (+ i 1)) (j start (+ j 1)))
((>= i to))
(string-set! dst j (string-ref src i))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; reading and writing
(define (write-line str . o)
(let ((out (if (pair? o) (car o) (current-output-port))))
(display str out)
(newline out)))
(define (read-line . o)
(let ((in (if (pair? o) (car o) (current-input-port)))
(n (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) 8192)))
(let ((res (%read-line n in)))
(if (not res)
eof
(let ((len (string-length res)))
(if (and (> len 0) (eqv? #\newline (string-ref res (- len 1))))
(if (and (> len 1) (eqv? #\return (string-ref res (- len 2))))
(substring res 0 (- len 2))
(substring res 0 (- len 1)))
res))))))
(define (read-string n . o)
(let ((in (if (pair? o) (car o) (current-input-port))))
(let ((res (%read-string n in)))
(if (if (pair? res) (= 0 (car res)) #t)
eof
(cadr res)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; higher order port operations
(define (port-fold kons knil . o)
(let ((read (if (pair? o) (car o) read))
(in (if (and (pair? o) (pair? (cdr o)))
(car (cdr o))
(current-input-port))))
(let lp ((acc knil))
(let ((x (read in)))
(if (eof-object? x) acc (lp (kons x acc)))))))
(define (port-fold-right kons knil . o)
(let ((read (if (pair? o) (car o) read))
(in (if (and (pair? o) (pair? (cdr o)))
(car (cdr o))
(current-input-port))))
(let lp ()
(let ((x (read in)))
(if (eof-object? x) knil (kons x (lp)))))))
(define (port-map fn . o)
(reverse (apply port-fold (lambda (x ls) (cons (fn x) ls)) '() o)))
(define (port->list read in)
(port-map (lambda (x) x) read in))
(define (port->sexp-list in)
(port->list read in))
(define (port->string-list in)
(port->list read-line in))
(define (port->string in)
(string-concatenate (port->list (lambda (in) (read-string 1024 in)) in)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; custom port utilities
(define (make-custom-input-port read . o)
(let ((seek (and (pair? o) (car o)))
(close (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
(%make-custom-input-port read seek close)))
(define (make-custom-output-port write . o)
(let ((seek (and (pair? o) (car o)))
(close (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
(%make-custom-output-port write seek close)))
(define (make-null-output-port)
(make-custom-output-port (lambda (str n) 0)))
(define (make-broadcast-port . ports)
(make-custom-output-port
(lambda (str n)
(for-each (lambda (p) (write-string str n p)) ports)
n)))
(define (make-filtered-output-port filter out)
(make-custom-output-port
(lambda (str n)
(let* ((len (string-length str))
(s1 (if (= n len) str (substring str 0 n)))
(s2 (filter s1)))
(if (string? s2)
(write-string s2 (string-length s2) out))))))
(define (make-concatenated-port . ports)
(make-custom-input-port
(lambda (str n)
(if (null? ports)
0
(let lp ((i (read-string! str n (car ports))))
(cond
((>= i n)
i)
(else
(set! ports (cdr ports))
(cond
((null? ports)
i)
(else
(let* ((s (read-string (- n i) (car ports)))
(len (if (string? s) (string-length s) 0)))
(if (and (string? str) (> len 0))
(string-copy! str i s 0 len))
(lp (+ i len))))))))))))
(define (make-generated-input-port generator)
(let ((buf "")
(len 0)
(offset 0))
(make-custom-input-port
(lambda (str n)
(cond
((>= (- len offset) n)
(string-copy! str 0 buf offset (+ offset n))
(set! offset (+ offset n))
n)
(else
(string-copy! str 0 buf offset len)
(let lp ((i (- len offset)))
(set! buf (generator))
(cond
((not (string? buf))
(set! buf "")
(set! len 0)
(set! offset 0)
(- n i))
(else
(set! len (string-length buf))
(set! offset 0)
(cond
((>= (- len offset) (- n i))
(string-copy! str i buf offset (+ offset (- n i)))
(set! offset (+ offset (- n i)))
n)
(else
(string-copy! str i buf offset len)
(lp (+ i (- len offset))))))))))))))
(define (make-filtered-input-port filter in)
(make-generated-input-port
(lambda ()
(let ((res (read-string 1024 in)))
(if (string? res) (filter res) res)))))

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

@ -0,0 +1,27 @@
(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 arg2)) (value 1 size_t) size_t (default (current-input-port) input-port)))
(define-c size_t (read-string! "fread")
(string (value 1 size_t) size_t (default (current-input-port) input-port)))
(define-c size_t (write-string "fwrite")
(string (value 1 size_t) size_t (default (current-output-port) output-port)))
(define-c-const int (seek/set "SEEK_SET"))
(define-c-const int (seek/cur "SEEK_CUR"))
(define-c-const int (seek/end "SEEK_END"))
(define-c long (file-position "ftell") (port))
(define-c long (set-file-position! "fseek") (port long int))
(c-include "port.c")
(define-c sexp (%make-custom-input-port "sexp_make_custom_input_port")
((value ctx sexp) (value self sexp) sexp sexp sexp))
(define-c sexp (%make-custom-output-port "sexp_make_custom_output_port")
((value ctx sexp) (value self sexp) sexp sexp sexp))

196
lib/chibi/io/port.c Normal file
View file

@ -0,0 +1,196 @@
#include <stdio.h>
#include <chibi/eval.h>
#define SEXP_PORT_BUFFER_SIZE 1024
#define SEXP_LAST_CONTEXT_CHECK_LIMIT 256
#define sexp_cookie_ctx(vec) sexp_vector_ref((sexp)vec, SEXP_ZERO)
#define sexp_cookie_buffer(vec) sexp_vector_ref((sexp)vec, SEXP_ONE)
#define sexp_cookie_read(vec) sexp_vector_ref((sexp)vec, SEXP_TWO)
#define sexp_cookie_write(vec) sexp_vector_ref((sexp)vec, SEXP_THREE)
#define sexp_cookie_seek(vec) sexp_vector_ref((sexp)vec, SEXP_FOUR)
#define sexp_cookie_close(vec) sexp_vector_ref((sexp)vec, SEXP_FIVE)
#if ! SEXP_USE_BOEHM
static int sexp_in_heap_p (sexp_heap h, sexp p) {
for ( ; h; h = h->next)
if (((sexp)h < p) && (p < (sexp)((char*)h + h->size)))
return 1;
return 0;
}
#endif
static sexp sexp_last_context (sexp ctx, sexp *cstack) {
sexp res=SEXP_FALSE, p;
#if ! SEXP_USE_BOEHM
sexp_sint_t i;
sexp_heap h = sexp_context_heap(ctx);
for (i=0; i<SEXP_LAST_CONTEXT_CHECK_LIMIT; i++) {
p = cstack[i];
if (p && (p != ctx) && sexp_pointerp(p) && sexp_in_heap_p(h, p)
&& (sexp_pointer_tag(p) == SEXP_CONTEXT)
&& (sexp_context_heap(p) == h)) {
res = p;
break;
}
}
#endif
return res;
}
#if SEXP_BSD
static int sexp_cookie_reader (void *cookie, char *buffer, int size)
#else
static ssize_t sexp_cookie_reader (void *cookie, char *buffer, size_t size)
#endif
{
sexp vec = (sexp)cookie, ctx, res;
if (! sexp_procedurep(sexp_cookie_read(vec))) return -1;
sexp_gc_var2(ctx2, args);
ctx = sexp_cookie_ctx(vec);
ctx2 = sexp_last_context(ctx, (sexp*)&cookie);
sexp_gc_preserve2(ctx, ctx2, args);
if (size > sexp_string_length(sexp_cookie_buffer(vec)))
sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID);
args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size));
res = sexp_apply(ctx, sexp_cookie_read(vec), args);
sexp_gc_release2(ctx);
if (sexp_fixnump(res)) {
memcpy(buffer, sexp_string_data(sexp_cookie_buffer(vec)), sexp_unbox_fixnum(res));
return sexp_unbox_fixnum(res);
} else {
return -1;
}
}
#if SEXP_BSD
static int sexp_cookie_writer (void *cookie, const char *buffer, int size)
#else
static ssize_t sexp_cookie_writer (void *cookie, const char *buffer, size_t size)
#endif
{
sexp vec = (sexp)cookie, ctx, res;
if (! sexp_procedurep(sexp_cookie_write(vec))) return -1;
sexp_gc_var2(ctx2, args);
ctx = sexp_cookie_ctx(vec);
ctx2 = sexp_last_context(ctx, (sexp*)&cookie);
sexp_gc_preserve2(ctx, ctx2, args);
if (size > sexp_string_length(sexp_cookie_buffer(vec)))
sexp_cookie_buffer(vec) = sexp_make_string(ctx, sexp_make_fixnum(size), SEXP_VOID);
memcpy(sexp_string_data(sexp_cookie_buffer(vec)), buffer, size);
args = sexp_list2(ctx, sexp_cookie_buffer(vec), sexp_make_fixnum(size));
res = sexp_apply(ctx, sexp_cookie_write(vec), args);
sexp_gc_release2(ctx);
return (sexp_fixnump(res) ? sexp_unbox_fixnum(res) : -1);
}
#if ! SEXP_BSD
static int sexp_cookie_seeker (void *cookie, off64_t *position, int whence) {
sexp vec = (sexp)cookie, ctx, res;
if (! sexp_procedurep(sexp_cookie_seek(vec))) return -1;
sexp_gc_var2(ctx2, args);
ctx = sexp_cookie_ctx(vec);
ctx2 = sexp_last_context(ctx, (sexp*)&cookie);
sexp_gc_preserve2(ctx, ctx2, args);
args = sexp_make_integer(ctx, *position);
args = sexp_list2(ctx, args, sexp_make_fixnum(whence));
res = sexp_apply(ctx, sexp_cookie_seek(vec), args);
if (sexp_fixnump(res))
*position = sexp_unbox_fixnum(res);
sexp_gc_release2(ctx);
return sexp_fixnump(res);
}
#endif
static int sexp_cookie_cleaner (void *cookie) {
sexp vec = (sexp)cookie, ctx, res;
if (! sexp_procedurep(sexp_cookie_close(vec))) return 0;
ctx = sexp_cookie_ctx(vec);
res = sexp_apply(ctx, sexp_cookie_close(vec), SEXP_NULL);
return (sexp_exceptionp(res) ? -1 : sexp_truep(res));
}
#if ! SEXP_BSD
static cookie_io_functions_t sexp_cookie = {
.read = (cookie_read_function_t*)sexp_cookie_reader,
.write = (cookie_write_function_t*)sexp_cookie_writer,
.seek = (cookie_seek_function_t*)sexp_cookie_seeker,
.close = (cookie_close_function_t*)sexp_cookie_cleaner,
};
static cookie_io_functions_t sexp_cookie_no_seek = {
.read = (cookie_read_function_t*)sexp_cookie_reader,
.write = (cookie_write_function_t*)sexp_cookie_writer,
.seek = NULL,
.close = (cookie_close_function_t*)sexp_cookie_cleaner,
};
#endif
#if SEXP_USE_STRING_STREAMS
static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode,
sexp read, sexp write,
sexp seek, sexp close) {
FILE *in;
sexp res;
sexp_gc_var1(vec);
if (sexp_truep(read) && ! sexp_procedurep(read))
return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read);
if (sexp_truep(write) && ! sexp_procedurep(write))
return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write);
if (sexp_truep(seek) && ! sexp_procedurep(seek))
return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek);
if (sexp_truep(close) && ! sexp_procedurep(close))
return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close);
sexp_gc_preserve1(ctx, vec);
vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID);
sexp_cookie_ctx(vec) = ctx;
sexp_cookie_buffer(vec)
= sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID);
sexp_cookie_read(vec) = read;
sexp_cookie_write(vec) = write;
sexp_cookie_seek(vec) = seek;
sexp_cookie_close(vec) = close;
#if SEXP_BSD
in = funopen(vec,
(sexp_procedurep(read) ? sexp_cookie_reader : NULL),
(sexp_procedurep(write) ? sexp_cookie_writer : NULL),
NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */
(sexp_procedurep(close) ? sexp_cookie_cleaner : NULL));
#else
in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek));
#endif
if (! in) {
res = sexp_user_exception(ctx, self, "couldn't make custom port", read);
} else {
res = sexp_make_input_port(ctx, in, SEXP_FALSE);
sexp_port_cookie(res) = vec; /* for gc preserving */
}
sexp_gc_release1(ctx);
return res;
}
#else
static sexp sexp_make_custom_port (sexp ctx, sexp self,
char *mode, sexp read, sexp write,
sexp seek, sexp close) {
return sexp_user_exception(ctx, self, "custom ports not supported in this configuration", SEXP_NULL);
}
#endif
static sexp sexp_make_custom_input_port (sexp ctx, sexp self,
sexp read, sexp seek, sexp close) {
return sexp_make_custom_port(ctx, self, "r", read, SEXP_FALSE, seek, close);
}
static sexp sexp_make_custom_output_port (sexp ctx, sexp self,
sexp write, sexp seek, sexp close) {
sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close);
sexp_pointer_tag(res) = SEXP_OPORT;
return res;
}

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

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

@ -0,0 +1,7 @@
(define-module (chibi mime)
(export mime-ref assoc-ref mime-header-fold mime-headers->list
mime-parse-content-type mime-decode-header
mime-message-fold mime-message->sxml)
(import-immutable (scheme) (chibi base64) (chibi quoted-printable) (chibi io))
(include "mime.scm"))

410
lib/chibi/mime.scm Normal file
View file

@ -0,0 +1,410 @@
;; mime.scm -- RFC2045 MIME library
;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RFC2822 headers
;; Procedure: mime-header-fold kons knil [source [limit [kons-from]]]
;;
;; Performs a fold operation on the MIME headers of source which can be
;; either a string or port, and defaults to current-input-port. kons
;; is called on the three values:
;; kons header value accumulator
;; where accumulator begins with knil. Neither the header nor the
;; value are modified, except wrapped lines are handled for the value.
;;
;; The optional procedure KONS-FROM is a procedure to be called when
;; the first line of the headers is an "From <address> <date>" line, to
;; enable this procedure to be used as-is on mbox files and the like.
;; It defaults to KONS, and if such a line is found the fold will begin
;; with (KONS-FROM "%from" <address> (KONS-FROM "%date" <date> KNIL)).
;;
;; The optional LIMIT gives a limit on the number of headers to read.
;; Procedure: mime-headers->list [source]
;; Return an alist of the MIME headers from source with headers all
;; downcased.
;; Procedure: mime-parse-content-type str
;; Parses STR as a Content-Type style-value returning the list
;; (type (attr . val) ...)
;; For example:
;; (mime-parse-content-type
;; "text/html; CHARSET=US-ASCII; filename=index.html")
;; => ("text/html" ("charset" . "US-ASCII") ("filename" . "index.html"))
;; Procedure: mime-decode-header str
;; Replace all occurrences of RFC1522 =?ENC?...?= escapes in STR with
;; the appropriate decoded and charset converted value.
;; Procedure: mime-ref headers str [default]
;; A case-insensitive assoc-ref.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RFC2045 MIME encoding
;; Procedure: mime-message-fold src headers kons knil
;; Performs a fold operation on the given string or port SRC as a MIME
;; body corresponding to the headers give in HEADERS. KONS is called
;; on the successive values:
;;
;; KONS part-headers part-body accumulator
;;
;; where part-headers are the headers for the given MIME part (the
;; original headers for single-part MIME), part-body is the
;; appropriately decoded and charset-converted body of the message,
;; and the accumulator begins with KNIL.
;;
;; TODO: Extend mime-message-fold to (optionally?) pass KONS an
;; input-port instead of string for the body to handle very large bodies
;; (this is not much of an issue for SMTP since the messages are in
;; practice limited, but it could be problematic for large HTTP bodies).
;;
;; This does a depth-first search, folding in sequence. It should
;; probably be doing a tree-fold as in html-parser.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define mime-line-length-limit 4096)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; association lists
(define (assoc* key ls . o)
(let ((eq (if (pair? o) (car o) equal?)))
(let lp ((ls ls))
(cond
((null? ls) #f)
((eq key (caar ls)) (car ls))
(else (lp (cdr ls)))))))
(define (assoc-ref ls key . o)
(let ((default (and (pair? o) (car o)))
(eq (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) equal?)))
(cond ((assoc* key ls eq) => cdr)
(else default))))
(define (mime-ref ls key . o)
(assoc-ref ls key (and (pair? o) (car o)) string-ci=?))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; simple matching instead of regexps
(define (match-mbox-from-line line)
(let ((len (string-length line)))
(and (> len 5)
(string=? (substring line 0 5) "From ")
(let lp ((i 6))
(cond
((= i len) (list (substring line 5 len) ""))
((memq (string-ref line i) '(#\space #\tab))
(list (substring line 5 i) (substring line (+ i 1) len)))
(else (lp (+ i 1))))))))
(define (string-scan-colon-or-maybe-equal str)
(let ((len (string-length str)))
(let lp ((i 0) (best #f))
(if (= i len)
best
(let ((c (string-ref str i)))
(cond ((or (char-alphabetic? c)
(char-numeric? c)
(memv c '(#\- #\_)))
(lp (+ i 1) best))
((eq? c #\:)
(if (= i 0) #f i))
((eqv? c #\=)
(lp (+ i 1) (or best i)))
(else
best)))))))
(define (string-skip-white-space str i)
(let ((lim (string-length str)))
(let lp ((i i))
(cond ((>= i lim) lim)
((char-whitespace? (string-ref str i)) (lp (+ i 1)))
(else i)))))
(define (match-mime-header-line line)
(let ((i (string-scan-colon-or-maybe-equal line)))
(and i
(let ((j (string-skip-white-space line (+ i 1))))
(list (substring line 0 i)
(substring line j (string-length line)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; dummy encoder
(define (ces-convert str . x)
str)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; some srfi-13 & string utils
(define (string-copy! to tstart from . o)
(let ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length from))))
(let lp ((i start) (j tstart))
(cond
((< i end)
(string-set! to j (string-ref from i))
(lp (+ i 1) (+ j 1)))))))
(define (string-concatenate-reverse ls)
(let lp ((ls ls) (rev '()) (len 0))
(if (null? ls)
(let ((res (make-string len)))
(let lp ((ls rev) (i 0))
(cond
((null? ls)
res)
(else
(string-copy! res i (car ls))
(lp (cdr ls) (+ i (string-length (car ls))))))))
(lp (cdr ls) (cons (car ls) rev) (+ len (string-length (car ls)))))))
(define (string-downcase s . o)
(let ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length s))))
(let* ((len (- end start)) (s2 (make-string len)))
(let lp ((i start) (j 0))
(cond
((>= i end)
s2)
(else
(string-set! s2 j (char-downcase (string-ref s i)))
(lp (+ i 1) (+ j 1))))))))
(define (string-char-index str c . 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)
((eq? c (string-ref str i)) i)
(else (lp (+ i 1)))))))
(define (string-trim-white-space s)
(let ((len (string-length s)))
(let lp ((i 0))
(cond ((= i len) "")
((char-whitespace? (string-ref s i)) (lp (+ i 1)))
(else
(let lp ((j (- len 1)))
(cond ((<= j i) "")
((char-whitespace? (string-ref s j)) (lp (- j 1)))
(else (substring s i (+ j 1))))))))))
(define (string-split str ch)
(let ((len (string-length str)))
(let lp ((i 0) (res '()))
(let ((j (string-char-index str ch i)))
(if j
(lp (+ j 1) (cons (substring str i j) res))
(reverse (cons (substring str i len) res)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; header parsing
(define (mime-header-fold kons knil . o)
(let ((src (and (pair? o) (car o)))
(limit (and (pair? o) (pair? (cdr o)) (car (cdr o))))
(kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (caddr o) kons)))
((if (string? src) mime-header-fold-string mime-header-fold-port)
kons knil (or src (current-input-port)) limit kons-from)))
(define (mime-header-fold-string kons knil str limit kons-from)
(call-with-input-string str
(lambda (in) (mime-header-fold-port kons knil in limit kons-from))))
(define (mime-header-fold-port kons knil port limit kons-from)
(define (out line acc count)
(cond
((or (and limit (> count limit)) (eof-object? line) (string=? line ""))
acc)
((match-mime-header-line line)
=> (lambda (m) (in (car m) (list (cadr m)) acc (+ count 1))))
(else
;;(warn "invalid header line: ~S\n" line)
(out (read-line port mime-line-length-limit) acc (+ count 1)))))
(define (in header value acc count)
(let ((line (read-line port mime-line-length-limit)))
(cond
((and limit (> count limit))
acc)
((or (eof-object? line) (string=? line ""))
(kons header (string-concatenate-reverse value) acc))
((char-whitespace? (string-ref line 0))
(in header (cons line value) acc (+ count 1)))
(else
(out line
(kons header (string-concatenate-reverse value) acc)
(+ count 1))))))
(let ((first-line (read-line port mime-line-length-limit)))
(cond
((eof-object? first-line)
knil)
((and kons-from (match-mbox-from-line first-line))
=> (lambda (m) ; special case check on first line for mbox files
(out (read-line port mime-line-length-limit)
(kons-from "%from" (car m)
(kons-from "%date" (cadr m) knil))
0)))
(else
(out first-line knil 0)))))
(define (mime-headers->list . o)
(reverse
(apply
mime-header-fold
(lambda (h v acc) (cons (cons (string-downcase h) v) acc))
'()
o)))
(define (mime-split-name+value s)
(let ((i (string-char-index s #\=)))
(if i
(cons (string-downcase (string-trim-white-space (substring s 0 i)))
(if (= i (string-length s))
""
(if (eqv? #\" (string-ref s (+ i 1)))
(substring s (+ i 2) (- (string-length s) 1))
(substring s (+ i 1) (string-length s)))))
(cons (string-downcase (string-trim-white-space s)) ""))))
(define (mime-parse-content-type str)
(map mime-split-name+value (string-split str #\;)))
(define (mime-decode-header str)
(let* ((len (string-length str))
(limit (- len 8))) ; need at least 8 chars: "=?Q?X??="
(let lp ((i 0) (from 0) (res '()))
(if (>= i limit)
(string-concatenate (reverse (cons (substring str from len) res)))
(if (and (eqv? #\= (string-ref str i))
(eqv? #\? (string-ref str (+ i 1))))
(let* ((j (string-char-index str #\? (+ i 3)))
(k (string-char-index str #\? (+ j 3))))
(if (and j k (< (+ k 1) len)
(eqv? #\? (string-ref str (+ j 2)))
(memq (string-ref str (+ j 1)) '(#\Q #\B #\q #\b))
(eqv? #\= (string-ref str (+ k 1))))
(let ((decode (if (memq (string-ref str (+ j 1)) '(#\Q #\q))
quoted-printable-decode-string
base64-decode-string))
(cset (substring str (+ i 2) j))
(content (substring str (+ j 3) k))
(k2 (+ k 2)))
(lp k2 k2 (cons (ces-convert (decode content) cset)
(cons (substring str from i) res))))
(lp (+ i 2) from res)))
(lp (+ i 1) from res))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; message parsing
(define (mime-read-to-boundary port boundary next final)
(let ((final-boundary (and boundary (string-append boundary "--"))))
(let lp ((res '()))
(let ((line (read-line port mime-line-length-limit)))
(cond
((or (eof-object? line) (equal? line final-boundary))
(final (string-concatenate (reverse res)
(call-with-output-string newline))))
((equal? line boundary)
(next (string-concatenate (reverse res)
(call-with-output-string newline))))
(else
(lp (cons line res))))))))
(define (mime-convert-part str cte enc)
(let ((str (cond
((and (string? cte) (string-ci=? cte "quoted-printable"))
(quoted-printable-decode-string str))
((and (string? cte) (string-ci=? cte "base64"))
(base64-decode-string str))
(else
str))))
(if (string? enc) (ces-convert str enc) str)))
(define (mime-read-part port cte enc boundary next final)
(mime-read-to-boundary
port boundary
(lambda (x) (next (mime-convert-part x cte enc)))
(lambda (x) (final (mime-convert-part x cte enc)))))
;; (kons parent-headers part-headers part-body seed)
;; (start headers seed)
;; (end headers parent-seed seed)
(define (mime-message-fold src kons init-seed . o)
(let ((port (if (string? src) (open-input-string src) src)))
(let ((kons-start
(if (pair? o) (car o) (lambda (headers seed) '())))
(kons-end
(if (and (pair? o) (pair? (cdr o)))
(car (cdr o))
(lambda (headers parent-seed seed)
`((mime (^ ,@headers)
,@(if (pair? seed) (reverse seed) seed))
,@parent-seed))))
(headers
(if (and (pair? o) (pair? (cdr o)) (pair? (cdr (cdr o))))
(car (cdr (cdr o)))
(mime-headers->list port))))
(let tfold ((parent-headers '())
(headers headers)
(seed init-seed)
(boundary #f)
(next (lambda (x) x))
(final (lambda (x) x)))
(let* ((ctype (mime-parse-content-type
(mime-ref headers "Content-Type" "text/plain")))
(type (string-trim-white-space (caar ctype)))
(enc (string-trim-white-space
(or (mime-ref ctype "charset")
(mime-ref headers "charset" "ASCII"))))
(cte (string-trim-white-space
(or (mime-ref headers "Content-Transfer-Encoding")
(mime-ref headers "Encoding" "7-bit")))))
(cond
((and (string-ci=? type "multipart/")
(mime-ref ctype "boundary"))
=> (lambda (boundary2)
(let ((boundary2 (string-append "--" boundary2)))
;; skip preamble
(mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x))
(let lp ((part-seed (kons-start headers seed)))
(let ((part-headers (mime-headers->list port)))
(tfold parent-headers part-headers
part-seed boundary2
lp
(lambda (x)
;; skip epilogue
(if boundary
(mime-read-to-boundary port boundary
(lambda (x) x) (lambda (x) x)))
(next (kons-end headers seed x)))
))))))
(else
(mime-read-part
port cte enc boundary
(lambda (x) (next (kons parent-headers headers x seed)))
(lambda (x) (final (kons parent-headers headers x seed)))))))))))
;; (mime (^ (header . value) ...) parts ...)
(define (mime-message->sxml . o)
(car
(apply
mime-message-fold
(if (pair? o) (car o) (current-input-port))
(lambda (parent-headers headers body seed)
`((mime (^ ,@headers) ,body) ,@seed))
'()
(lambda (headers seed) '())
(lambda (headers parent-seed seed)
`((mime (^ ,@headers)
,@(if (pair? seed) (reverse seed) seed))
,@parent-seed))
(if (pair? o) (cdr o) '()))))

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

@ -0,0 +1,11 @@
(define-module (chibi net)
(export sockaddr? address-info? get-address-info socket connect
with-net-io open-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"))

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

@ -0,0 +1,32 @@
;; net.scm -- the high-level network interface
;; Copyright (c) 2010 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (open-net-io host service)
(let lp ((addr (get-address-info host
(if (integer? service)
(number->string service)
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))
(list (open-input-file-descriptor sock)
(open-output-file-descriptor sock))))))))
(define (with-net-io host service proc)
(let ((io (open-net-io host service)))
(if (not (pair? io))
(error "couldn't find address" host service)
(let ((res (proc (car io) (car (cdr io)))))
(close-input-port (car io))
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/net/http.module Normal file
View file

@ -0,0 +1,7 @@
(define-module (chibi net http)
(export http-get call-with-input-url with-input-from-url
http-parse-request http-parse-form)
(import-immutable (scheme) (srfi 39) (chibi net) (chibi io)
(chibi uri) (chibi mime))
(include "http.scm"))

180
lib/chibi/net/http.scm Normal file
View file

@ -0,0 +1,180 @@
;; http.scm -- http client
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; string utils
(define (string-char-index str c . 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)
((eq? c (string-ref str i)) i)
(else (lp (+ i 1)))))))
(define (string-split str ch)
(let ((len (string-length str)))
(let lp ((i 0) (res '()))
(let ((j (string-char-index str ch i)))
(if j
(lp (+ j 1) (cons (substring str i j) res))
(reverse (cons (substring str i len) res)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; client utils
(define http-user-agent "chibi")
(define http-redirect-limit 10)
(define http-chunked-buffer-size 4096)
(define http-chunked-size-limit 409600)
(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 (http-parse-response line)
(let* ((len (string-length line))
(i (or (string-scan line #\space 0 len) len))
(j (or (string-scan line #\space (+ i 1) len) len))
(n (and (< i j) (string->number (substring line (+ i 1) j)))))
(if (not (integer? n))
(error "bad response" line i j)
(list (substring line 0 i)
n
(if (>= j len) "" (substring line (+ j 1) len))))))
(define (http-wrap-chunked-input-port in)
(define (read-chunk in)
(let* ((line (read-line in))
(n (and (string? line) (string->number line 16))))
(display "read-chunk ") (write line) (newline)
(cond
((not (and (integer? n) (<= 0 n http-chunked-size-limit)))
(error "invalid chunked size line" line))
((zero? n) "")
(else (read-string n in)))))
(make-generated-input-port
(lambda () (read-chunk in))))
(define (http-get/raw url in-headers limit)
(if (<= limit 0)
(error "http-get: redirect limit reached" url)
(let* ((uri (if (uri? url) url (string->uri url)))
(host (and uri (uri-host uri))))
(if (not host)
(error "invalid url" url)
(let* ((io (open-net-io
host
(or (uri-port uri)
(if (eq? 'https (uri-scheme uri)) 443 80))))
(in (car io))
(out (car (cdr io))))
(display "GET " out)
(display (or (uri-path uri) "/") out)
(display " HTTP/1.0\r\n" out)
(display "Host: " out) (display host out) (display "\r\n" out)
(cond
((not (mime-ref in-headers "user-agent"))
(display "User-Agent: " out)
(display http-user-agent out)
(display "\r\n" out)))
(for-each
(lambda (x)
(display (car x) out) (display ": " out)
(display (cdr x) out) (display "\r\n" out))
in-headers)
(display "Connection: close\r\n\r\n" out)
(flush-output out)
(let* ((resp (http-parse-response (read-line in)))
(headers (mime-headers->list in))
(status (quotient (cadr resp) 100)))
(case status
((2)
(let ((enc (mime-ref headers "transfer-encoding")))
(cond
((equal? enc "chunked")
(http-wrap-chunked-input-port in))
(else
in))))
((3)
(close-input-port in)
(close-output-port out)
(let ((url2 (mime-ref headers "location")))
(if url2
(http-get/raw url2 in-headers (- limit 1))
(error "redirect with no location header"))))
(else
(close-input-port in)
(close-output-port out)
(error "couldn't retrieve url" url resp)))))))))
(define (http-get url . headers)
(http-get/raw url
(if (pair? headers) (car headers) '())
http-redirect-limit))
(define (call-with-input-url url proc)
(let* ((p (http-get url))
(res (proc p)))
(close-input-port p)
res))
(define (with-input-from-url url thunk)
(let ((p (http-get url)))
(let ((res (parameterize ((current-input-port p)) (thunk))))
(close-input-port p)
res)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; server utils
;; read and parse a request line
(define (http-parse-request . o)
(let ((line (string-split
(read-line (if (pair? o) (car o) (current-input-port)) 4096))))
(cons (string->symbol (car line)) (cdr line))))
;; Parse a form body with a given URI and MIME headers (as parsed with
;; mime-headers->list). Returns an alist of (name . value) for every
;; query or form parameter.
(define (http-parse-form uri headers . o)
(let* ((in (if (pair? o) (car o) (current-input-port)))
(type (mime-ref headers
"content-type"
"application/x-www-form-urlencoded"))
(query0 (or (uri-query (if (string? uri) (string->uri uri) uri)) '()))
(query (if (string? query0) (uri-query->alist query0) query0)))
(cond
((string-ci=? "multipart/" type)
(let ((mime (mime-message->sxml in headers)))
(append
(let lp ((ls (cddr mime))
(res '()))
(cond
((null? ls)
res)
((and (pair? (car ls))
(eq? 'mime (caar ls))
(pair? (cdar ls))
(pair? (cadar ls))
(memq (caadar ls) '(^ @)))
(let* ((disp0 (mime-ref (cdadar ls) "content-disposition" ""))
(disp (mime-parse-content-type disp0))
(name (mime-ref disp "name")))
(if name
(lp (cdr ls) (cons (cons name (caddar ls)) res))
(lp (cdr ls) res))))
(else
(lp (cdr ls) res))))
query)))
(else
query))))

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) (value self 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)))

7
lib/chibi/quoted-printable.module Normal file
View file

@ -0,0 +1,7 @@
(define-module (chibi quoted-printable)
(export quoted-printable-encode quoted-printable-encode-string
quoted-printable-encode-header
quoted-printable-decode quoted-printable-decode-string)
(import-immutable (scheme) (srfi 33) (chibi io))
(include "quoted-printable.scm"))

157
lib/chibi/quoted-printable.scm Normal file
View file

@ -0,0 +1,157 @@
;; quoted-printable.scm -- RFC2045 implementation
;; Copyright (c) 2005-2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;; Procedure: quoted-printable-encode-string str [start-col max-col]
;; Return a quoted-printable encoded representation of string
;; according to the official standard as described in RFC2045.
;;
;; ? and _ are always encoded for compatibility with RFC1522 encoding,
;; and soft newlines are inserted as necessary to keep each lines
;; length less than MAX-COL (default 76). The starting column may be
;; overridden with START-COL (default 0).
;; Procedure: quoted-printable-decode-string str [mime?]
;; Return a quoted-printable decoded representation of string. If
;; MIME? is specified and true, _ will be decoded as as space in
;; accordance with RFC1522. No errors will be raised on invalid
;; input.
;; Procedure: quoted-printable-encode [port start-col max-col]
;; Procedure: quoted-printable-decode [port start-col max-col]
;; Variations of the above which read and write to ports.
;; Procedure: quoted-printable-encode-header enc str [start-col max-col]
;; Return a quoted-printable encoded representation of string as
;; above, wrapped in =?ENC?Q?...?= as per RFC1522, split across
;; multiple MIME-header lines as needed to keep each lines length less
;; than MAX-COL. The string is encoded as is, and the encoding ENC is
;; just used for the prefix, i.e. you are responsible for ensuring STR
;; is already encoded according to ENC.
;; Example:
;; (define (mime-encode-header header value charset)
;; (let ((prefix (string-append header ": "))
;; (str (ces-convert value "UTF8" charset)))
;; (string-append
;; prefix
;; (quoted-printable-encode-header charset str (string-length prefix)))))
;; This API is backwards compatible with the Gauche library
;; rfc.quoted-printable.
(define *default-max-col* 76)
;; Allow for RFC1522 quoting for headers by always escaping ? and _
(define (qp-encode str start-col max-col separator)
(define (hex i) (integer->char (+ i (if (<= i 9) 48 55))))
(let ((end (string-length str))
(buf (make-string max-col)))
(let lp ((i 0) (col start-col) (res '()))
(cond
((= i end)
(if (pair? res)
(string-concatenate (reverse (cons (substring buf 0 col) res))
separator)
(substring buf start-col col)))
((>= col (- max-col 3))
(lp i 0 (cons (substring buf (if (pair? res) 0 start-col) col) res)))
(else
(let ((c (char->integer (string-ref str i))))
(cond
((and (<= 33 c 126) (not (memq c '(61 63 95))))
(string-set! buf col (integer->char c))
(lp (+ i 1) (+ col 1) res))
(else
(string-set! buf col #\=)
(string-set! buf (+ col 1) (hex (arithmetic-shift c -4)))
(string-set! buf (+ col 2) (hex (bitwise-and c #b1111)))
(lp (+ i 1) (+ col 3) res)))))))))
(define (quoted-printable-encode-string . o)
(let ((src (if (pair? o) (car o) (current-input-port)))
(start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
(max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
(caddr o)
*default-max-col*)))
(qp-encode (if (string? src) src (read-string #f src))
start-col max-col "=\r\n")))
(define (quoted-printable-encode . o)
(display (apply (quoted-printable-encode-string o))))
(define (quoted-printable-encode-header encoding . o)
(let ((src (if (pair? o) (car o) (current-input-port)))
(start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
(max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
(caddr o)
*default-max-col*))
(nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdddr o)))
(cadddr o)
"\r\n")))
(let* ((prefix (string-append "=?" encoding "?Q?"))
(prefix-length (+ 2 (string-length prefix)))
(separator (string-append "?=" nl "\t" prefix))
(effective-max-col (- max-col prefix-length)))
(string-append prefix
(qp-encode (if (string? src) src (read-string #f src))
start-col effective-max-col separator)
"?="))))
(define (quoted-printable-decode-string . o)
(define (hex? c) (or (char-numeric? c) (<= 65 (char->integer c) 70)))
(define (unhex1 c)
(let ((i (char->integer c))) (if (>= i 65) (- i 55) (- i 48))))
(define (unhex c1 c2)
(integer->char (+ (arithmetic-shift (unhex1 c1) 4) (unhex1 c2))))
(let ((src (if (pair? o) (car o) (current-input-port)))
(mime-header? (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
(let* ((str (if (string? src) src (read-string #f src)))
(end (string-length str)))
(call-with-output-string
(lambda (out)
(let lp ((i 0))
(cond
((< i end)
(let ((c (string-ref str i)))
(case c
((#\=) ; = escapes
(cond
((< (+ i 2) end)
(let ((c2 (string-ref str (+ i 1))))
(cond
((eq? c2 #\newline) (lp (+ i 2)))
((eq? c2 #\return)
(lp (if (eq? (string-ref str (+ i 2)) #\newline)
(+ i 3)
(+ i 2))))
((hex? c2)
(let ((c3 (string-ref str (+ i 2))))
(if (hex? c3) (write-char (unhex c2 c3) out))
(lp (+ i 3))))
(else (lp (+ i 3))))))))
((#\_) ; maybe translate _ to space
(write-char (if mime-header? #\space c) out)
(lp (+ i 1)))
((#\space #\tab) ; strip trailing whitespace
(let lp2 ((j (+ i 1)))
(cond
((not (= j end))
(case (string-ref str j)
((#\space #\tab) (lp2 (+ j 1)))
((#\newline)
(lp (+ j 1)))
((#\return)
(let ((k (+ j 1)))
(lp (if (and (< k end)
(eqv? #\newline (string-ref str k)))
(+ k 1) k))))
(else (display (substring str i j) out) (lp j)))))))
(else ; a literal char
(write-char c out)
(lp (+ i 1)))))))))))))
(define (quoted-printable-decode . o)
(display (apply quoted-printable-decode-string o)))

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 self, 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_xtype_exception(ctx, self, "not a valid signal number", signum);
if (! (sexp_procedurep(newaction) || sexp_opcodep(newaction)
|| sexp_booleanp(newaction)))
return sexp_type_exception(ctx, self, SEXP_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, self, "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;
}

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

@ -0,0 +1,11 @@
(define-module (chibi stty)
(export stty with-stty with-raw-io
get-terminal-width get-terminal-dimensions
TCSANOW TCSADRAIN TCSAFLUSH)
(import-immutable (scheme)
(srfi 33)
(srfi 69))
(include-shared "stty")
(include "stty.scm"))

235
lib/chibi/stty.scm Normal file
View file

@ -0,0 +1,235 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; symbolic representation of attributes
(define stty-lookup (make-hash-table eq?))
(for-each
(lambda (c)
(let ((type (cadr c))
(value (caddr c)))
(hash-table-set! stty-lookup (car c) (cdr c))))
;; ripped from the stty man page, then trimmed down to what seemed
;; available on most systems
`(;; characters
;;(dsusp char ,VDSUSP) ; CHAR will send a terminal stop signal
(eof char ,VEOF) ; CHAR will send an EOF (terminate input)
(eol char ,VEOL) ; CHAR will end the line
(eol2 char ,VEOL2) ; alternate CHAR for ending the line
(erase char ,VERASE) ; CHAR will erase the last character typed
(intr char ,VINTR) ; CHAR will send an interrupt signal
(kill char ,VKILL) ; CHAR will erase the current line
(lnext char ,VLNEXT) ; CHAR will enter the next character quoted
(quit char ,VQUIT) ; CHAR will send a quit signal
(rprnt char ,VREPRINT) ; CHAR will redraw the current line
(start char ,VSTART) ; CHAR will restart output after stopping it
(stop char ,VSTOP) ; CHAR will stop the output
(susp char ,VSUSP) ; CHAR will send a terminal stop signal
(werase char ,VWERASE) ; CHAR will erase the last word typed
;; special settings
(cols special #f) ; tell the kernel that the terminal has N columns
(columns special #f) ; same as cols N
(ispeed special #f) ; set the input speed to N
(line special #f) ; use line discipline N
(min special #f) ; with -icanon, set N characters minimum for a completed read
(ospeed special #f) ; set the output speed to N
(rows special #f) ; tell the kernel that the terminal has N rows
(size special #f) ; print the number of rows and columns according to the kernel
(speed special #f) ; print the terminal speed
(time special #f) ; with -icanon, set read timeout of N tenths of a second
;; control settings
(clocal control ,CLOCAL) ; disable modem control signals
(cread control ,CREAD) ; allow input to be received
(crtscts control ,CRTSCTS) ; enable RTS/CTS handshaking
(cs5 control ,CS5) ; set character size to 5 bits
(cs6 control ,CS6) ; set character size to 6 bits
(cs7 control ,CS7) ; set character size to 7 bits
(cs8 control ,CS8) ; set character size to 8 bits
(cstopb control ,CSTOPB) ; use two stop bits per character (one with `-')
(hup control ,HUPCL) ; send a hangup signal when the last process closes the tty
(hupcl control ,HUPCL) ; same as [-]hup
(parenb control ,PARENB) ; generate parity bit in output and expect parity bit in input
(parodd control ,PARODD) ; set odd parity (even with `-')
;; input settings
(brkint input ,BRKINT) ; breaks cause an interrupt signal
(icrnl input ,ICRNL) ; translate carriage return to newline
(ignbrk input ,IGNBRK) ; ignore break characters
(igncr input ,IGNCR) ; ignore carriage return
(ignpar input ,IGNPAR) ; ignore characters with parity errors
(imaxbel input ,IMAXBEL) ; * beep and do not flush a full input buffer on a character
(inlcr input ,INLCR) ; translate newline to carriage return
(inpck input ,INPCK) ; enable input parity checking
(istrip input ,ISTRIP) ; clear high (8th) bit of input characters
;;(iuclc input ,IUCLC) ; * translate uppercase characters to lowercase
(ixany input ,IXANY) ; * let any character restart output, not only start character
(ixoff input ,IXOFF) ; enable sending of start/stop characters
(ixon input ,IXON) ; enable XON/XOFF flow control
(parmrk input ,PARMRK) ; mark parity errors (with a 255-0-character sequence)
(tandem input ,IXOFF) ; same as [-]ixoff
;; output settings
;;(bs0 output ,BS0) ; backspace delay style, N in [0..1]
;;(bs1 output ,BS1) ; backspace delay style, N in [0..1]
;;(cr0 output ,CR0) ; carriage return delay style, N in [0..3]
;;(cr1 output ,CR1) ; carriage return delay style, N in [0..3]
;;(cr2 output ,CR2) ; carriage return delay style, N in [0..3]
;;(cr3 output ,CR3) ; carriage return delay style, N in [0..3]
;;(ff0 output ,FF0) ; form feed delay style, N in [0..1]
;;(ff1 output ,FF1) ; form feed delay style, N in [0..1]
;;(nl0 output ,NL0) ; newline delay style, N in [0..1]
;;(nl1 output ,NL1) ; newline delay style, N in [0..1]
(ocrnl output ,OCRNL) ; translate carriage return to newline
;;(ofdel output ,OFDEL) ; use delete characters for fill instead of null characters
;;(ofill output ,OFILL) ; use fill (padding) characters instead of timing for delays
;;(olcuc output ,OLCUC) ; translate lowercase characters to uppercase
(onlcr output ,ONLCR) ; translate newline to carriage return-newline
(onlret output ,ONLRET) ; newline performs a carriage return
(onocr output ,ONOCR) ; do not print carriage returns in the first column
(opost output ,OPOST) ; postprocess output
(tab0 output #f) ; horizontal tab delay style, N in [0..3]
(tab1 output #f) ; horizontal tab delay style, N in [0..3]
(tab2 output #f) ; horizontal tab delay style, N in [0..3]
(tab3 output #f) ; horizontal tab delay style, N in [0..3]
(tabs output #f) ; same as tab0
;;(-tabs output #f) ; same as tab3
;;(vt0 output ,VT0) ; vertical tab delay style, N in [0..1]
;;(vt1 output ,VT1) ; vertical tab delay style, N in [0..1]
;; local settings
(crterase local ,ECHOE) ; echo erase characters as backspace-space-backspace
(crtkill local ,ECHOKE) ; kill all line by obeying the echoprt and echoe settings
;;(-crtkill local #f) ; kill all line by obeying the echoctl and echok settings
(ctlecho local ,ECHOCTL) ; echo control characters in hat notation (`^c')
(echo local ,ECHO) ; echo input characters
(echoctl local ,ECHOCTL) ; same as [-]ctlecho
(echoe local ,ECHOE) ; same as [-]crterase
;;(echok local ,ECHOK) ; echo a newline after a kill character
(echoke local ,ECHOKE) ; same as [-]crtkill
(echonl local ,ECHONL) ; echo newline even if not echoing other characters
(echoprt local ,ECHOPRT) ; echo erased characters backward, between `\' and '/'
(icanon local ,ICANON) ; enable erase, kill, werase, and rprnt special characters
;;(iexten local ,IEXTEN) ; enable non-POSIX special characters
(isig local ,ISIG) ; enable interrupt, quit, and suspend special characters
(noflsh local ,NOFLSH) ; disable flushing after interrupt and quit special characters
(prterase local ,ECHOPRT) ; same as [-]echoprt
(tostop local ,TOSTOP) ; stop background jobs that try to write to the terminal
;;(xcase local ,XCASE) ; with icanon, escape with `\' for uppercase characters
;; combination settings
(LCASE combine (lcase))
(cbreak combine (not icanon))
(cooked combine (brkint ignpar istrip icrnl ixon opost isig icanon))
; also eof and eol characters
; to their default values
(crt combine (echoe echoctl echoke))
(dec combine (echoe echoctl echoke (not ixany)))
; also intr ^c erase 0177 kill ^u
(decctlq combine (ixany))
(ek combine ()) ; erase and kill characters to their default values
(evenp combine (parenb (not parodd) cs7))
;;(-evenp combine #f) ; same as -parenb cs8
(lcase combine (xcase iuclc olcuc))
(litout combine (cs8 (not parenb istrip opost)))
;;(-litout combine #f) ; same as parenb istrip opost cs7
(nl combine (not icrnl onlcr))
;;(-nl combine #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret
(oddp combine (parenb parodd cs7))
(parity combine (evenp)) ; same as [-]evenp
(pass8 combine (cs8 (not parenb istrip)))
;;(-pass8 combine #f) ; same as parenb istrip cs7
(raw combine (not ignbrk brkint ignpar parmrk
inpck istrip inlcr igncr icrnl))
(ixon combine (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc
;;(time combine #f) ; 0
;;(-raw combine #f) ; same as cooked
(sane combine (cread brkint icrnl imaxbel opost onlcr
isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0
echo echoe echoctl echoke ;; iexten echok
(not ignbrk igncr ixoff ixany inlcr ;; iuclc
ocrnl onocr onlret ;; olcuc ofill ofdel
echonl noflsh tostop echoprt))) ;; xcase
; plus all special characters to
; their default values
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; high-level interface
(define (port? x) (or (input-port? x) (output-port? x)))
(define (stty . args)
(let* ((port (if (and (pair? args) (port? (car args)))
(car args)
(current-output-port)))
(attr (get-terminal-attributes port)))
;; parse change requests
(let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args))
(iflag (term-attrs-iflag attr))
(oflag (term-attrs-oflag attr))
(cflag (term-attrs-cflag attr))
(lflag (term-attrs-lflag attr))
(invert? #f)
(return (lambda (iflag oflag cflag lflag)
(term-attrs-iflag-set! attr iflag)
(term-attrs-oflag-set! attr oflag)
(term-attrs-cflag-set! attr cflag)
(term-attrs-lflag-set! attr lflag)
(set-terminal-attributes! port TCSANOW attr))))
(define (join old new)
(if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new)))
(cond
((pair? lst)
(let ((command (car lst)))
(cond
((pair? command) ;; recurse on sub-expr
(lp command iflag oflag cflag lflag invert?
(lambda (i o c l) (lp (cdr lst) i o c l invert? return))))
((eq? command 'not) ;; toggle current setting
(lp (cdr lst) iflag oflag cflag lflag (not invert?) return))
(else
(let ((x (hash-table-ref/default stty-lookup command #f)))
(case (and x (car x))
((input)
(lp (cdr lst) (join iflag (cadr x)) oflag cflag lflag invert? return))
((output)
(lp (cdr lst) iflag (join oflag (cadr x)) cflag lflag invert? return))
((control)
(lp (cdr lst) iflag oflag (join cflag (cadr x)) lflag invert? return))
((local)
(lp (cdr lst) iflag oflag cflag (join lflag (cadr x)) invert? return))
((char)
;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0))
(lp (cddr lst) iflag oflag cflag lflag invert? return))
((combine)
(lp (cadr x) iflag oflag cflag lflag invert?
(lambda (i o c l) (lp (cdr lst) i o c l invert? return))))
((special)
(error "special settings not yet supported" command))
(else
(error "unknown stty command" command))))))))
(else
(return iflag oflag cflag lflag))))))
(define (with-stty setting thunk . o)
(let* ((port (if (pair? o) (car o) (current-input-port)))
(orig-attrs (get-terminal-attributes port)))
(dynamic-wind
(lambda () (stty setting))
thunk
(lambda () (set-terminal-attributes! port TCSANOW orig-attrs)))))
(define (with-raw-io port thunk)
(with-stty '(not icanon echo) thunk port))
(define (get-terminal-width x)
(let ((ws (ioctl x TIOCGWINSZ)))
(and ws (winsize-col ws))))
(define (get-terminal-dimensions x)
(let ((ws (ioctl x TIOCGWINSZ)))
(and ws (list (winsize-col ws) (winsize-row ws)))))

106
lib/chibi/stty.stub Normal file
View file

@ -0,0 +1,106 @@
(c-system-include "termios.h")
(c-system-include "sys/ioctl.h")
(define-c-struct termios
predicate: term-attrs?
constructor: (make-term-attrs)
(unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!)
(unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!)
(unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!)
(unsigned-long c_lflag term-attrs-lflag term-attrs-lflag-set!)
;;(unsigned-char (c_cc 22) term-attrs-cc term-attrs-cc-set!)
(unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!)
(unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!))
(define-c-struct winsize
predicate: winsize?
(unsigned-short ws_row winsize-row)
(unsigned-short ws_col winsize-col))
(define-c errno ioctl (port-or-fd unsigned-long (result winsize)))
(define-c-const int TIOCGWINSZ)
(define-c-const int TCSANOW)
(define-c-const int TCSADRAIN)
(define-c-const int TCSAFLUSH)
(define-c-const unsigned-long IGNBRK)
(define-c-const unsigned-long BRKINT)
(define-c-const unsigned-long IGNPAR)
(define-c-const unsigned-long PARMRK)
(define-c-const unsigned-long INPCK)
(define-c-const unsigned-long ISTRIP)
(define-c-const unsigned-long INLCR)
(define-c-const unsigned-long IGNCR)
(define-c-const unsigned-long ICRNL)
(define-c-const unsigned-long IXON)
(define-c-const unsigned-long IXOFF)
(define-c-const unsigned-long IXANY)
(define-c-const unsigned-long IMAXBEL)
;; (define-c-const unsigned-long IUCLC)
(define-c-const unsigned-long OPOST)
(define-c-const unsigned-long ONLCR)
;; (define-c-const unsigned-long OXTABS)
;; (define-c-const unsigned-long ONOEOT)
(define-c-const unsigned-long OCRNL)
;; (define-c-const unsigned-long OLCUC)
(define-c-const unsigned-long ONOCR)
(define-c-const unsigned-long ONLRET)
(define-c-const unsigned-long CSIZE)
(define-c-const unsigned-long CS5)
(define-c-const unsigned-long CS6)
(define-c-const unsigned-long CS7)
(define-c-const unsigned-long CS8)
(define-c-const unsigned-long CSTOPB)
(define-c-const unsigned-long CREAD)
(define-c-const unsigned-long PARENB)
(define-c-const unsigned-long PARODD)
(define-c-const unsigned-long HUPCL)
(define-c-const unsigned-long CLOCAL)
;; (define-c-const unsigned-long CCTS_OFLOW)
(define-c-const unsigned-long CRTSCTS)
;; (define-c-const unsigned-long CRTS_IFLOW)
;; (define-c-const unsigned-long MDMBUF)
(define-c-const unsigned-long ECHOKE)
(define-c-const unsigned-long ECHOE)
(define-c-const unsigned-long ECHO)
(define-c-const unsigned-long ECHONL)
(define-c-const unsigned-long ECHOPRT)
(define-c-const unsigned-long ECHOCTL)
(define-c-const unsigned-long ISIG)
(define-c-const unsigned-long ICANON)
;; (define-c-const unsigned-long ALTWERASE)
(define-c-const unsigned-long IEXTEN)
;; (define-c-const unsigned-long EXTPROC)
(define-c-const unsigned-long TOSTOP)
(define-c-const unsigned-long FLUSHO)
;; (define-c-const unsigned-long NOKERNINFO)
(define-c-const unsigned-long PENDIN)
(define-c-const unsigned-long NOFLSH)
(define-c-const unsigned-long VEOF)
(define-c-const unsigned-long VEOL)
(define-c-const unsigned-long VEOL2)
(define-c-const unsigned-long VERASE)
;; (define-c-const unsigned-long VERASE2)
(define-c-const unsigned-long VWERASE)
(define-c-const unsigned-long VINTR)
(define-c-const unsigned-long VKILL)
(define-c-const unsigned-long VQUIT)
(define-c-const unsigned-long VSUSP)
(define-c-const unsigned-long VSTART)
(define-c-const unsigned-long VSTOP)
;; (define-c-const unsigned-long VDSUSP)
(define-c-const unsigned-long VLNEXT)
(define-c-const unsigned-long VREPRINT)
;; (define-c-const unsigned-long VSTATUS)
(define-c errno (get-terminal-attributes "tcgetattr")
(port-or-fd (result termios)))
(define-c errno (set-terminal-attributes! "tcsetattr")
(port-or-fd int termios))

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

5
lib/chibi/term/edit-line.module Normal file
View file

@ -0,0 +1,5 @@
(define-module (chibi term edit-line)
(export edit-line edit-line-repl)
(import-immutable (scheme) (chibi stty) (srfi 9))
(include "edit-line.scm"))

492
lib/chibi/term/edit-line.scm Normal file
View file

@ -0,0 +1,492 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; vt100 terminal utilities
(define (terminal-escape out ch arg)
(write-char (integer->char 27) out)
(write-char #\[ out)
(if arg (display arg out))
(write-char ch out))
;; we use zero-based columns
(define (terminal-goto-col out n) (terminal-escape out #\G (+ n 1)))
(define (terminal-up out n) (terminal-escape out #\A n))
(define (terminal-down out n) (terminal-escape out #\B n))
(define (terminal-clear-below out) (terminal-escape out #\J #f))
(define (terminal-clear-right out) (terminal-escape out #\K #f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; history
(define maximum-history-size 128)
(define-record-type history
(%make-history remaining past future)
history?
(remaining history-remaining history-remaining-set!)
(past history-past history-past-set!)
(future history-future history-future-set!))
(define (make-history . o)
(%make-history (if (pair? o) (car o) maximum-history-size) '() '()))
(define (history-current h)
(let ((p (history-past h)))
(and (pair? p) (car p))))
(define (history->list h)
(let ((past (history-past h)) (future (history-future h)))
(if (pair? past) (cons (car past) (append future (cdr past))) future)))
(define (history-flatten! h)
(history-past-set! h (history->list h))
(history-future-set! h '()))
(define (drop-last ls) (reverse (cdr (reverse ls))))
(define (history-past-push! h x)
(if (positive? (history-remaining h))
(history-remaining-set! h (- (history-remaining h) 1))
(if (pair? (history-past h))
(history-past-set! h (drop-last (history-past h)))
(history-future-set! h (drop-last (history-future h)))))
(history-past-set! h (cons x (history-past h))))
(define (history-insert! h x)
(history-flatten! h)
(history-past-push! h x))
(define (history-commit! h x)
(cond
((pair? (history-future h))
(history-past-set!
h (cons x (append (drop-last (history-future h)) (history-past h))))
(history-future-set! h '()))
(else
(history-insert! h x))))
(define (history-prev! h)
(let ((past (history-past h)))
(and (pair? past)
(pair? (cdr past))
(begin
(history-future-set! h (cons (car past) (history-future h)))
(history-past-set! h (cdr past))
(cadr past)))))
(define (history-next! h)
(let ((future (history-future h)))
(and (pair? future)
(begin
(history-past-set! h (cons (car future) (history-past h)))
(history-future-set! h (cdr future))
(car future)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; char and string utils
(define (char-word-constituent? ch)
(or (char-alphabetic? ch) (char-numeric? ch)
(memv ch '(#\_ #\- #\+ #\:))))
(define (char-non-word-constituent? ch) (not (char-word-constituent? ch)))
(define (string-copy! dst dstart src start end)
(if (>= start dstart)
(do ((i start (+ i 1)) (j dstart (+ j 1)))
((= i end))
(string-set! dst j (string-ref src i)))
(do ((i (- end 1) (- i 1)) (j (+ dstart (- end start 1)) (- j 1)))
((< i start))
(string-set! dst j (string-ref src i)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; buffers
(define-record-type buffer
(%make-buffer refresh? min pos row max-row col gap width string history)
buffer?
(refresh? buffer-refresh? buffer-refresh?-set!)
(min buffer-min buffer-min-set!)
(pos buffer-pos buffer-pos-set!)
(row buffer-row buffer-row-set!)
(max-row buffer-max-row buffer-max-row-set!)
(col buffer-col buffer-col-set!)
(gap buffer-gap buffer-gap-set!)
(width buffer-width buffer-width-set!)
(string buffer-string buffer-string-set!)
(history buffer-history buffer-history-set!))
(define default-buffer-size 256)
(define default-buffer-width 80)
(define (make-buffer)
(%make-buffer #f 0 0 0 0 0 default-buffer-size default-buffer-width
(make-string default-buffer-size) '()))
(define (buffer->string buf)
(let ((str (buffer-string buf)))
(string-append (substring str (buffer-min buf) (buffer-pos buf))
(substring str (buffer-gap buf) (string-length str)))))
(define (buffer-right-length buf)
(- (string-length (buffer-string buf)) (buffer-gap buf)))
(define (buffer-length buf)
(+ (buffer-pos buf) (buffer-right-length buf)))
(define (buffer-free-space buf)
(- (buffer-gap buf) (buffer-pos buf)))
(define (buffer-clamp buf n)
(max (buffer-min buf) (min n (buffer-length buf))))
(define (buffer-resize buf n)
(cond ((<= (buffer-free-space buf) n)
(let* ((right-len (buffer-right-length buf))
(new-len (* 2 (max n (buffer-length buf))))
(new-gap (- new-len right-len))
(new (make-string new-len))
(old (buffer-string buf)))
(string-copy! new 0 old 0 (buffer-pos buf))
(string-copy! new new-gap old (buffer-gap buf) (string-length old))
(buffer-string-set! buf new)
(buffer-gap-set! buf new-gap)))))
(define (buffer-update-position! buf)
(let ((pos (buffer-pos buf))
(gap (buffer-gap buf))
(end (string-length (buffer-string buf)))
(width (buffer-width buf)))
(let lp ((i 0) (row 0) (col 0)) ;; update row/col
(cond ((= i pos)
(buffer-row-set! buf row)
(buffer-col-set! buf col)
(lp gap row col))
((>= i end)
(buffer-max-row-set!
buf (if (and (zero? col) (> row 0)) (- row 1) row)))
((= (+ col 1) width)
(lp (+ i 1) (+ row 1) 0))
(else
(lp (+ i 1) row (+ col 1)))))))
(define (buffer-draw buf out)
(let* ((gap (buffer-gap buf))
(str (buffer-string buf))
(end (string-length str))
(old-row (buffer-row buf))
(old-col (buffer-col buf)))
(buffer-update-position! buf)
;; goto start of input
(terminal-goto-col out 0)
(if (positive? old-row)
(terminal-up out old-row))
;; clear and display new buffer
(terminal-clear-below out)
(display (substring str 0 (buffer-pos buf)) out)
(display (substring str (buffer-gap buf) end) out)
;; move to next line if point at eol
(if (and (zero? (buffer-col buf)) (positive? (buffer-row buf)))
(write-char #\space out))
;; move to correct row then col
(if (< (buffer-row buf) (buffer-max-row buf))
(terminal-up out (- (buffer-max-row buf) (buffer-row buf))))
(terminal-goto-col out (buffer-col buf))))
(define (buffer-refresh buf out)
(cond ((buffer-refresh? buf)
(buffer-draw buf out)
(buffer-refresh?-set! buf #f))))
(define (buffer-goto! buf out n)
(let ((pos (buffer-pos buf))
(gap (buffer-gap buf))
(str (buffer-string buf))
(n (buffer-clamp buf n)))
(cond ((not (= n pos))
(buffer-update-position! buf) ;; XXXX shouldn't be needed
(if (< n pos)
(string-copy! str (- gap (- pos n)) str n pos)
(string-copy! str pos str gap (+ gap (- n pos))))
(buffer-pos-set! buf n)
(buffer-gap-set! buf (+ gap (- n pos)))
(cond
((not (buffer-refresh? buf))
(let ((old-row (buffer-row buf)))
(buffer-update-position! buf)
(let ((row-diff (- old-row (buffer-row buf))))
(cond ((> row-diff 0) (terminal-up out row-diff))
((< row-diff 0) (terminal-down out (- row-diff)))))
(terminal-goto-col out (buffer-col buf)))))))))
(define (buffer-insert! buf out x)
(let ((len (if (char? x) 1 (string-length x)))
(pos (buffer-pos buf)))
(buffer-resize buf len)
(if (char? x)
(string-set! (buffer-string buf) pos x)
(string-copy! (buffer-string buf) pos x 0 len))
(buffer-pos-set! buf (+ (buffer-pos buf) len))
(cond
((buffer-refresh? buf))
((and (= (buffer-gap buf) (string-length (buffer-string buf)))
(< (+ (buffer-col buf) len) (buffer-width buf)))
;; fast path - append to end of buffer w/o wrapping to next line
(display x out)
(buffer-col-set! buf (+ (buffer-col buf) len)))
(else
(buffer-refresh?-set! buf #t)))))
(define (buffer-delete! buf out start end)
(let ((pos (buffer-pos buf))
(gap (buffer-gap buf))
(str (buffer-string buf))
(start (buffer-clamp buf start))
(end (buffer-clamp buf end)))
(if (not (buffer-refresh? buf))
(if (and (= start pos) (>= end (buffer-length buf)))
(terminal-clear-below out)
(buffer-refresh?-set! buf #t)))
(cond ((< end pos)
(string-copy! str start str end pos)
(buffer-pos-set! buf (+ start (- pos end))))
((> start gap)
(string-copy! str start str gap (+ gap (- end start)))
(buffer-gap-set! buf (+ gap (- end start))))
(else
(buffer-pos-set! buf (min pos start))
(buffer-gap-set! buf (max gap (+ pos (- gap pos) (- end pos))))))))
(define (buffer-skip buf pred)
(let* ((str (buffer-string buf)) (end (string-length str)))
(let lp ((i (buffer-gap buf)))
(if (or (>= i end) (not (pred (string-ref str i))))
(+ (- i (buffer-gap buf)) (buffer-pos buf))
(lp (+ i 1))))))
(define (buffer-skip-reverse buf pred)
(let ((str (buffer-string buf)))
(let lp ((i (- (buffer-pos buf) 1)))
(if (or (< i 0) (not (pred (string-ref str i)))) i (lp (- i 1))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; keymaps
(define keymap? pair?)
(define (make-keymap . o)
(cons (make-vector 256 #f) (and (pair? o) (car o))))
(define (make-sparse-keymap . o)
(cons '() (and (pair? o) (car o))))
(define (make-printable-keymap)
(let* ((keymap (make-keymap))
(v (car keymap)))
(do ((i #x20 (+ i 1))) ((= i #x7F) keymap)
(vector-set! v i command/self-insert))))
(define (make-standard-escape-bracket-keymap)
(let* ((keymap (make-keymap))
(v (car keymap)))
(vector-set! v 65 command/backward-history)
(vector-set! v 66 command/forward-history)
(vector-set! v 67 command/forward-char)
(vector-set! v 68 command/backward-char)
keymap))
(define (make-standard-escape-keymap)
(let* ((keymap (make-keymap))
(v (car keymap)))
(vector-set! v 8 command/backward-delete-word)
(vector-set! v 91 (make-standard-escape-bracket-keymap))
(vector-set! v 98 command/backward-word)
(vector-set! v 100 command/forward-delete-word)
(vector-set! v 102 command/forward-word)
(vector-set! v 127 command/backward-delete-word)
keymap))
(define (make-standard-keymap)
(let* ((keymap (make-printable-keymap))
(v (car keymap)))
(vector-set! v 1 command/beggining-of-line)
(vector-set! v 2 command/backward-char)
(vector-set! v 4 command/forward-delete-char)
(vector-set! v 5 command/end-of-line)
(vector-set! v 6 command/forward-char)
(vector-set! v 8 command/backward-delete-char)
(vector-set! v 10 command/enter)
(vector-set! v 11 command/forward-delete-line)
(vector-set! v 12 command/refresh)
(vector-set! v 13 command/enter)
(vector-set! v 21 command/backward-delete-line)
(vector-set! v 27 (make-standard-escape-keymap))
(vector-set! v 127 command/backward-delete-char)
keymap))
(define (keymap-lookup keymap n)
(let ((table (car keymap)))
(or (if (vector? table)
(and (< n (vector-length table)) (vector-ref table n))
(cond ((assv n table) => cdr) (else #f)))
(if (keymap? (cdr keymap))
(keymap-lookup (cdr keymap) n)
(cdr keymap)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; commands
(define (command/self-insert ch buf out return)
(buffer-insert! buf out ch))
(define (command/enter ch buf out return)
(command/end-of-line ch buf out return)
(newline out)
(return))
(define (command/beep ch buf out return)
(write-char (integer->char 7) out))
(define (command/refresh ch buf out return)
(buffer-draw buf out))
(define (command/beggining-of-line ch buf out return)
(buffer-goto! buf out 0))
(define (command/end-of-line ch buf out return)
(buffer-goto! buf out (buffer-length buf)))
(define (command/forward-char ch buf out return)
(buffer-goto! buf out (+ (buffer-pos buf) 1)))
(define (command/backward-char ch buf out return)
(buffer-goto! buf out (- (buffer-pos buf) 1)))
(define (command/forward-delete-char ch buf out return)
(buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1)))
(define (command/backward-delete-char ch buf out return)
(buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf)))
(define (command/forward-delete-line ch buf out return)
(buffer-delete! buf out (buffer-pos buf) (buffer-length buf)))
(define (command/backward-delete-line ch buf out return)
(buffer-delete! buf out 0 (buffer-pos buf)))
(define (command/backward-history ch buf out return)
(let ((history (buffer-history buf)))
(cond
((and (history? history) (pair? (history-past history)))
(if (null? (history-future history))
(history-insert! history (buffer->string buf)))
(cond
((pair? (cdr (history-past history)))
(buffer-delete! buf out 0 (buffer-length buf))
(buffer-insert! buf out (history-prev! history))))))))
(define (command/forward-history ch buf out return)
(let ((history (buffer-history buf)))
(cond
((and (history? history) (pair? (history-future history)))
(buffer-delete! buf out 0 (buffer-length buf))
(let ((res (buffer-insert! buf out (history-next! history))))
(if (null? (history-future history))
(history-past-set! history (cdr (history-past history))))
res)))))
(define (command/forward-word ch buf out return)
(buffer-goto! buf out (buffer-skip buf char-non-word-constituent?))
(buffer-goto! buf out (buffer-skip buf char-word-constituent?)))
(define (command/backward-word ch buf out return)
(buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?))
(buffer-goto! buf out (+ (buffer-skip-reverse buf char-word-constituent?) 1)))
(define (command/forward-delete-word ch buf out return)
(let ((start (buffer-pos buf)))
(buffer-goto! buf out (buffer-skip buf char-non-word-constituent?))
(buffer-delete! buf out start (buffer-skip buf char-word-constituent?))))
(define (command/backward-delete-word ch buf out return)
(let ((end (buffer-pos buf)))
(buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?))
(let ((start (buffer-skip-reverse buf char-word-constituent?)))
(buffer-delete! buf out (+ start 1) end))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; line-editing
(define standard-keymap (make-standard-keymap))
(define (get-key ls key . o)
(let ((x (memq key ls)))
(if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o)))))
(define (with-leading-ports ls proc)
(if (and (pair? ls) (input-port? (car ls)))
(if (and (pair? (cdr ls)) (output-port? (cadr ls)))
(proc (car ls) (cadr ls) (cddr ls))
(proc (car ls) (current-output-port) (cdr ls)))
(proc (current-input-port) (current-output-port) ls)))
(define (make-line-editor . args)
(let* ((prompt (get-key args 'prompt: "> "))
(history (get-key args 'history:))
(terminal-width (get-key args 'terminal-width:))
(keymap (get-key args 'keymap: standard-keymap)))
(lambda (in out)
(let* ((width (or terminal-width (get-terminal-width out)))
(buf (make-buffer))
(done? #f)
(return (lambda o (set! done? #t))))
(buffer-refresh?-set! buf #t)
(buffer-width-set! buf width)
(buffer-insert! buf out prompt)
(buffer-min-set! buf (string-length prompt))
(buffer-history-set! buf history)
(buffer-refresh buf out)
(flush-output out)
((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io)
out
(lambda ()
(let lp ((kmap keymap))
(let ((ch (read-char in)))
(if (eof-object? ch)
(buffer->string buf)
(let ((x (keymap-lookup kmap (char->integer ch))))
(cond
((keymap? x)
(lp x))
((procedure? x)
(x ch buf out return)
(buffer-refresh buf out)
(if done? (buffer->string buf) (lp keymap)))
(else
;;(command/beep ch buf out return)
(lp keymap)))))))))))))
(define (edit-line . args)
(with-leading-ports
args
(lambda (in out rest) ((apply make-line-editor rest) in out))))
(define (edit-line-repl . args)
(with-leading-ports
args
(lambda (in out rest)
(let ((eval (get-key rest 'eval: (lambda (x) x)))
(print (get-key rest 'write: write))
(history (or (get-key rest 'history:) (make-history))))
(let ((edit-line
(apply make-line-editor 'no-stty?: #t 'history: history rest)))
((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io)
out
(lambda ()
(let lp ()
(let ((line (edit-line in out)))
(if (pair? (history-future history))
(history-past-set! history (cdr (history-past history))))
(history-commit! history line)
(print (eval line) out)
(newline out)
(lp))))))))))

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

@ -0,0 +1,12 @@
(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?
tm? timeval? timezone?)
(import-immutable (scheme))
(include-shared "time"))

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

@ -0,0 +1,46 @@
(c-system-include "time.h")
(c-system-include "sys/time.h")
(define-c-struct tm
predicate: 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? uri->string make-uri string->uri
uri-scheme uri-user uri-host uri-port 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)))))))

177
lib/config.scm Normal file
View file

@ -0,0 +1,177 @@
;; 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)))
(define (load-modules files extension)
(for-each
(lambda (f)
(let ((f (string-append dir f extension)))
(cond ((find-module-file f) => (lambda (x) (load x env)))
(else (error "couldn't find include" f)))))
files))
(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)
(load-modules (cdr x) ""))
((include-shared)
(cond-expand
(dynamic-loading (load-modules (cdr x) *shared-object-extension*))
(else #f)))
((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))))))

875
lib/init.scm Normal file
View file

@ -0,0 +1,875 @@
;; 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)
((lambda (vars vals)
(if (identifier? (cadr expr))
`((,(rename 'lambda) ,vars
(,(rename 'letrec) ((,(cadr expr)
(,(rename 'lambda) ,vars
,@(cdddr expr))))
(,(cadr expr) ,@vars)))
,@vals)
`((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals)))
(map car bindings)
(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? x) (if (fixnum? x) #t (bignum? x)))
(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 num . o)
(if (if (null? o) #t (eq? 10 (car o)))
(call-with-output-string (lambda (out) (write num out)))
(let lp ((n (abs num)) (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 (if (negative? num) (cons #\- 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) 0))
(step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1)))
(let lp ((i count) (n (+ start (* (- count 1) 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 eq (if (member (car b) a eq) a (cons (car b) a)) (cdr b))))
(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-2010 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_api_params(self, n), sexp rs, sexp bound) {
sexp res;
int32_t m;
#if SEXP_USE_BIGNUMS
int32_t hi, mod, len, i, *data;
#endif
if (! sexp_random_source_p(rs))
res = sexp_type_exception(ctx, self, rs_type_id, rs);
if (sexp_fixnump(bound)) {
sexp_call_random(rs, m);
res = sexp_make_fixnum(m % 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, m);
data[i] = m;
}
sexp_call_random(rs, m);
mod = sexp_bignum_data(bound)[hi-1] * sizeof(int32_t) / sizeof(sexp_uint_t);
if (mod)
data[i] = m % mod;
#endif
} else {
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, bound);
}
return res;
}
static sexp sexp_random_integer (sexp ctx sexp_api_params(self, n), sexp bound) {
return sexp_rs_random_integer(ctx sexp_api_pass(self, n), default_random_source, bound);
}
static sexp sexp_rs_random_real (sexp ctx sexp_api_params(self, n), sexp rs) {
int32_t res;
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, self, rs_type_id, rs);
sexp_call_random(rs, res);
return sexp_make_flonum(ctx, (double)res / (double)RAND_MAX);
}
static sexp sexp_random_real (sexp ctx sexp_api_params(self, n)) {
return sexp_rs_random_real(ctx sexp_api_pass(self, n), default_random_source);
}
#if SEXP_BSD
static sexp sexp_make_random_source (sexp ctx sexp_api_params(self, n)) {
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_api_params(self, n), sexp rs) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, self, rs_type_id, rs);
else
return sexp_make_integer(ctx, *sexp_random_data(rs));
}
static sexp sexp_random_source_state_set (sexp ctx sexp_api_params(self, n), sexp rs, sexp state) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, self, rs_type_id, 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, self, SEXP_FIXNUM, state);
return SEXP_VOID;
}
#else
static sexp sexp_make_random_source (sexp ctx sexp_api_params(self, n)) {
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_api_params(self, n), sexp rs) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, self, rs_type_id, rs);
else
return sexp_substring(ctx, sexp_random_state(rs), ZERO, STATE_SIZE);
}
static sexp sexp_random_source_state_set (sexp ctx sexp_api_params(self, n), sexp rs, sexp state) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, self, rs_type_id, rs);
else if (! (sexp_stringp(state)
&& (sexp_string_length(state) == SEXP_RANDOM_STATE_SIZE)))
return sexp_type_exception(ctx, self, SEXP_STRING, state);
sexp_random_state(rs) = state;
sexp_random_init(rs, 1);
return SEXP_VOID;
}
#endif
static sexp sexp_random_source_randomize (sexp ctx sexp_api_params(self, n), sexp rs) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, self, rs_type_id, rs);
sexp_seed_random(time(NULL), rs);
return SEXP_VOID;
}
static sexp sexp_random_source_pseudo_randomize (sexp ctx sexp_api_params(self, n), sexp rs, sexp seed) {
if (! sexp_random_source_p(rs))
return sexp_type_exception(ctx, self, rs_type_id, rs);
if (! sexp_fixnump(seed))
return sexp_type_exception(ctx, self, rs_type_id, seed);
sexp_seed_random(sexp_unbox_fixnum(seed), rs);
return SEXP_VOID;
}
sexp sexp_init_library (sexp ctx sexp_api_params(self, n), 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?", -1);
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 sexp_api_pass(NULL, 0));
name = sexp_intern(ctx, "default-random-source", -1);
sexp_env_define(ctx, env, name, default_random_source);
sexp_random_source_randomize(ctx sexp_api_pass(NULL, 0), 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-2010 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_api_params(self, n), 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 sexp_api_pass(self, n), y, x);
#endif
else
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, 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, self, SEXP_FIXNUM, y);
}
#endif
} else {
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
}
return sexp_bignum_normalize(res);
}
static sexp sexp_bit_ior (sexp ctx sexp_api_params(self, n), 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 sexp_api_pass(self, n), y, x);
#endif
else
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, 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, self, SEXP_FIXNUM, y);
}
#endif
} else {
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, x);
}
return sexp_bignum_normalize(res);
}
static sexp sexp_bit_xor (sexp ctx sexp_api_params(self, n), 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 sexp_api_pass(self, n), y, x);
#endif
else
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, 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, self, SEXP_FIXNUM, y);
}
#endif
} else {
res = sexp_type_exception(ctx, self, SEXP_FIXNUM, 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_api_params(self, n), 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, self, SEXP_FIXNUM, 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 sexp_api_pass(self, n), 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, self, SEXP_FIXNUM, 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_api_params(self, n), 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, self, SEXP_FIXNUM, 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_api_params(self, n), 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, self, SEXP_FIXNUM, x);
}
}
static sexp sexp_bit_set_p (sexp ctx sexp_api_params(self, n), sexp i, sexp x) {
#if SEXP_USE_BIGNUMS
sexp_uint_t pos;
#endif
if (! sexp_fixnump(i))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, 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, self, SEXP_FIXNUM, x);
}
}
sexp sexp_init_library (sexp ctx sexp_api_params(self, n), 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) (- (arithmetic-shift 1 len) 1))
(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-2010 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_api_params(self, n), sexp str, sexp bound) {
if (! sexp_stringp(str))
return sexp_type_exception(ctx, self, SEXP_STRING, str);
else if (! sexp_fixnump(bound))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, 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_api_params(self, n), sexp str, sexp bound) {
if (! sexp_stringp(str))
return sexp_type_exception(ctx, self, SEXP_STRING, str);
else if (! sexp_fixnump(bound))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, 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_api_params(self, n), sexp obj, sexp bound) {
if (! sexp_exact_integerp(bound))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, bound);
return sexp_make_fixnum(hash_one(ctx, obj, sexp_unbox_fixnum(bound), HASH_DEPTH));
}
static sexp sexp_hash_by_identity (sexp ctx sexp_api_params(self, n), sexp obj, sexp bound) {
if (! sexp_exact_integerp(bound))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, 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 sexp_api_pass(NULL, 2), obj, sexp_make_fixnum(len));
else if (hash_fn == sexp_make_fixnum(2))
res = sexp_hash(ctx sexp_api_pass(NULL, 2), 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)", -1, 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_api_params(self, n), 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)) /* XXXX check the real type id */
return sexp_xtype_exception(ctx, self, "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_api_params(self, n), 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_api_params(self, n), 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)))))))

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

@ -0,0 +1,85 @@
(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))
(name-str (symbol->string (identifier->symbol name)))
(make (caaddr expr))
(make-fields (cdaddr expr))
(pred (cadddr expr))
(fields (cddddr expr))
(num-fields (length fields))
(index (register-simple-type name-str 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 (identifier->symbol pred))
,index))
,@(let lp ((ls fields) (i 0) (res '()))
(if (null? ls)
res
(let ((res
(cons `(,_define ,(cadar ls)
(,(rename 'make-getter)
,(symbol->string
(identifier->symbol (cadar ls)))
,index
,i))
res)))
(lp (cdr ls)
(+ i 1)
(if (pair? (cddar ls))
(cons
`(,_define ,(caddar ls)
(,(rename 'make-setter)
,(symbol->string
(identifier->symbol (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 (identifier->symbol 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 "%" name-str "-"
(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! object-cmp)
(import-immutable (scheme))
(include-shared "95/qsort")
(include "95/sort.scm"))

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

@ -0,0 +1,228 @@
/* qsort.c -- quicksort implementation */
/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include "chibi/eval.h"
#if SEXP_USE_HUFF_SYMS
#include "../../../opt/sexp-hufftabs.c"
#endif
#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;
}
#if SEXP_USE_HUFF_SYMS
static int sexp_isymbol_compare (sexp ctx, sexp a, sexp b) {
int res, res2, tmp;
sexp_uint_t c = ((sexp_uint_t)a)>>3, d = ((sexp_uint_t)b)>>3;
while (c && d) {
#include "../../../opt/sexp-unhuff.c"
#define c d
#define res res2
#include "../../../opt/sexp-unhuff.c"
#undef c
#undef res
if ((tmp=res-res2) != 0)
return tmp;
}
return c ? 1 : d ? -1 : 0;
}
#endif
static int sexp_object_compare (sexp ctx, sexp a, sexp b) {
int res;
if (a == b)
return 0;
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;
case SEXP_SYMBOL:
res = strcmp(sexp_string_data(sexp_symbol_string(a)),
sexp_string_data(sexp_symbol_string(b)));
break;
default:
res = 0;
break;
}
}
#if SEXP_USE_HUFF_SYMS
} else if (sexp_lsymbolp(a) && sexp_isymbolp(b)) {
res = sexp_object_compare(ctx, sexp_symbol_string(a),
sexp_write_to_string(ctx, b));
#endif
} else {
res = 1;
}
} else if (sexp_pointerp(b)) {
#if SEXP_USE_HUFF_SYMS
if (sexp_isymbolp(a) && sexp_lsymbolp(b))
res = sexp_object_compare(ctx, sexp_symbol_string(b),
sexp_write_to_string(ctx, a));
else
#endif
res = -1;
} else {
#if SEXP_USE_HUFF_SYMS
if (sexp_isymbolp(a) && sexp_isymbolp(b))
return sexp_isymbol_compare(ctx, a, b);
else
#endif
res = (sexp_sint_t)a - (sexp_sint_t)b;
}
return res;
}
static sexp sexp_object_compare_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) {
return sexp_make_fixnum(sexp_object_compare(ctx, a, b));
}
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]);
if (sexp_truep(key)) {
sexp_car(args1) = tmp;
b = sexp_apply(ctx, key, args1);
} else {
b = tmp;
}
for (i=j=lo; i < hi; i++) {
if (sexp_truep(key)) {
sexp_car(args1) = vec[i];
a = sexp_apply(ctx, key, args1);
} else {
a = vec[i];
}
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_api_params(self, n), 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, self, SEXP_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, self, SEXP_PROCEDURE, less);
} else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) {
res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key);
} 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_api_params(self, n), sexp env) {
sexp_define_foreign(ctx, env, "object-cmp", 2, sexp_object_compare_op);
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)
#t)
(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-2010 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_api_params(self, n), sexp str) {
char *cstr;
if (! sexp_stringp(str))
return sexp_type_exception(ctx, self, SEXP_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 sexp_api_params(self, n)) {
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_api_params(self, n), 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;
}

217
main.c Normal file
View file

@ -0,0 +1,217 @@
/* main.c -- chibi-scheme command-line app */
/* Copyright (c) 2009-2010 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 "))"
#define sexp_version_string "chibi-scheme "sexp_version" \""sexp_release_name"\" "
#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_make_env(ctx);
sexp_env_parent(env) = sexp_context_env(ctx);
sexp_env_define(ctx, sexp_context_env(ctx),
sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env);
sexp_context_tracep(ctx) = 1;
in = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), SEXP_FALSE);
out = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), SEXP_FALSE);
err = sexp_env_ref(env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE);
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);
#endif
if (res != SEXP_VOID) {
sexp_write(ctx, res, out);
sexp_write_char(ctx, '\n', out);
}
}
}
}
sexp_gc_release4(ctx);
}
static void check_nonull_arg (int c, char *arg) {
if (! arg) {
fprintf(stderr, "chibi-scheme: option '%c' requires an argument\n", c);
exit_failure();
}
}
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);
check_nonull_arg('e', arg);
res = check_exception(ctx, sexp_read_from_string(ctx, arg, -1));
res = check_exception(ctx, sexp_eval(ctx, res, env));
if (print) {
if (! sexp_oportp(out))
out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
sexp_write(ctx, res, out);
sexp_write_char(ctx, '\n', out);
}
quit = 1;
break;
case 'l':
load_init();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('l', arg);
check_exception(ctx, sexp_load_module_file(ctx, arg, env));
break;
case 'm':
load_init();
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
check_nonull_arg('m', arg);
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, -1, 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);
check_nonull_arg('A', arg);
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);
check_nonull_arg('I', arg);
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);
check_nonull_arg('h', arg);
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':
load_init();
if (! sexp_oportp(out))
out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
sexp_write_string(ctx, sexp_version_string, out);
tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*", -1), SEXP_NULL);
sexp_write(ctx, tmp, out);
sexp_newline(ctx, out);
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, -1), args);
sexp_eval_string(ctx, sexp_argv_proc, -1, 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", -1);
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);
sexp_destroy_context(ctx);
}
int main (int argc, char **argv) {
sexp_scheme_init();
run_main(argc, argv);
return 0;
}

28
mkfile Normal file
View file

@ -0,0 +1,28 @@
</$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
echo '#define sexp_version "'`{cat VERSION}'"' >> include/chibi/install.h
echo '#define sexp_release_name "'`{cat RELEASE}'"' >> 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

154
opcodes.c Normal file
View file

@ -0,0 +1,154 @@
#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_GETTER, SEXP_OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL),
_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL),
_OP(SEXP_OPC_GETTER, SEXP_OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL),
_OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL),
_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL),
_OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL),
_OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL),
_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL),
_OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL),
_OP(SEXP_OPC_GETTER, 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_ZERO, NULL),
_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", SEXP_ONE, NULL),
_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, SEXP_FIXNUM, 0, 1, "-", SEXP_ZERO, NULL),
_OP(SEXP_OPC_ARITHMETIC, SEXP_OP_DIV, 1, 1, SEXP_FIXNUM, 0, 1, "/", SEXP_ONE, 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_flonump_op),
#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_op),
_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write_op),
_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display_op),
_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output_op),
_FN2(0, 0, "equal?", 0, sexp_equalp_op),
_FN1(0, "list?", 0, sexp_listp_op),
_FN1(0, "identifier?", 0, sexp_identifierp_op),
_FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr_op),
_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq_op),
_FN1(SEXP_PAIR, "length", 0, sexp_length_op),
_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse_op),
_FN1(SEXP_PAIR, "reverse!", 0, sexp_nreverse_op),
_FN2(SEXP_PAIR, SEXP_PAIR, "append2", 0, sexp_append2_op),
_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector_op),
_FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file_op),
_FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file_op),
_FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port_op),
_FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port_op),
_FN0("make-environment", 0, sexp_make_env_op),
_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env_op),
_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env_op),
_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval_op),
_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load_op),
_FN4(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy_op),
_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception_op),
_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_op),
_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string_op),
_FN2OPT(SEXP_FIXNUM, SEXP_FIXNUM, "string->number", SEXP_TEN, sexp_string_to_number_op),
_FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp_op),
_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring_op),
_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol_op),
_FN2OPT(SEXP_PAIR, SEXP_STRING, "string-concatenate", SEXP_FALSE, sexp_string_concatenate_op),
_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq_op),
_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq_op),
_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo_op),
_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_op),
_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port_op),
_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string_op),
#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_op),
#if SEXP_USE_TYPE_DEFS
_FN2(SEXP_STRING, SEXP_FIXNUM, "register-simple-type", 0, sexp_register_simple_type_op),
_FN2(SEXP_STRING, SEXP_FIXNUM, "make-type-predicate", 0, sexp_make_type_predicate_op),
_FN2(SEXP_STRING, SEXP_FIXNUM, "make-constructor", 0, sexp_make_constructor_op),
_FN3(SEXP_STRING, SEXP_FIXNUM, "make-getter", 0, sexp_make_getter_op),
_FN3(SEXP_STRING, SEXP_FIXNUM, "make-setter", 0, sexp_make_setter_op),
#endif
#if PLAN9
#include "opt/plan9-opcodes.c"
#endif
#if SEXP_USE_MODULES
_FN1(SEXP_ENV, "env-exports", 0, sexp_env_exports_op),
_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_op),
#endif
};

775
opt/bignum.c Normal file
View file

@ -0,0 +1,775 @@
/* bignum.c -- bignum support */
/* Copyright (c) 2009-2010 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_ZERO);
scale = sexp_fixnum_to_bignum(ctx, SEXP_ONE);
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);
memmove(dst, a, size);
sexp_bignum_length(dst) = len;
} else {
memset(dst->value.bignum.data, 0,
sexp_bignum_length(dst)*sizeof(sexp_uint_t));
memmove(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_sint_t i;
sexp_uint_t *data=sexp_bignum_data(a);
for (i=sexp_bignum_hi(a)-1; i>=0; i--)
res = res * ((double)SEXP_UINT_T_MAX+1) + data[i];
return res * sexp_bignum_sign(a);
}
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;
sexp_gc_var1(tmp);
sexp_gc_preserve1(ctx, tmp);
if ((! d) || (sexp_bignum_length(d)+offset < len))
d = tmp = 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;
}
sexp_gc_release1(ctx);
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);
} else {
if (c!='.') sexp_push_char(ctx, c, in); /* push the e back */
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);
} else {
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_ZERO);
}
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_ONE);
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_gc_var1(rem);
sexp_gc_preserve1(ctx, rem);
sexp_bignum_quot_rem(ctx, &rem, a, b); /* discard quotient */
sexp_gc_release1(ctx);
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_ONE);
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, 0, 2, 3, 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, NULL, SEXP_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;
sexp_gc_var1(tmp);
sexp_gc_preserve1(ctx, tmp);
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, NULL, SEXP_NUMBER, a);
break;
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
r = sexp_type_exception(ctx, NULL, SEXP_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:
tmp = sexp_fixnum_to_bignum(ctx, a);
r = sexp_bignum_sub(ctx, NULL, b, tmp);
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:
tmp = sexp_fixnum_to_bignum(ctx, b);
r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, tmp));
break;
case SEXP_NUM_BIG_FLO:
r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) - sexp_flonum_value(b));
break;
case SEXP_NUM_BIG_BIG:
r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, b));
break;
}
sexp_gc_release1(ctx);
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, NULL, SEXP_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;
sexp_gc_var2(tmp, rem);
sexp_gc_preserve2(ctx, tmp, 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, NULL, SEXP_NUMBER, a);
break;
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
r = sexp_type_exception(ctx, NULL, SEXP_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_flonum_value(a)/sexp_fixnum_to_double(b));
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 = tmp = 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_ZERO)
r = sexp_make_flonum(ctx, sexp_bignum_to_double(a)
/ sexp_bignum_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;
}
sexp_gc_release2(ctx);
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;
sexp_gc_var1(tmp);
sexp_gc_preserve1(ctx, tmp);
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, NULL, SEXP_FIXNUM, a);
break;
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
break;
case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG:
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
break;
case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO:
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
break;
case SEXP_NUM_FIX_FIX:
r = sexp_fx_div(a, b);
break;
case SEXP_NUM_FIX_BIG:
r = SEXP_ZERO;
break;
case SEXP_NUM_BIG_FIX:
b = tmp = sexp_fixnum_to_bignum(ctx, b);
/* ... FALLTHROUGH ... */
case SEXP_NUM_BIG_BIG:
r = sexp_bignum_normalize(sexp_bignum_quotient(ctx, a, b));
break;
}
sexp_gc_release1(ctx);
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;
sexp_gc_var1(tmp);
sexp_gc_preserve1(ctx, tmp);
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, NULL, SEXP_FIXNUM, a);
break;
case SEXP_NUM_FIX_NOT: case SEXP_NUM_FLO_NOT: case SEXP_NUM_BIG_NOT:
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b);
break;
case SEXP_NUM_FLO_FIX: case SEXP_NUM_FLO_FLO: case SEXP_NUM_FLO_BIG:
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a);
break;
case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO:
r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, 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 = tmp = sexp_fixnum_to_bignum(ctx, b);
/* ... FALLTHROUGH ... */
case SEXP_NUM_BIG_BIG:
r = sexp_bignum_normalize(sexp_bignum_remainder(ctx, a, b));
break;
}
sexp_gc_release1(ctx);
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, NULL, SEXP_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;
}

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