commit 8b5eb68238b5979055302ea9e42e8e3b8b45ead9 Author: Alex Shinn Date: Thu Feb 20 22:32:50 2014 +0900 File descriptors maintain a reference count of ports open on them They can be close()d explicitly with close-file-descriptor, and will close() on gc, but only explicitly closing the last port on them will close the fileno. Notably needed for network sockets where we open separate input and output ports on the same socket. diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..8fbf21cc --- /dev/null +++ b/.hgignore @@ -0,0 +1,42 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.sch +*.sps +*.txt +*.image +*.wav +*.dylib +*.class +*.dSYM +*.orig +.hg +junk* +*.tgz +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +clibs.c +chibi-scheme +chibi-scheme-static +build-lib/chibi/char-set/derived.scm +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 +lib/chibi/stty.c +doc/*.html +doc/lib/chibi/*.html +misc/* +tests/ffi/*.c +tests/ffi/*.stub diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 00000000..8ef3492d --- /dev/null +++ b/AUTHORS @@ -0,0 +1,47 @@ +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. + +The (scheme time) module includes code for handling leap seconds +from Alan Watson's Scheme clock library at +http://code.google.com/p/scheme-clock/ under the same license. + +The benchmarks are based on the Racket versions of the classic +Gabriel benchmarks from +http://www.cs.utah.edu/~mflatt/benchmarks-20100126/log3/index.html. +They are not installed or needed but are included for convenience. + +Thanks to the following people for patches and bug reports: + + * Alan Watson + * Alexander Shendi + * Andreas Rottman + * Bakul Shah + * Ben Mather + * Ben Weaver + * Bruno Deferrari + * Doug Currie + * Derrick Eddington + * Dmitry Chestnykh + * Eduardo Cavazos + * Felix Winkelmann + * Gregor Klinke + * Jeremy Wolff + * Jeronimo Pellegrini + * John Cowan + * John Samsa + * Lars J Aas + * Lorenzo Campedelli + * Michal Kowalski (sladegen) + * Rajesh Krishnan + * Taylor Venable + * Travis Cross + * Zhang Meng + +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! diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..cb3c8220 --- /dev/null +++ b/COPYING @@ -0,0 +1,24 @@ +Copyright (c) 2009-2012 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. diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..dea064fc --- /dev/null +++ b/Makefile @@ -0,0 +1,369 @@ +# -*- makefile-gmake -*- + +.PHONY: dist mips-dist cleaner test test-all test-dist checkdefs +.DEFAULT_GOAL := all + +CHIBI_FFI ?= $(CHIBI) -q tools/chibi-ffi +CHIBI_FFI_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-ffi + +CHIBI_DOC ?= $(CHIBI) tools/chibi-doc +CHIBI_DOC_DEPENDENCIES ?= $(CHIBI_DEPENDENCIES) tools/chibi-doc + +GENSTATIC ?= ./tools/chibi-genstatic + +CHIBI ?= LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" CHIBI_MODULE_PATH=lib ./chibi-scheme$(EXE) +CHIBI_DEPENDENCIES = ./chibi-scheme$(EXE) + +######################################################################## + +CHIBI_COMPILED_LIBS = lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \ + lib/chibi/time$(SO) lib/chibi/system$(SO) lib/chibi/stty$(SO) \ + lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \ + lib/chibi/net$(SO) lib/chibi/ast$(SO) +CHIBI_IO_COMPILED_LIBS = lib/chibi/io/io$(SO) +CHIBI_OPT_COMPILED_LIBS = lib/chibi/optimize/rest$(SO) \ + lib/chibi/optimize/profile$(SO) +COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \ + $(CHIBI_OPT_COMPILED_LIBS) lib/srfi/18/threads$(SO) \ + lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) lib/srfi/39/param$(SO) \ + lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \ + lib/scheme/time$(SO) + +BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h +INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h + +MODULE_DOCS := ast config disasm equiv filesystem generic heap-stats io \ + loop match mime modules net pathname process repl scribble stty \ + system test time trace type-inference uri weak + +HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html) + +######################################################################## + +include Makefile.libs + +######################################################################## +# Library config. +# +# This is to allow "make SEXP_USE_BOEHM=1" and "make SEXP_USE_DL=0" to +# automatically include the necessary compiler and linker flags in +# addition to setting those features. If not using GNU make just +# comment out the ifs and use the else branches for the defaults. + +ifeq ($(SEXP_USE_BOEHM),1) +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%) -DSEXP_USE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude $(D:%=-DSEXP_USE_%) +endif + +ifeq ($(SEXP_USE_DL),0) +XLDFLAGS := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -DSEXP_USE_DL=0 -g -g3 -O3 $(CFLAGS) +else +XLDFLAGS := $(LDFLAGS) $(RLDFLAGS) $(GCLDFLAGS) $(LIBDL) -lm +XCFLAGS := -Wall -g -g3 -O3 $(CFLAGS) +endif + +######################################################################## + +all: chibi-scheme$(EXE) all-libs + +include/chibi/install.h: Makefile + echo '#define sexp_so_extension "'$(SO)'"' > $@ + echo '#define sexp_default_module_path "'$(MODDIR):$(BINMODDIR)'"' >> $@ + echo '#define sexp_platform "'$(PLATFORM)'"' >> $@ + echo '#define sexp_version "'`cat VERSION`'"' >> $@ + echo '#define sexp_release_name "'`cat RELEASE`'"' >> $@ + +%.o: %.c $(BASE_INCLUDES) + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +gc-ulimit.o: gc.c $(BASE_INCLUDES) + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -DSEXP_USE_LIMITED_MALLOC -o $@ $< + +sexp-ulimit.o: sexp.c $(BASE_INCLUDES) + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -DSEXP_USE_LIMITED_MALLOC -o $@ $< + +main.o: main.c $(INCLUDES) + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< + +SEXP_OBJS = gc.o sexp.o bignum.o +SEXP_ULIMIT_OBJS = gc-ulimit.o sexp-ulimit.o bignum.o +EVAL_OBJS = opcodes.o vm.o eval.o simplify.o + +libchibi-sexp$(SO): $(SEXP_OBJS) + $(CC) $(CLIBFLAGS) $(CLINKFLAGS) -o $@ $^ $(XLDFLAGS) + +libchibi-scheme$(SO): $(SEXP_OBJS) $(EVAL_OBJS) + $(CC) $(CLIBFLAGS) $(CLINKFLAGS) -o $@ $^ $(XLDFLAGS) + +libchibi-scheme.a: $(SEXP_OBJS) $(EVAL_OBJS) + $(AR) rcs $@ $^ + +chibi-scheme$(EXE): main.o libchibi-scheme$(SO) + $(CC) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +chibi-scheme-static$(EXE): main.o $(SEXP_OBJS) $(EVAL_OBJS) + $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm + +chibi-scheme-ulimit$(EXE): main.o $(SEXP_ULIMIT_OBJS) $(EVAL_OBJS) + $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) -lm + +clibs.c: $(GENSTATIC) chibi-scheme$(EXE) + $(FIND) lib -name \*.sld | $(CHIBI) $(GENSTATIC) > $@ + +# A special case, this needs to be linked with the LDFLAGS in case +# we're using Boehm. +lib/chibi/ast$(SO): lib/chibi/ast.c $(INCLUDES) + -$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< $(GCLDFLAGS) -L. -lchibi-scheme + +doc/lib/chibi/%.html: lib/chibi/%.sld $(CHIBI_DOC_DEPENDENCIES) + $(CHIBI_DOC) --html chibi.$* > $@ + +doc: doc/chibi.html doc-libs + +%.html: %.scrbl $(CHIBI_DOC_DEPENDENCIES) + $(CHIBI_DOC) --html $< > $@ + +######################################################################## +# Dist builds - rules to build generated files included in distribution +# (currently just char-sets since it takes a long time and we don't want +# to bundle the raw Unicode files or require a net connection to build). + +data/%.txt: + curl --silent http://www.unicode.org/Public/UNIDATA/$*.txt > $@ + +build-lib/chibi/char-set/derived.scm: data/UnicodeData.txt data/DerivedCoreProperties.txt chibi-scheme$(EXE) + $(CHIBI) tools/extract-unicode-props.scm --default > $@ + +lib/chibi/char-set/ascii.scm: build-lib/chibi/char-set/derived.scm chibi-scheme$(EXE) + $(CHIBI) -Abuild-lib tools/optimize-char-sets.scm --ascii chibi.char-set.compute > $@ + +lib/chibi/char-set/full.scm: build-lib/chibi/char-set/derived.scm chibi-scheme$(EXE) + $(CHIBI) -Abuild-lib tools/optimize-char-sets.scm chibi.char-set.compute > $@ + +lib/scheme/char/case-offsets.scm: data/CaseFolding.txt chibi-scheme$(EXE) all-libs + $(CHIBI) tools/extract-case-offsets.scm $< > $@ + +######################################################################## +# Tests + +checkdefs: + @for d in $(D); do \ + if ! $(GREP) -q " SEXP_USE_$${d%%=*} " include/chibi/features.h; then \ + echo "WARNING: unknown definition $$d"; \ + fi; \ + done + +test-basic: chibi-scheme$(EXE) + @for f in tests/basic/*.scm; do \ + $(CHIBI) -xchibi $$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-memory: chibi-scheme-ulimit$(EXE) + ./tests/memory/memory-tests.sh + +test-build: + MAKE=$(MAKE) ./tests/build/build-tests.sh + +test-ffi: chibi-scheme$(EXE) + $(CHIBI) tests/ffi/ffi-tests.scm + +test-threads: chibi-scheme$(EXE) lib/srfi/18/threads$(SO) lib/srfi/39/param$(SO) lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/time$(SO) + $(CHIBI) -xchibi tests/thread-tests.scm + +test-numbers: chibi-scheme$(EXE) + $(CHIBI) -xchibi tests/numeric-tests.scm + +test-flonums: chibi-scheme$(EXE) + $(CHIBI) -xchibi tests/flonum-tests.scm + +test-hash: chibi-scheme$(EXE) lib/srfi/69/hash$(SO) + $(CHIBI) -xchibi tests/hash-tests.scm + +test-io: chibi-scheme$(EXE) lib/chibi/io/io$(SO) + $(CHIBI) -xchibi tests/io-tests.scm + +test-match: chibi-scheme$(EXE) + $(CHIBI) -xchibi tests/match-tests.scm + +test-loop: chibi-scheme$(EXE) + $(CHIBI) -xchibi tests/loop-tests.scm + +test-sort: chibi-scheme$(EXE) lib/srfi/33/bit$(SO) + $(CHIBI) -xchibi tests/sort-tests.scm + +test-srfi-1: chibi-scheme$(EXE) + $(CHIBI) -xchibi tests/srfi-1-tests.scm + +test-records: chibi-scheme$(EXE) + $(CHIBI) -xchibi tests/record-tests.scm + +test-weak: chibi-scheme$(EXE) lib/chibi/weak$(SO) + $(CHIBI) -xchibi tests/weak-tests.scm + +test-unicode: chibi-scheme$(EXE) + $(CHIBI) -xchibi tests/unicode-tests.scm + +test-process: chibi-scheme$(EXE) lib/chibi/process$(SO) + $(CHIBI) -xchibi tests/process-tests.scm + +test-system: chibi-scheme$(EXE) lib/chibi/system$(SO) + $(CHIBI) -xchibi tests/system-tests.scm + +test-libs: chibi-scheme$(EXE) + $(CHIBI) -xchibi tests/lib-tests.scm + +test-r5rs: chibi-scheme$(EXE) + $(CHIBI) -xchibi tests/r5rs-tests.scm + +test-r7rs: chibi-scheme$(EXE) + $(CHIBI) tests/r7rs-tests.scm + +test: test-r7rs + +test-all: test test-libs test-ffi + +test-dist: test-all test-memory test-build + +bench-gabriel: chibi-scheme$(EXE) + ./benchmarks/gabriel/run.sh + +######################################################################## +# Packaging + +clean: clean-libs + -$(RM) *.o *.i *.s *.8 tests/basic/*.out tests/basic/*.err + +cleaner: clean + -$(RM) chibi-scheme$(EXE) chibi-scheme-static$(EXE) chibi-scheme-ulimit$(EXE) \ + libchibi-scheme$(SO) *.a include/chibi/install.h \ + $(shell $(FIND) lib -name \*.o) + +dist-clean: dist-clean-libs cleaner + +install: all + $(MKDIR) $(DESTDIR)$(BINDIR) + $(INSTALL) chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/ + $(INSTALL) tools/chibi-ffi $(DESTDIR)$(BINDIR)/ + $(INSTALL) tools/chibi-doc $(DESTDIR)$(BINDIR)/ + $(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/term + $(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char + $(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time + $(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records + $(INSTALL) lib/*.scm $(DESTDIR)$(MODDIR)/ + $(INSTALL) lib/chibi/*.sld lib/chibi/*.scm $(DESTDIR)$(MODDIR)/chibi/ + $(INSTALL) lib/chibi/char-set/*.sld lib/chibi/char-set/*.scm $(DESTDIR)$(MODDIR)/chibi/char-set/ + $(INSTALL) lib/chibi/crypto/*.sld lib/chibi/crypto/*.scm $(DESTDIR)$(MODDIR)/chibi/crypto/ + $(INSTALL) lib/chibi/io/*.scm $(DESTDIR)$(MODDIR)/chibi/io/ + $(INSTALL) lib/chibi/iset/*.sld lib/chibi/iset/*.scm $(DESTDIR)$(MODDIR)/chibi/iset/ + $(INSTALL) lib/chibi/loop/*.scm $(DESTDIR)$(MODDIR)/chibi/loop/ + $(INSTALL) lib/chibi/match/*.scm $(DESTDIR)$(MODDIR)/chibi/match/ + $(INSTALL) lib/chibi/math/*.sld lib/chibi/math/*.scm $(DESTDIR)$(MODDIR)/chibi/math/ + $(INSTALL) lib/chibi/monad/*.sld lib/chibi/monad/*.scm $(DESTDIR)$(MODDIR)/chibi/monad/ + $(INSTALL) lib/chibi/net/*.sld lib/chibi/net/*.scm $(DESTDIR)$(MODDIR)/chibi/net/ + $(INSTALL) lib/chibi/optimize/*.sld lib/chibi/optimize/*.scm $(DESTDIR)$(MODDIR)/chibi/optimize/ + $(INSTALL) lib/chibi/parse/*.sld lib/chibi/parse/*.scm $(DESTDIR)$(MODDIR)/chibi/parse/ + $(INSTALL) lib/chibi/show/*.sld lib/chibi/show/*.scm $(DESTDIR)$(MODDIR)/chibi/show/ + $(INSTALL) lib/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/ + $(INSTALL) lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/ + $(INSTALL) lib/scheme/char/*.sld lib/scheme/char/*.scm $(DESTDIR)$(MODDIR)/scheme/char/ + $(INSTALL) lib/scheme/time/*.sld $(DESTDIR)$(MODDIR)/scheme/time/ + $(INSTALL) lib/srfi/*.sld lib/srfi/*.scm $(DESTDIR)$(MODDIR)/srfi/ + $(INSTALL) lib/srfi/1/*.scm $(DESTDIR)$(MODDIR)/srfi/1/ + $(INSTALL) lib/srfi/18/*.scm $(DESTDIR)$(MODDIR)/srfi/18/ + $(INSTALL) lib/srfi/27/*.scm $(DESTDIR)$(MODDIR)/srfi/27/ + $(INSTALL) lib/srfi/33/*.scm $(DESTDIR)$(MODDIR)/srfi/33/ + $(INSTALL) lib/srfi/39/*.scm $(DESTDIR)$(MODDIR)/srfi/39/ + $(INSTALL) lib/srfi/69/*.scm $(DESTDIR)$(MODDIR)/srfi/69/ + $(INSTALL) lib/srfi/95/*.scm $(DESTDIR)$(MODDIR)/srfi/95/ + $(INSTALL) lib/srfi/99/*.sld $(DESTDIR)$(MODDIR)/srfi/99/ + $(INSTALL) lib/srfi/99/records/*.sld lib/srfi/99/records/*.scm $(DESTDIR)$(MODDIR)/srfi/99/records/ + $(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/ + $(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/ + $(MKDIR) $(DESTDIR)$(BINMODDIR)/scheme/ + $(MKDIR) $(DESTDIR)$(BINMODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98 + $(INSTALL) $(CHIBI_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/ + $(INSTALL) $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/ + $(INSTALL) $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/ + $(INSTALL) lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/ + $(INSTALL) lib/srfi/18/threads$(SO) $(DESTDIR)$(BINMODDIR)/srfi/18 + $(INSTALL) lib/srfi/27/rand$(SO) $(DESTDIR)$(BINMODDIR)/srfi/27 + $(INSTALL) lib/srfi/33/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/33 + $(INSTALL) lib/srfi/39/param$(SO) $(DESTDIR)$(BINMODDIR)/srfi/39 + $(INSTALL) lib/srfi/69/hash$(SO) $(DESTDIR)$(BINMODDIR)/srfi/69 + $(INSTALL) lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95 + $(INSTALL) lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98 + $(MKDIR) $(DESTDIR)$(INCDIR) + $(INSTALL) $(INCLUDES) $(DESTDIR)$(INCDIR)/ + $(MKDIR) $(DESTDIR)$(LIBDIR) + $(MKDIR) $(DESTDIR)$(SOLIBDIR) + $(INSTALL) libchibi-scheme$(SO) $(DESTDIR)$(SOLIBDIR)/ + -$(INSTALL) libchibi-scheme.a $(DESTDIR)$(SOLIBDIR)/ + $(MKDIR) $(DESTDIR)$(MANDIR) + $(INSTALL) doc/chibi-scheme.1 $(DESTDIR)$(MANDIR)/ + $(INSTALL) doc/chibi-ffi.1 $(DESTDIR)$(MANDIR)/ + $(INSTALL) doc/chibi-doc.1 $(DESTDIR)$(MANDIR)/ + -if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + +uninstall: + -$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme$(EXE) + -$(RM) $(DESTDIR)$(BINDIR)/chibi-scheme-static$(EXE) + -$(RM) $(DESTDIR)$(BINDIR)/chibi-ffi + -$(RM) $(DESTDIR)$(BINDIR)/chibi-doc + -$(RM) $(DESTDIR)$(SOLIBDIR)/libchibi-scheme$(SO) + -$(RM) $(DESTDIR)$(LIBDIR)/libchibi-scheme$(SO).a + -$(CD) $(DESTDIR)$(INCDIR) && $(RM) $(INCLUDES) + -$(RM) $(DESTDIR)$(MODDIR)/srfi/99/records/*.{sld,scm} + -$(RM) $(DESTDIR)$(MODDIR)/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*.{sld,scm} $(DESTDIR)$(MODDIR)/*/*/*.{sld,scm} + -$(CD) $(DESTDIR)$(MODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%) + -$(CD) $(DESTDIR)$(BINMODDIR) && $(RM) $(COMPILED_LIBS:lib/%=%) + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(BINMODDIR)/chibi/char-set + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/crypto $(DESTDIR)$(BINMODDIR)/chibi/crypto + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(BINMODDIR)/chibi/io + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(BINMODDIR)/chibi/loop + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(BINMODDIR)/chibi/match + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/math $(DESTDIR)$(BINMODDIR)/chibi/math + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(BINMODDIR)/chibi/monad + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(BINMODDIR)/chibi/net + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(BINMODDIR)/chibi/optimize + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(BINMODDIR)/chibi/parse + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(BINMODDIR)/chibi/show + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(BINMODDIR)/chibi/term + -$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi + -$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char + -$(RMDIR) $(DESTDIR)$(MODDIR)/scheme $(DESTDIR)$(BINMODDIR)/scheme + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(BINMODDIR)/srfi/1 + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/18 + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/27 + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/33 + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/39 + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/69 + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/95 + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/98 $(DESTDIR)$(BINMODDIR)/srfi/98 + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(BINMODDIR)/srfi/99/records + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(BINMODDIR)/srfi/99 + -$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi + -$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR) + -$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1 + +dist: dist-clean + $(RM) chibi-scheme-`cat VERSION`.tgz + $(MKDIR) chibi-scheme-`cat VERSION` + @for f in `hg manifest | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-`cat VERSION`/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done + $(TAR) cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION` + $(RM) -r chibi-scheme-`cat VERSION` + +mips-dist: dist-clean + $(RM) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz + $(MKDIR) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + @for f in `hg manifest | grep -v ^benchmarks/`; do $(MKDIR) chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/`dirname $$f`; $(SYMLINK) `pwd`/$$f chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`/$$f; done + $(TAR) cphzvf chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'`.tgz chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` + $(RM) -r chibi-scheme-`date +%Y%m%d`-`hg tags|head -1|sed -n 's/.* \([0-9]*\):.*/\1/p'` diff --git a/Makefile.detect b/Makefile.detect new file mode 100644 index 00000000..7357130a --- /dev/null +++ b/Makefile.detect @@ -0,0 +1,113 @@ +# -*- makefile-gmake -*- + +######################################################################## +# Detect the PLATFORM with uname. + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +ifeq ($(shell uname),FreeBSD) +PLATFORM=bsd +else +ifeq ($(shell uname),NetBSD) +PLATFORM=bsd +else +ifeq ($(shell uname),OpenBSD) +PLATFORM=bsd +else +ifeq ($(shell uname),DragonFly) +PLATFORM=bsd +else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +ifeq ($(shell uname -o),Cygwin) +PLATFORM=cygwin +SOLIBDIR = $(BINDIR) +DIFFOPTS = -b +else +ifeq ($(shell uname -o),GNU/Linux) +PLATFORM=linux +else +PLATFORM=unix +endif +endif +endif +endif +endif +endif +endif +endif + +######################################################################## +# Set default variables for the platform. + +LIBDL = -ldl + +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = +CLINKFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc -DSEXP_USE_DL=0 +else +ifeq ($(PLATFORM),bsd) +SO = .so +EXE = +CLIBFLAGS = -fPIC +CLINKFLAGS = -shared +LIBDL = +else +ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = +CLINKFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 -DBUILDING_DLL +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +STATICFLAGS = -DSEXP_USE_DL=0 +LIBDL = +else +ifeq ($(PLATFORM),cygwin) +SO = .dll +EXE = .exe +CC = gcc +CLIBFLAGS = +CLINKFLAGS = -shared +CPPFLAGS += -DSEXP_USE_STRING_STREAMS=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a +else +SO = .so +EXE = +CLIBFLAGS = -fPIC +CLINKFLAGS = -shared +STATICFLAGS = -static -DSEXP_USE_DL=0 +ifeq ($(PLATFORM),BSD) +LIBDL= +RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR) +endif +endif +endif +endif +endif +endif + +ifeq ($(PLATFORM),unix) +#RLDFLAGS=-rpath $(LIBDIR) +RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR) +endif + +######################################################################## +# Check for NTP (who needs autoconf?) + +ifndef $(SEXP_USE_NTP_GETTIME) +SEXP_USE_NTP_GETTIME := $(shell echo "main(){struct ntptimeval n; ntp_gettime(&n);}" | gcc -fsyntax-only -include sys/timex.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0) +endif + +ifeq ($(SEXP_USE_NTP_GETTIME),1) +CPPFLAGS += -DSEXP_USE_NTPGETTIME +endif diff --git a/Makefile.libs b/Makefile.libs new file mode 100644 index 00000000..02599184 --- /dev/null +++ b/Makefile.libs @@ -0,0 +1,86 @@ +# -*- makefile-gmake -*- + +# Include-able makefile for building Chibi libraries - see README.libs +# for usage. + +.PHONY: all all-libs clean clean-libs dist-clean dist-clean-libs install install-libs uninstall uninstall-libs doc doc-libs +.PRECIOUS: %.c lib/%.c + +# install configuration + +CC ?= cc +AR ?= ar +CD ?= cd +RM ?= rm -f +LS ?= ls +INSTALL ?= install +MKDIR ?= $(INSTALL) -d +RMDIR ?= rmdir +TAR ?= tar +DIFF ?= diff +GREP ?= grep +FIND ?= find +SYMLINK ?= ln -s + +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +SOLIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi +BINMODDIR ?= $(PREFIX)/lib/chibi +MANDIR ?= $(PREFIX)/share/man/man1 + +DESTDIR ?= + +######################################################################## +# System configuration - if not using GNU make, set PLATFORM and the +# flags from Makefile.detect (at least SO, EXE, CLIBFLAGS) as necessary. + +include Makefile.detect + +######################################################################## + +all-libs: $(COMPILED_LIBS) + +lib/%.c: lib/%.stub $(CHIBI_FFI_DEPENDENCIES) + $(CHIBI_FFI) $< + +lib/%$(SO): lib/%.c $(INCLUDES) + $(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. $(XLIBS) -lchibi-scheme + +doc-libs: $(HTML_LIBS) + +doc/lib/%.html: lib/%.sld + $(MKDIR) $(dir $@) + $(CHIBI_DOC) --html $(subst /,.,$*) > $@ + +clean-libs: + $(RM) $(COMPILED_LIBS) + $(RM) -r $(patsubst %,%.dSYM,$(COMPILED_LIBS)) + $(RM) $(HTML_LIBS) + +dist-clean-libs: clean-libs + $(RM) $(patsubst %.stub, %.c, $(shell $(FIND) lib -name \*.stub)) + +install-libs: all-libs + for dir in $(dir $(patsubst lib/%,%,$(COMPILED_LIBS))) ; do \ + $(MKDIR) $(DESTDIR)$(BINMODDIR)/$$dir; \ + done + for file in $(patsubst lib/%,%,$(COMPILED_LIBS)) ; do \ + $(INSTALL) lib/$$file $(DESTDIR)$(BINMODDIR)/$$file ; \ + done + for dir in $(dir $(patsubst lib/%,%,$(SCM_LIBS))) ; do \ + $(MKDIR) $(DESTDIR)$(MODDIR)/$$dir; \ + done + for file in $(patsubst lib/%,%,$(SCM_LIBS)) ; do \ + $(INSTALL) lib/$$file $(DESTDIR)$(MODDIR)/$$file ; \ + done + +uninstall-libs: + for file in $(patsubst lib/%,%,$(COMPILED_LIBS)) ; do \ + $(RM) $(DESTDIR)$(BINMODDIR)/$$file ; \ + done + for file in $(patsubst lib/%,%,$(SCM_LIBS)) ; do \ + $(RM) $(DESTDIR)$(MODDIR)/$$file ; \ + done diff --git a/README b/README new file mode 100644 index 00000000..520dfcb8 --- /dev/null +++ b/README @@ -0,0 +1,39 @@ + + Chibi-Scheme + -------------- + + Minimal Scheme Implementation for use as an Extension Language + + http://synthcode.com/wiki/chibi-scheme/ + +Chibi-Scheme is a very small library intended for use as an extension +and scripting language in C programs. In addition to support for +lightweight VM-based threads, each VM itself runs in an isolated heap +allowing multiple VMs to run simultaneously in different OS threads. + +The default language is the R7RS (scheme base) library. + +Support for additional languages such as JavaScript, Go, Lua and Bash +are planned for future releases. Scheme is chosen as a substrate +because its first class continuations and guaranteed tail-call +optimization makes implementing other languages easy. + +To build on most platforms just run "make && make test". This will +provide a shared library "libchibi-scheme", as well as a sample +"chibi-scheme" command-line repl. You can then run + + sudo make install + +to install the binaries and libraries. You can optionally specify a +PREFIX for the installation directory: + + make PREFIX=/path/to/install/ + sudo make PREFIX=/path/to/install/ install + +By default files are installed in /usr/local. + +If you want to try out chibi-scheme without installing, be sure to set +LD_LIBRARY_PATH so it can find the shared libraries. + +For more detailed documentation, run "make doc" and see the generated +"doc/chibi.html". diff --git a/README.libs b/README.libs new file mode 100644 index 00000000..6c17f960 --- /dev/null +++ b/README.libs @@ -0,0 +1,110 @@ +Using the Makefile.libs File To Build and Install Libraries +----------------------------------------------------------- + +The Makefile.libs file distributed with the Chibi Scheme sources +can facilitate building and installing Chibi Scheme libraries written +in C or Scheme. To use it, follow these instructions: + +1. Copy the Makefile.libs and Makefile.detect files from the Chibi + Scheme source directory to the library source top-level directory. + +2. Place the library source in the subdirectory "lib" of the library + source top-level directory. For example, + + lib/foo/bar.c + lib/foo/bar.h + lib/foo/bar.sld + lib/foo/bar.scm + +3. In the Makefile in the library source top-level directory, define + the following targets: + + all + doc + install + uninstall + clean + dist-clean + + These should depend on the corresponding "-libs" target, but + can include additional commands. For example: + + all: all-libs + install: install-libs + cp -r doc $(PREFIX)/share/chibi/ + uninstall: uninstall-libs + doc: doc-libs + clean: clean-libs + dist-clean: dist-clean-libs + + The all target should be the first target in the Makefile. + + The all-libs target makes the shared libraries in the library. + The doc-libs target generates HTML files for the library. The + install-libs and uninstall-libs targets install and uninstall + the library under the prefix. The clean-libs target removes the + shared libraries and generated HTML files. The dist-clean-libs + removes any .c files generated from .stub files and also performs + a clean-libs. + +4. In the Makefile in the library source top-level directory, define + the following variables: + + COMPILED_LIBS: Any shared libraries that should be built and + installed. The shared library is build from the corresponding + .c or .stub file. The $(SO) variable should be used for the + shared-library suffix; in order for this to work COMPILED_LIBS + should be defined as a recursively-expanded variable (with + =) rather than a simply-expanded variable (with :=). + + INCLUDES: Any other files on which the shared libraries depend. + + SCM_LIBS: Any Scheme source files that should be installed. + + HTML_LIBS: Any HTML files that should be generated. The HTML + files are generated from the corresponding .sld files using + chibi-doc. + + For example, + + COMPILED_LIBS = lib/foo/bar$(SO) + INCLUDES = lib/foo/bar.h + SCM_LIBS = lib/foo/bar.sld lib/foo/bar.scm + HTML_LIBS = doc/lib/foo/bar.html + +5. Add additional flags as necessary to XCPPFLAGS, XCFLAGS, and XLIBS. + These flags are passed to the compiler and linker when they + generate the shared library. These should probably be defined at + minimum as: + + XCPPFLAGS += -I$(PREFIX)/include + XCFLAGS += -L$(PREFIX)/lib + XLIBS += + + These additions will ensure that the compiler and linker can + find the Chibi Scheme include and library files, even if they + are installed under a non-standard prefix. + +6. Include the common Makefile using: + + include Makefile.libs + +A complete example is: + + all: all-libs + install: install-libs + uninstall: uninstall-libs + doc: doc-libs + clean: clean-libs + dist-clean: dist-clean-libs + + COMPILED_LIBS = lib/foo/bar$(SO) + INCLUDES = lib/foo/bar.h + SCM_LIBS = lib/foo/bar.sld lib/foo/bar.scm + HTML_LIBS = doc/lib/foo/bar.html + + XCPPFLAGS += -I$(PREFIX)/include + XCFLAGS += -L$(PREFIX)/lib + XLIBS += -lpthread + + include Makefile.libs diff --git a/RELEASE b/RELEASE new file mode 100644 index 00000000..ca932e56 --- /dev/null +++ b/RELEASE @@ -0,0 +1 @@ +carbon diff --git a/TODO b/TODO new file mode 100644 index 00000000..1d741ce1 --- /dev/null +++ b/TODO @@ -0,0 +1,187 @@ +-*- 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 + API redesign in preparation complete, initial + tests on native factorial and closures working. +** TODO fasl/image files + sexp_copy_context() can form the basis for images, + FASL for arbitrary modules will need additional + help with resolving external references. +*** DONE optional image loading on startup + - State "DONE" from "TODO" [2011-11-10 Thu 20:44] +*** TODO static image compiled into library + With this you'll be able to run Chibi without any filesystem. +*** TODO external tool to compact and optimize images + The current GC is mark&sweep, which can cause fragmentation, + but we can at at least compact the initial fixed image. +*** TODO fasl versions of modules + Important for large applications, and fast loading of script + with many dependencies. +** 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 +** DONE type inference with warnings + - State "DONE" from "TODO" [2010-09-21 Tue 23:18] +*** TODO structured type inference +*** DONE infer error branches + CLOSED: [2011-11-14 Mon 08:17] +*** TODO elide type checks from type information + +* 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] +** DONE support weak references + - State "DONE" from "TODO" [2010-09-21 Tue 23:16] +*** TODO support proper weak key-value references + +* runtime +** DONE bignums + - State "DONE" [2009-07-07 Tue 14:42] +** DONE unicode + - State "DONE" from "TODO" [2010-07-11 Sun 23:58] + Supported with UTF-8 strings, string-ref is O(n) and + string-set! may need to reallocate the whole string. + string-cursor-ref can be used for O(1) string access. +** DONE threads + - State "DONE" from "TODO" [2010-07-11 Sun 15:31] + VM now supports an optional hook for green threads, + and a SRFI-18 interface is provided as a separate module. + I/O operations will currently block all threads though, + this needs to be addressed. +*** DONE thread-local parameters + CLOSED: [2010-12-06 Mon 21:52] +*** TODO efficient priority queues +** 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] +** DONE network interface + - State "DONE" from "TODO" [2011-11-10 Thu 20:46] +** DONE posix interface + - State "DONE" from "TODO" [2010-07-11 Sun 15:36] + 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] +** DONE iPhone support + - State "DONE" from "TODO" [2011-11-10 Thu 20:46] +** TODO bare-metal support + +* miscellaneous +** DONE user documentation + - State "DONE" from "TODO" [2011-11-10 Thu 20:45] +** TODO full test suite for libraries +** TODO thorough source documentation + +* distribution +** TODO packaging format (Snow2) +** TODO code repository with fetch+install tool +** TODO translator to/from other implementations + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..e28ba924 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.6.99 diff --git a/benchmarks/gabriel/chibi-prelude.scm b/benchmarks/gabriel/chibi-prelude.scm new file mode 100644 index 00000000..3f9fb1d1 --- /dev/null +++ b/benchmarks/gabriel/chibi-prelude.scm @@ -0,0 +1,30 @@ + +(import (chibi time) (scheme cxr) (srfi 33) (srfi 39)) + +(define (timeval->milliseconds tv) + (quotient (+ (* 1000000 (timeval-seconds tv)) (timeval-microseconds tv)) + 1000)) + +(define (time* thunk) + (call-with-output-string + (lambda (out) + (let* ((start (car (get-time-of-day))) + (result (parameterize ((current-output-port out)) (thunk))) + (end (car (get-time-of-day))) + (msecs (- (timeval->milliseconds end) + (timeval->milliseconds start)))) + (display "user: ") + (display msecs) + (display " system: 0") + (display " real: ") + (display msecs) + (display " gc: 0") + (newline) + (display "result: ") + (write result) + (newline) + result)))) + +(define-syntax time + (syntax-rules () + ((_ expr) (time* (lambda () expr))))) diff --git a/benchmarks/gabriel/conform.sch b/benchmarks/gabriel/conform.sch new file mode 100644 index 00000000..dadcc5d9 --- /dev/null +++ b/benchmarks/gabriel/conform.sch @@ -0,0 +1,623 @@ +; +; conform.scm [portable/R^399RS version] +; By Jim Miller [mods by oz] +; [call to run-benchmark added by wdc 14 Feb 1997] + +; (declare (usual-integrations)) + +;; SORT + +(define (vector-copy v) + (let* ((length (vector-length v)) + (result (make-vector length))) + (let loop ((n 0)) + (vector-set! result n (vector-ref v n)) + (if (= n length) + v + (loop (+ n 1)))))) + +(define (sort obj pred) + (define (loop l) + (if (and (pair? l) (pair? (cdr l))) + (split l '() '()) + l)) + + (define (split l one two) + (if (pair? l) + (split (cdr l) two (cons (car l) one)) + (merge (loop one) (loop two)))) + + (define (merge one two) + (cond ((null? one) two) + ((pred (car two) (car one)) + (cons (car two) + (merge (cdr two) one))) + (else + (cons (car one) + (merge (cdr one) two))))) + + (cond ((or (pair? obj) (null? obj)) + (loop obj)) + ((vector? obj) + (sort! (vector-copy obj) pred)) + (else + (error "sort: argument should be a list or vector" obj)))) + +;; This merge sort is stable for partial orders (for predicates like +;; <=, rather than like <). + +(define (sort! v pred) + (define (sort-internal! vec temp low high) + (if (< low high) + (let* ((middle (quotient (+ low high) 2)) + (next (+ middle 1))) + (sort-internal! temp vec low middle) + (sort-internal! temp vec next high) + (let loop ((p low) (p1 low) (p2 next)) + (if (not (> p high)) + (cond ((> p1 middle) + (vector-set! vec p (vector-ref temp p2)) + (loop (+ p 1) p1 (+ p2 1))) + ((or (> p2 high) + (pred (vector-ref temp p1) + (vector-ref temp p2))) + (vector-set! vec p (vector-ref temp p1)) + (loop (+ p 1) (+ p1 1) p2)) + (else + (vector-set! vec p (vector-ref temp p2)) + (loop (+ p 1) p1 (+ p2 1))))))))) + + (if (not (vector? v)) + (error "sort!: argument not a vector" v)) + + (sort-internal! v + (vector-copy v) + 0 + (- (vector-length v) 1)) + v) + +;; SET OPERATIONS +; (representation as lists with distinct elements) + +(define (adjoin element set) + (if (memq element set) set (cons element set))) + +(define (eliminate element set) + (cond ((null? set) set) + ((eq? element (car set)) (cdr set)) + (else (cons (car set) (eliminate element (cdr set)))))) + +(define (intersect list1 list2) + (let loop ((l list1)) + (cond ((null? l) '()) + ((memq (car l) list2) (cons (car l) (loop (cdr l)))) + (else (loop (cdr l)))))) + +(define (union list1 list2) + (if (null? list1) + list2 + (union (cdr list1) + (adjoin (car list1) list2)))) + +;; GRAPH NODES + +; (define-structure +; (internal-node +; (print-procedure (unparser/standard-method +; 'graph-node +; (lambda (state node) +; (unparse-object state (internal-node-name node)))))) +; name +; (green-edges '()) +; (red-edges '()) +; blue-edges) + +; Above is MIT version; below is portable + +(define make-internal-node vector) +(define (internal-node-name node) (vector-ref node 0)) +(define (internal-node-green-edges node) (vector-ref node 1)) +(define (internal-node-red-edges node) (vector-ref node 2)) +(define (internal-node-blue-edges node) (vector-ref node 3)) +(define (set-internal-node-name! node name) (vector-set! node 0 name)) +(define (set-internal-node-green-edges! node edges) (vector-set! node 1 edges)) +(define (set-internal-node-red-edges! node edges) (vector-set! node 2 edges)) +(define (set-internal-node-blue-edges! node edges) (vector-set! node 3 edges)) + +; End of portability stuff + +(define (make-node name . blue-edges) ; User's constructor + (let ((name (if (symbol? name) (symbol->string name) name)) + (blue-edges (if (null? blue-edges) 'NOT-A-NODE-YET (car blue-edges)))) + (make-internal-node name '() '() blue-edges))) + +(define (copy-node node) + (make-internal-node (name node) '() '() (blue-edges node))) + +; Selectors + +(define name internal-node-name) +(define (make-edge-getter selector) + (lambda (node) + (if (or (none-node? node) (any-node? node)) + (error "Can't get edges from the ANY or NONE nodes") + (selector node)))) +(define red-edges (make-edge-getter internal-node-red-edges)) +(define green-edges (make-edge-getter internal-node-green-edges)) +(define blue-edges (make-edge-getter internal-node-blue-edges)) + +; Mutators + +(define (make-edge-setter mutator!) + (lambda (node value) + (cond ((any-node? node) (error "Can't set edges from the ANY node")) + ((none-node? node) 'OK) + (else (mutator! node value))))) +(define set-red-edges! (make-edge-setter set-internal-node-red-edges!)) +(define set-green-edges! (make-edge-setter set-internal-node-green-edges!)) +(define set-blue-edges! (make-edge-setter set-internal-node-blue-edges!)) + +;; BLUE EDGES + +; (define-structure +; (blue-edge +; (print-procedure +; (unparser/standard-method +; 'blue-edge +; (lambda (state edge) +; (unparse-object state (blue-edge-operation edge)))))) +; operation arg-node res-node) + +; Above is MIT version; below is portable + +(define make-blue-edge vector) +(define (blue-edge-operation edge) (vector-ref edge 0)) +(define (blue-edge-arg-node edge) (vector-ref edge 1)) +(define (blue-edge-res-node edge) (vector-ref edge 2)) +(define (set-blue-edge-operation! edge value) (vector-set! edge 0 value)) +(define (set-blue-edge-arg-node! edge value) (vector-set! edge 1 value)) +(define (set-blue-edge-res-node! edge value) (vector-set! edge 2 value)) + +; End of portability stuff + +; Selectors +(define operation blue-edge-operation) +(define arg-node blue-edge-arg-node) +(define res-node blue-edge-res-node) + +; Mutators +(define set-arg-node! set-blue-edge-arg-node!) +(define set-res-node! set-blue-edge-res-node!) + +; Higher level operations on blue edges + +(define (lookup-op op node) + (let loop ((edges (blue-edges node))) + (cond ((null? edges) '()) + ((eq? op (operation (car edges))) (car edges)) + (else (loop (cdr edges)))))) + +(define (has-op? op node) + (not (null? (lookup-op op node)))) + +; Add a (new) blue edge to a node + +; (define (adjoin-blue-edge! blue-edge node) +; (let ((current-one (lookup-op (operation blue-edge) node))) +; (cond ((null? current-one) +; (set-blue-edges! node +; (cons blue-edge (blue-edges node)))) +; ((and (eq? (arg-node current-one) (arg-node blue-edge)) +; (eq? (res-node current-one) (res-node blue-edge))) +; 'OK) +; (else (error "Two non-equivalent blue edges for op" +; blue-edge node))))) + +;; GRAPHS + +; (define-structure +; (internal-graph +; (print-procedure +; (unparser/standard-method 'graph +; (lambda (state edge) +; (unparse-object state (map name (internal-graph-nodes edge))))))) +; nodes already-met already-joined) + +; Above is MIT version; below is portable + +(define make-internal-graph vector) +(define (internal-graph-nodes graph) (vector-ref graph 0)) +(define (internal-graph-already-met graph) (vector-ref graph 1)) +(define (internal-graph-already-joined graph) (vector-ref graph 2)) +(define (set-internal-graph-nodes! graph nodes) (vector-set! graph 0 nodes)) + +; End of portability stuff + +; Constructor + +(define (make-graph . nodes) + (make-internal-graph nodes (make-empty-table) (make-empty-table))) + +; Selectors + +(define graph-nodes internal-graph-nodes) +(define already-met internal-graph-already-met) +(define already-joined internal-graph-already-joined) + +; Higher level functions on graphs + +(define (add-graph-nodes! graph nodes) + (set-internal-graph-nodes! graph (cons nodes (graph-nodes graph)))) + +(define (copy-graph g) + (define (copy-list l) (vector->list (list->vector l))) + (make-internal-graph + (copy-list (graph-nodes g)) + (already-met g) + (already-joined g))) + +(define (clean-graph g) + (define (clean-node node) + (if (not (or (any-node? node) (none-node? node))) + (begin + (set-green-edges! node '()) + (set-red-edges! node '())))) + (for-each clean-node (graph-nodes g)) + g) + +(define (canonicalize-graph graph classes) + (define (fix node) + (define (fix-set object selector mutator) + (mutator object + (map (lambda (node) + (find-canonical-representative node classes)) + (selector object)))) + (if (not (or (none-node? node) (any-node? node))) + (begin + (fix-set node green-edges set-green-edges!) + (fix-set node red-edges set-red-edges!) + (for-each + (lambda (blue-edge) + (set-arg-node! blue-edge + (find-canonical-representative (arg-node blue-edge) classes)) + (set-res-node! blue-edge + (find-canonical-representative (res-node blue-edge) classes))) + (blue-edges node)))) + node) + (define (fix-table table) + (define (canonical? node) (eq? node (find-canonical-representative node classes))) + (define (filter-and-fix predicate-fn update-fn list) + (let loop ((list list)) + (cond ((null? list) '()) + ((predicate-fn (car list)) + (cons (update-fn (car list)) (loop (cdr list)))) + (else (loop (cdr list)))))) + (define (fix-line line) + (filter-and-fix + (lambda (entry) (canonical? (car entry))) + (lambda (entry) (cons (car entry) + (find-canonical-representative (cdr entry) classes))) + line)) + (if (null? table) + '() + (cons (car table) + (filter-and-fix + (lambda (entry) (canonical? (car entry))) + (lambda (entry) (cons (car entry) (fix-line (cdr entry)))) + (cdr table))))) + (make-internal-graph + (map (lambda (class) (fix (car class))) classes) + (fix-table (already-met graph)) + (fix-table (already-joined graph)))) + +;; USEFUL NODES + +(define none-node (make-node 'none #t)) +(define (none-node? node) (eq? node none-node)) + +(define any-node (make-node 'any '())) +(define (any-node? node) (eq? node any-node)) + +;; COLORED EDGE TESTS + + +(define (green-edge? from-node to-node) + (cond ((any-node? from-node) #f) + ((none-node? from-node) #t) + ((memq to-node (green-edges from-node)) #t) + (else #f))) + +(define (red-edge? from-node to-node) + (cond ((any-node? from-node) #f) + ((none-node? from-node) #t) + ((memq to-node (red-edges from-node)) #t) + (else #f))) + +;; SIGNATURE + +; Return signature (i.e. ) given an operation and a node + +(define sig + (let ((none-comma-any (cons none-node any-node))) + (lambda (op node) ; Returns (arg, res) + (let ((the-edge (lookup-op op node))) + (if (not (null? the-edge)) + (cons (arg-node the-edge) (res-node the-edge)) + none-comma-any))))) + +; Selectors from signature + +(define (arg pair) (car pair)) +(define (res pair) (cdr pair)) + +;; CONFORMITY + +(define (conforms? t1 t2) + (define nodes-with-red-edges-out '()) + (define (add-red-edge! from-node to-node) + (set-red-edges! from-node (adjoin to-node (red-edges from-node))) + (set! nodes-with-red-edges-out + (adjoin from-node nodes-with-red-edges-out))) + (define (greenify-red-edges! from-node) + (set-green-edges! from-node + (append (red-edges from-node) (green-edges from-node))) + (set-red-edges! from-node '())) + (define (delete-red-edges! from-node) + (set-red-edges! from-node '())) + (define (does-conform t1 t2) + (cond ((or (none-node? t1) (any-node? t2)) #t) + ((or (any-node? t1) (none-node? t2)) #f) + ((green-edge? t1 t2) #t) + ((red-edge? t1 t2) #t) + (else + (add-red-edge! t1 t2) + (let loop ((blues (blue-edges t2))) + (if (null? blues) + #t + (let* ((current-edge (car blues)) + (phi (operation current-edge))) + (and (has-op? phi t1) + (does-conform + (res (sig phi t1)) + (res (sig phi t2))) + (does-conform + (arg (sig phi t2)) + (arg (sig phi t1))) + (loop (cdr blues))))))))) + (let ((result (does-conform t1 t2))) + (for-each (if result greenify-red-edges! delete-red-edges!) + nodes-with-red-edges-out) + result)) + +(define (equivalent? a b) + (and (conforms? a b) (conforms? b a))) + +;; EQUIVALENCE CLASSIFICATION +; Given a list of nodes, return a list of equivalence classes + +(define (classify nodes) + (let node-loop ((classes '()) + (nodes nodes)) + (if (null? nodes) + (map (lambda (class) + (sort class + (lambda (node1 node2) + (< (string-length (name node1)) + (string-length (name node2)))))) + classes) + (let ((this-node (car nodes))) + (define (add-node classes) + (cond ((null? classes) (list (list this-node))) + ((equivalent? this-node (caar classes)) + (cons (cons this-node (car classes)) + (cdr classes))) + (else (cons (car classes) + (add-node (cdr classes)))))) + (node-loop (add-node classes) + (cdr nodes)))))) + +; Given a node N and a classified set of nodes, +; find the canonical member corresponding to N + +(define (find-canonical-representative element classification) + (let loop ((classes classification)) + (cond ((null? classes) (error "Can't classify" element)) + ((memq element (car classes)) (car (car classes))) + (else (loop (cdr classes)))))) + +; Reduce a graph by taking only one member of each equivalence +; class and canonicalizing all outbound pointers + +(define (reduce graph) + (let ((classes (classify (graph-nodes graph)))) + (canonicalize-graph graph classes))) + +;; TWO DIMENSIONAL TABLES + +(define (make-empty-table) (list 'TABLE)) + +(define (lookup table x y) + (let ((one (assq x (cdr table)))) + (if one + (let ((two (assq y (cdr one)))) + (if two (cdr two) #f)) + #f))) + +(define (insert! table x y value) + (define (make-singleton-table x y) + (list (cons x y))) + (let ((one (assq x (cdr table)))) + (if one + (set-cdr! one (cons (cons y value) (cdr one))) + (set-cdr! table (cons (cons x (make-singleton-table y value)) + (cdr table)))))) + +;; MEET/JOIN +; These update the graph when computing the node for node1*node2 + +(define (blue-edge-operate arg-fn res-fn graph op sig1 sig2) + (make-blue-edge op + (arg-fn graph (arg sig1) (arg sig2)) + (res-fn graph (res sig1) (res sig2)))) + +(define (meet graph node1 node2) + (cond ((eq? node1 node2) node1) + ((or (any-node? node1) (any-node? node2)) any-node) ; canonicalize + ((none-node? node1) node2) + ((none-node? node2) node1) + ((lookup (already-met graph) node1 node2)) ; return it if found + ((conforms? node1 node2) node2) + ((conforms? node2 node1) node1) + (else + (let ((result + (make-node (string-append "(" (name node1) " ^ " (name node2) ")")))) + (add-graph-nodes! graph result) + (insert! (already-met graph) node1 node2 result) + (set-blue-edges! result + (map + (lambda (op) + (blue-edge-operate join meet graph op (sig op node1) (sig op node2))) + (intersect (map operation (blue-edges node1)) + (map operation (blue-edges node2))))) + result)))) + +(define (join graph node1 node2) + (cond ((eq? node1 node2) node1) + ((any-node? node1) node2) + ((any-node? node2) node1) + ((or (none-node? node1) (none-node? node2)) none-node) ; canonicalize + ((lookup (already-joined graph) node1 node2)) ; return it if found + ((conforms? node1 node2) node1) + ((conforms? node2 node1) node2) + (else + (let ((result + (make-node (string-append "(" (name node1) " v " (name node2) ")")))) + (add-graph-nodes! graph result) + (insert! (already-joined graph) node1 node2 result) + (set-blue-edges! result + (map + (lambda (op) + (blue-edge-operate meet join graph op (sig op node1) (sig op node2))) + (union (map operation (blue-edges node1)) + (map operation (blue-edges node2))))) + result)))) + +;; MAKE A LATTICE FROM A GRAPH + +(define (make-lattice g print?) + (define (step g) + (let* ((copy (copy-graph g)) + (nodes (graph-nodes copy))) + (for-each (lambda (first) + (for-each (lambda (second) + (meet copy first second) + (join copy first second)) + nodes)) + nodes) + copy)) + (define (loop g count) + (if print? (display count)) + (let ((lattice (step g))) + (if print? (begin (display " -> ") + (display (length (graph-nodes lattice))))) + (let* ((new-g (reduce lattice)) + (new-count (length (graph-nodes new-g)))) + (if (= new-count count) + (begin + (if print? (newline)) + new-g) + (begin + (if print? (begin (display " -> ") + (display new-count) (newline))) + (loop new-g new-count)))))) + (let ((graph + (apply make-graph + (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g))))))) + (loop graph (length (graph-nodes graph))))) + +;; DEBUG and TEST + +(define a '()) +(define b '()) +(define c '()) +(define d '()) + +(define (reset) + (set! a (make-node 'a)) + (set! b (make-node 'b)) + (set-blue-edges! a (list (make-blue-edge 'phi any-node b))) + (set-blue-edges! b (list (make-blue-edge 'phi any-node a) + (make-blue-edge 'theta any-node b))) + (set! c (make-node "c")) + (set! d (make-node "d")) + (set-blue-edges! c (list (make-blue-edge 'theta any-node b))) + (set-blue-edges! d (list (make-blue-edge 'phi any-node c) + (make-blue-edge 'theta any-node d))) + '(made a b c d)) + +(define (test) + (reset) + (map name + (graph-nodes + (make-lattice (make-graph a b c d any-node none-node) #t)))) + ;;; note printflag #t +;(define (time-test) +; (let ((t (runtime))) +; (let ((ans (test))) +; (cons ans (- (runtime) t))))) + +; +; run and make sure result is correct +; +(define (go) + (reset) + (let ((result '("(((b v d) ^ a) v c)" + "(c ^ d)" + "(b v (a ^ d))" + "((a v d) ^ b)" + "(b v d)" + "(b ^ (a v c))" + "(a v (c ^ d))" + "((b v d) ^ a)" + "(c v (a v d))" + "(a v c)" + "(d v (b ^ (a v c)))" + "(d ^ (a v c))" + "((a ^ d) v c)" + "((a ^ b) v d)" + "(((a v d) ^ b) v (a ^ d))" + "(b ^ d)" + "(b v (a v d))" + "(a ^ c)" + "(b ^ (c v d))" + "(a ^ b)" + "(a v b)" + "((a ^ d) ^ b)" + "(a ^ d)" + "(a v d)" + "d" + "(c v d)" + "a" + "b" + "c" + "any" + "none"))) + + (if (equal? (test) result) + (display " ok.") + (display " um.")) + (newline))) + +;[mods made by wdc] +;(go) +;(exit) + +(time (let loop ((n 10)) + (if (zero? n) + 'done + (begin + (go) + (loop (- n 1)))))) + + + diff --git a/benchmarks/gabriel/cpstack.sch b/benchmarks/gabriel/cpstack.sch new file mode 100644 index 00000000..6ef109b8 --- /dev/null +++ b/benchmarks/gabriel/cpstack.sch @@ -0,0 +1,34 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: cpstak.sch +; Description: continuation-passing version of TAK +; Author: Will Clinger +; Created: 20-Aug-87 +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; CPSTAK -- A continuation-passing version of the TAK benchmark. +;;; A good test of first class procedures and tail recursion. + +(define (cpstak x y z) + (define (tak x y z k) + (if (not (< y x)) + (k z) + (tak (- x 1) + y + z + (lambda (v1) + (tak (- y 1) + z + x + (lambda (v2) + (tak (- z 1) + x + y + (lambda (v3) + (tak v1 v2 v3 k))))))))) + (tak x y z (lambda (a) a))) + +;;; call: (cpstak 18 12 6) + +(time (cpstak 18 12 2)) diff --git a/benchmarks/gabriel/ctak.sch b/benchmarks/gabriel/ctak.sch new file mode 100644 index 00000000..f6c6cbc1 --- /dev/null +++ b/benchmarks/gabriel/ctak.sch @@ -0,0 +1,61 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: ctak.sch +; Description: The ctak benchmark +; Author: Richard Gabriel +; Created: 5-Apr-85 +; Modified: 10-Apr-85 14:53:02 (Bob Shaw) +; 24-Jul-87 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; The original version of this benchmark used a continuation mechanism that +; is less powerful than call-with-current-continuation and also relied on +; dynamic binding, which is not provided in standard Scheme. Since the +; intent of the benchmark seemed to be to test non-local exits, the dynamic +; binding has been replaced here by lexical binding. + +; For Scheme the comment that follows should read: +;;; CTAK -- A version of the TAK procedure that uses continuations. + +;;; CTAK -- A version of the TAK function that uses the CATCH/THROW facility. + +(define (ctak x y z) + (call-with-current-continuation + (lambda (k) + (ctak-aux k x y z)))) + +(define (ctak-aux k x y z) + (cond ((not (< y x)) ;xy + (k z)) + (else (call-with-current-continuation + (ctak-aux + k + (call-with-current-continuation + (lambda (k) + (ctak-aux k + (- x 1) + y + z))) + (call-with-current-continuation + (lambda (k) + (ctak-aux k + (- y 1) + z + x))) + (call-with-current-continuation + (lambda (k) + (ctak-aux k + (- z 1) + x + y)))))))) + +;;; call: (ctak 18 12 6) + +(let ((input (with-input-from-file "input.txt" read))) + (time (let loop ((n 8) (v 0)) + (if (zero? n) + v + (loop (- n 1) + (ctak 18 12 (if input 6 0))))))) + diff --git a/benchmarks/gabriel/dderiv.sch b/benchmarks/gabriel/dderiv.sch new file mode 100644 index 00000000..5e47a0b0 --- /dev/null +++ b/benchmarks/gabriel/dderiv.sch @@ -0,0 +1,97 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: dderiv.sch +; Description: DDERIV benchmark from the Gabriel tests +; Author: Vaughan Pratt +; Created: 8-Apr-85 +; Modified: 10-Apr-85 14:53:29 (Bob Shaw) +; 23-Jul-87 (Will Clinger) +; 9-Feb-88 (Will Clinger) +; Language: Scheme (but see note below) +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Note: This benchmark uses property lists. The procedures that must +; be supplied are get and put, where (put x y z) is equivalent to Common +; Lisp's (setf (get x y) z). + +;;; DDERIV -- Symbolic derivative benchmark written by Vaughn Pratt. + +;;; This benchmark is a variant of the simple symbolic derivative program +;;; (DERIV). The main change is that it is `table-driven.' Instead of using a +;;; large COND that branches on the CAR of the expression, this program finds +;;; the code that will take the derivative on the property list of the atom in +;;; the CAR position. So, when the expression is (+ . ), the code +;;; stored under the atom '+ with indicator DERIV will take and +;;; return the derivative for '+. The way that MacLisp does this is with the +;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an +;;; atomic name in that it expects an argument list and the compiler compiles +;;; code, but the name of the function with that code is stored on the +;;; property list of FOO under the indicator BAR, in this case. You may have +;;; to do something like: + +;;; :property keyword is not Common Lisp. + +; Returns the wrong answer for quotients. +; Fortunately these aren't used in the benchmark. + +(define pg-alist '()) +(define (put sym d what) + (set! pg-alist (cons (cons sym what) pg-alist))) +(define (get sym d) + (cdr (assq sym pg-alist))) + +(define (dderiv-aux a) + (list '/ (dderiv a) a)) + +(define (f+dderiv a) + (cons '+ (map dderiv a))) + +(define (f-dderiv a) + (cons '- (map dderiv a))) + +(define (*dderiv a) + (list '* (cons '* a) + (cons '+ (map dderiv-aux a)))) + +(define (/dderiv a) + (list '- + (list '/ + (dderiv (car a)) + (cadr a)) + (list '/ + (car a) + (list '* + (cadr a) + (cadr a) + (dderiv (cadr a)))))) + +(define (dderiv a) + (cond + ((not (pair? a)) + (cond ((eq? a 'x) 1) (else 0))) + (else (let ((dderiv (get (car a) 'dderiv))) + (cond (dderiv (dderiv (cdr a))) + (else 'error)))))) + +(define (run) + (do ((i 0 (+ i 1))) + ((= i 50000)) + (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) + (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) + (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) + (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) + (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)))) + +(put '+ 'dderiv f+dderiv) ; install procedure on the property list + +(put '- 'dderiv f-dderiv) ; install procedure on the property list + +(put '* 'dderiv *dderiv) ; install procedure on the property list + +(put '/ 'dderiv /dderiv) ; install procedure on the property list + +;;; call: (run) + +(time (run)) + + diff --git a/benchmarks/gabriel/deriv.sch b/benchmarks/gabriel/deriv.sch new file mode 100644 index 00000000..74881b46 --- /dev/null +++ b/benchmarks/gabriel/deriv.sch @@ -0,0 +1,59 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: deriv.sch +; Description: The DERIV benchmark from the Gabriel tests. +; Author: Vaughan Pratt +; Created: 8-Apr-85 +; Modified: 10-Apr-85 14:53:50 (Bob Shaw) +; 23-Jul-87 (Will Clinger) +; 9-Feb-88 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; DERIV -- Symbolic derivative benchmark written by Vaughn Pratt. +;;; It uses a simple subset of Lisp and does a lot of CONSing. + +; Returns the wrong answer for quotients. +; Fortunately these aren't used in the benchmark. + +(define (deriv-aux a) (list '/ (deriv a) a)) + +(define (deriv a) + (cond + ((not (pair? a)) + (cond ((eq? a 'x) 1) (else 0))) + ((eq? (car a) '+) + (cons '+ (map deriv (cdr a)))) + ((eq? (car a) '-) + (cons '- (map deriv + (cdr a)))) + ((eq? (car a) '*) + (list '* + a + (cons '+ (map deriv-aux (cdr a))))) + ((eq? (car a) '/) + (list '- + (list '/ + (deriv (cadr a)) + (caddr a)) + (list '/ + (cadr a) + (list '* + (caddr a) + (caddr a) + (deriv (caddr a)))))) + (else 'error))) + +(define (run) + (do ((i 0 (+ i 1))) + ((= i 50000)) + (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) + (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) + (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) + (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) + (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)))) + +;;; call: (run) + +(time (run)) + diff --git a/benchmarks/gabriel/destruct.sch b/benchmarks/gabriel/destruct.sch new file mode 100644 index 00000000..bbc4473e --- /dev/null +++ b/benchmarks/gabriel/destruct.sch @@ -0,0 +1,70 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: destruct.sch +; Description: DESTRUCTIVE benchmark from Gabriel tests +; Author: Bob Shaw, HPLabs/ATC +; Created: 8-Apr-85 +; Modified: 10-Apr-85 14:54:12 (Bob Shaw) +; 23-Jul-87 (Will Clinger) +; 22-Jan-88 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; append! is no longer a standard Scheme procedure, so it must be defined +; for implementations that don't already have it. + +(define (my-append! x y) + (if (null? x) + y + (do ((a x b) + (b (cdr x) (cdr b))) + ((null? b) + (set-cdr! a y) + x)))) + +;;; DESTRU -- Destructive operation benchmark + +(define (destructive n m) + (let ((l (do ((i 10 (- i 1)) + (a '() (cons '() a))) + ((= i 0) a)))) + (do ((i n (- i 1))) + ((= i 0)) + (cond ((null? (car l)) + (do ((l l (cdr l))) + ((null? l)) + (or (car l) + (set-car! l (cons '() '()))) + (my-append! (car l) + (do ((j m (- j 1)) + (a '() (cons '() a))) + ((= j 0) a))))) + (else + (do ((l1 l (cdr l1)) + (l2 (cdr l) (cdr l2))) + ((null? l2)) + (set-cdr! (do ((j (quotient (length (car l2)) 2) (- j 1)) + (a (car l2) (cdr a))) + ((zero? j) a) + (set-car! a i)) + (let ((n (quotient (length (car l1)) 2))) + (cond ((= n 0) (set-car! l1 '()) + (car l1)) + (else + (do ((j n (- j 1)) + (a (car l1) (cdr a))) + ((= j 1) + (let ((x (cdr a))) + (set-cdr! a '()) + x)) + (set-car! a i)))))))))))) + +;;; call: (destructive 600 50) + +(let ((input (with-input-from-file "input.txt" read))) + (time (let loop ((n 10) (v 0)) + (if (zero? n) + 'v + (loop (- n 1) + (destructive (if input 600 0) 500)))))) + diff --git a/benchmarks/gabriel/div.sch b/benchmarks/gabriel/div.sch new file mode 100644 index 00000000..cbdaeb08 --- /dev/null +++ b/benchmarks/gabriel/div.sch @@ -0,0 +1,57 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: div.sch +; Description: DIV benchmarks +; Author: Richard Gabriel +; Created: 8-Apr-85 +; Modified: 19-Jul-85 18:28:01 (Bob Shaw) +; 23-Jul-87 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s. +;;; This file contains a recursive as well as an iterative test. + +(define (create-n n) + (do ((n n (- n 1)) + (a '() (cons '() a))) + ((= n 0) a))) + +(define *ll* (create-n 200)) + +(define (iterative-div2 l) + (do ((l l (cddr l)) + (a '() (cons (car l) a))) + ((null? l) a))) + +(define (recursive-div2 l) + (cond ((null? l) '()) + (else (cons (car l) (recursive-div2 (cddr l)))))) + +(define (test-1 l) + (do ((i 3000 (- i 1))) + ((= i 0)) + (iterative-div2 l) + (iterative-div2 l) + (iterative-div2 l) + (iterative-div2 l))) + +(define (test-2 l) + (do ((i 3000 (- i 1))) + ((= i 0)) + (recursive-div2 l) + (recursive-div2 l) + (recursive-div2 l) + (recursive-div2 l))) + +;;; for the iterative test call: (test-1 *ll*) +;;; for the recursive test call: (test-2 *ll*) + +(let ((input (with-input-from-file "input.txt" read))) + (time (let loop ((n 10) (v 0)) + (if (zero? n) + v + (loop (- n 1) + (cons + (test-1 (if input *ll* '())) + (test-2 (if input *ll* '())))))))) diff --git a/benchmarks/gabriel/earley.sch b/benchmarks/gabriel/earley.sch new file mode 100644 index 00000000..d5f90a23 --- /dev/null +++ b/benchmarks/gabriel/earley.sch @@ -0,0 +1,649 @@ +;;; EARLEY -- Earley's parser, written by Marc Feeley. + +; $Id: earley.sch,v 1.2 1999/07/12 18:05:19 lth Exp $ +; 990708 / lth -- changed 'main' to 'earley-benchmark'. +; +; (make-parser grammar lexer) is used to create a parser from the grammar +; description `grammar' and the lexer function `lexer'. +; +; A grammar is a list of definitions. Each definition defines a non-terminal +; by a set of rules. Thus a definition has the form: (nt rule1 rule2...). +; A given non-terminal can only be defined once. The first non-terminal +; defined is the grammar's goal. Each rule is a possibly empty list of +; non-terminals. Thus a rule has the form: (nt1 nt2...). A non-terminal +; can be any scheme value. Note that all grammar symbols are treated as +; non-terminals. This is fine though because the lexer will be outputing +; non-terminals. +; +; The lexer defines what a token is and the mapping between tokens and +; the grammar's non-terminals. It is a function of one argument, the input, +; that returns the list of tokens corresponding to the input. Each token is +; represented by a list. The first element is some `user-defined' information +; associated with the token and the rest represents the token's class(es) (as a +; list of non-terminals that this token corresponds to). +; +; The result of `make-parser' is a function that parses the single input it +; is given into the grammar's goal. The result is a `parse' which can be +; manipulated with the procedures: `parse->parsed?', `parse->trees' +; and `parse->nb-trees' (see below). +; +; Let's assume that we want a parser for the grammar +; +; S -> x = E +; E -> E + E | V +; V -> V y | +; +; and that the input to the parser is a string of characters. Also, assume we +; would like to map the characters `x', `y', `+' and `=' into the corresponding +; non-terminals in the grammar. Such a parser could be created with +; +; (make-parser +; '( +; (s (x = e)) +; (e (e + e) (v)) +; (v (v y) ()) +; ) +; (lambda (str) +; (map (lambda (char) +; (list char ; user-info = the character itself +; (case char +; ((#\x) 'x) +; ((#\y) 'y) +; ((#\+) '+) +; ((#\=) '=) +; (else (fatal-error "lexer error"))))) +; (string->list str))) +; ) +; +; An alternative definition (that does not check for lexical errors) is +; +; (make-parser +; '( +; (s (#\x #\= e)) +; (e (e #\+ e) (v)) +; (v (v #\y) ()) +; ) +; (lambda (str) (map (lambda (char) (list char char)) (string->list str))) +; ) +; +; To help with the rest of the discussion, here are a few definitions: +; +; An input pointer (for an input of `n' tokens) is a value between 0 and `n'. +; It indicates a point between two input tokens (0 = beginning, `n' = end). +; For example, if `n' = 4, there are 5 input pointers: +; +; input token1 token2 token3 token4 +; input pointers 0 1 2 3 4 +; +; A configuration indicates the extent to which a given rule is parsed (this +; is the common `dot notation'). For simplicity, a configuration is +; represented as an integer, with successive configurations in the same +; rule associated with successive integers. It is assumed that the grammar +; has been extended with rules to aid scanning. These rules are of the +; form `nt ->', and there is one such rule for every non-terminal. Note +; that these rules are special because they only apply when the corresponding +; non-terminal is returned by the lexer. +; +; A configuration set is a configuration grouped with the set of input pointers +; representing where the head non-terminal of the configuration was predicted. +; +; Here are the rules and configurations for the grammar given above: +; +; S -> . \ +; 0 | +; x -> . | +; 1 | +; = -> . | +; 2 | +; E -> . | +; 3 > special rules (for scanning) +; + -> . | +; 4 | +; V -> . | +; 5 | +; y -> . | +; 6 / +; S -> . x . = . E . +; 7 8 9 10 +; E -> . E . + . E . +; 11 12 13 14 +; E -> . V . +; 15 16 +; V -> . V . y . +; 17 18 19 +; V -> . +; 20 +; +; Starters of the non-terminal `nt' are configurations that are leftmost +; in a non-special rule for `nt'. Enders of the non-terminal `nt' are +; configurations that are rightmost in any rule for `nt'. Predictors of the +; non-terminal `nt' are configurations that are directly to the left of `nt' +; in any rule. +; +; For the grammar given above, +; +; Starters of V = (17 20) +; Enders of V = (5 19 20) +; Predictors of V = (15 17) + +(define (make-parser grammar lexer) + + (define (non-terminals grammar) ; return vector of non-terminals in grammar + + (define (add-nt nt nts) + (if (member nt nts) nts (cons nt nts))) ; use equal? for equality tests + + (let def-loop ((defs grammar) (nts '())) + (if (pair? defs) + (let* ((def (car defs)) + (head (car def))) + (let rule-loop ((rules (cdr def)) + (nts (add-nt head nts))) + (if (pair? rules) + (let ((rule (car rules))) + (let loop ((l rule) (nts nts)) + (if (pair? l) + (let ((nt (car l))) + (loop (cdr l) (add-nt nt nts))) + (rule-loop (cdr rules) nts)))) + (def-loop (cdr defs) nts)))) + (list->vector (reverse nts))))) ; goal non-terminal must be at index 0 + + (define (ind nt nts) ; return index of non-terminal `nt' in `nts' + (let loop ((i (- (vector-length nts) 1))) + (if (>= i 0) + (if (equal? (vector-ref nts i) nt) i (loop (- i 1))) + #f))) + + (define (nb-configurations grammar) ; return nb of configurations in grammar + (let def-loop ((defs grammar) (nb-confs 0)) + (if (pair? defs) + (let ((def (car defs))) + (let rule-loop ((rules (cdr def)) (nb-confs nb-confs)) + (if (pair? rules) + (let ((rule (car rules))) + (let loop ((l rule) (nb-confs nb-confs)) + (if (pair? l) + (loop (cdr l) (+ nb-confs 1)) + (rule-loop (cdr rules) (+ nb-confs 1))))) + (def-loop (cdr defs) nb-confs)))) + nb-confs))) + +; First, associate a numeric identifier to every non-terminal in the +; grammar (with the goal non-terminal associated with 0). +; +; So, for the grammar given above we get: +; +; s -> 0 x -> 1 = -> 4 e ->3 + -> 4 v -> 5 y -> 6 + + (let* ((nts (non-terminals grammar)) ; id map = list of non-terms + (nb-nts (vector-length nts)) ; the number of non-terms + (nb-confs (+ (nb-configurations grammar) nb-nts)) ; the nb of confs + (starters (make-vector nb-nts '())) ; starters for every non-term + (enders (make-vector nb-nts '())) ; enders for every non-term + (predictors (make-vector nb-nts '())) ; predictors for every non-term + (steps (make-vector nb-confs #f)) ; what to do in a given conf + (names (make-vector nb-confs #f))) ; name of rules + + (define (setup-tables grammar nts starters enders predictors steps names) + + (define (add-conf conf nt nts class) + (let ((i (ind nt nts))) + (vector-set! class i (cons conf (vector-ref class i))))) + + (let ((nb-nts (vector-length nts))) + + (let nt-loop ((i (- nb-nts 1))) + (if (>= i 0) + (begin + (vector-set! steps i (- i nb-nts)) + (vector-set! names i (list (vector-ref nts i) 0)) + (vector-set! enders i (list i)) + (nt-loop (- i 1))))) + + (let def-loop ((defs grammar) (conf (vector-length nts))) + (if (pair? defs) + (let* ((def (car defs)) + (head (car def))) + (let rule-loop ((rules (cdr def)) (conf conf) (rule-num 1)) + (if (pair? rules) + (let ((rule (car rules))) + (vector-set! names conf (list head rule-num)) + (add-conf conf head nts starters) + (let loop ((l rule) (conf conf)) + (if (pair? l) + (let ((nt (car l))) + (vector-set! steps conf (ind nt nts)) + (add-conf conf nt nts predictors) + (loop (cdr l) (+ conf 1))) + (begin + (vector-set! steps conf (- (ind head nts) nb-nts)) + (add-conf conf head nts enders) + (rule-loop (cdr rules) (+ conf 1) (+ rule-num 1)))))) + (def-loop (cdr defs) conf)))))))) + +; Now, for each non-terminal, compute the starters, enders and predictors and +; the names and steps tables. + + (setup-tables grammar nts starters enders predictors steps names) + +; Build the parser description + + (let ((parser-descr (vector lexer + nts + starters + enders + predictors + steps + names))) + (lambda (input) + + (define (ind nt nts) ; return index of non-terminal `nt' in `nts' + (let loop ((i (- (vector-length nts) 1))) + (if (>= i 0) + (if (equal? (vector-ref nts i) nt) i (loop (- i 1))) + #f))) + + (define (comp-tok tok nts) ; transform token to parsing format + (let loop ((l1 (cdr tok)) (l2 '())) + (if (pair? l1) + (let ((i (ind (car l1) nts))) + (if i + (loop (cdr l1) (cons i l2)) + (loop (cdr l1) l2))) + (cons (car tok) (reverse l2))))) + + (define (input->tokens input lexer nts) + (list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input)))) + + (define (make-states nb-toks nb-confs) + (let ((states (make-vector (+ nb-toks 1) #f))) + (let loop ((i nb-toks)) + (if (>= i 0) + (let ((v (make-vector (+ nb-confs 1) #f))) + (vector-set! v 0 -1) + (vector-set! states i v) + (loop (- i 1))) + states)))) + + (define (conf-set-get state conf) + (vector-ref state (+ conf 1))) + + (define (conf-set-get* state state-num conf) + (let ((conf-set (conf-set-get state conf))) + (if conf-set + conf-set + (let ((conf-set (make-vector (+ state-num 6) #f))) + (vector-set! conf-set 1 -3) ; old elems tail (points to head) + (vector-set! conf-set 2 -1) ; old elems head + (vector-set! conf-set 3 -1) ; new elems tail (points to head) + (vector-set! conf-set 4 -1) ; new elems head + (vector-set! state (+ conf 1) conf-set) + conf-set)))) + + (define (conf-set-merge-new! conf-set) + (vector-set! conf-set + (+ (vector-ref conf-set 1) 5) + (vector-ref conf-set 4)) + (vector-set! conf-set 1 (vector-ref conf-set 3)) + (vector-set! conf-set 3 -1) + (vector-set! conf-set 4 -1)) + + (define (conf-set-head conf-set) + (vector-ref conf-set 2)) + + (define (conf-set-next conf-set i) + (vector-ref conf-set (+ i 5))) + + (define (conf-set-member? state conf i) + (let ((conf-set (vector-ref state (+ conf 1)))) + (if conf-set + (conf-set-next conf-set i) + #f))) + + (define (conf-set-adjoin state conf-set conf i) + (let ((tail (vector-ref conf-set 3))) ; put new element at tail + (vector-set! conf-set (+ i 5) -1) + (vector-set! conf-set (+ tail 5) i) + (vector-set! conf-set 3 i) + (if (< tail 0) + (begin + (vector-set! conf-set 0 (vector-ref state 0)) + (vector-set! state 0 conf))))) + + (define (conf-set-adjoin* states state-num l i) + (let ((state (vector-ref states state-num))) + (let loop ((l1 l)) + (if (pair? l1) + (let* ((conf (car l1)) + (conf-set (conf-set-get* state state-num conf))) + (if (not (conf-set-next conf-set i)) + (begin + (conf-set-adjoin state conf-set conf i) + (loop (cdr l1))) + (loop (cdr l1)))))))) + + (define (conf-set-adjoin** states states* state-num conf i) + (let ((state (vector-ref states state-num))) + (if (conf-set-member? state conf i) + (let* ((state* (vector-ref states* state-num)) + (conf-set* (conf-set-get* state* state-num conf))) + (if (not (conf-set-next conf-set* i)) + (conf-set-adjoin state* conf-set* conf i)) + #t) + #f))) + + (define (conf-set-union state conf-set conf other-set) + (let loop ((i (conf-set-head other-set))) + (if (>= i 0) + (if (not (conf-set-next conf-set i)) + (begin + (conf-set-adjoin state conf-set conf i) + (loop (conf-set-next other-set i))) + (loop (conf-set-next other-set i)))))) + + (define (forw states state-num starters enders predictors steps nts) + + (define (predict state state-num conf-set conf nt starters enders) + + ; add configurations which start the non-terminal `nt' to the + ; right of the dot + + (let loop1 ((l (vector-ref starters nt))) + (if (pair? l) + (let* ((starter (car l)) + (starter-set (conf-set-get* state state-num starter))) + (if (not (conf-set-next starter-set state-num)) + (begin + (conf-set-adjoin state starter-set starter state-num) + (loop1 (cdr l))) + (loop1 (cdr l)))))) + + ; check for possible completion of the non-terminal `nt' to the + ; right of the dot + + (let loop2 ((l (vector-ref enders nt))) + (if (pair? l) + (let ((ender (car l))) + (if (conf-set-member? state ender state-num) + (let* ((next (+ conf 1)) + (next-set (conf-set-get* state state-num next))) + (conf-set-union state next-set next conf-set) + (loop2 (cdr l))) + (loop2 (cdr l))))))) + + (define (reduce states state state-num conf-set head preds) + + ; a non-terminal is now completed so check for reductions that + ; are now possible at the configurations `preds' + + (let loop1 ((l preds)) + (if (pair? l) + (let ((pred (car l))) + (let loop2 ((i head)) + (if (>= i 0) + (let ((pred-set (conf-set-get (vector-ref states i) pred))) + (if pred-set + (let* ((next (+ pred 1)) + (next-set (conf-set-get* state state-num next))) + (conf-set-union state next-set next pred-set))) + (loop2 (conf-set-next conf-set i))) + (loop1 (cdr l)))))))) + + (let ((state (vector-ref states state-num)) + (nb-nts (vector-length nts))) + (let loop () + (let ((conf (vector-ref state 0))) + (if (>= conf 0) + (let* ((step (vector-ref steps conf)) + (conf-set (vector-ref state (+ conf 1))) + (head (vector-ref conf-set 4))) + (vector-set! state 0 (vector-ref conf-set 0)) + (conf-set-merge-new! conf-set) + (if (>= step 0) + (predict state state-num conf-set conf step starters enders) + (let ((preds (vector-ref predictors (+ step nb-nts)))) + (reduce states state state-num conf-set head preds))) + (loop))))))) + + (define (forward starters enders predictors steps nts toks) + (let* ((nb-toks (vector-length toks)) + (nb-confs (vector-length steps)) + (states (make-states nb-toks nb-confs)) + (goal-starters (vector-ref starters 0))) + (conf-set-adjoin* states 0 goal-starters 0) ; predict goal + (forw states 0 starters enders predictors steps nts) + (let loop ((i 0)) + (if (< i nb-toks) + (let ((tok-nts (cdr (vector-ref toks i)))) + (conf-set-adjoin* states (+ i 1) tok-nts i) ; scan token + (forw states (+ i 1) starters enders predictors steps nts) + (loop (+ i 1))))) + states)) + + (define (produce conf i j enders steps toks states states* nb-nts) + (let ((prev (- conf 1))) + (if (and (>= conf nb-nts) (>= (vector-ref steps prev) 0)) + (let loop1 ((l (vector-ref enders (vector-ref steps prev)))) + (if (pair? l) + (let* ((ender (car l)) + (ender-set (conf-set-get (vector-ref states j) + ender))) + (if ender-set + (let loop2 ((k (conf-set-head ender-set))) + (if (>= k 0) + (begin + (and (>= k i) + (conf-set-adjoin** states states* k prev i) + (conf-set-adjoin** states states* j ender k)) + (loop2 (conf-set-next ender-set k))) + (loop1 (cdr l)))) + (loop1 (cdr l))))))))) + + (define (back states states* state-num enders steps nb-nts toks) + (let ((state* (vector-ref states* state-num))) + (let loop1 () + (let ((conf (vector-ref state* 0))) + (if (>= conf 0) + (let* ((conf-set (vector-ref state* (+ conf 1))) + (head (vector-ref conf-set 4))) + (vector-set! state* 0 (vector-ref conf-set 0)) + (conf-set-merge-new! conf-set) + (let loop2 ((i head)) + (if (>= i 0) + (begin + (produce conf i state-num enders steps + toks states states* nb-nts) + (loop2 (conf-set-next conf-set i))) + (loop1))))))))) + + (define (backward states enders steps nts toks) + (let* ((nb-toks (vector-length toks)) + (nb-confs (vector-length steps)) + (nb-nts (vector-length nts)) + (states* (make-states nb-toks nb-confs)) + (goal-enders (vector-ref enders 0))) + (let loop1 ((l goal-enders)) + (if (pair? l) + (let ((conf (car l))) + (conf-set-adjoin** states states* nb-toks conf 0) + (loop1 (cdr l))))) + (let loop2 ((i nb-toks)) + (if (>= i 0) + (begin + (back states states* i enders steps nb-nts toks) + (loop2 (- i 1))))) + states*)) + + (define (parsed? nt i j nts enders states) + (let ((nt* (ind nt nts))) + (if nt* + (let ((nb-nts (vector-length nts))) + (let loop ((l (vector-ref enders nt*))) + (if (pair? l) + (let ((conf (car l))) + (if (conf-set-member? (vector-ref states j) conf i) + #t + (loop (cdr l)))) + #f))) + #f))) + + (define (deriv-trees conf i j enders steps names toks states nb-nts) + (let ((name (vector-ref names conf))) + + (if name ; `conf' is at the start of a rule (either special or not) + (if (< conf nb-nts) + (list (list name (car (vector-ref toks i)))) + (list (list name))) + + (let ((prev (- conf 1))) + (let loop1 ((l1 (vector-ref enders (vector-ref steps prev))) + (l2 '())) + (if (pair? l1) + (let* ((ender (car l1)) + (ender-set (conf-set-get (vector-ref states j) + ender))) + (if ender-set + (let loop2 ((k (conf-set-head ender-set)) (l2 l2)) + (if (>= k 0) + (if (and (>= k i) + (conf-set-member? (vector-ref states k) + prev i)) + (let ((prev-trees + (deriv-trees prev i k enders steps names + toks states nb-nts)) + (ender-trees + (deriv-trees ender k j enders steps names + toks states nb-nts))) + (let loop3 ((l3 ender-trees) (l2 l2)) + (if (pair? l3) + (let ((ender-tree (list (car l3)))) + (let loop4 ((l4 prev-trees) (l2 l2)) + (if (pair? l4) + (loop4 (cdr l4) + (cons (append (car l4) + ender-tree) + l2)) + (loop3 (cdr l3) l2)))) + (loop2 (conf-set-next ender-set k) l2)))) + (loop2 (conf-set-next ender-set k) l2)) + (loop1 (cdr l1) l2))) + (loop1 (cdr l1) l2))) + l2)))))) + + (define (deriv-trees* nt i j nts enders steps names toks states) + (let ((nt* (ind nt nts))) + (if nt* + (let ((nb-nts (vector-length nts))) + (let loop ((l (vector-ref enders nt*)) (trees '())) + (if (pair? l) + (let ((conf (car l))) + (if (conf-set-member? (vector-ref states j) conf i) + (loop (cdr l) + (append (deriv-trees conf i j enders steps names + toks states nb-nts) + trees)) + (loop (cdr l) trees))) + trees))) + #f))) + + (define (nb-deriv-trees conf i j enders steps toks states nb-nts) + (let ((prev (- conf 1))) + (if (or (< conf nb-nts) (< (vector-ref steps prev) 0)) + 1 + (let loop1 ((l (vector-ref enders (vector-ref steps prev))) + (n 0)) + (if (pair? l) + (let* ((ender (car l)) + (ender-set (conf-set-get (vector-ref states j) + ender))) + (if ender-set + (let loop2 ((k (conf-set-head ender-set)) (n n)) + (if (>= k 0) + (if (and (>= k i) + (conf-set-member? (vector-ref states k) + prev i)) + (let ((nb-prev-trees + (nb-deriv-trees prev i k enders steps + toks states nb-nts)) + (nb-ender-trees + (nb-deriv-trees ender k j enders steps + toks states nb-nts))) + (loop2 (conf-set-next ender-set k) + (+ n (* nb-prev-trees nb-ender-trees)))) + (loop2 (conf-set-next ender-set k) n)) + (loop1 (cdr l) n))) + (loop1 (cdr l) n))) + n))))) + + (define (nb-deriv-trees* nt i j nts enders steps toks states) + (let ((nt* (ind nt nts))) + (if nt* + (let ((nb-nts (vector-length nts))) + (let loop ((l (vector-ref enders nt*)) (nb-trees 0)) + (if (pair? l) + (let ((conf (car l))) + (if (conf-set-member? (vector-ref states j) conf i) + (loop (cdr l) + (+ (nb-deriv-trees conf i j enders steps + toks states nb-nts) + nb-trees)) + (loop (cdr l) nb-trees))) + nb-trees))) + #f))) + + (let* ((lexer (vector-ref parser-descr 0)) + (nts (vector-ref parser-descr 1)) + (starters (vector-ref parser-descr 2)) + (enders (vector-ref parser-descr 3)) + (predictors (vector-ref parser-descr 4)) + (steps (vector-ref parser-descr 5)) + (names (vector-ref parser-descr 6)) + (toks (input->tokens input lexer nts))) + + (vector nts + starters + enders + predictors + steps + names + toks + (backward (forward starters enders predictors steps nts toks) + enders steps nts toks) + parsed? + deriv-trees* + nb-deriv-trees*)))))) + +(define (parse->parsed? parse nt i j) + (let* ((nts (vector-ref parse 0)) + (enders (vector-ref parse 2)) + (states (vector-ref parse 7)) + (parsed? (vector-ref parse 8))) + (parsed? nt i j nts enders states))) + +(define (parse->trees parse nt i j) + (let* ((nts (vector-ref parse 0)) + (enders (vector-ref parse 2)) + (steps (vector-ref parse 4)) + (names (vector-ref parse 5)) + (toks (vector-ref parse 6)) + (states (vector-ref parse 7)) + (deriv-trees* (vector-ref parse 9))) + (deriv-trees* nt i j nts enders steps names toks states))) + +(define (parse->nb-trees parse nt i j) + (let* ((nts (vector-ref parse 0)) + (enders (vector-ref parse 2)) + (steps (vector-ref parse 4)) + (toks (vector-ref parse 6)) + (states (vector-ref parse 7)) + (nb-deriv-trees* (vector-ref parse 10))) + (nb-deriv-trees* nt i j nts enders steps toks states))) + +(define (test k) + (let ((p (make-parser '( (s (a) (s s)) ) + (lambda (l) (map (lambda (x) (list x x)) l))))) + (let ((x (p (vector->list (make-vector k 'a))))) + (length (parse->trees x 's 0 k))))) + +(time (test 12)) diff --git a/benchmarks/gabriel/fft.sch b/benchmarks/gabriel/fft.sch new file mode 100644 index 00000000..92ed55d0 --- /dev/null +++ b/benchmarks/gabriel/fft.sch @@ -0,0 +1,117 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: fft.cl +; Description: FFT benchmark from the Gabriel tests. +; Author: Harry Barrow +; Created: 8-Apr-85 +; Modified: 6-May-85 09:29:22 (Bob Shaw) +; 11-Aug-87 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define pi (atan 0 -1)) + +;;; FFT -- This is an FFT benchmark written by Harry Barrow. +;;; It tests a variety of floating point operations, +;;; including array references. + +(define *re* (make-vector 1025 0.0)) + +(define *im* (make-vector 1025 0.0)) + +(define (fft areal aimag) + (let ((ar 0) + (ai 0) + (i 0) + (j 0) + (k 0) + (m 0) + (n 0) + (le 0) + (le1 0) + (ip 0) + (nv2 0) + (nm1 0) + (ur 0) + (ui 0) + (wr 0) + (wi 0) + (tr 0) + (ti 0)) + ;; initialize + (set! ar areal) + (set! ai aimag) + (set! n (vector-length ar)) + (set! n (- n 1)) + (set! nv2 (quotient n 2)) + (set! nm1 (- n 1)) + (set! m 0) ;compute m = log(n) + (set! i 1) + (let loop () + (if (< i n) + (begin (set! m (+ m 1)) + (set! i (+ i i)) + (loop)))) + (cond ((not (= n (expt 2 m))) + (error "array size not a power of two."))) + ;; interchange elements in bit-reversed order + (set! j 1) + (set! i 1) + (let l3 () + (cond ((< i j) + (set! tr (vector-ref ar j)) + (set! ti (vector-ref ai j)) + (vector-set! ar j (vector-ref ar i)) + (vector-set! ai j (vector-ref ai i)) + (vector-set! ar i tr) + (vector-set! ai i ti))) + (set! k nv2) + (let l6 () + (cond ((< k j) + (set! j (- j k)) + (set! k (/ k 2)) + (l6)))) + (set! j (+ j k)) + (set! i (+ i 1)) + (cond ((< i n) + (l3)))) + (do ((l 1 (+ l 1))) ;loop thru stages (syntax converted + ((> l m)) ; from old MACLISP style \bs) + (set! le (expt 2 l)) + (set! le1 (quotient le 2)) + (set! ur 1.0) + (set! ui 0.) + (set! wr (cos (/ pi le1))) + (set! wi (sin (/ pi le1))) + ;; loop thru butterflies + (do ((j 1 (+ j 1))) + ((> j le1)) + ;; do a butterfly + (do ((i j (+ i le))) + ((> i n)) + (set! ip (+ i le1)) + (set! tr (- (* (vector-ref ar ip) ur) + (* (vector-ref ai ip) ui))) + (set! ti (+ (* (vector-ref ar ip) ui) + (* (vector-ref ai ip) ur))) + (vector-set! ar ip (- (vector-ref ar i) tr)) + (vector-set! ai ip (- (vector-ref ai i) ti)) + (vector-set! ar i (+ (vector-ref ar i) tr)) + (vector-set! ai i (+ (vector-ref ai i) ti)))) + (set! tr (- (* ur wr) (* ui wi))) + (set! ti (+ (* ur wi) (* ui wr))) + (set! ur tr) + (set! ui ti)) + #t)) + +;;; the timer which does 10 calls on fft + +(define (fft-bench) + (do ((ntimes 0 (+ ntimes 1))) + ((= ntimes 1000)) + (fft *re* *im*))) + +;;; call: (fft-bench) + +(time (fft-bench)) + diff --git a/benchmarks/gabriel/graphs.sch b/benchmarks/gabriel/graphs.sch new file mode 100644 index 00000000..7a27c230 --- /dev/null +++ b/benchmarks/gabriel/graphs.sch @@ -0,0 +1,645 @@ +; Modified 2 March 1997 by Will Clinger to add graphs-benchmark +; and to expand the four macros below. +; Modified 11 June 1997 by Will Clinger to eliminate assertions +; and to replace a use of "recur" with a named let. +; +; Performance note: (graphs-benchmark 7) allocates +; 34509143 pairs +; 389625 vectors with 2551590 elements +; 56653504 closures (not counting top level and known procedures) + +; End of new code. + +;;; ==== std.ss ==== + +; (define-syntax assert +; (syntax-rules () +; ((assert test info-rest ...) +; #f))) +; +; (define-syntax deny +; (syntax-rules () +; ((deny test info-rest ...) +; #f))) +; +; (define-syntax when +; (syntax-rules () +; ((when test e-first e-rest ...) +; (if test +; (begin e-first +; e-rest ...))))) +; +; (define-syntax unless +; (syntax-rules () +; ((unless test e-first e-rest ...) +; (if (not test) +; (begin e-first +; e-rest ...))))) + +;;; ==== util.ss ==== + + +; Fold over list elements, associating to the left. +(define fold + (lambda (lst folder state) + '(assert (list? lst) + lst) + '(assert (procedure? folder) + folder) + (do ((lst lst + (cdr lst)) + (state state + (folder (car lst) + state))) + ((null? lst) + state)))) + +; Given the size of a vector and a procedure which +; sends indices to desired vector elements, create +; and return the vector. +(define proc->vector + (lambda (size f) + '(assert (and (integer? size) + (exact? size) + (>= size 0)) + size) + '(assert (procedure? f) + f) + (if (zero? size) + (vector) + (let ((x (make-vector size (f 0)))) + (let loop ((i 1)) + (if (< i size) (begin ; [wdc - was when] + (vector-set! x i (f i)) + (loop (+ i 1))))) + x)))) + +(define vector-fold + (lambda (vec folder state) + '(assert (vector? vec) + vec) + '(assert (procedure? folder) + folder) + (let ((len + (vector-length vec))) + (do ((i 0 + (+ i 1)) + (state state + (folder (vector-ref vec i) + state))) + ((= i len) + state))))) + +(define vec-map + (lambda (vec proc) + (proc->vector (vector-length vec) + (lambda (i) + (proc (vector-ref vec i)))))) + +; Given limit, return the list 0, 1, ..., limit-1. +(define giota + (lambda (limit) + '(assert (and (integer? limit) + (exact? limit) + (>= limit 0)) + limit) + (let _-*- + ((limit + limit) + (res + '())) + (if (zero? limit) + res + (let ((limit + (- limit 1))) + (_-*- limit + (cons limit res))))))) + +; Fold over the integers [0, limit). +(define gnatural-fold + (lambda (limit folder state) + '(assert (and (integer? limit) + (exact? limit) + (>= limit 0)) + limit) + '(assert (procedure? folder) + folder) + (do ((i 0 + (+ i 1)) + (state state + (folder i state))) + ((= i limit) + state)))) + +; Iterate over the integers [0, limit). +(define gnatural-for-each + (lambda (limit proc!) + '(assert (and (integer? limit) + (exact? limit) + (>= limit 0)) + limit) + '(assert (procedure? proc!) + proc!) + (do ((i 0 + (+ i 1))) + ((= i limit)) + (proc! i)))) + +(define natural-for-all? + (lambda (limit ok?) + '(assert (and (integer? limit) + (exact? limit) + (>= limit 0)) + limit) + '(assert (procedure? ok?) + ok?) + (let _-*- + ((i 0)) + (or (= i limit) + (and (ok? i) + (_-*- (+ i 1))))))) + +(define natural-there-exists? + (lambda (limit ok?) + '(assert (and (integer? limit) + (exact? limit) + (>= limit 0)) + limit) + '(assert (procedure? ok?) + ok?) + (let _-*- + ((i 0)) + (and (not (= i limit)) + (or (ok? i) + (_-*- (+ i 1))))))) + +(define there-exists? + (lambda (lst ok?) + '(assert (list? lst) + lst) + '(assert (procedure? ok?) + ok?) + (let _-*- + ((lst lst)) + (and (not (null? lst)) + (or (ok? (car lst)) + (_-*- (cdr lst))))))) + + +;;; ==== ptfold.ss ==== + + +; Fold over the tree of permutations of a universe. +; Each branch (from the root) is a permutation of universe. +; Each node at depth d corresponds to all permutations which pick the +; elements spelled out on the branch from the root to that node as +; the first d elements. +; Their are two components to the state: +; The b-state is only a function of the branch from the root. +; The t-state is a function of all nodes seen so far. +; At each node, b-folder is called via +; (b-folder elem b-state t-state deeper accross) +; where elem is the next element of the universe picked. +; If b-folder can determine the result of the total tree fold at this stage, +; it should simply return the result. +; If b-folder can determine the result of folding over the sub-tree +; rooted at the resulting node, it should call accross via +; (accross new-t-state) +; where new-t-state is that result. +; Otherwise, b-folder should call deeper via +; (deeper new-b-state new-t-state) +; where new-b-state is the b-state for the new node and new-t-state is +; the new folded t-state. +; At the leaves of the tree, t-folder is called via +; (t-folder b-state t-state accross) +; If t-folder can determine the result of the total tree fold at this stage, +; it should simply return that result. +; If not, it should call accross via +; (accross new-t-state) +; Note, fold-over-perm-tree always calls b-folder in depth-first order. +; I.e., when b-folder is called at depth d, the branch leading to that +; node is the most recent calls to b-folder at all the depths less than d. +; This is a gross efficiency hack so that b-folder can use mutation to +; keep the current branch. +(define fold-over-perm-tree + (lambda (universe b-folder b-state t-folder t-state) + '(assert (list? universe) + universe) + '(assert (procedure? b-folder) + b-folder) + '(assert (procedure? t-folder) + t-folder) + (let _-*- + ((universe + universe) + (b-state + b-state) + (t-state + t-state) + (accross + (lambda (final-t-state) + final-t-state))) + (if (null? universe) + (t-folder b-state t-state accross) + (let _-**- + ((in + universe) + (out + '()) + (t-state + t-state)) + (let* ((first + (car in)) + (rest + (cdr in)) + (accross + (if (null? rest) + accross + (lambda (new-t-state) + (_-**- rest + (cons first out) + new-t-state))))) + (b-folder first + b-state + t-state + (lambda (new-b-state new-t-state) + (_-*- (fold out cons rest) + new-b-state + new-t-state + accross)) + accross))))))) + + +;;; ==== minimal.ss ==== + + +; A directed graph is stored as a connection matrix (vector-of-vectors) +; where the first index is the `from' vertex and the second is the `to' +; vertex. Each entry is a bool indicating if the edge exists. +; The diagonal of the matrix is never examined. +; Make-minimal? returns a procedure which tests if a labelling +; of the vertices is such that the matrix is minimal. +; If it is, then the procedure returns the result of folding over +; the elements of the automoriphism group. If not, it returns #f. +; The folding is done by calling folder via +; (folder perm state accross) +; If the folder wants to continue, it should call accross via +; (accross new-state) +; If it just wants the entire minimal? procedure to return something, +; it should return that. +; The ordering used is lexicographic (with #t > #f) and entries +; are examined in the following order: +; 1->0, 0->1 +; +; 2->0, 0->2 +; 2->1, 1->2 +; +; 3->0, 0->3 +; 3->1, 1->3 +; 3->2, 2->3 +; ... +(define make-minimal? + (lambda (max-size) + '(assert (and (integer? max-size) + (exact? max-size) + (>= max-size 0)) + max-size) + (let ((iotas + (proc->vector (+ max-size 1) + giota)) + (perm + (make-vector max-size 0))) + (lambda (size graph folder state) + '(assert (and (integer? size) + (exact? size) + (<= 0 size max-size)) + size + max-size) + '(assert (vector? graph) + graph) + '(assert (procedure? folder) + folder) + (fold-over-perm-tree (vector-ref iotas size) + (lambda (perm-x x state deeper accross) + (case (cmp-next-vertex graph perm x perm-x) + ((less) + #f) + ((equal) + (vector-set! perm x perm-x) + (deeper (+ x 1) + state)) + ((more) + (accross state)) + ;(else + ; (assert #f)) + )) + 0 + (lambda (leaf-depth state accross) + '(assert (eqv? leaf-depth size) + leaf-depth + size) + (folder perm state accross)) + state))))) + +; Given a graph, a partial permutation vector, the next input and the next +; output, return 'less, 'equal or 'more depending on the lexicographic +; comparison between the permuted and un-permuted graph. +(define cmp-next-vertex + (lambda (graph perm x perm-x) + (let ((from-x + (vector-ref graph x)) + (from-perm-x + (vector-ref graph perm-x))) + (let _-*- + ((y + 0)) + (if (= x y) + 'equal + (let ((x->y? + (vector-ref from-x y)) + (perm-y + (vector-ref perm y))) + (cond ((eq? x->y? + (vector-ref from-perm-x perm-y)) + (let ((y->x? + (vector-ref (vector-ref graph y) + x))) + (cond ((eq? y->x? + (vector-ref (vector-ref graph perm-y) + perm-x)) + (_-*- (+ y 1))) + (y->x? + 'less) + (else + 'more)))) + (x->y? + 'less) + (else + 'more)))))))) + + +;;; ==== rdg.ss ==== + + +; Fold over rooted directed graphs with bounded out-degree. +; Size is the number of vertices (including the root). Max-out is the +; maximum out-degree for any vertex. Folder is called via +; (folder edges state) +; where edges is a list of length size. The ith element of the list is +; a list of the vertices j for which there is an edge from i to j. +; The last vertex is the root. +(define fold-over-rdg + (lambda (size max-out folder state) + '(assert (and (exact? size) + (integer? size) + (> size 0)) + size) + '(assert (and (exact? max-out) + (integer? max-out) + (>= max-out 0)) + max-out) + '(assert (procedure? folder) + folder) + (let* ((root + (- size 1)) + (edge? + (proc->vector size + (lambda (from) + (make-vector size #f)))) + (edges + (make-vector size '())) + (out-degrees + (make-vector size 0)) + (minimal-folder + (make-minimal? root)) + (non-root-minimal? + (let ((cont + (lambda (perm state accross) + '(assert (eq? state #t) + state) + (accross #t)))) + (lambda (size) + (minimal-folder size + edge? + cont + #t)))) + (root-minimal? + (let ((cont + (lambda (perm state accross) + '(assert (eq? state #t) + state) + (case (cmp-next-vertex edge? perm root root) + ((less) + #f) + ((equal more) + (accross #t)) + ;(else + ; (assert #f)) + )))) + (lambda () + (minimal-folder root + edge? + cont + #t))))) + (let _-*- + ((vertex + 0) + (state + state)) + (cond ((not (non-root-minimal? vertex)) + state) + ((= vertex root) + '(assert + (begin + (gnatural-for-each root + (lambda (v) + '(assert (= (vector-ref out-degrees v) + (length (vector-ref edges v))) + v + (vector-ref out-degrees v) + (vector-ref edges v)))) + #t)) + (let ((reach? + (make-reach? root edges)) + (from-root + (vector-ref edge? root))) + (let _-*- + ((v + 0) + (outs + 0) + (efr + '()) + (efrr + '()) + (state + state)) + (cond ((not (or (= v root) + (= outs max-out))) + (vector-set! from-root v #t) + (let ((state + (_-*- (+ v 1) + (+ outs 1) + (cons v efr) + (cons (vector-ref reach? v) + efrr) + state))) + (vector-set! from-root v #f) + (_-*- (+ v 1) + outs + efr + efrr + state))) + ((and (natural-for-all? root + (lambda (v) + (there-exists? efrr + (lambda (r) + (vector-ref r v))))) + (root-minimal?)) + (vector-set! edges root efr) + (folder + (proc->vector size + (lambda (i) + (vector-ref edges i))) + state)) + (else + state))))) + (else + (let ((from-vertex + (vector-ref edge? vertex))) + (let _-**- + ((sv + 0) + (outs + 0) + (state + state)) + (if (= sv vertex) + (begin + (vector-set! out-degrees vertex outs) + (_-*- (+ vertex 1) + state)) + (let* ((state + ; no sv->vertex, no vertex->sv + (_-**- (+ sv 1) + outs + state)) + (from-sv + (vector-ref edge? sv)) + (sv-out + (vector-ref out-degrees sv)) + (state + (if (= sv-out max-out) + state + (begin + (vector-set! edges + sv + (cons vertex + (vector-ref edges sv))) + (vector-set! from-sv vertex #t) + (vector-set! out-degrees sv (+ sv-out 1)) + (let* ((state + ; sv->vertex, no vertex->sv + (_-**- (+ sv 1) + outs + state)) + (state + (if (= outs max-out) + state + (begin + (vector-set! from-vertex sv #t) + (vector-set! edges + vertex + (cons sv + (vector-ref edges vertex))) + (let ((state + ; sv->vertex, vertex->sv + (_-**- (+ sv 1) + (+ outs 1) + state))) + (vector-set! edges + vertex + (cdr (vector-ref edges vertex))) + (vector-set! from-vertex sv #f) + state))))) + (vector-set! out-degrees sv sv-out) + (vector-set! from-sv vertex #f) + (vector-set! edges + sv + (cdr (vector-ref edges sv))) + state))))) + (if (= outs max-out) + state + (begin + (vector-set! edges + vertex + (cons sv + (vector-ref edges vertex))) + (vector-set! from-vertex sv #t) + (let ((state + ; no sv->vertex, vertex->sv + (_-**- (+ sv 1) + (+ outs 1) + state))) + (vector-set! from-vertex sv #f) + (vector-set! edges + vertex + (cdr (vector-ref edges vertex))) + state))))))))))))) + +; Given a vector which maps vertex to out-going-edge list, +; return a vector which gives reachability. +(define make-reach? + (lambda (size vertex->out) + (let ((res + (proc->vector size + (lambda (v) + (let ((from-v + (make-vector size #f))) + (vector-set! from-v v #t) + (for-each + (lambda (x) + (vector-set! from-v x #t)) + (vector-ref vertex->out v)) + from-v))))) + (gnatural-for-each size + (lambda (m) + (let ((from-m + (vector-ref res m))) + (gnatural-for-each size + (lambda (f) + (let ((from-f + (vector-ref res f))) + (if (vector-ref from-f m); [wdc - was when] + (begin + (gnatural-for-each size + (lambda (t) + (if (vector-ref from-m t) + (begin ; [wdc - was when] + (vector-set! from-f t #t))))))))))))) + res))) + + +;;; ==== test input ==== + +; Produces all directed graphs with N vertices, distinguished root, +; and out-degree bounded by 2, upto isomorphism (there are 44). + +;(define go +; (let ((N 7)) +; (fold-over-rdg N +; 2 +; cons +; '()))) + +(let ((input (with-input-from-file "input.txt" read))) + (time + (length + (let loop ((n 3) (v 0)) + (if (zero? n) + v + (loop (- n 1) + (fold-over-rdg (if input 6 0) + 2 + cons + '()))))))) diff --git a/benchmarks/gabriel/kanren.sch b/benchmarks/gabriel/kanren.sch new file mode 100644 index 00000000..8d46a91d --- /dev/null +++ b/benchmarks/gabriel/kanren.sch @@ -0,0 +1,6489 @@ +;; smashed into benchmark form by Matthew + +(define errorf error) + +; like cout << arguments << args +; where argument can be any Scheme object. If it's a procedure +; (without args) it's executed rather than printed (like newline) + +(define (cout . args) + (for-each (lambda (x) + (if (procedure? x) (x) (display x))) + args)) + +(define cerr cout) + +(define pntall (lambda v (write v) (newline))) +(define (_pretty-print v) (write v) (newline)) + +(define nl (string #\newline)) + +;; ========================================================================= +;; term.scm +;; ========================================================================= + +; Terms, variables, substitutions, unification +; +; The appropriate prelude (e.g., chez-specific.scm) is assumed. + +; Some terminology related to variables and substitutions +; +; A substitution subst is a finite map { xi -> ti ... } +; where xi is a logic variable. +; ti is a term ::= variable | Scheme-atom | (cons term term) +; We will sometimes call one `component' xi -> ti of a substitution +; a commitment, or a binding, of a variable xi to a term ti. +; +; A variable x is free in the substitution subst if x \not\in Dom(subst) +; +; Given a term t and a substitution subst, a weak reduction +; t -->w t' +; is defined as +; x -->w subst[x] if x is a var and x \in Dom(subst) +; t -->w t otherwise +; +; A strong reduction +; t -->s t' +; is defined as +; x -->s subst[x] if x is a var and x \in Dom(subst) +; (cons t1 t2) -->s (cons t1' t2') +; where t1 -->s t1' t2 -->s t2' +; t -->s t otherwise +; +; The notion of reduction can be extended to substitutions themselves: +; { xi -> ti ...} -->w { xi -> ti' } where ti -> ti' +; ditto for -->s. +; Let -->w* be a reflexive transitive closure of -->w, and +; let -->w! be a fixpoint of -->w. Ditto for -->s* and -->s! +; For acyclic substitutions, the fixpoints exist. +; +; The confluence of the reduction is guaranteed by the particular form +; of the substitution produced by the unifier (the unifier always +; deals with the weak normal forms of submitted terms). +; +; The similarity of the weak normalization with call-by-value and +; the strong normalization with the applicative-order reduction should +; be apparent. +; +; Variable x is called ultimately free if +; x -->w! x' and x' is free in the subtutution in question. +; +; Two ultimately free variables x and y belong to the same equivalence class +; if x -->w! u and y -->w! u +; The (free) variable u is the natural class representative. +; For the purpose of presentation, one may wish for a better representative. +; Given a set of equivalent variables xi -->w! u, +; a pretty representative is a member z of that set such that the +; string name of 'z' is lexicographically smaller than the string names +; of the other variables in that set. +; +; If a variable x is ultimately free in subst and x ->w! u, +; then there is a binding +; v1 -> v2 where both v1 and v2 are variables and v2 ->w! u. Furthermore, +; the set of all such v1 union {u} is the whole equivalence class of x. +; That property is guaranteed by the unifier. That property lets us +; build an inverse index to find the equivalence class of x. +; +; $Id: term.scm,v 4.50 2005/02/12 00:05:27 oleg Exp $ + + +;---------------------------------------- +; A few preliminaries +; LET*-AND: a simplified and streamlined AND-LET*. +; The latter is defined in SRFI-2 + +(define-syntax let*-and + (syntax-rules () + ((_ false-exp () body0 body1 ...) (begin body0 body1 ...)) + ((_ false-exp ((var0 exp0) (var1 exp1) ...) body0 body1 ...) + (let ((var0 exp0)) + (if var0 + (let*-and false-exp ((var1 exp1) ...) body0 body1 ...) + false-exp))))) + +; Regression testing framework +; test-check TITLE TESTED-EXPRESSION EXPECTED-RESULT +; where TITLE is something printable (e.g., a symbol or a string) +; EXPECTED-RESULT and TESTED-EXPRESSION are both expressions. +; The expressions are evaluated and their results are cmpared +; by equal? +; If the results compare, we just print the TITLE. +; Otherwise, we print the TITLE, the TESTED-EXPRESSION, and +; the both results. +(define-syntax test-check + (syntax-rules () + ((_ title tested-expression expected-result) + (begin + (cout "Testing " title nl) + (let* ((expected expected-result) + (produced tested-expression)) + (or (equal? expected produced) + (errorf 'test-check + "Failed: ~a~%Expected: ~a~%Computed: ~a~%" + 'tested-expression expected produced))) + #f)))) + +(define symbol-append + (lambda symbs + (string->symbol + (apply string-append + (map symbol->string symbs))))) + +;---------------------------------------- + + +;; use SRFI-9 records +(define (make-logical-variable name) + (vector 'lv name)) +(define (logical-variable? x) + (and (vector? x) (eq? 'lv (vector-ref x 0)))) +(define (logical-variable-id x) + (vector-ref x 1)) + +(define logical-variable make-logical-variable) +(define var? logical-variable?) + +; Introduction of a logical variable +(define-syntax let-lv + (syntax-rules () + ((_ (id ...) body) + (let ((id (logical-variable 'id)) ...) body)))) + +; The anonymous variable +(define __ (let-lv (_) _)) + +; Another way to introduce logical variables: via distinguished pairs +; (define logical-var-tag (list '*logical-var-tag*)) ; unique for eq? +; (define native-pair? pair?) +; (define logical-variable +; (lambda (id) +; (cons logical-var-tag id))) +; (define var? +; (lambda (x) +; (and (native-pair? x) (eq? (car x) logical-var-tag)))) +; (define logical-variable-id +; (lambda (x) +; (if (var? x) (cdr x) +; (errorf 'logical-variable-id "Invalid Logic Variable: ~s" x)))) +; (define pair? +; (lambda (x) +; (and (native-pair? x) (not (eq? (car x) logical-var-tag))))) + + +; Eigen-variables -- unique symbols that represent universally-quantified +; variables in a term +; For identification, we prefix the name of the eigen-variable with +; the exclamation mark. The mark makes sure the symbol stands out when +; printed. + +(define counter 0) +(define (jensym s) + (set! counter (+ counter 1)) + (string->symbol (string-append "!$gen$!" s (number->string counter)))) + +(define eigen-variable + (lambda (id) + (symbol-append '! id '_ (jensym "x")))) + +(define eigen-var? + (lambda (x) + (and (symbol? x) + (let ((str (symbol->string x))) + (> (string-length str) 2) + (char=? (string-ref str 0) #\!))))) + + +; (eigen (id ...) body) -- evaluate body in the environment +; extended with the bindings of id ... to the corresponding +; eigen-variables +(define-syntax eigen + (syntax-rules () + ((_ (id ...) body) + (let ((id (eigen-variable 'id)) ...) body)))) + +(define (eigen-test) +(test-check 'eigen + (and + (eigen () #t) + (eigen (x) (eigen-var? x)) + (eigen (x y) + (begin (display "eigens: ") (display (list x y)) + (newline) #t))) + #t)) + +;;; ------------------------------------------------------ + +(define commitment cons) +(define commitment->term cdr) +(define commitment->var car) + +(define empty-subst '()) +(define empty-subst? null?) + +(define extend-subst + (lambda (v t subst) + (cons (commitment v t) subst))) + +; get the free vars of a term (a list without duplicates) +(define vars-of + (lambda (term) + (let loop ((term term) (fv '())) + (cond + ((var? term) (if (memq term fv) fv (cons term fv))) + ((pair? term) (loop (cdr term) (loop (car term) fv))) + (else fv))))) + +; Check to see if a var occurs in a term +(define occurs? + (lambda (var term) + (cond + ((var? term) (eq? term var)) + ((pair? term) (or (occurs? var (car term)) (occurs? var (cdr term)))) + (else #f)))) + +; A ground term contains no variables +(define ground? + (lambda (t) + (cond + ((var? t) #f) + ((pair? t) (and (ground? (car t)) (ground? (cdr t)))) + (else #t)))) + +; Given a term v and a subst s, return v', the weak normal form of v: +; v -->w! v' with respect to s +(define subst-in-weak + (lambda (v s) + (cond + ((var? v) + (cond + ((assq v s) => + (lambda (b) (subst-in-weak (commitment->term b) s))) + (else v))) + (else v)))) + +; Given a term v and a subst s, return v', the strong normal form of v: +; v -->s! v' with respect to s +(define subst-in + (lambda (t subst) + (cond + ((var? t) + (let ((c (assq t subst))) + (if c (subst-in (commitment->term c) subst) t))) + ((pair? t) + (cons + (subst-in (car t) subst) + (subst-in (cdr t) subst))) + (else t)))) + + +; ; Given a term v and a subst s, return v', the strong normal form of v: +; ; v -->s! v' with respect to s +; (define subst-vars-recursively +; (lambda (t subst) +; (cond +; ((var? t) +; (cond +; ((assq t subst) => +; (lambda (c) +; (subst-vars-recursively +; (commitment->term c) (remq c subst)))) +; (else t))) +; ((pair? t) +; (cons +; (subst-vars-recursively (car t) subst) +; (subst-vars-recursively (cdr t) subst))) +; (else t)))) + +; (define normalize-subst +; (lambda (subst) +; (map (lambda (c) +; (commitment (commitment->var c) +; (subst-vars-recursively (commitment->term c) subst))) +; subst))) + + +; Sooner or later, we will need to print out a term or do something +; else with it. We have to decide what to do with free variables that +; may be in that term. +; The long experience with Kanren and miniKanren and long discussions +; convinced us that it's best to `display' free variables as +; _.n where n is a number. BTW, we can't just display +; logical-variable-id, because distinct logical variables may have the same +; logical-variable-id. + +; reify:: term -> reified-term +; where reified-term is identical to term if it is ground. +; Otherwise, we replace all free variables in term with _.n symbols +; The 'reverse' in (reverse (vars-of t)) +; just makes the output look as it used to look before. Consider it +(define reify + (lambda (term) + (let ((fv (reverse (vars-of term)))) + (if (null? fv) term ; the term is ground + (let ((renaming ; build the renaming substitution + (let loop ((counter 0) (fv fv)) + (if (null? fv) empty-subst + (extend-subst + (car fv) + (string->symbol + (string-append "_." (number->string counter))) + (loop (+ 1 counter) (cdr fv))))))) + (subst-in term renaming)))))) + + +; we will also need to print the substitution, either in whole or in part +; reify-subst:: list-of-vars subst -> reified-subst +; where list-of-vars is a list of variables to reify, or the empty +; list. In the latter case, all variables from subst are reified. +; reified-subst has a form ((var-name reified-term) ...) +; where var-name, for historical reasons, has the form id.0 +; where `id' is logical-variable-id. + +(define reify-subst + (lambda (vars subst) + (let* ((vars (if (null? vars) (map commitment->var subst) vars)) + (terms (reify (subst-in vars subst)))) + (map (lambda (x y) + (list (string->symbol + (string-append (symbol->string (logical-variable-id x)) + ".0")) + y)) + vars terms)))) + + + + +; (define compose-subst/own-survivors +; (lambda (base refining survivors) +; (let refine ((b* base)) +; (if (null? b*) survivors +; (cons-if-real-commitment +; (commitment->var (car b*)) +; (subst-in (commitment->term (car b*)) refining) +; (refine (cdr b*))))))) +; +; (define compose-subst +; (lambda (base refining) +; (cond +; ((null? base) refining) +; ((null? refining) base) +; (else +; (compose-subst/own-survivors base refining +; (let survive ((r* refining)) +; (cond +; ((null? r*) '()) +; ((assq (commitment->var (car r*)) base) (survive (cdr r*))) +; (else (cons (car r*) (survive (cdr r*))))))))))) + +; Replace a logical variable with the corresponding eigen-variable +; Note: to be really right, universalize should be a scoping predicate, +; something like exists: +; (universalize (term) goal) +; to prove 'goal' in the env where term is universalized. +; In that case, the introduced eigen-variables do not escape. +; Also, perhaps universalize should take a subst and first +; do (subst-in term subst) and then universalize the remaining +; logical variables -- which by that time would surely be free. +(define universalize + (lambda (term) + (let ((fv (vars-of term))) + (let ((subst + (map + (lambda (v) + (commitment v (eigen-variable (logical-variable-id v)))) + fv))) + (subst-in term subst))))) + + +; copy-term TERM -> TERM +; return a TERM that is identical to the input term modulo the replacement +; of variables in TERM with fresh logical variables. +; If a logical variable occurs several times in TERM, the result +; will have the same number of occurrences of the replacement fresh +; variable. +; This is a sort-of dual to universalize, to be used on the other side +; of the implication. It replaces the existential quantification +; (implicit in free logical variables of a term) with the universal +; quantification. +(define copy-term + (lambda (t) + (let* ((fv (vars-of t)) + (subst + (map (lambda (old-var) + (commitment old-var + (logical-variable (logical-variable-id old-var)))) + fv))) + (subst-in t subst)))) + + +; Similar to universalize: makes nicer symbols for variables that look +; nicer when printed. The 'reverse' in (reverse (vars-of t)) +; just makes the output look as it used to look before. Consider it +; a historical accident. +; (define concretize +; (lambda (t) +; (subst-in t +; (let loop ((fv (reverse (vars-of t))) (env '())) +; (cond +; ((null? fv) empty-subst) +; (else (let ((id (logical-variable-id (car fv)))) +; (let ((num (let*-and 0 ((pr (assq id env))) (+ (cdr pr) 1)))) +; (cons (commitment (car fv) (artificial-id id num)) +; (loop (cdr fv) (cons (cons id num) env))))))))))) +; (define artificial-id +; (lambda (t-id num) +; (string->symbol +; (string-append +; (symbol->string t-id) "." (number->string num))))) + + + + + +;------------------------------------------------------- +;;;; This is Oleg's unifier + +; Either t or u may be: +; __ +; free-var +; bound-var +; pair +; other-value +; So, we have in general 25 possibilities to consider. +; actually, a pair or components of a pair can be variable-free +; or not. In the latter case, we have got to traverse them. +; Also, if a term to unify has come from subst, it has special properties, +; which we can exploit. See below. +; +; "Measurements of the dynamic behavior of unification on four real +; programs show that one or both of the arguments are variables about +; 85% of the time [63]. A subroutine call is made only if both arguments +; are nonvariables." (Peter Van Roy, The Wonder Years ...) +; +; Just like in the union-find unification algorithm, we produce +; substitutions in the "triangular form" (see Baader, Snyder, Unification +; Theory). Circularity is detected only at the end (when we do subst-in). + +(define unify + (lambda (t u subst) + (cond + ((eq? t u) subst) ; quick tests first + ((eq? t __) subst) + ((eq? u __) subst) + ((var? t) + (let*-and (unify-free/any t u subst) ((ct (assq t subst))) + (if (var? u) ; ct is a bound var, u is a var + (let*-and (unify-free/bound u ct subst) ((cu (assq u subst))) + (unify-bound/bound ct cu subst)) + (unify-bound/nonvar ct u subst)))) + ((var? u) ; t is not a variable... + (let*-and + (cond + ((pair? t) (unify-free/list u t subst)) + ; t is not a var and is not a pair: it's atomic + (else (extend-subst u t subst))) + ((cu (assq u subst))) + (unify-bound/nonvar cu t subst))) + ((and (pair? t) (pair? u)) + (let*-and #f ((subst (unify (car t) (car u) subst))) + (unify (cdr t) (cdr u) subst))) + (else (and (equal? t u) subst))))) + +; ct is a commitment to a bound variable, u is a atomic or a composite +; value -- but not a variable +(define unify-bound/nonvar + (lambda (ct u subst) + (let ((t (commitment->term ct))) + (cond ; search for the end of ct -> chain + ((eq? t u) subst) + ((var? t) + (let*-and + (cond + ((pair? u) (unify-free/list t u subst)) + ; u is not a var and is not a pair: it's atomic + (else (extend-subst t u subst))) + ((ct (assq t subst))) + (unify-bound/nonvar ct u subst))) + ; t is some simple or composite value. So is u. + ((and (pair? t) (pair? u)) + (let*-and #f ((subst (unify-internal/any (car t) (car u) subst))) + (unify-internal/any (cdr t) (cdr u) subst))) + (else (and (equal? t u) subst)))))) + + +; Just like unify. However, the first term, t, comes from +; an internalized term. We know it can't be __ and can't contain __ + +(define unify-internal/any + (lambda (t u subst) + (cond + ((eq? t u) subst) ; quick tests first + ((eq? u __) subst) + ((var? t) + (let*-and (unify-free/any t u subst) ((ct (assq t subst))) + (if (var? u) ; ct is a bound var, u is a var + (let*-and (unify-free/bound u ct subst) ((cu (assq u subst))) + (unify-bound/bound ct cu subst)) + (unify-bound/nonvar ct u subst)))) + ((var? u) ; t is not a variable... + (let*-and ; It's a part of an internal term + (extend-subst u t subst) ; no further checks needed + ((cu (assq u subst))) + (unify-internals (commitment->term cu) t subst))) + ((and (pair? t) (pair? u)) + (let*-and #f ((subst (unify-internal/any (car t) (car u) subst))) + (unify-internal/any (cdr t) (cdr u) subst))) + (else (and (equal? t u) subst))))) + + +; Unify two already bound variables represented by their commitments +; ct and cu. +; We single out this case because in the future we may wish +; to unify the classes of these variables, by making a redundant +; binding of (commitment->var ct) to (commitment->term cu) or +; the other way around. +; Aside from the above, this function can take advantage of the following +; facts about (commitment->term cx) (where cx is an existing commitment): +; - it is never __ +; - it never contains __ +; Most importantly, if, for example, (commitment->term ct) is a free variable, +; we enter its binding to (commitment->term cu) with fewer checks. +; in particular, we never need to call unify-free/list nor +; unify-free/any as we do need to rebuild any terms. + +(define unify-internals + (lambda (t u subst) + (cond + ((eq? t u) subst) ; quick tests first + ((var? t) + (let*-and (cond ; t is a free variable + ((var? u) + (let*-and (extend-subst t u subst) ((cu (assq u subst))) + (unify-free/bound t cu subst))) + (else ; t is free, u is not a var: done + (extend-subst t u subst))) + ((ct (assq t subst))) + (cond ; t is a bound variable + ((var? u) + (let*-and (unify-free/bound u ct subst) ((cu (assq u subst))) + (unify-bound/bound ct cu subst))) + (else ; unify bound and a value + (unify-internals (commitment->term ct) u subst))))) + ((var? u) ; t is not a variable... + (let*-and (extend-subst u t subst) ((cu (assq u subst))) + (unify-internals (commitment->term cu) t subst))) + ((and (pair? t) (pair? u)) + (let*-and #f ((subst (unify-internals (car t) (car u) subst))) + (unify-internals (cdr t) (cdr u) subst))) + (else (and (equal? t u) subst))))) + +(define unify-bound/bound + (lambda (ct cu subst) + (unify-internals (commitment->term ct) (commitment->term cu) subst))) + + +; t-var is a free variable, u can be anything +; This is analogous to get_variable instruction of Warren Abstract Machine +; (WAM). +; This function is not recursive and always succeeds, +; because unify-free/bound and unify-free/list always succeed. +(define unify-free/any + (lambda (t-var u subst) + (cond + ((eq? u __) subst) + ((var? u) + (let*-and (extend-subst t-var u subst) ((cu (assq u subst))) + (unify-free/bound t-var cu subst))) + ((pair? u) (unify-free/list t-var u subst)) + (else ; u is not a var and is not a pair: it's atomic + (extend-subst t-var u subst))))) + +; On entrance: t-var is free. +; we are trying to unify it with a bound variable (commitment->var cu) +; Chase the binding chain, see below for comments +; This also works somewhat like union-find... +; This function always succeeds. The resulting substitution is either +; identical to the input one, or differs only in the binding to t-var. +; +; Unlike the previous version of the unifier, +; The following code does not introduce the temp variables *a and *d +; It makes substitutions more complex. Therefore, pruning them +; will take a while, and will break up the sharing. Therefore, we +; don't do any pruning. + +(define unify-free/bound + (lambda (t-var cu s) + (let loop ((cm cu)) + (let ((u-term (commitment->term cm))) + (cond + ((eq? u-term t-var) s) + ((var? u-term) + (cond + ((assq u-term s) => loop) + (else (extend-subst t-var u-term s)))) ; u-term is free here + (else (extend-subst t-var u-term s))))))) + +; ((and (pattern-var? tree2) (assq tree2 env)) => ; tree2 is a bound var +; ; binding a free variable to a bound. Search for a substantial binding +; ; or a loop. If we find a loop tree1->tree2->...->tree1 +; ; then we do not enter the binding to tree1, because tree1 is not +; ; actually constrained. +; (lambda (tree2-binding) +; (let loop ((binding tree2-binding)) +; (cond +; ((eq? tree1 (cdr binding)) env) ; loop: no binding needed +; ((and (pattern-var? (cdr binding)) (assq (cdr binding) env)) +; => loop) +; (else (cons (cons tree1 (cdr binding)) env)))))) + +; t-var is a free variable, u-value is a proper or improper +; list, which may be either fully or partially grounded (or not at all). +; We scan the u-value for __, and if, found, replace them with fresh +; variables. We then bind t-var to the term. +; This function is not recursive and always succeeds. +; +; We assume that more often than not u-value does not contain __. +; Therefore, to avoid the wasteful rebuilding of u-value, we +; first scan it for the occurrence of __. If the scan returns negative, +; we can use u-value as it is. + + ; Rebuild lst replacing all anonymous variables with some + ; fresh logical variables + ; If lst contains no anonymous variables, return #f + ; Note that lst itself may be #f -- and yet no contradiction arises. +(define ufl-rebuild-without-anons + (lambda (lst) + (cond + ((eq? lst __) (logical-variable '*anon)) + ((not (pair? lst)) #f) + ((null? (cdr lst)) + (let ((new-car (ufl-rebuild-without-anons (car lst)))) + (and new-car (cons new-car '())))) + (else + (let ((new-car (ufl-rebuild-without-anons (car lst))) + (new-cdr (ufl-rebuild-without-anons (cdr lst)))) + (if new-car + (cons new-car (or new-cdr (cdr lst))) + (and new-cdr (cons (car lst) new-cdr)))))))) + +(define unify-free/list + (lambda (t-var u-value subst) + (extend-subst t-var + (or (ufl-rebuild-without-anons u-value) u-value) + subst))) + +;------------------------------------------------------------------------ +; Tests + +(define (term-tests) + + ; (cout nl "Compositions of substitutions" nl) + ; (let-lv (x y) + ; (test-check 'test-compose-subst-0 + ; (append (unit-subst x y) (unit-subst y 52)) + ; `(,(commitment x y) ,(commitment y 52)))) + + + ; (test-check 'test-compose-subst-1 + ; (let-lv (x y) + ; (equal? + ; (compose-subst (unit-subst x y) (unit-subst y 52)) + ; `(,(commitment x 52) ,(commitment y 52)))) + ; #t) + + ; (test-check 'test-compose-subst-2 + ; (let-lv (w x y) + ; (equal? + ; (let ((s (compose-subst (unit-subst y w) (unit-subst w 52)))) + ; (compose-subst (unit-subst x y) s)) + ; `(,(commitment x 52) ,(commitment y 52) ,(commitment w 52)))) + ; #t) + + ; (test-check 'test-compose-subst-3 + ; (let-lv (w x y) + ; (equal? + ; (let ((s (compose-subst (unit-subst w 52) (unit-subst y w)))) + ; (compose-subst (unit-subst x y) s)) + ; `(,(commitment x w) ,(commitment w 52) ,(commitment y w)))) + ; #t) + + ; (test-check 'test-compose-subst-4 + ; (let-lv (x y z) + ; (equal? + ; (let ((s (compose-subst (unit-subst y z) (unit-subst x y))) + ; (r (compose-subst + ; (compose-subst (unit-subst x 'a) (unit-subst y 'b)) + ; (unit-subst z y)))) + ; (compose-subst s r)) + ; `(,(commitment x 'b) ,(commitment z y)))) + ; #t) + + ; (test-check 'test-compose-subst-5 + ; (concretize-subst + ; (compose-subst + ; (let-lv (x) (unit-subst x 3)) + ; (let-lv (x) (unit-subst x 4)))) + ; '((x.0 . 3) (x.1 . 4))) + + + ; (test-check 'test-compose-subst-5 + ; (let-lv (x y z) + ; (equal? + ; (let ((term `(p ,x ,y (g ,z)))) + ; (let ((s (compose-subst (unit-subst y z) (unit-subst x `(f ,y)))) + ; (r (compose-subst (unit-subst x 'a) (unit-subst z 'b)))) + ; (let ((term1 (subst-in term s))) + ; (write term1) + ; (newline) + ; (let ((term2 (subst-in term1 r))) + ; (write term2) + ; (newline) + ; (let ((sr (compose-subst s r))) + ; (write sr) + ; (newline) + ; (subst-in term sr)))))) + ; (begin + ; `(p (f ,y) ,z (g ,z)) + ; `(p (f ,y) b (g b)) + ; `(,(commitment y 'b) ,(commitment x `(f ,y)) ,(commitment z 'b)) + ; `(p (f ,y) b (g b))))) + ; #t) + + + (test-check 'test-unify/pairs-oleg1 + (let-lv (x y) + (unify `(,x ,4) `(3 ,x) empty-subst)) + #f) + + (test-check 'test-unify/pairs-oleg2 + (let-lv (x y) + (unify `(,x ,x) '(3 4) empty-subst)) + #f) + + (let-lv (x y) + (test-check 'test-unify/pairs-oleg3 + (reify-subst '() (unify `(,x ,y) '(3 4) empty-subst)) + '((y.0 4) (x.0 3)))) + + (let-lv (x y) + (test-check 'test-unify/pairs-oleg4 + (reify-subst '() (unify `(,x 4) `(3 ,y) empty-subst)) + `((y.0 4) (x.0 3)))) + + (let-lv (x y w z) + (test-check 'test-unify/pairs-oleg5 + (reify-subst (list w y x) + (unify `(,x 4 3 ,w) `(3 ,y ,x ,z) empty-subst)) + '((w.0 _.0) (y.0 4) (x.0 3)))) + + (let-lv (x y w z) + (test-check 'test-unify/pairs-oleg6 + (reify-subst (list y x) + (unify `(,x 4) `(,y ,y) empty-subst)) + '((y.0 4) (x.0 4)))) + + (test-check 'test-unify/pairs-oleg7 + (let-lv (x y) + (unify `(,x 4 3) `(,y ,y ,x) empty-subst)) + #f) + + (let-lv (x y w z u) + (test-check 'test-unify/pairs-oleg8 + (reify-subst (list u z y x) + (unify + `(,w (,x (,y ,z) 8)) + `(,w (,u (abc ,u) ,z)) + empty-subst)) + '((u.0 8) (z.0 8) (y.0 abc) (x.0 8)))) + + (let-lv (x y w z u) + (test-check 'test-unify/pairs-oleg8 + (reify-subst (list y x) + (unify `(p (f a) (g ,x)) `(p ,x ,y) empty-subst)) + '((y.0 (g (f a))) (x.0 (f a))))) + + (let-lv (x y w z u) + (test-check 'test-unify/pairs-oleg10 + (reify-subst (list x y) + (unify `(p (g ,x) (f a)) `(p ,y ,x) empty-subst)) + '((x.0 (f a)) (y.0 (g (f a)))))) + + (let-lv (x y w z u) + (test-check 'test-unify/pairs-oleg11 + (reify-subst (list y x z) + (unify + `(p a ,x (h (g ,z))) + `(p ,z (h ,y) (h ,y)) + empty-subst)) + '((y.0 (g a)) (x.0 (h (g a))) (z.0 a)))) + + ; The following loops... + ; (concretize-subst + ; (let-lv (x y) + ; (let* ((s (unify x `(1 ,x) '())) + ; (s (unify y `(1 ,y) s)) + ; (s (unify x y s))) s))) + + + ; (let-lv (x y w z u) + ; (test-check 'test-unify/pairs-oleg12 + ; (concretize-subst ;;; was #f + ; (let ((s (unify `(p ,x ,x) `(p ,y (f ,y)) empty-subst))) + ; (let ((var (map commitment->var s))) + ; (map commitment + ; var + ; (subst-vars-recursively var s))))) + ; `(;,(commitment '*d.0 '()) + ; ,(commitment '*a.0 '(f *a.0)) + ; ;,(commitment '*d.1 '((f . *d.1))) + ; ,(commitment '*d.0 '((f . *d.0))) + ; ;,(commitment '*a.1 'f) + ; ;,(commitment 'y.0 '(f (f . *d.1))) + ; ,(commitment 'y.0 '(f (f . *d.0))) + ; ,(commitment 'x.0 '(f (f . *d.0)))))) + + ; (let-lv (x y w z u) + ; (test-check 'test-unify/pairs-oleg13 + ; (concretize-subst ;;; was #f + ; (let ((s (unify `(p ,x ,x) `(p ,y (f ,y)) empty-subst))) + ; (let ((var (map commitment->var s))) + ; (map commitment + ; var + ; (subst-vars-recursively var s))))) + ; `(;,(commitment '*d.0 '()) + ; ,(commitment '*a.0 '(f *a.0)) + ; ;,(commitment '*d.1 '((f . *d.1))) + ; ,(commitment '*d.0 '((f . *d.0))) + ; ;,(commitment '*a.1 'f) + ; ;,(commitment 'y.0 '(f (f . *d.1))) + ; ,(commitment 'y.0 '(f (f . *d.0))) + ; ,(commitment 'x.0 '(f (f . *d.0)))))) + + ;Baader & Snyder + (test-check 'test-pathological + (list + (let-lv (x0 x1 y0 y1) + (begin + (_pretty-print + (reify-subst '() + (unify + `(h ,x1 (f ,y0 ,y0) ,y1) + `(h (f ,x0 ,x0) ,y1 ,x1) + empty-subst))) + (newline) #t)) + + (let-lv (x0 x1 x2 y0 y1 y2) + (begin + (_pretty-print + (reify-subst '() + (unify + `(h ,x1 ,x2 (f ,y0 ,y0) (f ,y1 ,y1) ,y2) + `(h (f ,x0 ,x0) (f ,x1 ,x1) ,y1 ,y2 ,x2) + empty-subst))) + (newline) #t)) + + (let-lv (x0 x1 x2 x3 x4 y0 y1 y2 y3 y4) + (begin + (_pretty-print + (reify-subst '() + (unify + `(h ,x1 ,x2 ,x3 ,x4 (f ,y0 ,y0) (f ,y1 ,y1) (f ,y2 ,y2) (f ,y3 ,y3) ,y4) + `(h (f ,x0 ,x0) (f ,x1 ,x1) (f ,x2 ,x2) (f ,x3 ,x3) ,y1 ,y2 ,y3 ,y4 ,x4) + empty-subst))) #t))) + (list #t #t #t)) + + + (test-check 'length-of-subst + (let-lv (x y z) + (let* ((subst (unify x `(1 2 3 4 5 ,z) '())) + (subst (unify x `(1 . ,y) subst)) + (subst (unify z 42 subst))) + (reify-subst '() subst))) + '((z.0 42) (y.0 (2 3 4 5 42)) (x.0 (1 2 3 4 5 42)))) + ;'((z.0 . 42) (y.0 2 3 4 5 a*.0) (a*.0 . z.0) (x.0 1 2 3 4 5 a*.0))) + + 10 + ) + + +;; ========================================================================= +;; kanren.scm +;; ========================================================================= + +; The body of KANREN +; +; The appropriate prelude (e.g., chez-specific.scm) is assumed. +; +; $Id: kanren.ss,v 4.50 2005/02/12 00:05:05 oleg Exp $ + +(define-syntax lambda@ + (syntax-rules () + ((_ (formal) body0 body1 ...) (lambda (formal) body0 body1 ...)) + ((_ (formal0 formal1 formal2 ...) body0 body1 ...) + (lambda (formal0) + (lambda@ (formal1 formal2 ...) body0 body1 ...))))) + +(define-syntax at@ + (syntax-rules () + ((_ rator rand) (rator rand)) + ((_ rator rand0 rand1 rand2 ...) (at@ (rator rand0) rand1 rand2 ...)))) + +;(test-check 'test-@-lambda@ +; (at@ (lambda@ (x y z) (+ x (+ y z))) 1 2 3) +; 6) + +;'(test-check 'test-@-lambda@ +; (at@ (lambda@ (x y z) (+ x (+ y z))) 1 2 3) +; 42) + +(define Y + (lambda (f) + ((lambda (u) (u (lambda (x) (lambda (n) ((f (u x)) n))))) + (lambda (x) (x x))))) + +; An attempt to do a limited beta-substitution at macro-expand time +; (define-syntax @ +; (syntax-rules (syntax-rules) +; ((_ (syntax-rules sdata ...) rand0 ...) +; (let-syntax +; ((tempname (syntax-rules sdata ...))) +; (tempname rand0 ...))) +; ((_ rator rand0 rand1 ...) +; (@-simple rator rand0 rand1 ...)))) + + +; Fk = () -> Ans +; Ans = Nil + [Subst,Fk] or just a conceptual stream of substitutions +; Sk = Subst -> Fk -> Ans +; Goal = Subst -> SGoal +; SGoal = Sk -> Fk -> Ans + +; initial-sk : Sk +; initial-fk : Fk + +(define initial-sk (lambda@ (subst fk) + (cons subst fk))) +(define initial-fk (lambda () '())) + + +; Trivial goals +(define succeed (lambda@ (s k) (at@ k s))) ; eta-reduced +(define fail (lambda@ (s k f) (f))) +(define sfail (lambda@ (k f) (f))) ; Failed SGoal + + +;------------------------------------------------------------------------ +; Making logical variables "scoped" and garbage-collected +; -----> it was used, but no longer +; -----> The code is still here, as we plan to come back to this... +; +; A framework to remove introduced variables when they leave their scope. +; To make removing variables easier, we consider the list of subst as a +; "stack". Before we add a new variable, we retain a pointer to the +; stack. Then, when we are about to remove the added variables after their +; scope is ended, we stop at the shared retained substitution, and we know +; that anything below the retained substitution can't possibly contain the +; reference to the variables we're about to remove. +; +; Pruning of substitutions is analogous to environment pruning (aka tail-call +; optimization) in WAM on _forward_ execution. + +; LV-ELIM IN-SUBST SUBST ID .... +; remove the bindings of ID ... from SUBST (by composing with the +; rest of subst). IN-SUBST is the mark. +; If we locate IN-SUBST in SUBST, we know that everything below the +; mark can't possibly contain ID ... + +; lv-elim-1 VAR IN-SUBST SUBST +; VAR is a logical variable, SUBST is a substitution, and IN-SUBST +; is a tail of SUBST (which may be '()). +; VAR is supposed to have non-complex binding in SUBST +; (see Definition 3 in the document "Properties of Substitutions"). +; If VAR is bound in SUBST, the corresponding commitment +; is supposed to occur in SUBST up to but not including IN-SUBST. +; According to Proposition 10, if VAR freely occurs in SUBST, all such +; terms are VAR itself. +; The result is a substitution with the commitment to VAR removed +; and the other commitments composed with the removed commitment. +; The order of commitments is preserved. + +(define lv-elim-1 + (lambda (var in-subst subst) + (if (eq? subst in-subst) subst + ; if VAR is not bound, there is nothing to prune + (let*-and subst ((var-binding (assq var subst))) + (let ((tv (commitment->term var-binding))) + (let loop ((current subst)) + (cond + ((null? current) current) + ((eq? current in-subst) current) + ((eq? (car current) var-binding) + (loop (cdr current))) + ((eq? (commitment->term (car current)) var) + (cons (commitment (commitment->var (car current)) tv) + (loop (cdr current)))) + (else (cons (car current) (loop (cdr current))))))))))) + +; The same but for multiple vars +; To prune multiple-vars, we can prune them one-by-one +; We can attempt to be more efficient and prune them in parallel. +; But we encounter a problem: +; If we have a substitution +; ((x . y) (y . 1) (a . x)) +; Then pruning 'x' first and 'y' second will give us ((a . 1)) +; Pruning 'y' first and 'x' second will give us ((a . 1)) +; But naively attempting to prune 'x' and 'y' in parallel +; disregarding dependency between them results in ((a . y)) +; which is not correct. +; We should only be concerned about a direct dependency: +; ((x . y) (y . (1 t)) (t . x) (a . x)) +; pruning x and y in sequence or in parallel gives the same result: +; ((t . (1 t)) (a . (1 t))) +; We should also note that the unifier will never return a substitution +; that contains a cycle ((x1 . x2) (x2 . x3) ... (xn . x1)) + +(define lv-elim + (lambda (vars in-subst subst) + (if (eq? subst in-subst) + subst + (let ((var-bindings ; the bindings of truly bound vars + (let loop ((vars vars)) + (if (null? vars) vars + (let ((binding (assq (car vars) subst))) + (if binding + (cons binding (loop (cdr vars))) + (loop (cdr vars)))))))) + (cond + ((null? var-bindings) subst) ; none of vars are bound + ((null? (cdr var-bindings)) + ; only one variable to prune, use the faster version + (lv-elim-1 (commitment->var (car var-bindings)) + in-subst subst)) + ((let test ((vb var-bindings)) ; check multiple dependency + (and (pair? vb) + (or (let ((term (commitment->term (car vb)))) + (and (var? term) (assq term var-bindings))) + (test (cdr vb))))) + ; do pruning sequentially + (let loop ((var-bindings var-bindings) (subst subst)) + (if (null? var-bindings) subst + (loop (cdr var-bindings) + (lv-elim-1 (commitment->var (car var-bindings)) + in-subst subst))))) + (else ; do it in parallel + (let loop ((current subst)) + (cond + ((null? current) current) + ((eq? current in-subst) current) + ((memq (car current) var-bindings) + (loop (cdr current))) + ((assq (commitment->term (car current)) var-bindings) => + (lambda (ct) + (cons (commitment (commitment->var (car current)) + (commitment->term ct)) + (loop (cdr current))))) + (else (cons (car current) (loop (cdr current)))))))))))) + +; when the unifier is moved up, move lv-elim test from below up... + +; That was the code for the unifier that introduced temp variables +; (define-syntax exists +; (syntax-rules () +; ((_ () gl) gl) +; ((_ (ex-id) gl) +; (let-lv (ex-id) +; (lambda@ (sk fk in-subst) +; (at@ gl +; (lambda@ (fk out-subst) +; (at@ sk fk (lv-elim-1 ex-id in-subst out-subst))) +; fk in-subst)))) +; ((_ (ex-id ...) gl) +; (let-lv (ex-id ...) +; (lambda@ (sk fk in-subst) +; (at@ gl +; (lambda@ (fk out-subst) +; (at@ sk fk (lv-elim (list ex-id ...) in-subst out-subst))) +; fk in-subst)))))) + +; For the unifier that doesn't introduce temp variables, +; exists is essentially let-lv +; At present, we don't do any GC. +; Here's the reason we don't do any pruning now: +; Let's unify the variable x with a term `(1 2 3 4 5 ,z). The result +; will be the binding x -> `(1 2 3 4 5 ,z). Let's unify `(1 . ,y) with +; x. The result will be a binding y -> `(2 3 4 5 ,z). Note that the +; bindings of x and y share a tail. Let us now unify z with 42. The +; result will be a binding z->42. So far, so good. Suppose however that +; z now "goes out of scope" (the exists form that introduced z +; finishes). We now have to traverse all the terms in the substitution +; and replace z with its binding. The result will be a substitution +; x -> (1 2 3 4 5 42) +; y -> (2 3 4 5 42) +; Now, the bindings of x and y do not share anything at all! The pruning +; has broke sharing. If we want to unify x and `(1 . ,y) again, we have +; to fully traverse the corresponding terms again. +; So, to prune variables and preserve sharing, we have to topologically sort +; the bindings first! + +(define-syntax _exists + (syntax-rules () + ((_ () gl) gl) + ((_ (ex-id ...) gl) + (let-lv (ex-id ...) gl)) + )) + +;----------------------------------------------------------- +; Sequencing of relations +; Goal is a multi-valued function (which takes +; subst, sk, fk, and exits to either sk or fk). +; A relation is a parameterized goal. +; +; All sequencing operations are defined on goals. +; They can be "lifted" to relations (see below). +; + +; TRACE-GOAL-RAW TITLE GL -> GL +; Traces all invocations and re-invocations of a goal +; printing subst before and after, in their raw form +(define trace-goal-raw + (lambda (title gl) + (let ((print-it + (lambda (event subst) + (display title) (display " ") + (display event) (_pretty-print subst) (newline)))) + (lambda@ (subst sk fk) + (print-it "CALL:" subst) + (at@ gl subst + (lambda@ (subst fk) + (print-it "RETURN:" subst) + (at@ sk subst + (lambda () + (display title) (display " REDO") (newline) + (fk)) + )) + (lambda () + (display title) (display " FAIL") (newline) + (fk)) + ))))) + +; Conjunctions +; All conjunctions below satisfy properties +; ans is an answer of (a-conjunction gl1 gl2 ...) ==> +; forall i. ans is an answer of gl_i +; (a-conjunction) ==> success + + +; (all gl1 gl2 ...) +; A regular Prolog conjunction. Non-deterministic (i.e., can have 0, 1, +; or more answers). +; Properties: +; (all gl) ==> gl +; (all gl1 ... gl_{n-1} gln) is a "join" of answerlists of +; (all gl1 ... gl_{n-1}) and gln + +(define-syntax all + (syntax-rules () + ((_) succeed) + ((_ gl) gl) + ((_ gl0 gl1 ...) + (lambda@ (subst sk) (splice-in-gls/all subst sk gl0 gl1 ...))))) + +(define-syntax splice-in-gls/all + (syntax-rules () + ((_ subst sk gl) (at@ gl subst sk)) + ((_ subst sk gl0 gl1 ...) + (at@ gl0 subst (lambda (subst) (splice-in-gls/all subst sk gl1 ...)))))) + + +; (promise-one-answer gl) +; Operationally, it is the identity. +; It is an optimization directive: if the user knows that an goal +; can produce at most one answer, he can tell the system about it. +; The behavior is undefined if the user has lied. + +(define-syntax promise-one-answer + (syntax-rules () + ((_ gl) gl))) + +; (all! gl1 gl2 ...) +; A committed choice nondeterminism conjunction +; From the Mercury documentation: + +; In addition to the determinism annotations described earlier, there +; are "committed choice" versions of multi and nondet, called cc_multi +; and cc_nondet. These can be used instead of multi or nondet if all +; calls to that mode of the predicate (or function) occur in a context +; in which only one solution is needed. +; +; (all! gl) evaluates gl in a single-choice context. That is, +; if gl fails, (all! gl) fails. If gl has at least one answer, +; this answer is returned. +; (all! gl) has at most one answer regardless of the answers of gl. +; ans is an answer of (all! gl) ==> ans is an answer of gl +; The converse is not true. +; Corollary: (all! gl) =/=> gl +; Corollary: gl is (semi-) deterministic: (all! gl) ==> gl +; (all! (promise-one-answer gl)) ==> gl +; +; By definition, (all! gl1 gl2 ...) ===> (all! (all gl1 gl2 ...)) + +(define-syntax all! + (syntax-rules (promise-one-answer) + ((_) (promise-one-answer (all))) + ((_ (promise-one-answer gl)) (promise-one-answer gl)) ; keep the mark + ((_ gl0 gl1 ...) + (promise-one-answer + (lambda@ (subst sk fk) + (at@ + (splice-in-gls/all subst + (lambda@ (subst fk-ign) (at@ sk subst fk)) gl0 gl1 ...) + fk)))))) + +; (all!! gl1 gl2 ...) +; Even more committed choice nondeterministic conjunction +; It evaluates all elements of the conjunction in a single answer context +; (all!! gl) ==> (all! gl) =/=> gl +; (all!! gl1 gl2 ...) ==> (all (all! gl1) (all! gl2) ...) +; ==> (all! (all! gl1) (all! gl2) ...) +; (all!! gl1 ... gln (promise-one-answer gl)) ==> +; (all (all!! gl1 ... gln) gl) + +(define-syntax all!! + (syntax-rules () + ((_) (all!)) + ((_ gl) (all! gl)) + ((_ gl0 gl1 ...) + (promise-one-answer + (lambda@ (subst sk fk) + (splice-in-gls/all!! subst sk fk gl0 gl1 ...)))))) + +(define-syntax splice-in-gls/all!! + (syntax-rules (promise-one-answer) + ((_ subst sk fk) + (at@ sk subst fk)) + ((_ subst sk fk (promise-one-answer gl)) + (at@ gl subst sk fk)) + ((_ subst sk fk gl0 gl1 ...) + (at@ gl0 subst + (lambda@ (subst fk-ign) (splice-in-gls/all!! subst sk fk gl1 ...)) + fk)))) + +; (if-only COND THEN) +; (if-only COND THEN ELSE) +; Here COND, THEN, ELSE are goals. +; If COND succeeds at least once, the result is equivalent to +; (all (all! COND) TNEN) +; If COND fails, the result is the same as ELSE. +; If ELSE is omitted, it is assumed fail. That is, (if-only COND THEN) +; fails if the condition fails. "This unusual semantics +; is part of the ISO and all de-facto Prolog standards." +; Thus, declaratively, +; (if-only COND THEN ELSE) ==> (any (all (all! COND) THEN) +; (all (fails COND) ELSE)) +; Operationally, we try to generate a good code. + +; "The majority of predicates written by human programmers are +; intended to give at most one solution, i.e., they are +; deterministic. These predicates are in effect case statements +; [sic!], yet they are too often compiled in an inefficient manner +; using the full generality of backtracking (which implies saving the +; machine state and repeated failure and state restoration)." (Peter +; Van Roy, 1983-1993: The Wonder Years of Sequential Prolog +; Implementation). + + +(define-syntax if-only + (syntax-rules () + ((_ condition then) + (lambda@ (subst sk fk) + (at@ condition subst + ; sk from cond + (lambda@ (subst fk-ign) (at@ then subst sk fk)) + ; failure from cond + fk))) + ((_ condition then else) + (lambda@ (subst sk fk) + (at@ condition subst + (lambda@ (subst fk-ign) (at@ then subst sk fk)) + (lambda () (at@ else subst sk fk)) + ))))) + +; (if-all! (COND1 ... CONDN) THEN) +; (if-all! (COND1 ... CONDN) THEN ELSE) +; +; (if-all! (COND1 ... CONDN) THEN ELSE) ==> +; (if-only (all! COND1 ... CONDN) THEN ELSE) +; (if-all! (COND1) THEN ELSE) ==> +; (if-only COND1 THEN ELSE) + +; Eventually, it might be a recognized special case in if-only. + +; (define-syntax if-all! +; (syntax-rules () +; ((_ (condition) then) (if-only condition then)) +; ((_ (condition) then else) (if-only condition then else)) +; ((_ (condition1 condition2 ...) then) +; (lambda@ (sk fk) +; (@ (splice-in-gls/all +; (lambda@ (fk-ign) +; (@ then sk fk)) +; condition1 condition2 ...) +; fk))) +; ((_ (condition1 condition2 ...) then else) +; (lambda@ (sk fk subst) +; (@ (splice-in-gls/all +; (lambda@ (fk-ign) +; (@ then sk fk)) condition1 condition2 ...) +; (lambda () +; (@ else sk fk subst)) +; subst))))) + +; Disjunction of goals +; All disjunctions below satisfy properties +; ans is an answer of (a-disjunction gl1 gl2 ...) ==> +; exists i. ans is an answer of gl_i +; (a-disjunction) ==> fail + +; Any disjunction. A regular Prolog disjunction (introduces +; a choicepoints, in Prolog terms) +; Note that 'any' is not a union! In particular, it is not +; idempotent. +; (any) ===> fail +; (any gl) ===> gl +; (any gl1 ... gln) ==> _concatenation_ of their answerlists + +(define-syntax any + (syntax-rules () + ((_) fail) + ((_ gl) gl) + ((_ gl ...) + (lambda@ (subst sk fk) + (splice-in-gls/any subst sk fk gl ...))))) + +(define-syntax splice-in-gls/any + (syntax-rules () + ((_ subst sk fk gl1) (at@ gl1 subst sk fk)) + ((_ subst sk fk gl1 gl2 ...) + (at@ gl1 subst sk (lambda () (splice-in-gls/any subst sk fk gl2 ...)))))) + + +; Negation +; (fails gl) succeeds iff gl has no solutions +; (fails gl) is a semi-deterministic predicate: it can have at most +; one solution +; (succeeds gl) succeeds iff gl has a solution +; +; (fails (fails gl)) <===> (succeeds gl) +; but (succeeds gl) =/=> gl +; Cf. (equal? (not (not x)) x) is #f in Scheme in general. +; Note, negation is only sound if some rules (Grounding Rules) are satisfied. + +(define fails + (lambda (gl) + (lambda@ (subst sk fk) + (at@ gl subst + (lambda@ (subst current-fk) (fk)) + (lambda () (at@ sk subst fk)) + )))) + +; Again, G-Rule must hold for this predicate to be logically sound +(define succeeds + (lambda (gl) + (lambda@ (subst sk fk) + (at@ gl subst (lambda@ (subst-ign fk-ign) (at@ sk subst fk)) + fk)))) + +; partially-eval-sgl: Partially evaluate a semi-goal. A +; semi-goal is an expression that, when applied to two +; arguments, sk and fk, can produce zero, one, or more answers. Any +; goal can be turned into a semi-goal if partially applied +; to subst. The following higher-order semi-goal takes a +; goal and yields the first answer and another, residual +; goal. The latter, when evaluated, will give the rest of the +; answers of the original semi-goal. partially-eval-sgl could +; be implemented with streams (lazy lists). The following is a purely +; combinational implementation. +; +; (at@ partially-eval-sgl sgl a b) => +; (b) if sgl has no answers +; (a s residial-sgl) if sgl has a answer. That answer is delivered +; in s. +; The residial semi-goal can be passed to partially-eval-sgl +; again, and so on, to obtain all answers from a goal one by one. + +; The following definition is eta-reduced. + +(define (partially-eval-sgl sgl) + (at@ sgl + (lambda@ (subst fk a b) + (at@ a subst + (lambda@ (sk1 fk1) + (at@ + (fk) + ; new a + (lambda@ (sub11 x) (at@ sk1 sub11 (lambda () (at@ x sk1 fk1)))) + ; new b + fk1)))) + (lambda () (lambda@ (a b) (b))))) + +; An interleaving disjunction. +; Declaratively, any-interleave is the same as any. +; Operationally, any-interleave schedules each component goal +; in round-robin. So, any-interleave is fair: it won't let a goal +; that produces infinitely many answers (such as repeat) starve the others. +; any-interleave introduces a breadth-first-like traversal of the +; decision tree. +; I seem to have seen a theorem that says that a _fair_ scheduling +; (like that provided by any-interleave) entails a minimal or well-founded +; semantics of a Prolog program. + +(define-syntax any-interleave + (syntax-rules () + ((_) fail) + ((_ gl) gl) + ((_ gl ...) + (lambda@ (subst sk fk) + (interleave sk fk (list (gl subst) ...)))))) + +; we treat sgls as a sort of a circular list +(define interleave + (lambda (sk fk sgls) + (cond + ((null? sgls) (fk)) ; all of the sgls are finished + ((null? (cdr sgls)) + ; only one of sgls left -- run it through the end + (at@ (car sgls) sk fk)) + (else + (let loop ((curr sgls) (residuals '())) + ; check if the current round is finished + (if (null? curr) (interleave sk fk (reverse residuals)) + (at@ + partially-eval-sgl (car curr) + ; (car curr) had an answer + (lambda@ (subst residual) + (at@ sk subst + ; re-entrance cont + (lambda () (loop (cdr curr) (cons residual residuals))))) + ; (car curr) is finished - drop it, and try next + (lambda () (loop (cdr curr) residuals))))))))) + +; An interleaving disjunction removing duplicates: any-union +; This is a true union of the constituent goals: it is fair, and +; it removes overlap in the goals to union, if any. Therefore, +; (any-union gl gl) ===> gl +; whereas (any gl gl) =/=> gl +; because the latter has twice as many answers as gl. +; +; Any-union (or interleave-non-overlap, to be precise) is quite similar +; to the function interleave above. But now, the order of goals +; matters. Given goals gl1 gl2 ... glk ... gln, +; at the k-th step we try to partially-eval glk. If it yields an answer, +; we check if gl_{k+1} ... gln can be satisfied with that answer. +; If any of them does, we disregard the current answer and ask glk for +; another one. We maintain the invariant that +; ans is an answer of (any-union gl1 ... gln) +; ===> exists i. ans is an answer of gl_i +; && forall j>i. ans is not an answer of gl_j +; The latter property guarantees the true union. +; Note the code below does not check if the answers of each individual +; goal are unique. It is trivial to modify the code so that +; any-union removes the duplicates not only among the goals but +; also within a goal. That change entails a run-time cost. More +; importantly, it breaks the property +; (any-union gl gl) ===> gl +; Only a weaker version, (any-union' gl gl) ===> (any-union' gl) +; would hold. Therefore, we do not make that change. + +(define-syntax any-union + (syntax-rules () + ((_) fail) + ((_ gl) gl) + ((_ gl ...) + (lambda@ (subst sk fk) + (interleave-non-overlap sk fk (list (cons (gl subst) gl) ...)))))) + +; we treat sagls as a sort of a circular list +; Each element of sagls is a pair (sgl . gl) +; where gl is the original goal (needed for the satisfiability testing) +; and sgl is the corresponding semi-goal or a +; residual thereof. +(define interleave-non-overlap + (lambda (sk fk sagls) + (let outer ((sagls sagls)) + (cond + ((null? sagls) (fk)) ; all of the sagls are finished + ((null? (cdr sagls)) ; only one gl is left -- run it through the end + (at@ (caar sagls) sk fk)) + (else + (let loop ((curr sagls) + (residuals '())) + ; check if the current round is finished + (if (null? curr) (outer (reverse residuals)) + (at@ + partially-eval-sgl (caar curr) + ; (caar curr) had an answer + (lambda@ (subst residual) + ; let us see now if the answer, subst, satisfies any of the + ; gls down the curr. + (let check ((to-check (cdr curr))) + (if (null? to-check) ; OK, subst is unique,give it to user + (at@ sk subst + ; re-entrance cont + (lambda () + (loop (cdr curr) + (cons (cons residual (cdar curr)) residuals)))) + (at@ (cdar to-check) subst + ; subst was the answer to some other gl: + ; check failed + (lambda@ (subst1 fk1) + (loop (cdr curr) + (cons (cons residual (cdar curr)) residuals))) + ; subst was not the answer: continue check + (lambda () (check (cdr to-check))))))) + ; (car curr) is finished - drop it, and try next + (lambda () (loop (cdr curr) residuals)))))))))) + + +; Another if-then-else +; (if-some COND THEN) +; (if-some COND THEN ELSE) +; Here COND, THEN, ELSE are goals. +; If COND succeeds at least once, the result is equivalent to +; (all COND TNEN) +; If COND fails, the result is the same as ELSE. +; If ELSE is omitted, it is assumed fail. That is, (if-some COND THEN) +; fails if the condition fails. "This unusual semantics +; is part of the ISO and all de-facto Prolog standards." +; Thus, declaratively, +; (if-some COND THEN ELSE) ==> (any (all COND THEN) +; (all (fails COND) ELSE)) +; from which follows +; (if-some COND THEN) ==> (all COND THEN) +; (if-some COND THEN fail) ==> (all COND THEN) +; but +; (if-some COND succeed ELSE) =/=> (any COND ELSE) +; +; Other corollary: +; (if-some COND THEN ELSE) ==> (if-only (fails COND) ELSE (all COND THEN)) +; +; Operationally, we try to generate a good code. +; +; In Prolog, if-some is called a soft-cut (aka *->). In Mercury, +; if-some is the regular IF-THEN-ELSE. +; +; We can implement if-some with partially-eval-sgl. Given a COND, we +; peel off one answer, if possible. If there is one, we then execute THEN +; passing it the answer and the fk from COND so that if THEN fails, +; it can obtain another answer. If COND has no answers, we execute +; ELSE. Again, we can do all that purely declaratively, without +; talking about introducing and destroying choice points. + +(define-syntax if-some + (syntax-rules () + ((_ condition then) (all condition then)) + ((_ condition then else) + (lambda@ (subst sk fk) + (at@ partially-eval-sgl (condition subst) + (lambda@ (ans residual) + (at@ then ans sk + ; then failed. Check to see if condition has another answer + (lambda () (at@ residual (lambda@ (subst) (at@ then subst sk)) fk)))) + ; condition failed + (lambda () (at@ else subst sk fk))))))) + + +; An interleaving conjunction: all-interleave +; +; This conjunction is similar to the regular conjunction `all' but +; delivers the answers in the breadth-first rather than depth-first +; order. +; +; Motivation. +; Let us consider the conjunction (all gl1 gl2) +; where gl1 is (any gl11 gl12) and gl2 is an goal with the +; infinite number of answers (in the environment when either gl11 or +; gl12 succeed). It is easy to see (all gl1 gl2) will have the +; infinite number of answers too -- but only the proper subset of +; all the possible answers. Indeed, (all gl1 gl2) will essentially +; be equivalent to (all gl11 gl2). Because gl2 succeeds infinitely +; many times, the choice gl12 in gl1 will never be explored. +; We can see that formally: +; (all gl1 gl2) +; = (all (any gl11 gl12) gl2) +; = (any (all gl11 gl2) (all gl12 gl2)) +; Because (all gl11 gl2) can succeed infinitely many times, it starves +; the other disjunction, (all gl12 gl2). +; But we know how to deal with that: we just replace any with any-interleave: +; (all gl1 gl2) --> (any-interleave (all gl11 gl2) (all gl12 gl2)) +; +; It seems that the problem is solved? We just re-write our expressions +; into the disjunctive normal form, and then replace the top-level +; `any' with `any-interleave'. Alas, that means that to get the benefit +; of fair scheduling and get all the possible solutions of the conjunction +; (i.e., recursive enumerability), we need to re-write all the code. +; We have to explicitly re-write a conjunction of disjunctions into +; the disjunctive normal form. That is not that easy considering that gl2 +; will most likely be a recursive goal re-invoking the original +; conjunction. That would be a lot of re-writing. +; +; The conjunction all-interleave effectively does the above `re-writing' +; That is, given the example above, +; (all-interleave (any gl11 gl12) gl2) +; is observationally equivalent to +; (any-interleave (all gl11 gl2) (all gl12 gl2)) +; +; The advantage is that we do not need to re-write our conjunctions: +; we merely replace `all' with `all-interleave.' +; +; How can we do that in the general case, (all gl1 gl2) +; where gl1 is not _explicitly_ a disjunction? We should remember the +; property of partially-eval-sgl: Any goal `gl' with at least one +; answer can be represented as (any gl-1 gl-rest) +; where gl-1 is a primitive goal holding the first answer of `gl', +; and gl-rest holding the rest of the answers. We then apply the +; all-any-distributive law and re-write +; (all-interleave gl1 gl2) +; ==> (all-interleave (any gl1-1 gl1-rest) gl2) +; ==> (any-interleave (all gl1 gl2) (all-interleave gl1-rest gl2)) +; +; If gl1 has no answers, then (all-interleave gl1 gl2) fails, as +; a conjunction must. +; It is also easy to see that +; (all-interleave gl1 gl2 ...) is the same as +; (all-interleave gl1 (all-interleave gl2 ...)) +; +; Although all-interleave was motivated by an example (all gl1 gl2) +; where gl1 is finitary and only gl2 is infinitary, the above +; equations (and the implementation below) show that all-interleave +; can do the right thing even if gl1 is infinitary as well. To be +; precise, given +; +; (all-interleave gl1 gl2) +; +; with gl1 and gl2 infinitary, the i-th solution of gl1 will be +; observed in every 2^i-th solution to the whole conjunction. Granted, +; all-interleave isn't precisely very fair -- the later solutions of +; gl1 will appear progressively more rarely -- yet, they will all +; appear. The infinity of c0 is big enough. That is, given any +; solution to gl1, we will eventually, in finite time, find it in the +; solution of the whole conjunction (provided gl2 doesn't fail on +; that solution, of course). + + + +(define-syntax all-interleave + (syntax-rules () + ((_) (all)) + ((_ gl) gl) + ((_ gl0 gl1 ...) + (lambda@ (subst) + (all-interleave-bin + (gl0 subst) (all-interleave gl1 ...)))))) + +(define all-interleave-bin + (lambda (sgl1 gl2) + (lambda@ (sk fk) + (at@ partially-eval-sgl sgl1 + (lambda@ (ans residual) + (interleave sk fk + (list + (at@ gl2 ans) + (all-interleave-bin residual gl2) + ))) + ;gl1 failed + fk)))) + + +; Relations........................... + +; The current incremented unification of argument passing is quite similar to +; the compilation of argument unifications in WAM. + +; relation (VAR ...) (to-show TERM ...) [GL] +; Defines a relation of arity (length '(TERM ...)) with an optional body +; GL. VAR ... are logical variables that are local to the relation, i.e., +; appear in TERM or GL. It's better to list as VAR ... only logical +; variables that appear in TERM. Variables that appear only in GL should +; be introduced with exists. That makes their existential quantification +; clearer. Variables that appear in TERM are universally quantified. +; +; relation (head-let TERM ...) [GL] +; See relation-head-let below. +; +; relation (ANNOT-VAR ...) (to-show TERM ...) [GL] (see remark below!) +; where ANNOT-VAR is either a simple VAR or (once VAR) +; where 'once' is a distingushed symbol. The latter form introduces +; a once-var, aka linear variable. A linear variable appears only once in +; TERM ... and only at the top level (that is, one and only one TERM +; in the to-show pattern contains ONCE-VAR, and that term is ONCE-VAR +; itself). In addition, ONCE-VAR must appear at most once in the body GL. +; (Of course, then ONCE-VAR could be _, instead.) +; If these conditions are satisfied, we can replace a logical variable +; ONCE-VAR with a regular Scheme variable. + +; Alternative notation: +; (relation (a c) (to-show term1 (once c) term2) body) +; Makes it easier to deal with. But it is unsatisfactory: +; to-show becomes a binding form... +; +; When ``compiling'' a relation, we now look through the +; (to-show ...) pattern for a top-level occurrence of the logical variable +; introduced by the relation. For example: +; (relation (x y) (to-show `(,x . ,y) x) body) +; we notice that the logical variable 'x' occurs at the top-level. Normally we +; compile the relation like that into the following +; (lambda (g1 g2) +; (_exists (x y) +; (lambda@ (subst) +; (let*-and (fail subst) ((subst (unify g1 `(,x . ,y) subst)) +; (subst (unify g2 x subst))) +; (at@ body subst))))) +; +; However, that we may permute the order of 'unify g...' clauses +; to read +; (lambda (g1 g2) +; (_exists (x y) +; (lambda@ (subst) +; (let*-and (fail subst) ((subst (unify x g2 subst)) +; (subst (unify g1 `(,x . ,y) subst)) +; ) +; (at@ body subst))))) +; +; We may further note that according to the properties of the unifier +; (see below), (unify x g2 subst) must always succeed, +; because x is a fresh variable. +; Furthermore, the result of (unify x g2 subst) is either subst itself, +; or subst with the binding of x. Therefore, we can check if +; the binding at the top of (unify x g2 subst) is the binding to x. If +; so, we can remove the binding and convert the variable x from being logical +; to being lexical. Thus, we compile the relation as +; +; (lambda (g1 g2) +; (_exists (x y) +; (lambda@ (subst) +; (let* ((subst (unify-free/any x g2 subst)) +; (fast-path? (and (pair? subst) +; (eq? x (commitment->var (car subst))))) +; (x (if fast-path? (commitment->term (car subst)) x)) +; (subst (if fast-path? (cdr subst) subst))) +; (let*-and sfail ((subst (unify g1 `(,x . ,y) subst)) +; ) +; (at@ body subst)))))) +; +; The benefit of that approach is that we limit the growth of subst and avoid +; keeping commitments that had to be garbage-collected later. + + +(define-syntax relation + (syntax-rules (to-show head-let once __) + ((_ (head-let head-term ...) gl) + (relation-head-let (head-term ...) gl)) + ((_ (head-let head-term ...)) ; not particularly useful without body + (relation-head-let (head-term ...))) + ((_ () (to-show term ...) gl) ; pattern with no vars _is_ linear + (relation-head-let (`,term ...) gl)) + ((_ () (to-show term ...)) ; the same without body: not too useful + (relation-head-let (`,term ...))) + ((_ (ex-id ...) (to-show term ...) gl) ; body present + (relation "a" () () (ex-id ...) (term ...) gl)) + ((_ (ex-id ...) (to-show term ...)) ; no body + (relation "a" () () (ex-id ...) (term ...))) + ; process the list of variables and handle annotations + ((_ "a" vars once-vars ((once id) . ids) terms . gl) + (relation "a" vars (id . once-vars) ids terms . gl)) + ((_ "a" vars once-vars (id . ids) terms . gl) + (relation "a" (id . vars) once-vars ids terms . gl)) + ((_ "a" vars once-vars () terms . gl) + (relation "g" vars once-vars () () () (subst) terms . gl)) + ; generating temp names for each term in the head + ; don't generate if the term is a variable that occurs in + ; once-vars + ; For _ variables in the pattern, generate unique names for the lambda + ; parameters, and forget them + ; also, note and keep track of the first occurrence of a term + ; that is just a var (bare-var) + ((_ "g" vars once-vars (gs ...) gunis bvars bvar-cl (__ . terms) . gl) + (relation "g" vars once-vars (gs ... anon) gunis + bvars bvar-cl terms . gl)) + ((_ "g" vars once-vars (gs ...) gunis bvars (subst . cls) + (term . terms) . gl) + (id-memv?? term once-vars + ; success continuation: term is a once-var + (relation "g" vars once-vars (gs ... term) gunis bvars (subst . cls) + terms . gl) + ; failure continuation: term is not a once-var + (id-memv?? term vars + ; term is a bare var + (id-memv?? term bvars + ; term is a bare var, but we have seen it already: general case + (relation "g" vars once-vars (gs ... g) ((g . term) . gunis) + bvars (subst . cls) terms . gl) + ; term is a bare var, and we have not seen it + (relation "g" vars once-vars (gs ... g) gunis + (term . bvars) + (subst + (subst (unify-free/any term g subst)) + (fast-path? (and (pair? subst) + (eq? term (commitment->var (car subst))))) + (term (if fast-path? (commitment->term (car subst)) term)) + (subst (if fast-path? (cdr subst) subst)) + . cls) + terms . gl)) + ; term is not a bare var + (relation "g" vars once-vars (gs ... g) ((g . term) . gunis) + bvars (subst . cls) terms . gl)))) + ((_ "g" vars once-vars gs gunis bvars bvar-cl () . gl) + (relation "f" vars once-vars gs gunis bvar-cl . gl)) + + ; Final: writing the code + ((_ "f" vars () () () (subst) gl) ; no arguments (no head-tests) + (lambda () + (_exists vars gl))) + ; no tests but pure binding + ((_ "f" (ex-id ...) once-vars (g ...) () (subst) gl) + (lambda (g ...) + (_exists (ex-id ...) gl))) + ; the most general + ((_ "f" (ex-id ...) once-vars (g ...) ((gv . term) ...) + (subst let*-clause ...) gl) + (lambda (g ...) + (_exists (ex-id ...) + (lambda (subst) + (let* (let*-clause ...) + (let*-and sfail ((subst (unify gv term subst)) ...) + (at@ gl subst))))))))) + +; A macro-expand-time memv function for identifiers +; id-memv?? FORM (ID ...) KT KF +; FORM is an arbitrary form or datum, ID is an identifier. +; The macro expands into KT if FORM is an identifier that occurs +; in the list of identifiers supplied by the second argument. +; Otherwise, id-memv?? expands to KF. +; All the identifiers in (ID ...) must be unique. +; Two identifiers match if both refer to the same binding occurrence, or +; (both are undefined and have the same spelling). + +(define-syntax id-memv?? + (syntax-rules () + ((id-memv?? form (id ...) kt kf) + (let-syntax + ((test + (syntax-rules (id ...) + ((test id _kt _kf) _kt) ... + ((test otherwise _kt _kf) _kf)))) + (test form kt kf))))) + +; Test cases +; (id-memv?? x (a b c) #t #f) +; (id-memv?? a (a b c) 'OK #f) +; (id-memv?? () (a b c) #t #f) +; (id-memv?? (x ...) (a b c) #t #f) +; (id-memv?? "abc" (a b c) #t #f) +; (id-memv?? x () #t #f) +; (let ((x 1)) +; (id-memv?? x (a b x) 'OK #f)) +; (let ((x 1)) +; (id-memv?? x (a x b) 'OK #f)) +; (let ((x 1)) +; (id-memv?? x (x a b) 'OK #f)) + + +; relation-head-let (head-term ...) gl +; A simpler, and more efficient kind of relation. The simplicity comes +; from a simpler pattern at the head of the relation. The pattern must +; be linear and shallow with respect to introduced variables. The gl +; is optional (although omitting it doesn't make much sense in +; practice) There are two kinds of head-terms. One kind is an +; identifier. This identifier is taken to be a logical identifier, to +; be unified with the corresponding actual argument. Each logical +; identifier must occur exactly once. Another kind of a head-terms is +; anything else. That anything else may be a constant, a scheme +; variable, or a complex term that may even include logical variables +; such as _ -- but not logical variables defined in the same head-let +; pattern. To make the task of distinguishing logical identifiers +; from anything else easier, we require that anything else of a sort +; of a manifest constant be explicitly quoted or quasiquoted. It would +; be OK to add `, to each 'anything else' term. +; +; Examples: +; (relation-head-let (x y z) (foo x y z)) +; Here x y and z are logical variables. +; (relation-head-let (x y '7) (foo x y)) +; Here we used a manifest constant that must be quoted +; (relation-head-let (x y `(1 2 . ,_)) (foo x y)) +; We used a quasi-quoted constant with an anonymous variable. +; (let ((z `(1 2 . ,_))) (relation-head-let (x y `,z) (foo x y)) +; The same as above, but using a lexical Scheme variable. +; The binding procedure is justified by Proposition 9 of +; the Properties of Substitutions. +; +; 'head-let' is an example of "compile-time" simplifications. +; For example, we distinguish constants in the term head at +; "compile time" and so we re-arrange the argument-passing +; unifications to handle the constants first. +; The test for the anonymous variable (eq? gvv0 _) below +; is an example of a global simplification with a run-time +; test. A compiler could have inferred the result of the test -- but only +; upon the global analysis of all the clauses. +; Replacing a logical variable with an ordinary variable, which does +; not have to be pruned, is equivalent to the use of temporary and +; unsafe variables in WAM. + +(define-syntax relation-head-let + (syntax-rules () + ((_ (head-term ...) . gls) + (relation-head-let "g" () (head-term ...) (head-term ...) . gls)) + ; generate names of formal parameters + ((_ "g" (genvar ...) ((head-term . tail-term) . ht-rest) + head-terms . gls) + (relation-head-let "g" (genvar ... g) ht-rest head-terms . gls)) + ((_ "g" (genvar ...) (head-term . ht-rest) head-terms . gls) + (relation-head-let "g" (genvar ... head-term) ht-rest head-terms . gls)) + ((_ "g" genvars () head-terms . gls) + (relation-head-let "d" () () genvars head-terms genvars . gls)) + ; partition head-terms into vars and others + ((_ "d" vars others (gv . gv-rest) ((hth . htt) . ht-rest) gvs . gls) + (relation-head-let "d" vars ((gv (hth . htt)) . others) + gv-rest ht-rest gvs . gls)) + ((_ "d" vars others (gv . gv-rest) (htv . ht-rest) gvs . gls) + (relation-head-let "d" (htv . vars) others + gv-rest ht-rest gvs . gls)) + ((_ "d" vars others () () gvs . gls) + (relation-head-let "f" vars others gvs . gls)) + + ; final generation + ((_ "f" vars ((gv term) ...) gvs) ; no body + (lambda gvs ; don't bother bind vars + (lambda@ (subst) + (let*-and sfail ((subst (unify gv term subst)) ...) + (at@ succeed subst))))) + + ((_ "f" (var0 ...) ((gvo term) ...) gvs gl) + (lambda gvs + (lambda@ (subst) ; first unify the constants + (let*-and sfail ((subst (unify gvo term subst)) ...) + (let ((var0 (if (eq? var0 __) (logical-variable '?) var0)) ...) + (at@ gl subst)))))))) + +; (define-syntax relation/cut +; (syntax-rules (to-show) +; ((_ cut-id (ex-id ...) (to-show x ...) gl ...) +; (relation/cut cut-id (ex-id ...) () (x ...) (x ...) gl ...)) +; ((_ cut-id ex-ids (var ...) (x0 x1 ...) xs gl ...) +; (relation/cut cut-id ex-ids (var ... g) (x1 ...) xs gl ...)) +; ((_ cut-id (ex-id ...) (g ...) () (x ...) gl ...) +; (lambda (g ...) +; (_exists (ex-id ...) +; (all! (== g x) ... +; (lambda@ (sk fk subst cutk) +; (let ((cut-id (!! cutk))) +; (at@ (all gl ...) sk fk subst cutk))))))))) + +(define-syntax fact + (syntax-rules () + ((_ (ex-id ...) term ...) + (relation (ex-id ...) (to-show term ...) succeed)))) + +; Lifting from goals to relations +; (define-rel-lifted-comb rel-syntax gl-proc-or-syntax) +; Given (gl-proc-or-syntax gl ...) +; define +; (rel-syntax (id ...) rel-exp ...) +; We should make rel-syntax behave as a CBV function, that is, +; evaluate rel-exp early. +; Otherwise, things like +; (define father (extend-relation father ...)) +; loop. + +; (define-syntax extend-relation +; (syntax-rules () +; ((_ (id ...) rel-exp ...) +; (extend-relation-aux (id ...) () rel-exp ...)))) + +; (define-syntax extend-relation-aux +; (syntax-rules () +; ((_ (id ...) ((g rel-exp) ...)) +; (let ((g rel-exp) ...) +; (lambda (id ...) +; (any (g id ...) ...)))) +; ((_ (id ...) (let-pair ...) rel-exp0 rel-exp1 ...) +; (extend-relation-aux (id ...) +; (let-pair ... (g rel-exp0)) rel-exp1 ...)))) + +(define-syntax define-rel-lifted-comb + (syntax-rules () + ((_ rel-syntax-name gl-proc-or-syntax) + (define-syntax rel-syntax-name + (syntax-rules () + ((_ ids . rel-exps) + (lift-gl-to-rel-aux gl-proc-or-syntax ids () . rel-exps))))))) + +(define-syntax lift-gl-to-rel-aux + (syntax-rules () + ((_ gl-handler ids ((g rel-var) ...)) + (let ((g rel-var) ...) + (lambda ids + (gl-handler (g . ids) ...)))) + ((_ gl-handler ids (let-pair ...) rel-exp0 rel-exp1 ...) + (lift-gl-to-rel-aux gl-handler ids + (let-pair ... (g rel-exp0)) rel-exp1 ...)))) + +(define-rel-lifted-comb extend-relation any) + +; The following goal-to-relations +; transformers are roughly equivalent. I don't know which is better. +; see examples below. + +; (lift-to-relations ids (gl-comb rel rel ...)) +(define-syntax lift-to-relations + (syntax-rules () + ((_ ids (gl-comb rel ...)) + (lift-gl-to-rel-aux gl-comb ids () rel ...)))) + +; (let-gls ids ((name rel) ...) body) +; NB: some macro systems do not like if 'ids' below is replaced by (id ...) +(define-syntax let-gls + (syntax-rules () + ((_ ids ((gl-name rel-exp) ...) body) + (lambda ids + (let ((gl-name (rel-exp . ids)) ...) + body))))) + +; Unify lifted to be a binary relation +(define-syntax == + (syntax-rules (__) + ((_ __ u) (lambda@ (subst sk) (at@ sk subst))) + ((_ t __) (lambda@ (subst sk) (at@ sk subst))) + ((_ t u) + (lambda@ (subst) + (let*-and sfail ((subst (unify t u subst))) + (succeed subst)))))) + + +; query (redo-k subst id ...) A SE ... -> result or '() +; The macro 'query' runs the goal A in the empty +; initial substitution, and reifies the resulting +; answer: the substitution and the redo-continuation bound +; to fresh variables with the names supplied by the user. +; The substitution and the redo continuation can then be used +; by Scheme expressions SE ... +; Before running the goal, the macro creates logical variables +; id ... for use in A and SE ... +; If the goal fails, '() is returned and SE ... are not evaluated. +; Note the similarity with shift/reset-based programming +; where the immediate return signifies "failure" and the invocation +; of the continuation a "success" +; Returning '() on failure makes it easy to create the list of answers + +(define-syntax query + (syntax-rules () + ((_ (redo-k subst id ...) A SE ...) + (let-lv (id ...) + (at@ A empty-subst + (lambda@ (subst redo-k) SE ...) + (lambda () '())))))) + +(define stream-prefix + (lambda (n strm) + (if (null? strm) '() + (cons (car strm) + (if (zero? n) '() + (stream-prefix (- n 1) ((cdr strm)))))))) + +(define-syntax solve + (syntax-rules () + ((_ n (var0 ...) gl) + (if (<= n 0) '() + (stream-prefix (- n 1) + (query (redo-k subst var0 ...) + gl + (cons (reify-subst (list var0 ...) subst) redo-k))))))) + + +(define-syntax solution + (syntax-rules () + ((_ (var0 ...) x) + (let ((ls (solve 1 (var0 ...) x))) + (if (null? ls) #f (car ls)))))) + + +(define-syntax project + (syntax-rules () + ((_ (var ...) gl) + (lambda@ (subst) + (let ((var (nonvar! (subst-in var subst))) ...) + (at@ gl subst)))))) + +(define-syntax project/no-check + (syntax-rules () + ((_ (var ...) gl) + (lambda@ (subst) + (let ((var (subst-in var subst)) ...) + (at@ gl subst)))))) + +(define-syntax predicate + (syntax-rules () + ((_ scheme-expression) + (lambda@ (subst) + (if scheme-expression (succeed subst) (fail subst)))))) + +(define nonvar! + (lambda (t) + (if (var? t) + (errorf 'nonvar! "Logic variable ~s found after substituting." + (reify t)) + t))) + +; TRACE-VARS TITLE (VAR ...) +; Is a deterministic goal that prints the current values of VARS +; TITLE is any displayable thing. + +; (define-syntax trace-vars +; (syntax-rules () +; ((trace-vars title (var0 ...)) +; (promise-one-answer +; (predicate/no-check (var0 ...) +; (begin (display title) (display " ") +; (display '(var0 ...)) (display " ") (display (list var0 ...)) +; (newline))))))) + +(define-syntax trace-vars + (syntax-rules () + ((_ title (var0 ...)) + (promise-one-answer + (project/no-check (var0 ...) + (predicate + (for-each + (lambda (name val) + (cout title " " name ": " val nl)) + '(var0 ...) (reify `(,var0 ...))) + )))))) + +;equality predicate: X == Y in Prolog +;if X is a var, then X == Y holds only if Y +;is the same var +(define *equal? + (lambda (x y) + (cond + ((and (var? x) (var? y)) (eq? x y)) + ((var? x) #f) ; y is not a var + ((var? y) #f) ; x is not a var + (else (equal? x y))))) + +; extend-relation-with-recur-limit LIMIT VARS RELS -> REL +; This is a variation of 'extend-relation' that makes sure +; that the extended relation is not recursively entered more +; than LIMIT times. The form extend-relation-with-recur-limit +; can be used to cut a left-recursive relation, and to implement +; an iterative deepening strategy. +; extend-relation-with-recur-limit must be a special form +; because we need to define the depth-counter-var +; outside of relations' lambda (so we count the recursive invocations +; for all arguments). +(define-syntax extend-relation-with-recur-limit + (syntax-rules () + ((_ limit ids rel ...) + (let ((depth-counter-var (logical-variable '*depth-counter*))) + (lambda ids + (let ((gl (any (rel . ids) ...))) + (lambda@ (subst) + (cond + ((assq depth-counter-var subst) + => (lambda (cmt) + (let ((counter (commitment->term cmt))) + (if (>= counter limit) + sfail + (let ((s (extend-subst depth-counter-var + (+ counter 1) subst))) + (at@ gl s)))))) + (else + (let ((s (extend-subst depth-counter-var 1 subst))) + (at@ gl s))))))))) + )) + +; ?- help(call_with_depth_limit/3). +; call_with_depth_limit(+Goal, +Limit, -Result) +; If Goal can be proven without recursion deeper than Limit levels, +; call_with_depth_limit/3 succeeds, binding Result to the deepest +; recursion level used during the proof. Otherwise, Result is +; unified with depth_limit_exceeded if the limit was exceeded during +; the proof, or the entire predicate fails if Goal fails without +; exceeding Limit. + +; The depth-limit is guarded by the internal machinery. This may +; differ from the depth computed based on a theoretical model. For +; example, true/0 is translated into an inlined virtual machine +; instruction. Also, repeat/0 is not implemented as below, but as a +; non-deterministic foreign predicate. + +; repeat. +; repeat :- +; repeat. + +; As a result, call_with_depth_limit/3 may still loop inifitly on +; programs that should theoretically finish in finite time. This +; problem can be cured by using Prolog equivalents to such built-in +; predicates. + +; This predicate may be used for theorem-provers to realise +; techniques like iterrative deepening. It was implemented after +; discussion with Steve Moyle smoyle@ermine.ox.ac.uk. + +;------------------------------------------------------------------------ +;;;;; Starts the real work of the system. + +(define-rel-lifted-comb intersect-relation all) + +(define (kanren-tests) + (let* ((father + (relation () + (to-show 'jon 'sam))) + (child-of-male + (relation (child dad) + (to-show child dad) + (father dad child))) + (child-of-male1 + (relation (child dad) + (to-show child dad) + (child-of-male dad child))) + ) + (test-check 'test-father0 + (let ((result + (at@ (father 'jon 'sam) empty-subst + initial-sk initial-fk))) + (and + (equal? (car result) '()) + (equal? ((cdr result)) '()))) + #t) + + (test-check 'test-child-of-male-0 + (reify-subst '() + (car (at@ (child-of-male 'sam 'jon) empty-subst + initial-sk initial-fk))) + ;`(,(commitment 'child.0 'sam) ,(commitment 'dad.0 'jon))) + '()) ; variables shouldn't leak + + + ; The mark should be found here... + (test-check 'test-child-of-male-1 + (reify-subst '() + (car (at@ (child-of-male 'sam 'jon) empty-subst + initial-sk initial-fk))) + ;`(,(commitment 'child.0 'sam) ,(commitment 'dad.0 'jon))) + '()) + ) + + (let* ((father + (relation () + (to-show 'jon 'sam))) + (rob/sal + (relation () + (to-show 'rob 'sal))) + (new-father + (extend-relation (a1 a2) father rob/sal)) + (rob/pat + (relation () + (to-show 'rob 'pat))) + (newer-father + (extend-relation (a1 a2) new-father rob/pat)) + + ) + (test-check 'test-father-1 + (let ((result + (at@ (new-father 'rob 'sal) empty-subst + initial-sk initial-fk))) + (and + (equal? (car result) '()) + (equal? ((cdr result)) '()))) + #t) + + (test-check 'test-father-2 + (query (redo-k subst x) + (new-father 'rob x) + (list (equal? (car subst) (commitment x 'sal)) (redo-k))) + '(#t ())) + + (test-check 'test-father-3 + (query (_ subst x) + (new-father 'rob x) + (reify-subst (list x) subst)) + '((x.0 sal))) + + (test-check 'test-father-4 + (query (_ subst x y) + (new-father x y) + (reify-subst (list x y) subst)) + '((x.0 jon) (y.0 sam))) + + (test-check 'test-father-5 + (query (redok subst x) + (newer-father 'rob x) + (_pretty-print subst) + (cons + (reify-subst (list x) subst) + (redok))) + '(((x.0 sal)) ((x.0 pat)))) + + ) + + (let* ((father + (extend-relation (a1 a2) + (relation () (to-show 'jon 'sam)) + (relation () (to-show 'rob 'sal)) + (relation () (to-show 'rob 'pat)) + (relation () (to-show 'sam 'rob))) + )) + + (test-check 'test-father-6/solve + (and + (equal? + (solve 5 (x) (father 'rob x)) + '(((x.0 sal)) ((x.0 pat)))) + (equal? + (solve 6 (x y) (father x y)) + '(((x.0 jon) (y.0 sam)) + ((x.0 rob) (y.0 sal)) + ((x.0 rob) (y.0 pat)) + ((x.0 sam) (y.0 rob))))) + #t) + + (test-check 'test-father-7/solution + (solution (x) (father 'rob x)) + '((x.0 sal))) + ) + + + + ; (define-syntax intersect-relation + ; (syntax-rules () + ; ((_ (id ...) rel-exp) rel-exp) + ; ((_ (id ...) rel-exp0 rel-exp1 rel-exp2 ...) + ; (binary-intersect-relation (id ...) rel-exp0 + ; (intersect-relation (id ...) rel-exp1 rel-exp2 ...))))) + + (let* + ((parents-of-scouts + (extend-relation (a1 a2) + (fact () 'sam 'rob) + (fact () 'roz 'sue) + (fact () 'rob 'sal))) + (parents-of-athletes + (extend-relation (a1 a2) + (fact () 'sam 'roz) + (fact () 'roz 'sue) + (fact () 'rob 'sal))) + + (busy-parents + (intersect-relation (a1 a2) parents-of-scouts parents-of-athletes)) + + (conscientious-parents + (extend-relation (a1 a2) parents-of-scouts parents-of-athletes)) + ) + + (test-check 'test-conscientious-parents + (solve 7 (x y) (conscientious-parents x y)) + '(((x.0 sam) (y.0 rob)) + ((x.0 roz) (y.0 sue)) + ((x.0 rob) (y.0 sal)) + ((x.0 sam) (y.0 roz)) + ((x.0 roz) (y.0 sue)) + ((x.0 rob) (y.0 sal)))) + ) + + (let* ((father + (extend-relation (a1 a2) + (relation () (to-show 'jon 'sam)) + (relation () (to-show 'rob 'sal)) + (relation () (to-show 'rob 'pat)) + (relation () (to-show 'sam 'rob))) + )) + + (let + ((grandpa-sam + (relation (grandchild) + (to-show grandchild) + (_exists (parent) + (all (father 'sam parent) + (father parent grandchild)))))) + (test-check 'test-grandpa-sam-1 + (solve 6 (y) (grandpa-sam y)) + '(((y.0 sal)) ((y.0 pat)))) + ) + + (let + ((grandpa-sam + (relation ((once grandchild)) + (to-show grandchild) + (_exists (parent) + (all (father 'sam parent) + (father parent grandchild)))))) + (test-check 'test-grandpa-sam-1 + (solve 6 (y) (grandpa-sam y)) + '(((y.0 sal)) ((y.0 pat)))) + ) + + (let ((child + (relation ((once child) (once dad)) + (to-show child dad) + (father dad child)))) + (test-check 'test-child-1 + (solve 10 (x y) (child x y)) + '(((x.0 sam) (y.0 jon)) + ((x.0 sal) (y.0 rob)) + ((x.0 pat) (y.0 rob)) + ((x.0 rob) (y.0 sam)))) + ) + + (let ((grandpa + (relation ((once grandad) (once grandchild)) + (to-show grandad grandchild) + (_exists (parent) + (all + (father grandad parent) + (father parent grandchild)))))) + (test-check 'test-grandpa-1 + (solve 4 (x) (grandpa 'sam x)) + '(((x.0 sal)) ((x.0 pat))))) + + (let ((grandpa-maker + (lambda (guide* grandad*) + (relation (grandchild) + (to-show grandchild) + (_exists (parent) + (all + (guide* grandad* parent) + (guide* parent grandchild))))))) + (test-check 'test-grandpa-maker-2 + (solve 4 (x) ((grandpa-maker father 'sam) x)) + '(((x.0 sal)) ((x.0 pat))))) + + ) + + (let* + ((father + (extend-relation (a1 a2) + (fact () 'jon 'sam) + (extend-relation (a1 a2) + (fact () 'sam 'rob) + (extend-relation (a1 a2) + (fact () 'sam 'roz) + (extend-relation (a1 a2) + (fact () 'rob 'sal) + (fact () 'rob 'pat)))))) + (mother + (extend-relation (a1 a2) + (fact () 'roz 'sue) + (fact () 'roz 'sid))) + ) + + (let* + ((grandpa/father + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all + (father grandad parent) + (father parent grandchild))))) + (grandpa/mother + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all + (father grandad parent) + (mother parent grandchild))))) + (grandpa + (extend-relation (a1 a2) grandpa/father grandpa/mother))) + + (test-check 'test-grandpa-5 + (solve 10 (y) (grandpa 'sam y)) + '(((y.0 sal)) ((y.0 pat)) ((y.0 sue)) ((y.0 sid)))) + ) + + ; A relation is just a function + (let + ((grandpa-sam + (let ((r (relation (child) + (to-show child) + (_exists (parent) + (all + (father 'sam parent) + (father parent child)))))) + (relation (child) + (to-show child) + (r child))))) + + (test-check 'test-grandpa-55 + (solve 6 (y) (grandpa-sam y)) + '(((y.0 sal)) ((y.0 pat)))) + ) + + ; The solution that used cuts + ; (define grandpa/father + ; (relation/cut cut (grandad grandchild) + ; (to-show grandad grandchild) + ; (_exists (parent) + ; (all + ; (father grandad parent) + ; (father parent grandchild) + ; cut)))) + ; + ; (define grandpa/mother + ; (relation (grandad grandchild) + ; (to-show grandad grandchild) + ; (_exists (parent) + ; (all + ; (father grandad parent) + ; (mother parent grandchild))))) + + + ; Now we don't need it + (let* + ((grandpa/father + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all! + (father grandad parent) + (father parent grandchild))))) + + (grandpa/mother + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all + (father grandad parent) + (mother parent grandchild))))) + + (grandpa + (lift-to-relations (a1 a2) + (all! + (extend-relation (a1 a2) grandpa/father grandpa/mother)))) + ) + (test-check 'test-grandpa-8 + (solve 10 (x y) (grandpa x y)) + '(((x.0 jon) (y.0 rob)))) + ) + + ; The solution that used to require cuts + ; (define grandpa/father + ; (relation/cut cut (grandad grandchild) + ; (to-show grandad grandchild) + ; (_exists (parent) + ; (all cut (father grandad parent) (father parent grandchild))))) + + (let + ((grandpa/father + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all + (father grandad parent) (father parent grandchild))))) + + (grandpa/mother + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all + (father grandad parent) (mother parent grandchild))))) + ) + + ; Properly, this requires soft cuts, aka *->, or Mercury's + ; if-then-else. But we emulate it... + (let + ((grandpa + (let-gls (a1 a2) ((grandpa/father grandpa/father) + (grandpa/mother grandpa/mother)) + (if-only (succeeds grandpa/father) grandpa/father grandpa/mother))) + ) + (test-check 'test-grandpa-10 + (solve 10 (x y) (grandpa x y)) + '(((x.0 jon) (y.0 rob)) + ((x.0 jon) (y.0 roz)) + ((x.0 sam) (y.0 sal)) + ((x.0 sam) (y.0 pat)))) + (test-check 'test-grandpa-10-1 + (solve 10 (x) (grandpa x 'sue)) + '(((x.0 sam)))) + ) + + ; The same as above, with if-all! -- just to test the latter. + (let + ((grandpa + (let-gls (a1 a2) ((grandpa/father grandpa/father) + (grandpa/mother grandpa/mother)) + (if-only (all! (succeeds grandpa/father) (succeeds grandpa/father)) + grandpa/father grandpa/mother)))) + + (test-check 'test-grandpa-10 + (solve 10 (x y) (grandpa x y)) + '(((x.0 jon) (y.0 rob)) + ((x.0 jon) (y.0 roz)) + ((x.0 sam) (y.0 sal)) + ((x.0 sam) (y.0 pat)))) + + (test-check 'test-grandpa-10-1 + (solve 10 (x) (grandpa x 'sue)) + '(((x.0 sam)))) + ) + + + ; Now do it with soft-cuts + (let + ((grandpa + (let-gls (a1 a2) ((grandpa/father grandpa/father) + (grandpa/mother grandpa/mother)) + (if-some grandpa/father succeed grandpa/mother))) + ) + (test-check 'test-grandpa-10-soft-cut + (solve 10 (x y) (grandpa x y)) + '(((x.0 jon) (y.0 rob)) + ((x.0 jon) (y.0 roz)) + ((x.0 sam) (y.0 sal)) + ((x.0 sam) (y.0 pat)))) + ) + + (let* + ((a-grandma + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all! (mother grandad parent))))) + (no-grandma-grandpa + (let-gls (a1 a2) ((a-grandma a-grandma) + (grandpa (lift-to-relations (a1 a2) + (all! + (extend-relation (a1 a2) + grandpa/father grandpa/mother))))) + (if-only a-grandma fail grandpa))) + ) + (test-check 'test-no-grandma-grandpa-1 + (solve 10 (x) (no-grandma-grandpa 'roz x)) + '())) + )) + + (let + ((parents-of-scouts + (extend-relation (a1 a2) + (fact () 'sam 'rob) + (fact () 'roz 'sue) + (fact () 'rob 'sal))) + (fathers-of-cubscouts + (extend-relation (a1 a2) + (fact () 'sam 'bob) + (fact () 'tom 'adam) + (fact () 'tad 'carl))) + ) + + (test-check 'test-partially-eval-sgl + (let-lv (p1 p2) + (let* ((parents-of-scouts-sgl + ((parents-of-scouts p1 p2) empty-subst)) + (cons@ (lambda@ (x y) (cons x y))) + (split1 (at@ + partially-eval-sgl parents-of-scouts-sgl + cons@ (lambda () '()))) + (a1 (car split1)) + (split2 (at@ partially-eval-sgl (cdr split1) cons@ + (lambda () '()))) + (a2 (car split2)) + (split3 (at@ partially-eval-sgl (cdr split2) cons@ + (lambda () '()))) + (a3 (car split3))) + (map (lambda (subst) + (reify-subst (list p1 p2) subst)) + (list a1 a2 a3)))) + '(((p1.0 sam) (p2.0 rob)) ((p1.0 roz) (p2.0 sue)) ((p1.0 rob) (p2.0 sal)))) + ) + + + (test-check 'test-pred1 + (let ((test1 + (lambda (x) + (any (predicate (< 4 5)) + (== x (< 6 7)))))) + (solution (x) (test1 x))) + '((x.0 _.0))) + + (test-check 'test-pred2 + (let ((test2 + (lambda (x) + (any (predicate (< 5 4)) + (== x (< 6 7)))))) + (solution (x) (test2 x))) + '((x.0 #t))) + + (test-check 'test-pred3 + (let ((test3 + (lambda (x y) + (any + (== x (< 5 4)) + (== y (< 6 7)))))) + (solution (x y) (test3 x y))) + `((x.0 #f) (y.0 _.0))) + + (test-check 'test-Seres-Spivey + (let ((father + (lambda (dad child) + (any + (all (== dad 'jon) (== child 'sam)) + (all (== dad 'sam) (== child 'rob)) + (all (== dad 'sam) (== child 'roz)) + (all (== dad 'rob) (== child 'sal)) + (all (== dad 'rob) (== child 'pat)) + (all (== dad 'jon) (== child 'hal)) + (all (== dad 'hal) (== child 'ted)) + (all (== dad 'sam) (== child 'jay)))))) + (letrec + ((ancestor + (lambda (old young) + (any + (father old young) + (_exists (not-so-old) + (all + (father old not-so-old) + (ancestor not-so-old young))))))) + (solve 20 (x) (ancestor 'jon x)))) + '(((x.0 sam)) + ((x.0 hal)) + ((x.0 rob)) + ((x.0 roz)) + ((x.0 jay)) + ((x.0 sal)) + ((x.0 pat)) + ((x.0 ted)))) + + (let () + (define towers-of-hanoi + (letrec + ((move + (extend-relation (a1 a2 a3 a4) + (fact () 0 __ __ __) + (relation (n a b c) + (to-show n a b c) + (project (n) + (if-only (predicate (positive? n)) + (let ((m (- n 1))) + (all + (move m a c b) + (project (a b) + (begin + (cout "Move a disk from " a " to " b nl) + (move m c b a))))))))))) + (relation (n) + (to-show n) + (move n 'left 'middle 'right)))) + + (cout "test-towers-of-hanoi with 3 disks: " + (solution () (towers-of-hanoi 3)) + nl nl + )) + + + (test-check 'test-fun-resubst + (reify + (let ((j (relation (x w z) + (to-show z) + (let ((x 4) + (w 3)) + (== z (cons x w)))))) + (solve 4 (q) (j q)))) + '(((q.0 (4 . 3))))) + + (let () + (define towers-of-hanoi-path + (let ((steps '())) + (let ((push-step (lambda (x y) (set! steps (cons `(,x ,y) steps))))) + (letrec + ((move + (extend-relation (a1 a2 a3 a4) + (fact () 0 __ __ __) + (relation (n a b c) + (to-show n a b c) + (project (n) + (if-only (predicate (positive? n)) + (let ((m (- n 1))) + (all + (move m a c b) + (project (a b) + (begin + (push-step a b) + (move m c b a))))))))))) + (relation (n path) + (to-show n path) + (begin + (set! steps '()) + (any + (fails (move n 'l 'm 'r)) + (== path (reverse steps))))))))) + + (test-check 'test-towers-of-hanoi-path + (solution (path) (towers-of-hanoi-path 3 path)) + '((path.0 ((l m) (l r) (m r) (l m) (r l) (r m) (l m)))))) + + ;------------------------------------------------------------------------ + + + (test-check 'unification-of-free-vars-1 + (solve 1 (x) + (let-lv (y) + (all!! (== x y) (== y 5)))) + '(((x.0 5)))) + + (test-check 'unification-of-free-vars-2 + (solve 1 (x) + (let-lv (y) + (all!! (== y 5) (== x y)))) + '(((x.0 5)))) + + (test-check 'unification-of-free-vars-3 + (solve 1 (x) + (let-lv (y) + (all!! (== y x) (== y 5)))) + '(((x.0 5)))) + + (test-check 'unification-of-free-vars-3 + (solve 1 (x) + (let-lv (y) + (all!! (== x y) (== y 5) (== x y)))) + '(((x.0 5)))) + + (test-check 'unification-of-free-vars-4 + (solve 1 (x) + (_exists (y) + (all! (== y x) (== y 5) (== x y)))) + '(((x.0 5)))) + + + (letrec + ((concat + (lambda (xs ys) + (cond + ((null? xs) ys) + (else (cons (car xs) (concat (cdr xs) ys))))))) + + (test-check 'test-concat-as-function + (concat '(a b c) '(u v)) + '(a b c u v)) + + (test-check 'test-fun-concat + (solve 1 (q) + (== q (concat '(a b c) '(u v)))) + '(((q.0 (a b c u v))))) + ) + + ; Now the same with the relation + (letrec + ((concat + (extend-relation (a1 a2 a3) + (fact (xs) '() xs xs) + (relation (x xs (once ys) zs) + (to-show `(,x . ,xs) ys `(,x . ,zs)) + (concat xs ys zs))))) + (test-check 'test-concat + (values + (and + (equal? + (solve 6 (q) (concat '(a b c) '(u v) q)) + '(((q.0 (a b c u v))))) + (equal? + (solve 6 (q) (concat '(a b c) q '(a b c u v))) + '(((q.0 (u v))))) + (equal? + (solve 6 (q) (concat q '(u v) '(a b c u v))) + '(((q.0 (a b c))))) + (equal? + (solve 6 (q r) (concat q r '(a b c u v))) + '(((q.0 ()) (r.0 (a b c u v))) + ((q.0 (a)) (r.0 (b c u v))) + ((q.0 (a b)) (r.0 (c u v))) + ((q.0 (a b c)) (r.0 (u v))) + ((q.0 (a b c u)) (r.0 (v))) + ((q.0 (a b c u v)) (r.0 ())))) + (equal? + (solve 6 (q r s) (concat q r s)) + '(((q.0 ()) (r.0 _.0) (s.0 _.0)) + ((q.0 (_.0)) (r.0 _.1) (s.0 (_.0 . _.1))) + ((q.0 (_.0 _.1)) (r.0 _.2) (s.0 (_.0 _.1 . _.2))) + ((q.0 (_.0 _.1 _.2)) (r.0 _.3) (s.0 (_.0 _.1 _.2 . _.3))) + ((q.0 (_.0 _.1 _.2 _.3)) (r.0 _.4) (s.0 (_.0 _.1 _.2 _.3 . _.4))) + ((q.0 (_.0 _.1 _.2 _.3 _.4)) (r.0 _.5) + (s.0 (_.0 _.1 _.2 _.3 _.4 . _.5)))) + ) + '(equal? + (solve 6 (q r) (concat q '(u v) `(a b c . ,r))) + '(((q.0 (a b c)) (r.0 (u v))) + ((q.0 (a b c _.0)) (r.0 (_.0 u v))) + ((q.0 (a b c _.0 _.1)) (r.0 (_.0 _.1 u v))) + ((q.0 (a b c _.0 _.1 _.2)) (r.0 (_.0 _.1 _.2 u v))) + ((q.0 (a b c _.0 _.1 _.2 _.3)) (r.0 (_.0 _.1 _.2 _.3 u v))) + ((q.0 (a b c _.0 _.1 _.2 _.3 _.4)) + (r.0 (_.0 _.1 _.2 _.3 _.4 u v))))) + (equal? + (solve 6 (q) (concat q '() q)) + '(((q.0 ())) + ((q.0 (_.0))) + ((q.0 (_.0 _.1))) + ((q.0 (_.0 _.1 _.2))) + ((q.0 (_.0 _.1 _.2 _.3))) + ((q.0 (_.0 _.1 _.2 _.3 _.4))))) + )) + #t) + ) + + ; Using the properties of the unifier to do the proper garbage + ; collection of logical vars + + ; (test-check 'lv-elim-1 + ; (reify + ; (let-lv (x z dummy) + ; (at@ + ; (_exists (y) + ; (== `(,x ,z ,y) `(5 9 ,x))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((y.0 . 5) (z.0 . 9) (x.0 . 5) (dummy.0 . dummy))) + ; ;'((z.0 . 9) (x.0 . 5) (dummy.0 . dummy))) + + ; (test-check 'lv-elim-2 + ; (reify + ; (let-lv (x dummy) + ; (at@ + ; (_exists (y) + ; (== `(,x ,y) `((5 ,y) ,7))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((y.0 . 7) (x.0 5 y.0) (dummy.0 . dummy))) + ; ;'((a*.0 . 7) (x.0 5 a*.0) (dummy.0 . dummy))) + + ; ; verifying corollary 2 of proposition 10 + ; (test-check 'lv-elim-3 + ; (reify + ; (let-lv (x v dummy) + ; (at@ + ; (_exists (y) + ; (== x `(a b c ,v d))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((x.0 a b c v.0 d) (dummy.0 . dummy))) + ; ;'((a*.0 . v.0) (x.0 a b c a*.0 d) (dummy.0 . dummy))) + + ; ; pruning several variables sequentially and in parallel + ; (test-check 'lv-elim-4-1 + ; (reify + ; (let-lv (x v b dummy) + ; (at@ + ; (let-lv (y) + ; (== `(,b ,x ,y) `(,x ,y 1))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((y.0 . 1) (x.0 . y.0) (b.0 . x.0) (dummy.0 . dummy))) + + ; ; (test-check 'lv-elim-4-2 + ; ; (concretize + ; ; (let-lv (v b dummy) + ; ; (at@ + ; ; (_exists (x) + ; ; (_exists (y) + ; ; (== `(,b ,x ,y) `(,x ,y 1)))) + ; ; (lambda@ (fk subst) subst) + ; ; initial-fk + ; ; (unit-subst dummy 'dummy)))) + ; ; '((b.0 . 1) (dummy.0 . dummy))) + + ; ; (test-check 'lv-elim-4-3 + ; ; (concretize + ; ; (let-lv (v b dummy) + ; ; (at@ + ; ; (_exists (y) + ; ; (_exists (x) + ; ; (== `(,b ,x ,y) `(,x ,y 1)))) + ; ; (lambda@ (fk subst) subst) + ; ; initial-fk + ; ; (unit-subst dummy 'dummy)))) + ; ; '((b.0 . 1) (dummy.0 . dummy))) + + ; (test-check 'lv-elim-4-4 + ; (reify + ; (let-lv (v b dummy) + ; (at@ + ; (_exists (x y) + ; (== `(,b ,x ,y) `(,x ,y 1))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((y.0 . 1) (x.0 . y.0) (b.0 . x.0) (dummy.0 . dummy))) + ; ;'((b.0 . 1) (dummy.0 . dummy))) + + ; ; pruning several variables sequentially and in parallel + ; ; for indirect (cyclic) dependency + ; (test-check 'lv-elim-5-1 + ; (reify + ; (let-lv (x v b dummy) + ; (at@ + ; (let-lv (y) + ; (== `(,b ,y ,x) `(,x (1 ,x) ,y))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((x.0 1 x.0) (y.0 1 x.0) (b.0 . x.0) (dummy.0 . dummy))) + ; ;'((x.0 1 a*.0) (a*.0 . x.0) (y.0 1 a*.0) (b.0 . x.0) (dummy.0 . dummy))) + + ; ; (test-check 'lv-elim-5-2 + ; ; (concretize + ; ; (let-lv (v b dummy) + ; ; (at@ + ; ; (_exists (x) + ; ; (_exists (y) + ; ; (== `(,b ,y ,x) `(,x (1 ,x) ,y)))) + ; ; (lambda@ (fk subst) subst) + ; ; initial-fk + ; ; (unit-subst dummy 'dummy)))) + ; ; '((a*.0 1 a*.0) (b.0 1 a*.0) (dummy.0 . dummy))) + + ; ; (test-check 'lv-elim-5-3 + ; ; (concretize + ; ; (let-lv (v b dummy) + ; ; (at@ + ; ; (_exists (y) + ; ; (_exists (x) + ; ; (== `(,b ,y ,x) `(,x (1 ,x) ,y)))) + ; ; (lambda@ (fk subst) subst) + ; ; initial-fk + ; ; (unit-subst dummy 'dummy)))) + ; ; '((a*.0 1 a*.0) (b.0 1 a*.0) (dummy.0 . dummy))) + + ; (test-check 'lv-elim-5-4 + ; (reify + ; (let-lv (v b dummy) + ; (at@ + ; (_exists (x y) + ; (== `(,b ,y ,x) `(,x (1 ,x) ,y))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((x.0 1 x.0) (y.0 1 x.0) (b.0 . x.0) (dummy.0 . dummy))) + ; ;'((a*.0 1 a*.0) (b.0 1 a*.0) (dummy.0 . dummy))) + + ; ; We should only be concerned about a direct dependency: + ; ; ((x . y) (y . (1 t)) (t . x) (a . x)) + ; ; pruning x and y in sequence or in parallel gives the same result: + ; ; ((t . (1 t)) (a . (1 t))) + + + ; Extending relations in truly mathematical sense. + ; First, why do we need this. + (let* + ((fact1 (fact () 'x1 'y1)) + (fact2 (fact () 'x2 'y2)) + (fact3 (fact () 'x3 'y3)) + (fact4 (fact () 'x4 'y4)) + + ; R1 and R2 are overlapping + (R1 (extend-relation (a1 a2) fact1 fact2)) + (R2 (extend-relation (a1 a2) fact1 fact3)) + ) + ; Infinitary relation + ; r(z,z). + ; r(s(X),s(Y)) :- r(X,Y). + (letrec + ((Rinf + (extend-relation (a1 a2) + (fact () 'z 'z) + (relation (x y t1 t2) + (to-show t1 t2) + (all + (== t1 `(s ,x)) + (== t2 `(s ,y)) + (Rinf x y))))) + ) + + (cout nl "R1:" nl) + (_pretty-print (solve 10 (x y) (R1 x y))) + (cout nl "R2:" nl) + (_pretty-print (solve 10 (x y) (R2 x y))) + (cout nl "R1+R2:" nl) + (_pretty-print + (solve 10 (x y) + ((extend-relation (a1 a2) R1 R2) x y))) + + (cout nl "Rinf:" nl) + (values (_pretty-print (solve 5 (x y) (Rinf x y)))) + (cout nl "Rinf+R1: Rinf starves R1:" nl) + (values + (_pretty-print + (solve 5 (x y) + ((extend-relation (a1 a2) Rinf R1) x y)))) + + ; Solving the starvation problem: extend R1 and R2 so that they + ; are interleaved + ; ((sf-extend R1 R2) sk fk) + ; (R1 sk fk) + ; If R1 fails, we try the rest of R2 + ; If R1 succeeds, it executes (sk fk) + ; with fk to re-prove R1. Thus fk is the "rest" of R1 + ; So we pass sk (lambda () (run-rest-of-r2 interleave-with-rest-of-r1)) + ; There is a fixpoint in the following algorithm! + ; Or a second-level shift/reset! + + (test-check "Rinf+R1" + (values + (solve 7 (x y) + (any-interleave (Rinf x y) (R1 x y)))) + '(((x.0 z) (y.0 z)) + ((x.0 x1) (y.0 y1)) + ((x.0 (s z)) (y.0 (s z))) + ((x.0 x2) (y.0 y2)) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s z)))) (y.0 (s (s (s z))))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))) + ) + + (test-check "R1+Rinf" + (values + (solve 7 (x y) + (any-interleave (R1 x y) (Rinf x y)))) + '(((x.0 x1) (y.0 y1)) + ((x.0 z) (y.0 z)) + ((x.0 x2) (y.0 y2)) + ((x.0 (s z)) (y.0 (s z))) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s z)))) (y.0 (s (s (s z))))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))) + ) + + + (test-check "R2+R1" + (solve 7 (x y) + (any-interleave (R2 x y) (R1 x y))) + '(((x.0 x1) (y.0 y1)) + ((x.0 x1) (y.0 y1)) + ((x.0 x3) (y.0 y3)) + ((x.0 x2) (y.0 y2))) + ) + + (test-check "R1+fact3" + (solve 7 (x y) + (any-interleave (R1 x y) (fact3 x y))) + '(((x.0 x1) (y.0 y1)) ((x.0 x3) (y.0 y3)) ((x.0 x2) (y.0 y2))) + ) + + (test-check "fact3+R1" + (solve 7 (x y) + (any-interleave (fact3 x y) (R1 x y))) + '(((x.0 x3) (y.0 y3)) ((x.0 x1) (y.0 y1)) ((x.0 x2) (y.0 y2))) + ) + + ; testing all-interleave + (test-check 'all-interleave-1 + (solve 100 (x y z) + (all-interleave + (any (== x 1) (== x 2)) + (any (== y 3) (== y 4)) + (any (== z 5) (== z 6) (== z 7)))) + '(((x.0 1) (y.0 3) (z.0 5)) + ((x.0 2) (y.0 3) (z.0 5)) + ((x.0 1) (y.0 4) (z.0 5)) + ((x.0 2) (y.0 4) (z.0 5)) + ((x.0 1) (y.0 3) (z.0 6)) + ((x.0 2) (y.0 3) (z.0 6)) + ((x.0 1) (y.0 4) (z.0 6)) + ((x.0 2) (y.0 4) (z.0 6)) + ((x.0 1) (y.0 3) (z.0 7)) + ((x.0 2) (y.0 3) (z.0 7)) + ((x.0 1) (y.0 4) (z.0 7)) + ((x.0 2) (y.0 4) (z.0 7))) + ) + + (test-check "R1 * Rinf: clearly starvation" + (solve 5 (x y u v) + (all (R1 x y) (Rinf u v))) + ; indeed, only the first choice of R1 is apparent + '(((x.0 x1) (y.0 y1) (u.0 z) (v.0 z)) + ((x.0 x1) (y.0 y1) (u.0 (s z)) (v.0 (s z))) + ((x.0 x1) (y.0 y1) (u.0 (s (s z))) (v.0 (s (s z)))) + ((x.0 x1) (y.0 y1) (u.0 (s (s (s z)))) (v.0 (s (s (s z))))) + ((x.0 x1) (y.0 y1) (u.0 (s (s (s (s z))))) (v.0 (s (s (s (s z))))))) + ) + + (test-check "R1 * Rinf: interleaving" + (solve 5 (x y u v) + (all-interleave (R1 x y) (Rinf u v))) + ; both choices of R1 are apparent + '(((x.0 x1) (y.0 y1) (u.0 z) (v.0 z)) + ((x.0 x2) (y.0 y2) (u.0 z) (v.0 z)) + ((x.0 x1) (y.0 y1) (u.0 (s z)) (v.0 (s z))) + ((x.0 x2) (y.0 y2) (u.0 (s z)) (v.0 (s z))) + ((x.0 x1) (y.0 y1) (u.0 (s (s z))) (v.0 (s (s z))))) + ) + + ;; Test for nonoverlapping. + + (cout nl "any-union" nl) + (test-check "R1+R2" + (solve 10 (x y) + (any-union (R1 x y) (R2 x y))) + '(((x.0 x1) (y.0 y1)) + ((x.0 x2) (y.0 y2)) + ((x.0 x3) (y.0 y3)))) + + (test-check "R2+R1" + (solve 10 (x y) + (any-union (R2 x y) (R1 x y))) + '(((x.0 x1) (y.0 y1)) + ((x.0 x3) (y.0 y3)) + ((x.0 x2) (y.0 y2)))) + + (test-check "R1+R1" + (solve 10 (x y) + (any-union (R1 x y) (R1 x y))) + '(((x.0 x1) (y.0 y1)) + ((x.0 x2) (y.0 y2)))) + + (test-check "Rinf+R1" + (solve 7 (x y) + (any-union (Rinf x y) (R1 x y))) + '(((x.0 z) (y.0 z)) + ((x.0 x1) (y.0 y1)) + ((x.0 (s z)) (y.0 (s z))) + ((x.0 x2) (y.0 y2)) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s z)))) (y.0 (s (s (s z))))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))))) + + (test-check "R1+RInf" + (solve 7 (x y) + (any-union (R1 x y) (Rinf x y))) + '(((x.0 x1) (y.0 y1)) + ((x.0 z) (y.0 z)) + ((x.0 x2) (y.0 y2)) + ((x.0 (s z)) (y.0 (s z))) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s z)))) (y.0 (s (s (s z))))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))))) + + + ; Infinitary relation Rinf2 + ; r(z,z). + ; r(s(s(X)),s(s(Y))) :- r(X,Y). + ; Rinf2 overlaps with Rinf in the infinite number of points + (letrec + ((Rinf2 + (extend-relation (a1 a2) + (fact () 'z 'z) + (relation (x y t1 t2) + (to-show t1 t2) + (all + (== t1 `(s (s ,x))) + (== t2 `(s (s ,y))) + (Rinf2 x y))))) + ) + (test-check "Rinf2" + (solve 5 (x y) (Rinf2 x y)) + '(((x.0 z) (y.0 z)) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))) + ((x.0 (s (s (s (s (s (s z))))))) + (y.0 (s (s (s (s (s (s z)))))))) + ((x.0 (s (s (s (s (s (s (s (s z))))))))) + (y.0 (s (s (s (s (s (s (s (s z)))))))))))) + + (test-check "Rinf+Rinf2" + (solve 9 (x y) + (any-union (Rinf x y) (Rinf2 x y))) + '(((x.0 z) (y.0 z)) + ((x.0 (s z)) (y.0 (s z))) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))) + ((x.0 (s (s (s z)))) (y.0 (s (s (s z))))) + ((x.0 (s (s (s (s (s (s z))))))) + (y.0 (s (s (s (s (s (s z)))))))) + ((x.0 (s (s (s (s (s (s (s (s z))))))))) + (y.0 (s (s (s (s (s (s (s (s z)))))))))) + ((x.0 (s (s (s (s (s z)))))) (y.0 (s (s (s (s (s z))))))) + ((x.0 (s (s (s (s (s (s (s (s (s (s z))))))))))) + (y.0 (s (s (s (s (s (s (s (s (s (s z)))))))))))))) + + (test-check "Rinf2+Rinf" + (solve 9 (x y) + (any-union (Rinf2 x y) (Rinf x y))) + '(((x.0 z) (y.0 z)) + ((x.0 (s z)) (y.0 (s z))) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s z)))) (y.0 (s (s (s z))))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))) + ((x.0 (s (s (s (s (s z)))))) (y.0 (s (s (s (s (s z))))))) + ((x.0 (s (s (s (s (s (s z))))))) + (y.0 (s (s (s (s (s (s z)))))))) + ((x.0 (s (s (s (s (s (s (s z)))))))) + (y.0 (s (s (s (s (s (s (s z))))))))) + ((x.0 (s (s (s (s (s (s (s (s z))))))))) + (y.0 (s (s (s (s (s (s (s (s z)))))))))))) + ))) + + + (cout nl "Append with limited depth" nl) + ; In Prolog, we normally write: + ; append([],L,L). + ; append([X|L1],L2,[X|L3]) :- append(L1,L2,L3). + ; + ; If we switch the clauses, we get non-termination. + ; In our system, it doesn't matter! + + (letrec + ((extend-clause-1 + (relation (l) + (to-show '() l l) + succeed)) + (extend-clause-2 + (relation (x l1 l2 l3) + (to-show `(,x . ,l1) l2 `(,x . ,l3)) + (extend-rel l1 l2 l3))) + (extend-rel + (extend-relation-with-recur-limit 5 (a b c) + extend-clause-1 + extend-clause-2)) + ) + + ; Note (solve 100 ...) + ; Here 100 is just a large number: we want to print all solutions + (cout nl "Extend: clause1 first: " + (solve 100 (a b c) (extend-rel a b c)) + nl)) + + (letrec + ((extend-clause-1 + (relation (l) + (to-show '() l l) + succeed)) + (extend-clause-2 + (relation (x l1 l2 l3) + (to-show `(,x . ,l1) l2 `(,x . ,l3)) + (extend-rel l1 l2 l3))) + (extend-rel + (extend-relation-with-recur-limit 3 (a b c) + extend-clause-2 + extend-clause-1))) + + (cout nl "Extend: clause2 first. In Prolog, it would diverge!: " + (solve 100 (a b c) (extend-rel a b c)) nl)) + + + (letrec + ((base-+-as-relation + (fact (n) 'zero n n)) + (recursive-+-as-relation + (relation (n1 n2 n3) + (to-show `(succ ,n1) n2 `(succ ,n3)) + (plus-as-relation n1 n2 n3))) + ; Needed eta-expansion here: otherwise, SCM correctly reports + ; an error (but Petite doesn't, alas) + ; This is a peculiarity of extend-relation as a macro + ; Potentially, we need the same approach as in minikanren + (plus-as-relation + (extend-relation (a1 a2 a3) + (lambda (a1 a2 a3) (base-+-as-relation a1 a2 a3)) + (lambda (a1 a2 a3) (recursive-+-as-relation a1 a2 a3)) + )) + ) + + (test-check "Addition" + (solve 20 (x y) + (plus-as-relation x y '(succ (succ (succ (succ (succ zero))))))) + '(((x.0 zero) (y.0 (succ (succ (succ (succ (succ zero))))))) + ((x.0 (succ zero)) (y.0 (succ (succ (succ (succ zero)))))) + ((x.0 (succ (succ zero))) (y.0 (succ (succ (succ zero))))) + ((x.0 (succ (succ (succ zero)))) (y.0 (succ (succ zero)))) + ((x.0 (succ (succ (succ (succ zero))))) (y.0 (succ zero))) + ((x.0 (succ (succ (succ (succ (succ zero)))))) (y.0 zero)))) + + (newline) + ) +10) + +;; ======================================================================== +;; type-inference example +;; ======================================================================== + +; Type Inference +; +; We show two variations of Hindley-Milner type inference. Both +; variations support polymorphic, generalizing `let'. Both variations +; use Kanren's logical variables for type variables, and take advantage +; of Kanren's unifier to solve the equations that arise during the course +; of type inference. These features make the Kanren realization of the +; type inference algorithm concise and lucid. +; +; The variations differ in the syntax of the `source' language, and in +; the way type environments are implemented. One variation realizes +; type environments as regular lists, of associations between symbolic +; variable names and their types. The other variation extends the type +; entailment relation (which is a first-class relation in Kanren). The +; latter approach is similar to that of inductive proofs (see files +; ./deduction.scm and ./mirror-equ.scm) +; +; $Id: type-inference.scm,v 4.50 2005/02/12 00:05:01 oleg Exp $ + +; (display "Type inference") (newline) + +; Variation 1: use a subset of Scheme itself as the source language +; The following two functions translate between the source language +; and intermediate one. + +(define parse + (lambda (e) + (cond + ((symbol? e) `(var ,e)) + ((number? e) `(intc ,e)) + ((boolean? e) `(boolc ,e)) + (else (case (car e) + ((zero?) `(zero? ,(parse (cadr e)))) + ((sub1) `(sub1 ,(parse (cadr e)))) + ((+) `(+ ,(parse (cadr e)) ,(parse (caddr e)))) + ((if) `(if ,(parse (cadr e)) ,(parse (caddr e)) ,(parse (cadddr e)))) + ((fix) `(fix ,(parse (cadr e)))) + ((lambda) `(lambda ,(cadr e) ,(parse (caddr e)))) + ((let) `(let ((,(car (car (cadr e))) ,(parse (cadr (car (cadr e)))))) + ,(parse (caddr e)))) + (else `(app ,(parse (car e)) ,(parse (cadr e))))))))) + +(define unparse + (lambda (e) + (case (car e) + ((var) (cadr e)) + ((intc) (cadr e)) + ((boolc) (cadr e)) + ((zero?) `(zero? ,(unparse (cadr e)))) + ((sub1) `(sub1 ,(unparse (cadr e)))) + ((+) `(+ ,(unparse (cadr e)) ,(unparse (caddr e)))) + ((if) `(if ,(unparse (cadr e)) ,(unparse (caddr e)) ,(unparse (cadddr e)))) + ((fix) `(fix ,(unparse (cadr e)))) + ((lambda) `(lambda (,(car (cadr e))) ,(unparse (caddr e)))) + ((let) + `(let ((,(car (car (cadr e))) + ,(unparse (cadr (car (cadr e)))))) + ,(unparse (caddr e)))) + ((app) `(,(unparse (cadr e)) ,(unparse (caddr e))))))) + +; Type environments +; +; A type environment (often denoted as \Gamma, or g in this code) +; is an association between the names of variables of source language +; terms and the types of those variables. +; As a side condition, each variable may occur in the list +; exactly once. +; Hmm, to model lexical scope better, we may relax that condition. +; +; Here we implement type environments as regular associative lists, +; lists of triples: +; ( non-generic ) +; ( generic ) +; +; is a symbolic name of a source term variable. +; is a type term, e.g., int, bool, (--> int bool), etc. +; may include logical variables, which are treated then as +; type variables. +; +; The association '( generic )' asserts that +; is given a _generic_ type. then is a +; predicate of arity 1. To be more precise, ( ) +; is an goal that succeeds or fails depending on the fact if +; is an instance of a generic type represented by . +; +; This is precisely the logical meaning of generalization, as +; pointed out by Ken: +;
+; A cleaner, but less efficient, formulation of HM type inference is to +; use the following let rule instead: +; +; Gamma |- M : t Gamma |- N[M/x] : t' +; -------------------------------------- Let +; Gamma |- let x = M in N : t' +; +; Look ma, no FV! In words, this rule treats let as a construct for +; syntactic substitution. This means storing either M, or a thunk +; returning (a logical variable associated with a fresh copy of) the type +; of M, under x in the environment. This formulation avoids var? while +; taking advantage of built-in unification (to some extent). +;
+; +; We must emphasize that in Kanren, relations are first-class, and may, +; therefore, be included as parts of a data structure: of an associative +; list in our case. + +; Because type environments are regular lists, we can build them using +; regular cons. The empty type environemnt is the empty list. The +; following is a Kanren relation that searches the associative +; list. We are interested in the first match. + +; The following is a general-purpose function +; (membero v l) holds if v is a member of the list l. +; 'v' must be sufficiently instantiated (at least, the search key +; must be instantiated, to justify our use of the committed choice +; non-determinism). +(define membero + (relation (v lt lh) + (to-show v `(,lh . ,lt)) + (if-some (== v lh) succeed + (membero v lt)))) + +; The following is the type-environment-specific function. +; (env g v t) holds if the source term variable v has a type t +; in the environment g. +; We require that 'v' be instantiated, to justify our use +; of the committed choice non-determinism (e.g., membero). + +(define env + (relation (head-let g v t) + (_exists (tq) + (all!! + (membero `(,v . ,tq) g) + (any + (== tq `(non-generic ,t)) + (_exists (type-gen) + (all!! + (== tq `(generic ,type-gen)) + (project (type-gen) + (type-gen t))))))))) + +;;;; This starts the rules + +(define int 'int) +(define bool 'bool) + +(define var-rel + (relation (g v t) + (to-show g `(var ,v) t) + (all! (env g v t)))) + +(define int-rel + (fact (g x) g `(intc ,x) int)) + +(define bool-rel + (fact (g x) g `(boolc ,x) bool)) + +(define zero?-rel + (relation (g x) + (to-show g `(zero? ,x) bool) + (all! (!- g x int)))) + +(define sub1-rel + (relation (g x) + (to-show g `(sub1 ,x) int) + (all! (!- g x int)))) + +(define plus-rel + (relation (g x y) + (to-show g `(+ ,x ,y) int) + (all!! (!- g x int) (!- g y int)))) + +(define if-rel + (relation (g t test conseq alt) + (to-show g `(if ,test ,conseq ,alt) t) + (all!! (!- g test bool) (!- g conseq t) (!- g alt t)))) + +(define lambda-rel + (relation (g v t body type-v) + (to-show g `(lambda (,v) ,body) `(a--> ,type-v ,t)) + (all! (!- `((,v non-generic ,type-v) . ,g) body t)))) + +(define app-rel + (relation (g t rand rator) + (to-show g `(app ,rator ,rand) t) + (_exists (t-rand) + (all!! (!- g rator `(a--> ,t-rand ,t)) (!- g rand t-rand))))) + +(define fix-rel + (relation (g rand t) + (to-show g `(fix ,rand) t) + (all! (!- g rand `(a--> ,t ,t))))) + +; Type-checking polymorphic let: (let ([,v ,rand]) ,body) +; There is obviously an inefficiency, because we typecheck `rand' +; every time the variable `v' occurs in the body (and once more). +; We can fix it, with copy term. But for now, we leave this optimization out. +; The reason to test `(!- g rand some-type)' at the very beginning is +; to make sure that `rand' itself is well-typed. As Ken pointed out, +; we must outlaw expressions such as (let ((x (z z))) y) where 'x' +; does not occur in the body. The variable 'x' still must have some +; type. + +(define polylet-rel + (relation (g v rand body t) + (to-show g `(let ((,v ,rand)) ,body) t) + (all!! + (_exists (some-type) (!- g rand some-type)) + (!- `((,v generic ,(relation (head-let t-rand) + (all!! + (!- g rand t-rand) + (trace-vars 'poly-let (t-rand rand))))) + . ,g) + body t)))) + + +(define !- + (extend-relation (a1 a2 a3) + var-rel int-rel bool-rel zero?-rel sub1-rel plus-rel + if-rel lambda-rel app-rel fix-rel polylet-rel)) + +(define (ti-tests) +(test-check 'test-!-1 + (and + (equal? + (solution (?) (!- '() '(intc 17) int)) + '((?.0 _.0))) + (equal? + (solution (?) (!- '() '(intc 17) ?)) + '((?.0 int)))) + #t) + +(test-check 'arithmetic-primitives + (solution (?) (!- '() '(zero? (intc 24)) ?)) + '((?.0 bool))) + +(test-check 'test-!-sub1 + (solution (?) (!- '() '(zero? (sub1 (intc 24))) ?)) + '((?.0 bool))) + +(test-check 'test-!-+ + (solution (?) + (!- '() '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?)) + '((?.0 bool))) + +(test-check 'test-!-2 + (and + (equal? + (solution (?) (!- '() '(zero? (intc 24)) ?)) + '((?.0 bool))) + (equal? + (solution (?) (!- '() '(zero? (+ (intc 24) (intc 50))) ?)) + '((?.0 bool))) + (equal? + (solution (?) + (!- '() '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?)) + '((?.0 bool)))) + #t) + +(test-check 'test-!-3 + (solution (?) (!- '() '(if (zero? (intc 24)) (intc 3) (intc 4)) ?)) + '((?.0 int))) + +(test-check 'if-expressions + (solution (?) + (!- '() '(if (zero? (intc 24)) (zero? (intc 3)) (zero? (intc 4))) ?)) + '((?.0 bool))) + +(test-check 'variables + (and + (equal? + (solution (?) + (env '((b non-generic int) (a non-generic bool)) 'a ?)) + '((?.0 bool))) + (equal? + (solution (?) + (!- '((a non-generic int)) '(zero? (var a)) ?)) + '((?.0 bool))) + (equal? + (solution (?) + (!- '((b non-generic bool) (a non-generic int)) + '(zero? (var a)) + ?)) + '((?.0 bool)))) + #t) + +(test-check 'variables-4a + (solution (?) + (!- '((b non-generic bool) (a non-generic int)) + '(lambda (x) (+ (var x) (intc 5))) + ?)) + '((?.0 (a--> int int)))) + +(test-check 'variables-4b + (solution (?) + (!- '((b non-generic bool) (a non-generic int)) + '(lambda (x) (+ (var x) (var a))) + ?)) + '((?.0 (a--> int int)))) + +(test-check 'variables-4c + (solution (?) + (!- '() '(lambda (a) (lambda (x) (+ (var x) (var a)))) ?)) + '((?.0 (a--> int (a--> int int))))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!- '() (parse + '(lambda (f) + (lambda (x) + ((f x) x)))) + ?)) + '((?.0 (a--> + (a--> _.0 (a--> _.0 _.1)) + (a--> _.0 _.1))))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!- '() + (parse + '((fix (lambda (sum) + (lambda (n) + (if (zero? n) + 0 + (+ n (sum (sub1 n))))))) + 10)) + ?)) + '((?.0 int))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!- '() + (parse + '((fix (lambda (sum) + (lambda (n) + (+ n (sum (sub1 n)))))) + 10)) + ?)) + '((?.0 int))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!- '() + (parse '((lambda (f) + (if (f (zero? 5)) + (+ (f 4) 8) + (+ (f 3) 7))) + (lambda (x) x))) + ?)) + #f) + +(test-check 'polymorphic-let + (solution (?) + (!- '() + (parse + '(let ((f (lambda (x) x))) + (if (f (zero? 5)) + (+ (f 4) 8) + (+ (f 3) 7)))) + ?)) + '((?.0 int))) + +(test-check 'with-robust-syntax + (solution (?) + (!- '() + '(app + (fix + (lambda (sum) + (lambda (n) + (if (if (zero? (var n)) (boolc #t) (boolc #f)) + (intc 0) + (+ (var n) (app (var sum) (sub1 (var n)))))))) + (intc 10)) + ?)) + '((?.0 int))) + +(test-check 'with-robust-syntax-but-long-jumps/poly-let + (solution (?) + (!- '() + '(let ((f (lambda (x) (var x)))) + (if (app (var f) (zero? (intc 5))) + (+ (app (var f) (intc 4)) (intc 8)) + (+ (app (var f) (intc 3)) (intc 7)))) + ?)) + '((?.0 int))) + +(test-check 'type-habitation-1 + (solution (g ?) + (!- g ? '(a--> int int))) + '((g.0 ((_.0 non-generic (a--> int int)) . _.1)) (?.0 (var _.0)))) + +(test-check 'type-habitation-2 + (solution (g h r q z y t) + (!- g `(,h ,r (,q ,z ,y)) t)) + '((g.0 ((_.0 non-generic int) . _.1)) + (h.0 +) + (r.0 (var _.0)) + (q.0 +) + (z.0 (var _.0)) + (y.0 (var _.0)) + (t.0 int)) +) + +(test-check 'type-habitation-3 + (and + (equal? + (solution (la f b) + (!- '() `(,la (,f) ,b) '(a--> int int))) + '((la.0 lambda) (f.0 _.0) (b.0 (var _.0)))) + (equal? + (solution (h r q z y t u v) + (!- '() `(,h ,r (,q ,z ,y)) `(,t ,u ,v))) + '((h.0 lambda) + (r.0 (_.0)) + (q.0 +) + (z.0 (var _.0)) + (y.0 (var _.0)) + (t.0 a-->) + (u.0 int) + (v.0 int)))) + #t) + +10) + +;---------------------------------------------------------------------- +; A different implementation of type environments +; We define a first-class (and recursive) relation !- +; so that (!- `(var ,v) t) holds iff the source term variable v has a type +; t. +; This variant is close to the `natural deduction' scheme. +; It also has an OO flavor: we need open recursion. + +; The following are the separate components of which the relation +; !- will be built. All these components nevertheless receive the full +; !- as the argument. Actually, they will receive the 'self'-like +; argument. We need to explicitly find the fixpoint. + +; (cout nl "Natural-deduction-like type inference" nl nl) + + +(define pint-rel + (lambda (s!-) + (fact (x) `(intc ,x) int))) + +(define pbool-rel + (lambda (s!-) + (fact (x) `(boolc ,x) bool))) + +(define pzero?-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (x) + (to-show `(zero? ,x) bool) + (all! (!- x int)))))) + +(define psub1-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (x) + (to-show `(sub1 ,x) int) + (all! (!- x int)))))) + +(define p+-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (x y) + (to-show `(+ ,x ,y) int) + (all!! (!- x int) (!- y int)))))) + +(define pif-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (t test conseq alt) + (to-show `(if ,test ,conseq ,alt) t) + (all!! (!- test bool) (!- conseq t) (!- alt t)))))) + +; Here we extend !- with an additional assumption that v has the type +; type-v. This extension corresponds to a non-generic, regular type. +(define plambda-rel + (lambda (s!-) + (relation (v t body type-v) + (to-show `(lambda (,v) ,body) `(a--> ,type-v ,t)) + (let* ((snew-!- + (lambda (self) + (extend-relation (v t) + (fact () `(var ,v) type-v) ; lexically-scoped relation + (s!- self)))) + (!- (snew-!- snew-!-))) + (all! (!- body t)))))) + + +(define papp-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (t rand rator) + (to-show `(app ,rator ,rand) t) + (_exists (t-rand) + (all!! (!- rator `(a--> ,t-rand ,t)) (!- rand t-rand))))))) + +(define pfix-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (rand t) + (to-show `(fix ,rand) t) + (all! (!- rand `(a--> ,t ,t))))))) + +; Type-checking polymorphic let: (let ((,v ,rand)) ,body) +; There is obviously an inefficiency, because we typecheck `rand' +; every time the variable `v' occurs in the body (and once more). +; We can fix it, with copy term. But for now, we leave this optimization out. +; The reason to test `(!- g rand some-type)' at the very beginning is +; to make sure that `rand' itself is well-typed. As Ken pointed out, +; we must outlaw expressions such as (let ((x (z z))) y) where 'x' +; does not occur in the body. The variable 'x' still must have some +; type. + +(define ppolylet-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (v rand body t) + (to-show `(let ((,v ,rand)) ,body) t) + (all!! + (_exists (some-type) (!- rand some-type)) + (let* ((snew-!- + (lambda (self) + (extend-relation (v t) + (relation (head-let `(var ,v) t-rand) + (all!! + (!- rand t-rand) + (trace-vars 'poly-let (t-rand rand)))) + (s!- self)))) + (!- (snew-!- snew-!-))) + (!- body t))))))) + +; Now we build the recursive !- relation, as a fixpoint + +(define s!- + (lambda (self) + (lambda (v t) + ((extend-relation (a1 a2) + (pint-rel self) + (pbool-rel self) (pzero?-rel self) + (psub1-rel self) (p+-rel self) + (pif-rel self) (plambda-rel self) + (papp-rel self) (pfix-rel self) + (ppolylet-rel self)) v t)))) + +(define !-/2 (s!- s!-)) + + +; And we re-do all the tests + +(define (ti-tests-2) + +(test-check 'test-!-1 + (and + (equal? + (solution (?) (!-/2 '(intc 17) int)) + '((?.0 _.0))) + (equal? + (solution (?) (!-/2 '(intc 17) ?)) + '((?.0 int)))) + #t) + +(test-check 'arithmetic-primitives + (solution (?) (!-/2 '(zero? (intc 24)) ?)) + '((?.0 bool))) + +(test-check 'test-!-sub1 + (solution (?) (!-/2 '(zero? (sub1 (intc 24))) ?)) + '((?.0 bool))) + +(test-check 'test-!-+ + (solution (?) + (!-/2 '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?)) + '((?.0 bool))) + +(test-check 'test-!-2 + (and + (equal? + (solution (?) (!-/2 '(zero? (intc 24)) ?)) + '((?.0 bool))) + (equal? + (solution (?) (!-/2 '(zero? (+ (intc 24) (intc 50))) ?)) + '((?.0 bool))) + (equal? + (solution (?) + (!-/2 '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?)) + '((?.0 bool)))) + #t) + +(test-check 'test-!-3 + (solution (?) (!-/2 '(if (zero? (intc 24)) (intc 3) (intc 4)) ?)) + '((?.0 int))) + +(test-check 'if-expressions + (solution (?) + (!-/2 '(if (zero? (intc 24)) (zero? (intc 3)) (zero? (intc 4))) ?)) + '((?.0 bool))) + +; Commented out: we need to extend !- if we wish to typecheck open terms +'(test-check 'variables + (and + (equal? + (solution (?) + (env '((b non-generic int) (a non-generic bool)) 'a ?)) + '((?.0 bool))) + (equal? + (solution (?) + (!-/2 '((a non-generic int)) '(zero? (var a)) ?)) + '((?.0 bool))) + (equal? + (solution (?) + (!-/2 '((b non-generic bool) (a non-generic int)) + '(zero? (var a)) + ?)) + '((?.0 bool)))) + #t) + +(test-check 'variables-4a + (solution (?) + (!-/2 '(lambda (x) (+ (var x) (intc 5))) + ?)) + '((?.0 (a--> int int)))) + +; Commented out: we need to extend !- if we wish to typecheck open terms +'(test-check 'variables-4b + (solution (?) + (!-/2 '((b non-generic bool) (a non-generic int)) + '(lambda (x) (+ (var x) (var a))) + ?)) + '((?.0 (a--> int int)))) + +(test-check 'variables-4c + (solution (?) + (!-/2 '(lambda (a) (lambda (x) (+ (var x) (var a)))) ?)) + '((?.0 (a--> int (a--> int int))))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!-/2 (parse + '(lambda (f) + (lambda (x) + ((f x) x)))) + ?)) + '((?.0 (a--> + (a--> _.0 (a--> _.0 _.1)) + (a--> _.0 _.1))))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!-/2 (parse + '((fix (lambda (sum) + (lambda (n) + (if (zero? n) + 0 + (+ n (sum (sub1 n))))))) + 10)) + ?)) + '((?.0 int))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!-/2 (parse + '((fix (lambda (sum) + (lambda (n) + (+ n (sum (sub1 n)))))) + 10)) + ?)) + '((?.0 int))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!-/2 (parse '((lambda (f) + (if (f (zero? 5)) + (+ (f 4) 8) + (+ (f 3) 7))) + (lambda (x) x))) + ?)) + #f) + +(test-check 'polymorphic-let + (solution (?) + (!-/2 (parse + '(let ((f (lambda (x) x))) + (if (f (zero? 5)) + (+ (f 4) 8) + (+ (f 3) 7)))) + ?)) + '((?.0 int))) + +(test-check 'with-robust-syntax + (solution (?) + (!-/2 '(app + (fix + (lambda (sum) + (lambda (n) + (if (if (zero? (var n)) (boolc #t) (boolc #f)) + (intc 0) + (+ (var n) (app (var sum) (sub1 (var n)))))))) + (intc 10)) + ?)) + '((?.0 int))) + +(test-check 'with-robust-syntax-but-long-jumps/poly-let + (solution (?) + (!-/2 '(let ((f (lambda (x) (var x)))) + (if (app (var f) (zero? (intc 5))) + (+ (app (var f) (intc 4)) (intc 8)) + (+ (app (var f) (intc 3)) (intc 7)))) + ?)) + '((?.0 int))) + +; The latter doesn't work: but it wasn't too informative anyway +'(test-check 'type-habitation-1 + (solution (?) + (!-/2 ? '(a--> int int))) + '((g.0 ((v.0 non-generic (a--> int int)) . lt.0)) (?.0 (var v.0)))) + +(test-check 'type-habitation-2 + (solution (h r q z y t) + (!-/2 `(,h ,r (,q ,z ,y)) t)) + '((h.0 +) + (r.0 (intc _.0)) + (q.0 +) + (z.0 (intc _.1)) + (y.0 (intc _.2)) + (t.0 int)) +) + +(test-check 'type-habitation-3 + (and + (equal? + (solution (la f b) + (!-/2 `(,la (,f) ,b) '(a--> int int))) + '((la.0 lambda) (f.0 _.0) (b.0 (var _.0)))) + (equal? + (solution (h r q z y t u v) + (!-/2 `(,h ,r (,q ,z ,y)) `(,t ,u ,v))) + '((h.0 lambda) + (r.0 (_.0)) + (q.0 +) + (z.0 (var _.0)) + (y.0 (var _.0)) + (t.0 a-->) + (u.0 int) + (v.0 int)))) + #t) +10) + + +; The code below uses the low-level function var? Every use of var? +; entails a proof obligation that such use is safe. In our case here, +; invertible-binary-function->ternary-relation and +; invertible-unary-function->binary-relation are sound. + +(define invertible-binary-function->ternary-relation + (lambda (op inverted-op) + (relation (head-let x y z) + (project/no-check (z) + (if-only (predicate (var? z)) + (project (x y) (== z (op x y))) ; z is free, x and y must not + (project/no-check (y) + (if-only (predicate (var? y)) ; y is free, z is not + (project (x) + (== y (inverted-op z x))) + (project/no-check (x) + (if-only (predicate (var? x)) ; x is free, y and z are not + (== x (inverted-op z y)) + (== z (op x y))))))))))) + + +(define t++ (invertible-binary-function->ternary-relation + -)) +(define t-- (invertible-binary-function->ternary-relation - +)) +(define ** (invertible-binary-function->ternary-relation * /)) +(define // (invertible-binary-function->ternary-relation / *)) + +(define symbol->lnum + (lambda (sym) + (map char->integer (string->list (symbol->string sym))))) + +(define lnum->symbol + (lambda (lnums) + (string->symbol (list->string (map integer->char lnums))))) + +(define invertible-unary-function->binary-relation + (lambda (op inverted-op) + (relation (head-let x y) + (project/no-check (y) + (if-only (predicate (var? y)) + (project (x) (== y (op x))) ; y is free, x must not + (project/no-check (x) + (if-only (predicate (var? x)) + (== x (inverted-op y)) + (== y (op x))))))))) + +(define name + (invertible-unary-function->binary-relation symbol->lnum lnum->symbol)) + +(define (ti-tests-3) +(test-check 'test-instantiated-1 + (and + (equal? + (solution (x) (t++ x 16.0 8)) + '((x.0 -8.0))) + (equal? + (solution (x) (t++ 10 16.0 x)) + '((x.0 26.0))) + (equal? + (solution (x) (t-- 10 x 3)) + '((x.0 13)))) + #t) + +(test-check 'test-instantiated-2 + (and + (equal? + (solution (x) (name 'sleep x)) + '((x.0 (115 108 101 101 112)))) + (equal? + (solution (x) (name x '(115 108 101 101 112))) + '((x.0 sleep)))) + #t) +10) + +;; ======================================================================== +;; typeclasses example +;; ======================================================================== + +;(newline) +;(display "Checking for dependency satisfaction in Haskell typeclasses") +;(newline) +; Suppose we have the following Haskell class and instance declarations +; class C a b c | a b -> c +; instance C a b c => C a (x,y,b) c +; instance C a (a,c,b) c +; +; They will be compiled into the following database of instances, +; which define the class membership. +(define typeclass-C-instance-1 + (relation (a b c x y) + (to-show a `(,x ,y ,b) c) + (typeclass-C a b c))) + +(define typeclass-C-instance-2 + (relation (a b c) + (to-show a `(,a ,c ,b) c) + succeed)) + +(define typeclass-C + (extend-relation (a b c) + typeclass-C-instance-2 + typeclass-C-instance-1)) + +; Run the checker for the dependency a b -> c +; Try to find the counter-example, that is, two members of (C a b c) +; such that a's and b's are the same but the c's are different. + + +(define typeclass-counter-example-query + (lambda (a b c1 c2) + (all + (typeclass-C a b c1) + (typeclass-C a b c2) + (fails (project/no-check (c1 c2) (predicate (*equal? c1 c2))))))) + +; This does loop +;'(define typeclass-C +; (extend-relation (a b c) +; typeclass-C-instance-1 +; typeclass-C-instance-2)) + +(define typeclass-C/x + (extend-relation-with-recur-limit 2 (a b c) + typeclass-C-instance-1 + typeclass-C-instance-2)) + +; (pntall "~%Test: checking dependency satisfaction: Another example.~%") +; Suppose we have the following Haskell class and instance declarations +; class F a b | a->b +; instance F a b => F [a] [b] +; instance F [a] a +; + +(define typeclass-F + (extend-relation-with-recur-limit 10 (a b) + (relation (a b) + (to-show `(list ,a) `(list ,b)) + (typeclass-F a b)) + (fact (a) `(list ,a) a))) + + +; Run the checker for the dependency a -> b +; Try to find the counter-example, that is, two members of (F a b) +; such that as is the same but bs are different. +(define typeclass-F-counter-example-query + (lambda (a b1 b2) + (all + (typeclass-F a b1) + (typeclass-F a b2) + (fails (project/no-check (b1 b2) (predicate (*equal? b1 b2))))))) + +; (pntall "~%Overloading resolution in Haskell.~%") +; Suppose we have the following Haskell class and instance declarations +; class F a b | a->b where f :: a->b->Bool +; instance F a b => F [a] [b] +; +; we need to typecheck +; g x = f [x] x +; which says that f:: [a] -> a -> Bool +; In general, we need to figure out which instance to choose for f. +; In other words, we need to find out which subset of F to use. +; Here's only one instance. So we need to figure out if it applies. + +(define typeclass-F-instance-1 + (relation (a b) + (to-show `(list ,a) `(list ,b)) + (typeclass-F/x a b))) + +; This is a closed-world assumption +(define typeclass-F/x + (extend-relation-with-recur-limit 10 (a b) + typeclass-F-instance-1)) + +; This is an open-world assumption +(define typeclass-F/x2 + (extend-relation-with-recur-limit 2 (a b) + typeclass-F-instance-1 + (relation (a b1 b2) ; a relation under constraint a->b + (to-show a b1) + (fails + (all! + (typeclass-F/x a b2) + (fails (project/no-check (b1 b2) (predicate (*equal? b1 b2))))))) + )) + +(define (tc-tests) + (pntall "~%Counter-example: ~s~%" + (solution (a b c1 c2) + (typeclass-counter-example-query a b c1 c2))) + + (pntall "~%Counter-example: ~s~%" + (solution (a b c1 c2) + (typeclass-counter-example-query a b c1 c2))) + + (pntall "~%Counter-example: ~s~%" + (solve 4 (a b c1 c2) + (typeclass-counter-example-query a b c1 c2))) + + (pntall "~%Counter-example: ~s~%" + (solve 4 (a b1 b2) (typeclass-F-counter-example-query a b1 b2))) + + + (test-check "Typechecking (closed world)" + (solve 4 (a) + (typeclass-F-instance-1 `(list ,a) a)) + '()) ; meaning: does not typecheck! + + + (pntall "~%Typechecking (open world): ~s~%" + (solve 4 (a) (typeclass-F-instance-1 `(list ,a) a))) + + (test-check "Typechecking (open world) f [x] int" + (solve 4 (a) (typeclass-F-instance-1 `(list ,a) 'int)) + '()) ; meaning: does not typecheck! + + 10 + ) + +;; ======================================================================== +;; zebra example +;; ======================================================================== + +; (display "Zebra") (newline) + +; 1. There are five houses in a row, each of a different color +; and inhabited by men of different nationalities, +; with different pets, drinks, and cigarettes. +; 2. The Englishman lives in the red house. +; 3. The Spaniard owns a dog. +; 4. Coffee is drunk in the green house. +; 5. The Ukrainian drinks tea. +; 6. The green house is directly to the right of the ivory house. +; 7. The Old Gold smoker owns snails. +; 8. Kools are being smoked in the yellow house. +; 9. Milk is drunk in the middle house. +; 10. The Norwegian lives in the first house on the left. +; 11. The Chesterfield smoker lives next to the fox owner. +; 12. Kools are smoked in the house next to the house where the horse is kept. +; 13. The Lucky Strike smoker drinks orange juice. +; 14. The Japanese smokes Parliaments. +; 15. The Norwegian lives next to the blue house. + +; (define memb +; (extend-relation (a1 a2) +; (fact (item) item `(,item . ,_)) +; (relation (item rest) (to-show item `(,_ . ,rest)) (memb item rest)))) + +(define memb + (relation (head-let item lst) + (any (== lst `(,item . ,__)) + (_exists (rest) + (if-only (== lst `(,__ . ,rest)) (memb item rest)))))) + + +(define next-to + (relation (head-let item1 item2 rest) + (any (on-right item1 item2 rest) (on-right item2 item1 rest)))) + +(define on-right + (extend-relation (a0 a1 a2) + (fact (item1 item2) item1 item2 `(,item1 ,item2 . ,__)) + (relation ((once item1) (once item2) rest) + (to-show item1 item2 `(,__ . ,rest)) + (on-right item1 item2 rest)))) + +(define zebra + (relation (head-let h) + (if-only + (all! + (== h `((norwegian ,__ ,__ ,__ ,__) ,__ (,__ ,__ milk ,__ ,__) ,__ ,__)) + (memb `(englishman ,__ ,__ ,__ red) h) + (on-right `(,__ ,__ ,__ ,__ ivory) `(,__ ,__ ,__ ,__ green) h) + (next-to `(norwegian ,__ ,__ ,__ ,__) `(,__ ,__ ,__ ,__ blue) h) + (memb `(,__ kools ,__ ,__ yellow) h) + (memb `(spaniard ,__ ,__ dog ,__) h) + (memb `(,__ ,__ coffee ,__ green) h) + (memb `(ukrainian ,__ tea ,__ ,__) h) + (memb `(,__ luckystrikes oj ,__ ,__) h) + (memb `(japanese parliaments ,__ ,__ ,__) h) + (memb `(,__ oldgolds ,__ snails ,__) h) + (next-to `(,__ ,__ ,__ horse ,__) `(,__ kools ,__ ,__ ,__) h) + (next-to `(,__ ,__ ,__ fox ,__) `(,__ chesterfields ,__ ,__ ,__) h) + ) + (all (memb `(,__ ,__ water ,__ ,__) h) + (memb `(,__ ,__ ,__ zebra ,__) h))))) + +;'(_pretty-print +; (time (let loop ((n 100000)) +; (cond +; ((zero? n) 'done) +; (else (solution (h) (zebra h)) +; (loop (sub1 n))))))) + +(define (zebra-test) +(test-check "Zebra" + (values (solution (h) (zebra h))) + '((h.0 ((norwegian kools water fox yellow) + (ukrainian chesterfields tea horse blue) + (englishman oldgolds milk snails red) + (spaniard luckystrikes oj dog ivory) + (japanese parliaments coffee zebra green))))) +10) + +; Sample timing (Pentium IV, 2GHz, 1GB RAM) +; (time (solution (h) ...)) +; 1 collection +; 22 ms elapsed cpu time, including 0 ms collecting +; 27 ms elapsed real time, including 0 ms collecting +; 981560 bytes allocated, including 1066208 bytes reclaimed + +; For version 3.17 of kanren (with head-let ...) +; (time (solution (h) ...)) +; 1 collection +; 19 ms elapsed cpu time, including 0 ms collecting +; 19 ms elapsed real time, including 0 ms collecting +; 788928 bytes allocated, including 1052312 bytes reclaimed +; +; For version of kanren 3.36 (with once annotations) +; This seems to be similar of SWI-Prolog, which gives 0.01 sec +; timing for the equivalent zebra code. +; (time (solution (h) ...)) +; no collections +; 11 ms elapsed cpu time +; 11 ms elapsed real time +; 532912 bytes allocated + +; For version of kanren 4.0 (increased sharing during unification) +; (time (solution (h) ...)) +; no collections +; 7 ms elapsed cpu time +; 8 ms elapsed real time +; 443792 bytes allocated +; For version of kanren 4.1 (detection of bare variables, less garbage) +; no collections +; 8 ms elapsed cpu time +; 9 ms elapsed real time +; 448920 bytes allocated +; For version of kanren 4.50 (subst sk fk order) +; no collections +; 8 ms elapsed cpu time +; 8 ms elapsed real time +; 416864 bytes allocated + +;; ======================================================================== +;; Mirror example +;; ======================================================================== + +; First we need an extendible database of relations. +; We should be able to add to the database later on -- extend +; it with assumptions. +; +; One approach for the database is a finite map (hash table, assoc +; list) from the name of a relation to the procedure that is a relation +; in our system. Or, to make it even better, from a tuple +; (name arity) to the body of the relation. +; This is the approach of Prolog. +; Suppose we have a term (foo ?a ?b ?c) where ?a, ?b and ?c are arbitrary +; terms (logical variables, constants, expressions, etc). +; We would like to check if this term is consistent with (i.e., can +; be proven by) a particular instance of the database. +; First, we need to look up a key (foo 3) in the database. If the +; lookup fails, so does our query. If the lookup succeeds, we get +; a procedure of three arguments. We apply this procedure to +; ?a, ?b, and ?c and obtain an goal, which we can 'solve' +; as usual. + +; In the following, we chose a different approach. We represent the database +; of relations as a relation itself -- we will call it KB. That +; relation takes one argument -- the term to prove, and returns an goal +; that represents the answer (that goal may be 'fail'). +; A database of one fact +; foo(a,b,c). +; in Prolog notation will be represented in our approach as a relation +; (relation _ () (to-show `(foo a b c))) +; If we want to add another relation, say +; bar(X,X). +; we need to _extend_ the above relation with +; (relation _ (x) (to-show `(bar x x))). +; +; This approach is probably less efficient than the first one. It has +; however a redeeming value -- we do not need a separate procedure +; to look up names/arities of relations. We don't need separate procedures +; for extending our database. We can use the existing machinery of +; 'solving' relations for 'solving' the database of relations. +; This approach seems reminiscent of the Futamura projections: +; we use the same engine for meta-evaluations. Bootstrapping. + +; First we define the inductive structure + +; In Athena: +; (structure (BTree S) +; (leaf S) +; (root (BTree S) (BTree S))) + +; In Prolog +; btree(leaf(S)). +; btree(root(T1,T2)) :- btree(T1),btree(T2). + +; Note, our trees here (as well as those in Prolog) are polytypic +; (polymorphic): leaves can have values of different sorts. + +; When we attempt to translate +; btree(root(T1,T2)) :- btree(T1),btree(T2). +; into our system, we encounter the first difficulty. To find out +; if a term btree(root(T1,T2)) is consistent with our database of relations, +; we need to check if terms btree(T1) and btree(T2) are consistent. +; Thus, to add btree(root(T1,T2)) to our database, we need to use +; the database itself to verify btree(T1) and btree(T2). Clearly, +; we need a fixpoint. The need for the fixpoint _exists no matter what is +; the representation of the database -- a finite map or a relation. +; Prolog solves the fixpoint problem by making the database global +; and using mutations (similar to the way letrec is implemented in Scheme). +; If we attempt to be purely functional, we must make the fixpoint explicit +; and employ Y. + +; Note, the kb variable below represents the "current" database. +; In our approach, the database is a relation of one argument, +; which is a term to prove. A Second-order relation??? + +(define btree + (lambda (kb) + (extend-relation (t) + (fact (val) `(btree (leaf ,val))) + (relation (t1 t2) + (to-show `(btree (root ,t1 ,t2))) + (project (t1 t2) + (all + (predicate (pntall "btree ~s ~s ~n" t1 t2)) + (kb `(btree ,t1)) + (kb `(btree ,t2)))))))) + +;%> (declare mirror ((S) -> ((BTree S)) (BTree S))) + +; Introduce an equality predicate and the first axiom for mirror +; In Athena: +; (define mirror-axiom-1 +; (forall ?x +; (= (mirror (leaf ?x)) (leaf ?x)))) + +; In Prolog +; myeq(leaf(X),mirror(leaf(X))). + +(define mirror-axiom-eq-1 + (lambda (kb) + (fact (val) `(myeq (leaf ,val) (mirror (leaf ,val)))))) + +; The second axiom +; In Athena: +; (define mirror-axiom-eq-2 +; (forall ?t1 ?t2 +; (= (mirror (root ?t1 ?t2)) +; (root (mirror ?t2) (mirror ?t1))))) + +; In Prolog +; myeq(root(B,A),mirror(root(T1,T2))) :- myeq(A,mirror(T1)),myeq(B,mirror(T2)). + +; implicitly the axiom in Prolog and the one below assume +; the transitivity of myeq. Indeed, one may think that the direct +; translation from Athena to Prolog would be +; +; myeq(mirror(root(T1,T2)),root(mirror(T2),mirror(T1))) +; or +; myeq(mirror(root(T1,T2)),root(B,A)) :- B = T2, A = T1. +; However, Athena actually assumes that B and T2 can be myeq rather +; than merely identical. We also switched the order of arguments +; in myeq, assuming symmetry of myeq. +; It really helped in Prolog. In our system, we could have used +; the same order as in Athena and add: +; myeq(A,A). % reflexivity: identity implies equality +; myeq(A,B) :- myeq(B,A). % symmetry +; Clearly if we add these relations to Prolog code, it will diverge. +; In our system, we can use with-depth to keep divergence in check. +; Still, for simplicity and clarity we will simply model the Prolog solution +; in our code. + +(define mirror-axiom-eq-2 + (lambda (kb) + (relation (a b t1 t2) + (to-show `(myeq (root ,b ,a) (mirror (root ,t1 ,t2)))) + (all + (kb `(myeq ,a (mirror ,t1))) + (kb `(myeq ,b (mirror ,t2))))))) + +; we could also add reflexivity and transitivity and symmetry axioms +; and with-depth to keep them from diverging. + +; Define the goal +; In Athena: +; (define (goal t) +; (= (mirror (mirror t)) t)) + +; In Prolog +; Note, the goal is _equivalent_ to the conjunction of the +; predicates. That's why we couldn't use the standard Prolog +; notation goal(T) :- btree(T), ... +; because the latter would give us only the implication. +; goal(T,[btree(T),myeq(T,mirror(T1)),myeq(T1,mirror(T))]). + +(define goal + (lambda (t) + (let-lv (t1) + (list + `(btree ,t) + `(myeq ,t (mirror ,t1)) + `(myeq ,t1 (mirror ,t)))))) + +; For clarity, the above predicate can be written as two (prolog) relations +; The forward relation: +; (goal t) is implied by (btree t), (myeq t (mirror t1)) and +; (myeq t1 (mirror t)) +; In the above, t is universally quantified and t1 is existentially +; quantified + +(define goal-fwd + (lambda (kb) + (relation (t t1) + (to-show `(goal ,t)) + (all + (kb `(btree ,t)) + (kb `(myeq ,t (mirror ,t1))) + (kb `(myeq ,t1 (mirror ,t))))))) + +; The reverse relation for the goal: +; (goal t) implies (btree t), (myeq t (mirror t1)) and +; (myeq t1 (mirror t)) +; In the above, t is universally quantified and t1 is existentially +; quantified +; Because t1 now appears on the left-hand side, it is represented +; as an eigenvariable (skolem function) rather than a logical variable + +(define goal-rev + (let* ((sk (eigen-variable 'sk)) + (t1-sk (lambda (t) `(,sk ,t)))) + (lambda (kb) + (extend-relation (t) + (relation (t) ; (goal t) => (btree t) + (to-show `(btree ,t)) + (kb `(goal ,t))) + (relation (t) ; (goal t) => (myeq t (mirror t1)) + (to-show `(myeq ,t (mirror ,(t1-sk t)))) + (kb `(goal ,t))) + (relation (t) ; (goal t) => (myeq t1 (mirror t)) + (to-show `(myeq ,(t1-sk t) (mirror ,t))) + (kb `(goal ,t))) + )))) + +; The initial assumptions: just the btree +(define init-kb (Y btree)) + +; Verification engine +; verify-goal PREDS KB +; returns a nullary relation that is the conjunction of preds against the +; assumption base kb +(define verify-goal + (lambda (preds kb) + (cond + ((null? (cdr preds)) (kb (car preds))) + (else (all + (kb (car preds)) + (verify-goal (cdr preds) kb)))))) + +; extend the kb with the list of assumptions +; this is just like 'any' only it's a procedure rather than a syntax +; Why we need universalize? +; Suppose, the list of facts includes +; (fact (x) (foo x)) and (fact (x) (bar x)) +; definitely, we do not want to imply that facts foo and bar _share_ +; the same logical variable. The facts are independent and should +; not have any variables in common. +; Furthermore, we do not want to add +; (fact (x) (foo x)) +; because that would mean exist x. foo x +; We want our facts to be universally quantified. So, we add +; (fact () (foo 'unique-symbol)) +; See the distinction between sigma and pi in Lambda-Prolog. +; We use extend-kb to extend the database with assumptions, which most +; often are universally quantified. + +(define extend-kb + (lambda (facts kb) + (let ((facts (universalize facts))) + (pntall "Extending KB with ~s~%" facts) + (let loop ((facts facts)) + (if (null? facts) kb + (extend-relation (t) + (fact () (car facts)) + (loop (cdr facts)))))))) + +; Here's Athena's induction proof. +; +; (by-induction-on ?t (goal ?t) +; ((leaf x) (!pf (goal (leaf x)) [mirror-axiom-1])) +; ((root t1 t2) +; (!pf (goal (root t1 t2)) [(goal t1) (goal t2) mirror-axiom-2]))) + +; The first part of it, the base case, can be expressed in Prolog +; as follows. +; ?- goal(leaf(X),C),verify(C,[]). +; Here how it looks in our system: +(define (mirror-tests) +(test-check "First check the base case" + (query (_ subst) + (verify-goal (goal '(leaf x)) + (extend-relation (t) (mirror-axiom-eq-1 init-kb) init-kb)) + (reify-subst '() subst)) + '((val.0 x) (t1.0 (leaf x)) (val.0 x) (val.0 x))) + +(test-check "Check the base case, using goal-fwd" + (query (_ subst) + (let ((kb0 + (extend-relation (t) (mirror-axiom-eq-1 init-kb) init-kb))) + (let ((kb1 + (extend-relation (t) (goal-fwd kb0) kb0))) + (kb1 '(goal (leaf x))))) ; note, x is an eigenvariable! + (reify-subst '() subst)) + '((val.0 x) (t1.0 (leaf x)) (val.0 x) (val.0 x) (t.0 (leaf x)))) + +; that is, we obtain the list of subgoals to verify '(leaf x) +; by invoking the function 'goal'. +; we extend the initial database (which contains btree facts) +; with mirror-axiom-eq-1. Thus, mirror-axiom-eq-1 and btree form +; the assumptions. We then verify the subgoals against the assumptions. +; Note that we wrote +; '(leaf x) +; rather than +; (let-lv (x) `(leaf ,x)) +; because we want to prove that (goal '(leaf x)) holds for _all_ x +; rather than for some particular x. +; +; non-empty result printed by the above expressions means success... + + +; The inductive case. +; Now, assume the goal holds for t1 and t2 and check if it holds +; for root(t1,t2) +;?- goal(t1,A1),goal(t2,A2), append(A1,A2,A), goal(root(t1,t2),C), verify(C,A). + +(test-check "Some preliminary checks" + (solution (foo) + (verify-goal '((btree t2)) ; (goal t2) => (btree t2) + (let ((kb0 + (extend-kb (goal 't1) + (extend-kb (goal 't2) init-kb)))) + kb0))) + '((foo.0 _.0))) + +(test-check "Some preliminary checks, using goal-rev" + (solution (foo) + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (btree kb) + (goal-rev kb) + (fact () '(goal t1)) + (fact () '(goal t2))))))) + (kb '(btree t2)))) + '((foo.0 _.0))) + +; the above two expressions should give the same result: a non-empty stream +; (with an empty substitution: no variables leak) + +(test-check "Another check" + (solution (foo) + ;(goal t1), (goal t2) => (btree (root t1 t2)) + (verify-goal '((btree t1) (btree t2) + (btree (root t1 t2))) + (let ((kb0 + (extend-kb (goal 't1) + (extend-kb (goal 't2) + (fact () 'nothing))))) + (Y + (lambda (kb) + (extend-relation (t) + kb0 + (btree kb) + (mirror-axiom-eq-2 kb))))))) + '((foo.0 _.0))) + +(test-check "Another check, using goal-rev" + (solution (foo) + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (btree kb) + (goal-rev kb) + (mirror-axiom-eq-2 kb) + (fact () '(goal t1)) + (fact () '(goal t2))))))) + (kb '(btree (root t1 t2))))) + '((foo.0 _.0))) + +; now we really need Y because we rely on the clause +; btree(root(T1,T2)) :- btree(T1),btree(T2). +; which is recursive. + +(test-check "Check the inductive case" + (query (_ subst) + (verify-goal (goal '(root t1 t2)) + (let ((kb0 + (extend-kb (goal 't1) + (extend-kb (goal 't2) + (fact () 'initial))))) + (Y + (lambda (kb) + (extend-relation (t) + kb0 + (btree kb) + (mirror-axiom-eq-2 kb)))))) + (cout (reify-subst '() subst) nl) #t) + #t) + +(pntall "~%Check particulars of the inductive case, using goal-rev, goal-fwd ~s~%" + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (btree kb) + (fact () '(goal t1)) + (fact () '(goal t2)) + (mirror-axiom-eq-2 kb) + (goal-rev kb) + ))))) + (list + (solve 1 (x) (kb `(myeq (root t1 t2) (mirror ,x)))) + (solve 1 (x) (kb `(myeq ,x (mirror (root t1 t2)))))))) + +(test-check "Check the inductive case, using goal-rev, goal-fwd" + (query (_ subst) + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (btree kb) + (fact () '(goal t1)) + (fact () '(goal t2)) + (mirror-axiom-eq-2 kb) + (goal-rev kb)))))) + (let ((kb1 (goal-fwd kb))) + (kb1 '(goal (root t1 t2))))) + (cout (reify-subst '() subst) nl) #t) + #t) + +10) + + +; Again, we use Y because btree and mirror-axiom-eq-2 are recursive. +; We need the database that is the fixpoint of all constituent +; relations. +; The output above is a non-empty list: meaning that the inductive +; phase of the proof checks. + +;; ======================================================================== +;; Mirror-equ example +;; ======================================================================== + +; See mirror.scm for preliminaries + +(define btrii + (lambda (kb) + (extend-relation (t) + (fact (val) `(btrii (leaf ,val))) + (relation (t1 t2) + (to-show `(btrii (root ,t1 ,t2))) + (all + (trace-vars 'btrii (t1 t2)) + (kb `(btrii ,t1)) + (kb `(btrii ,t2))))))) + +(define myeq-axioms + (lambda (kb) + (extend-relation (t) + (fact (val) `(myeq ,val ,val)) ; reflexivity + (relation (a b) + (to-show `(myeq ,a ,b)) ; symmetry + (all + (trace-vars 'symmetry (a b)) + (kb `(myeq ,b ,a)))) + (relation (a b) ; transitivity + (to-show `(myeq ,a ,b)) + (_exists (c) + (all + (kb `(myeq ,a ,c)) + (kb `(myeq ,c ,b))))) + ))) + +(define myeq-axioms-trees ; equational theory of trees + (lambda (kb) ; equality commutes with root + (relation (a b c d) + (to-show `(myeq (root ,a ,b) (root ,c ,d))) + (all + (trace-vars 'trees (a b)) + (kb `(myeq ,a ,c)) + (kb `(myeq ,b ,d)))))) + +; equality on leaves follows from the reflexivity of equality + +(define myeq-axioms-mirror ; equational theory of mirror + (lambda (kb) ; equality commutes with root + (extend-relation (t) + (relation (a b) + (to-show `(myeq (mirror ,a) ,b)) + (all + (trace-vars 'mirror (a b)) + (_exists (c) + (all (kb `(myeq ,b (mirror ,c))) + (kb `(myeq ,a ,c))))))))) + +; Axioms of mirror +; In Prolog +; myeq(leaf(X),mirror(leaf(X))). + +(define mirror-axiom-eq-1/x + (lambda (kb) + (fact (val) `(myeq (leaf ,val) (mirror (leaf ,val)))))) + + +; The second axiom +; In Athena: +; (define mirror-axiom-eq-2/x +; (forall ?t1 ?t2 +; (= (mirror (root ?t1 ?t2)) +; (root (mirror ?t2) (mirror ?t1))))) + +(define mirror-axiom-eq-2/x + (lambda (kb) + (relation (t1 t2) + (to-show `(myeq (mirror (root ,t1 ,t2)) (root (mirror ,t2) (mirror ,t1)))) + (trace-vars 'mirror-ax2 (t1 t2))))) + +; Define the goal +; In Athena: +; (define (goal t) +; (= (mirror (mirror t)) t)) + +(define goal/x + (lambda (t) + (list + `(btrii ,t) + `(myeq (mirror (mirror ,t)) ,t)))) + +(define goal-fwd/x + (lambda (kb) + (relation (t) + (to-show `(goal/x ,t)) + (all + (kb `(btrii ,t)) + (kb `(myeq (mirror (mirror ,t)) ,t)))))) + +(define goal-rev/x + (lambda (kb) + (extend-relation (t) + (relation (t) ; (goal t) => (btrii t) + (to-show `(btrii ,t)) + (kb `(goal/x ,t))) + (relation (t) ; (goal t) => (myeq (mirror (mirror t)) t) + (to-show `(myeq (mirror (mirror ,t)) ,t)) + (kb `(goal/x ,t)))))) + +; (by-induction-on ?t (goal ?t) +; ((leaf x) (!pf (goal (leaf x)) [mirror-axiom-1])) +; ((root t1 t2) +; (!pf (goal (root t1 t2)) [(goal t1) (goal t2) mirror-axiom-2]))) + + + +(define-syntax un@ ; uncurry + (syntax-rules () + ((_ proc arg1 ...) + (lambda (arg1 ...) (at@ proc arg1 ...))))) + +; The initial assumptions: just the btrii +;(define init-kb (Y btrii)) +; Note that in order to be effective, +; extend-relation-with-recur-limit should not be under lambda! +; We want to use the same recursion count for all +; entrances to init-kb-coll. +; Also note that the limit 5 is the number of axioms in init-kb-coll +; plus one. This count will guarantee that each axiom will be tried +; once, but not more than twice. +(define init-kb-coll + (extend-relation-with-recur-limit 5 (kb t) + (un@ btrii kb t) + (un@ myeq-axioms kb t) + (un@ myeq-axioms-mirror kb t) + (un@ myeq-axioms-trees kb t))) + +(define (mirror-equ-tests) +(test-check "First check the base case, using goal-fwd" + (query (_ subst) + (let ((kb0 + (Y (lambda (kb) + (extend-relation (t) + (mirror-axiom-eq-1/x kb) + (lambda (t) (init-kb-coll kb t))))))) + (let ((kb1 + (extend-relation (t) (goal-fwd/x kb0) kb0))) + (kb1 '(goal/x (leaf x))))) ; note, x is an eigenvariable! + ;(cout (reify-subst '() subst) nl) + #t) + #t) + +; (goal t2) => (btrii t2) +(test-check "Some preliminary checks, using goal-rev" + (query (_ subst) + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (lambda (t) (init-kb-coll kb t)) + (goal-rev/x kb) + (fact () '(goal/x t1)) + (fact () '(goal/x t2))))))) + (kb '(btrii t2))) + ;(cout (reify-subst '() subst) nl) + #t) + #t) + +(test-check "Another check, using goal-rev" + ;(goal t1), (goal t2) => (btrii (root t1 t2)) + (query (_ subst) + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (lambda (t) (init-kb-coll kb t)) + (goal-rev/x kb) + (mirror-axiom-eq-2/x kb) + (fact () '(goal/x t1)) + (fact () '(goal/x t2))))))) + (kb '(btrii (root t1 t2)))) + (cout (reify-subst '() subst) nl) + #t) + #t) + +(pntall "~%Check particulars of the inductive case, using goal-rev, goal-fwd ~s~%" + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (lambda (t) (init-kb-coll kb t)) + (fact () '(goal/x t1)) + (fact () '(goal/x t2)) + (mirror-axiom-eq-2/x kb) + (goal-rev/x kb) + ))))) + (list + ;(solve 1 (x) (kb `(myeq (root t1 t2) (mirror ,x)))) + (solve 1 (x) (kb `(myeq ,x (mirror (root t1 t2))))) + ))) + +10) + +;; ======================================================================== +;; pure bin arith example +;; ======================================================================== + +; Pure, declarative, and constructive binary arithmetics +; +; aka: Addition, Multiplication, Division with remainder +; as sound and complete, pure and declarative relations that can be +; used in any mode whatsoever and that recursively enumerate their domains. +; The relations define arithmetics over base-2 non-negative numerals +; of *arbitrary* size. +; +; aka: division as relation. +; The function divo below is a KANREN relation between four binary numerals +; n, m, q, and r such that the following holds +; _exists r. 0<=r0! +; +; We give two implementations of addition and multiplication +; relations, `++o' and `**o'. Both versions have the properties of +; soundness and nealy refutational completeness. The first version of `++o' +; is faster, but it does not always recursively enumerate its domain +; if that domain is infinite. This is the case when, e.g., (**o x y +; z) is invoked when all three x, y, and z are uninstantiated +; variables. The relation in that case has the infinite number of +; solutions, as expected. Alas, those solutions look as follows: +; x = 2, y = 3, z = 6 +; x = 4, y = 3, z = 12 +; x = 8, y = 3, z = 24 +; x = 16, y = 3, z = 48 +; That is, (**o x y z) keeps generating solutions where x is a power of +; two. Therefore, when the answerset of the relation `**o' is infinite, it +; truly produces an infinite set of solutions -- but only the subset of +; all possible solutions. In other words, `**o' does not recursively +; enumerate the set of all numbers such that x*y=z if that set is infinite. +; +; Therefore, +; (all (== x '(1 1)) (== y '(1 1)) (**o x y z)) +; (all (**o x y z) (== x '(1 1)) (== y '(1 1))) +; work differently. The former terminates and binds z to the representation +; of 9 (the product of 3 and 3). The latter fails to terminate. +; This is not generally surprising as `all', like 'commas' in Prolog, +; is not truly a conjunction: they are not commutative. Still, +; we would like our `++o' and `**o' to have the algebraic properties +; expected of addition and multiplication. +; +; The second version of `++o' and `**o' completely fixes the +; problem without losing any performance. The addition and +; multiplication relations completely enumerate their domain, even if +; it is infinite. Furthermore, ++o and **o now generate the numbers +; _in sequence_, which is quite pleasing. We achieve the +; property of recursive enumerability without giving up neither +; completeness nor refutational completeness. As before, if 'z' is +; instantiated but 'x' and 'y' are not, (++o x y z) delivers *all* +; non-negative numbers that add to z and (**o x y z) computes *all* +; factorizations of z. +; +; Such relations are easy to implement in an impure system such as Prolog, +; with the help of a predicate 'var'. The latter can tell if its argument +; is an uninstantiated variable. However, 'var' is impure. The present +; file shows the implementation of arithmetic relations in a _pure_ +; logic system. +; +; The present approach places the correct upper bounds on the +; generated numbers to make sure the search process will terminate. +; Therefore, our arithmetic relations are not only sound +; (e.g., if (**o X Y Z) holds then it is indeed X*Y=Z) but also +; complete (if X*Y=Z is true then (**o X Y Z) holds) and +; nearly refutationally complete (if X*Y=Z is false and X, Y, and Z +; are either fully instantiated, or not instantiated, then (**o X Y Z) fails, +; in finite time). The refutational completeness +; claim is limited to the case when all terms passed to arithmetical +; functions do not share variables, are either fully instantiated or not +; instantiated at all. Indeed, sharing of variables or partial +; instantiation essentially imposes the constraint: e.g., +; (solution (q) (**o `(1 . ,q) `(1 1) `(1 . ,q))) +; is tantamount to +; (solution (q) (exist (q1) +; (all (**o `(1 . ,q) `(1 1) `(1 . ,q1)) (== q q1)))) +; That conjunction will never succeed. See the corresponding Prolog +; code for justification and relation to the 10th Hilbert problem. +; +; The numerals are represented in the binary little-endian +; (least-significant bit first) notation. The higher-order bit must be 1. +; () represents 0 +; (1) represents 1 +; (0 1) represents 2 +; (1 1) represents 3 +; (0 0 1) represents 4 +; etc. +; + + +; There is a Prolog version of this code, which has termination proofs. +; +; $Id: pure-bin-arithm.scm,v 4.50 2005/02/12 00:04:49 oleg Exp $ + +; Auxiliary functions to build and show binary numerals +; +(define (build n) + (if (zero? n) '() (cons (if (even? n) 0 1) (build (quotient n 2))))) + +(define (trans n) + (if (null? n) 0 (+ (car n) (* 2 (trans (cdr n)))))) + + +; (zeroo x) holds if x is zero numeral +(define zeroo + (fact () '())) + +; Not a zero +(define pos + (fact () `(,__ . ,__))) + +; At least two +(define gt1 + (fact () `(,__ ,__ . ,__))) + +; compare the lengths of two numerals +; (
    0, or if (floor (log2 a)) < (floor (log2 b)) +; That is, we compare the length (logarithms) of two numerals +; For a positive numeral, its bitlength = (floor (log2 n)) + 1 +; We also make sure that 'n' is a well-formed number. +(define
      0 or +; length(p1) < min(length(p), length(n) + length(m) + 1) +(define = 2 +; (_exists (r1 r2) +; (all (== r `(,r1 ,r2)) +; (half-adder carry-in 1 1 r1 r2)))) +; +; ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0 +; (relation (carry-in bb br rb rr) +; (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr)) +; (all +; (pos br) (pos rr) +; (_exists (carry-out) +; (all +; (half-adder carry-in 1 bb rb carry-out) +; (full-adder carry-out '() br rr))))) +; +; ; symmetric case for the above +; (relation (head-let carry-in a '(1) r) +; (all +; (gt1 a) (gt1 r) +; (full-adder carry-in '(1) a r))) +; +; ; carry-in + (2*ar + ab) + (2*br + bb) +; ; = (carry-in + ab + bb) (mod 2) +; ; + 2*(ar + br + (carry-in + ab + bb)/2) +; ; The cases of ar= 0 or br = 0 have already been handled. +; ; So, now we require ar >0 and br>0. That implies that rr>0. +; (relation (carry-in ab ar bb br rb rr) +; (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr)) +; (all +; (pos ar) (pos br) (pos rr) +; (_exists (carry-out) +; (all +; (half-adder carry-in ab bb rb carry-out) +; (full-adder carry-out ar br rr)))) +; ))) + +; After we have checked that both summands have some bits, and so we +; can decompose them the least-significant bit and the other ones, it appears +; we only need to consider the general case, the last relation in +; the code above. +; But that is not sufficient. Let's consider +; (full-adder 0 (1 . ()) (1 0 . ()) (0 1 . ())) +; It would then hold. But it shouldn't, because (1 0 . ()) is a bad +; number (with the most-significant bit 0). One can say why we should +; care about user supplying bad numbers. But we do: we don't know which +; arguments of full-adder are definite numbers and which are +; uninstantiated variables. We don't know which are the input and which +; are the output. So, if we keep only the last relation for the +; case of positive summands, and try to +; (_exists (x) (full-adder 0 (1 . ()) x (0 1 . ()))) +; we will see x bound to (1 0) -- an invalid number. So, our adder, when +; asked to subtract numbers, gave a bad number. And it would give us +; a bad number in all the cases when we use it to subtract numbers and +; the result has fewer bits than the number to subtract from. +; +; To guard against such a behavior (i.e., to transparently normalize +; the numbers when the full-adder is used in the ``subtraction'' mode) +; we have to specifically distinguish cases of +; "bit0 + 2*bit_others" where bit_others>0, and the +; terminal case "1" (that is, the most significant bit 1 and no other +; bits). +; The various (pos ...) conditions in the code are to guarantee that all +; cases are disjoin. At any time, only one case can match. Incidentally, +; the lack of overlap guarantees the optimality of the code. + + +; The full-adder above is not recursively enumerating however. +; Indeed, (solve 10 (x y z) (full-adder '0 x y z)) +; gives solutions with x = 1. +; We now convert the adder into a recursively enumerable form. +; We lose some performance however (but see below!) +; +; The general principles are: +; Convert the relation into a disjunctive normal form, that is +; (any (all a b c) (all c d e) ...) +; and then replace the single, top-level any with any-interleave. +; The conversion may be too invasive. We, therefore, use an effective +; conversion: if we have a relation +; (all (any a b) (any c d)) +; then rather than re-writing it into +; (any (all a c) (all a d) (all b c) (all b d)) +; to push disjunctions out and conjunctions in, we do +; (all gen (all (any a b) (any c d))) +; where gen is a relation whose answer set is precisely such +; that each answer in gen makes (all (any a b) (any c d)) +; semi-deterministic. That is, with the generator gen, we +; make all the further choices determined. +; +; In the code below we use a different kind of generator, whose full +; justification (with proofs) appears in the Prolog version of the code. +; Please see the predicate `enum' in that Prolog code. +; +; The price to pay is slow-down. +; Note, if we had all-interleave, then we would generally have +; breadth-first search and so the changes to the recursively enumerable +; version would be minimal and without loss of speed. + +; The following full-adder* is almost the same as full-adder above. +; +; (define full-adder* +; (extend-relation (carry-in a b r) +; ; (fact (a) 0 a '() a) ; 0 + a + 0 = a +; ; (relation (b) ; 0 + 0 + b = b +; ; (to-show 0 '() b b) +; ; (pos b)) +; ; (relation (head-let '1 a '() r) ; 1 + a + 0 = 0 + a + 1 +; ; (full-adder 0 a '(1) r)) +; ; (relation (head-let '1 '() b r) ; 1 + 0 + b = 0 + 1 + b +; ; (all (pos b) +; ; (full-adder 0 '(1) b r))) +; +; ; The following three relations are needed +; ; to make all numbers well-formed by construction, +; ; that is, to make sure the higher-order bit is one. +; (relation (head-let carry-in '(1) '(1) r) ; c + 1 + 1 >= 2 +; (_exists (r1 r2) +; (all (== r `(,r1 ,r2)) +; (half-adder carry-in 1 1 r1 r2)))) +; +; ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0 +; (relation (carry-in bb br rb rr) +; (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr)) +; (all +; (pos br) (pos rr) +; (_exists (carry-out) +; (all +; (half-adder carry-in 1 bb rb carry-out) +; (full-adder carry-out '() br rr))))) +; +; ; symmetric case for the above +; (relation (head-let carry-in a '(1) r) +; (all +; (gt1 a) (gt1 r) +; (full-adder* carry-in '(1) a r))) +; +; ; carry-in + (2*ar + ab) + (2*br + bb) +; ; = (carry-in + ab + bb) (mod 2) +; ; + 2*(ar + br + (carry-in + ab + bb)/2) +; ; The cases of ar= 0 or br = 0 have already been handled. +; ; So, now we require ar >0 and br>0. That implies that rr>0. +; (relation (carry-in ab ar bb br rb rr) +; (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr)) +; (all +; (pos ar) (pos br) (pos rr) +; (_exists (carry-out) +; (all +; (half-adder carry-in ab bb rb carry-out) +; (full-adder* carry-out ar br rr)))) +; ))) + +; This driver handles the trivial cases and then invokes full-adder* +; coupled with the recursively enumerating generator. + +; (define full-adder +; (extend-relation (carry-in a b r) +; (fact (a) 0 a '() a) ; 0 + a + 0 = a +; (relation (b) ; 0 + 0 + b = b +; (to-show 0 '() b b) +; (pos b)) +; (relation (head-let '1 a '() r) ; 1 + a + 0 = 0 + a + 1 +; (full-adder 0 a '(1) r)) +; (relation (head-let '1 '() b r) ; 1 + 0 + b = 0 + 1 + b +; (all (pos b) +; (full-adder 0 '(1) b r))) +; (relation (head-let carry-in a b r) +; (any-interleave +; ; Note that we take advantage of the fact that if +; ; a + b = r and length(b) <= length(a) then length(a) <= length(r) +; (all (
        = 2 + (_exists (r1 r2) + (all (== r `(,r1 ,r2)) + (half-adder carry-in 1 1 r1 r2)))) + + ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0 + (relation (carry-in bb br rb rr) + (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr)) + (all + (pos br) (pos rr) + (_exists (carry-out) + (all-interleave + (half-adder carry-in 1 bb rb carry-out) + (full-adder carry-out '() br rr))))) + + ; symmetric case for the above + (relation (head-let carry-in a '(1) r) + (all + (gt1 a) (gt1 r) + (full-adder carry-in '(1) a r))) + + ; carry-in + (2*ar + ab) + (2*br + bb) + ; = (carry-in + ab + bb) (mod 2) + ; + 2*(ar + br + (carry-in + ab + bb)/2) + ; The cases of ar= 0 or br = 0 have already been handled. + ; So, now we require ar >0 and br>0. That implies that rr>0. + (relation (carry-in ab ar bb br rb rr) + (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr)) + (all + (pos ar) (pos br) (pos rr) + (_exists (carry-out) + (all-interleave + (half-adder carry-in ab bb rb carry-out) + (full-adder carry-out ar br rr)))) + ))) + +; a + b = c +(define a++o + (relation (head-let a b c) + (full-adder 0 a b c))) + +; a - b = c +(define a--o + (lambda (x y out) + (a++o y out x))) + + +;(define 0 such that n + x = m +; (relation (head-let n m) +; (_exists (x) (all (pos x) (a++o n x m))))) + +; The following is an optimization: it is easier to test for the +; length of two numbers. If one number has fewer bits than the other number, +; the former is clearly shorter (provided that the numbers are well-formed, +; that is, the higher-order bit is one). So we don't need to go through +; the trouble of subtracting them. +(define 0 such that n + x = m + (relation (head-let n m) + (any-interleave + (
          1 + + ; (2*nr) * m = 2*(nr*m), m>0 (the case of m=0 is taken care of already) + ; nr > 0, otherwise the number is ill-formed + (_exists (nr pr) + (all + (gt1 m) + (== n `(0 . ,nr)) + (== p `(0 . ,pr)) + (pos nr) (pos pr) + (**o nr m pr))) + + ; The symmetric case to the above: m is even, n is odd + (_exists (mr pr) + (all + (== n `(1 ,__ . ,__)) ; n is odd and n > 1 + (== m `(0 . ,mr)) + (== p `(0 . ,pr)) + (pos mr) (pos pr) + (**o n mr pr))) + + ; (2*nr+1) * m = 2*(n*m) + m + ; m > 0; also nr>0 for well-formedness + ; the result is certainly greater than 1. + ; we note that m > 0 and so 2*(nr*m) < 2*(nr*m) + m + ; and (floor (log2 (nr*m))) < (floor (log2 (2*(nr*m) + m))) + (_exists (nr p1) + (all + (== m `(1 ,__ . ,__)) ; m is odd and n > 1 + (== n `(1 . ,nr)) + (pos nr) (gt1 p) + (0, so q*m <= n, +; (_exists (p) ; definitely q*m < 2*n +; (all ( (n - r) is even and (n-r)/2 = m*q +; ; (_exists (p m1) +; ; (all (== m `(0 . ,m1)) +; ; (== m1 `(__, . ,__)) +; ; (**o m1 q p) +; ; (a--o n r `(0 . ,p)))) +; + +; A faster and more refutationally complete divo algorithm +; Again, divo n m q r +; holds iff n = m*q + r +; Let l be the bit-length of r (if r=0, l=0). +; Let n = 2^(l+1) * n1 + n2 +; q = 2^(l+1) * q1 + q2 +; Note that n1 or q1 may be zero. +; We obtain that +; n = m*q + r +; is equivalent to the conjunction of the following two relations +; q2*m + r - n2 is divisible by 2^(l+1) +; n1 = q1*m + (q2*m + r - n2)/2^(l+1) +; We note that by construction (see the mentioning of (
            0) and q2*m + r = n2. The latter can be solved in finite +; time. +; We also note that (q2*m + r - n2)/2^(l+1) < m +; because r - n2 < (2^(l+1) - q2)* m +; because 2^(l+1) - q2 >=1 and m > r by construction. Therefore, to +; solve the relation n1 = q1*m + (q2*m + r - n2)/2^(l+1) we use +; divo itself: (divo n1 m q1 (q2*m + r - n2)/2^(l+1)) +; Thus our division algorithm is recursive. On each stage we determine at +; least one bit of the quotient (if r=0, l=0 and q2 is either 0 or 1), +; in finite time. + +(define divo + (relation (head-let n m q r) + (any-interleave + ; m has more digits than n: q=0,n=r + (all (== r n) (== q '()) (= b^q, n < b^(q+1) = b^q * b = (n-r)* b +; r*b < n*(b-1) +; +; We can also obtain the bounds on q: +; if |b| is the bitwidth of b and |n| is the bitwidth of n, +; we have, by the definition of the bitwidth: +; (1) 2^(|b|-1) <= b < 2^|b| +; (2) 2^(|n|-1) <= n < 2^|n| +; Raising (1) to the power of q: +; 2^((|b|-1)*q) <= b^q +; OTH, b^q <= n, and n < 2^|n|. So we obtain +; (3) (|b|-1)*q < |n| +; which defines the upper bound on |q|. +; OTH, raising (1) to the power of (q+1): +; b^(q+1) < 2^(|b|*(q+1)) +; But n < b^(q+1) by definition of exponentiation, and keeping in mind (1) +; (4) |n|-1 < |b|*(q+1) +; which is the lower bound on q. + +; When b = 2, exponentiation and discrete logarithm are easier to obtain +; n = 2^q + r, 0<= 2*r < n +; Here, we just relate n and q. +; exp2 n b q +; holds if: n = (|b|+1)^q + r, q is the largest such number, and +; (|b|+1) is a power of two. +; Side condition: (|b|+1) is a power of two and b is L-instantiated. +; To obtain the binary exp/log relation, invoke the relation as +; (exp2 n '() q) +; Properties: if n is L-instantiated, one answer, q is fully instantiated. +; If q is fully instantiated: one answer, n is L-instantiated. +; In any event, q is always fully instantiated in any answer +; and n is L-instantiated. +; We depend on the properties of split. + +(define exp2 + (letrec + ((r-append ; relational append + (extend-relation (a b c) + (fact (b) '() b b) + (relation (ah ar b cr) (to-show `(,ah . ,ar) b `(,ah . ,cr)) + (r-append ar b cr))))) + (relation (head-let n b q) + (any-interleave + (all (== n '(1)) (== q '())) ; 1 = b^0 + (all (gt1 n) (== q '(1)) (split n b '(1) __)) + (_exists (q1 b2) ; n = (2^k)^(2*q) + r + (all-interleave ; = (2^(2*k))^q + r + (== q `(0 . ,q1)) + (pos q1) + (
              0 + (all (== q '()) (0 + (all (== b '()) (pos q) (== r n)) ; n = 0^q + n, q>0 + ; in the rest, n is longer than b + (all (== b '(0 1)) ; b = 2 + (_exists (n1) + (all + (pos n1) + (== n `(,__ ,__ . ,n1)) ; n is at least 4 + (exp2 n '() q) ; that will L-instantiate n and n1 + (split n n1 __ r)))) + ; the general case + (all + (any (== b '(1 1)) (== b `(,__ ,__ ,__ . ,__))) ; b >= 3 + (
                0! + ((x.0 (0 _.0 . _.1)) (y.0 (1 _.0 . _.1))) + ((x.0 (1 1)) (y.0 (0 0 1))) + ((x.0 (1 0 _.0 . _.1)) (y.0 (0 1 _.0 . _.1)))) +) + +; check that add(X,Y,Z) recursively enumerates all +; numbers such as X+Y=Z +; +(cout "Test recursive enumerability of addition" nl) +(let ((n 7)) + (do ((i 0 (+ 1 i))) ((> i n)) + (do ((j 0 (+ 1 j))) ((> j n)) + (let ((p (+ i j))) + (test-check + (string-append "enumerability: " (number->string i) + "+" (number->string j) "=" (number->string p)) + (solve 1 (x y z) + (all (a++o x y z) + (== x (build i)) (== y (build j)) (== z (build p)))) + `(((x.0 ,(build i)) (y.0 ,(build j)) + (z.0 ,(build p))))))))) + +(test-check "strong commutativity" + (solve 5 (a b c) + (all (a++o a b c) + (_exists (x y z) + (all! + (a++o x y z) + (== x b) + (== y a) + (== z c) + )))) + '(((a.0 ()) (b.0 ()) (c.0 ())) + ((a.0 ()) (b.0 (_.0 . _.1)) (c.0 (_.0 . _.1))) + ((a.0 (1)) (b.0 (1)) (c.0 (0 1))) + ((a.0 (1)) (b.0 (0 _.0 . _.1)) (c.0 (1 _.0 . _.1))) + ((a.0 (0 _.0 . _.1)) (b.0 (1)) (c.0 (1 _.0 . _.1)))) +) + + +(cout nl "subtraction" nl) +(test (x) (a--o (build 29) (build 3) x)) +(test (x) (a--o (build 29) x (build 3))) +(test (x) (a--o x (build 3) (build 26))) +(test (x) (a--o (build 29) (build 29) x)) +(test (x) (a--o (build 29) (build 30) x)) +(test-check "print a few numbers such as Y - Z = 4" + (solve 11 (y z) (a--o y z (build 4))) + '(((y.0 (0 0 1)) (z.0 ())) ; 4 - 0 = 4 + ((y.0 (1 0 1)) (z.0 (1))) ; 5 - 1 = 4 + ((y.0 (0 1 1)) (z.0 (0 1))) ; 6 - 2 = 4 + ((y.0 (1 1 1)) (z.0 (1 1))) ; 7 - 3 = 4 + ((y.0 (0 0 0 1)) (z.0 (0 0 1))) ; 8 - 4 = 4 + ((y.0 (1 0 0 1)) (z.0 (1 0 1))) ; 9 - 5 = 4 + ((y.0 (0 1 0 1)) (z.0 (0 1 1))) ; 10 - 6 = 4 + ((y.0 (1 1 0 1)) (z.0 (1 1 1))) ; 11 - 7 = 4 + ; 8*k + 4 - 8*k = 4 forall k> 0!! + ((y.0 (0 0 1 _.0 . _.1)) (z.0 (0 0 0 _.0 . _.1))) + ((y.0 (1 0 1 _.0 . _.1)) (z.0 (1 0 0 _.0 . _.1))) + ((y.0 (0 1 1 _.0 . _.1)) (z.0 (0 1 0 _.0 . _.1)))) +) + +(test-check "print a few numbers such as X - Y = Z" + (solve 5 (x y z) (a--o x y z)) + '(((x.0 _.0) (y.0 _.0) (z.0 ())) ; 0 - 0 = 0 + ((x.0 (_.0 . _.1)) (y.0 ()) (z.0 (_.0 . _.1))) ; a - 0 = a + ((x.0 (0 1)) (y.0 (1)) (z.0 (1))) + ((x.0 (1 _.0 . _.1)) (y.0 (1)) (z.0 (0 _.0 . _.1))) + ((x.0 (1 _.0 . _.1)) (y.0 (0 _.0 . _.1)) (z.0 (1)))) +) + + +(cout nl "comparisons" nl) +(test (x) ( 0 + ; 1 * y = y for y > 0 + ((x.0 (1)) (y.0 (_.0 . _.1)) (z.0 (_.0 . _.1))) + ((x.0 (_.0 _.1 . _.2)) (y.0 (1)) + (z.0 (_.0 _.1 . _.2))) ; x * 1 = x, x > 1 + ; 2 * y = even positive number, for y > 1 + ((x.0 (0 1)) (y.0 (_.0 _.1 . _.2)) + (z.0 (0 _.0 _.1 . _.2))) + ; x * 2 = shifted-left x, for even x>1 + ((x.0 (1 _.0 . _.1)) (y.0 (0 1)) (z.0 (0 1 _.0 . _.1))) + ; 3 * 3 = 9 + ((x.0 (1 1)) (y.0 (1 1)) (z.0 (1 0 0 1))) + ) +) + +(test-check 'multiplication-even-1 + (solve 10 (y z) (**o (build 2) y z)) + '(((y.0 ()) (z.0 ())) + ((y.0 (1)) (z.0 (0 1))) ; 2 * 1 = 2 + ; 2*y is an even number, for any y > 1! + ((y.0 (_.0 _.1 . _.2)) (z.0 (0 _.0 _.1 . _.2))) + ) +) + +(test-check 'multiplication-even-2 + ; multiplication by an even number cannot yield an odd number + (solution (q x y u v) (**o '(1 1) `(0 0 1 ,x . ,y) `(1 0 0 ,u . ,v))) + #f +) + +(test-check 'multiplication-even-3 + ; multiplication by an even number cannot yield an odd number + (solution (q x y z) (**o `(0 0 1 . ,y) `(1 . ,x) `(1 0 . ,z))) + #f +) + +; check that mul(X,Y,Z) recursively enumerates all +; numbers such as X*Y=Z +; +(cout "Test recursive enumerability of multiplication" nl) +(let ((n 7)) + (do ((i 0 (+ 1 i))) ((> i n)) + (do ((j 0 (+ 1 j))) ((> j n)) + (let ((p (* i j))) + (test-check + (string-append "enumerability: " (number->string i) + "*" (number->string j) "=" (number->string p)) + (solve 1 (x y z) + (all (**o x y z) + (== x (build i)) (== y (build j)) (== z (build p)))) + `(((x.0 ,(build i)) (y.0 ,(build j)) + (z.0 ,(build p))))))))) + +(cout nl "split" nl) + +(test-check 'split-1 + (solve 5 (x y) (split (build 4) '() x y)) + '(((x.0 (0 1)) (y.0 ())))) +(test-check 'split-2 + (solve 5 (x y) (split (build 4) '(1) x y)) + '(((x.0 (1)) (y.0 ())))) +(test-check 'split-3 + (solve 5 (x y) (split (build 4) '(1 1) x y)) + '(((x.0 ()) (y.0 (0 0 1))))) +(test-check 'split-4 + (solve 5 (x y) (split (build 4) '(1 1 1) x y)) + '(((x.0 ()) (y.0 (0 0 1))))) +(test-check 'split-5 + (solve 5 (x y) (split (build 5) '(1) x y)) + '(((x.0 (1)) (y.0 (1))))) +(test-check 'split-6 + (solve 5 (n) (split n (build 5) '() '(1))) + '(((n.0 (1))))) + +(cout nl "division, general" nl) + + +(test-check 'divo-1 + (solution (x) (divo (build 4) (build 2) x __)) + '((x.0 (0 1)))) +(test-check 'div-fail-1 (test (x) (divo (build 4) (build 0) x __)) '()) +(test-check 'divo-2 + (solution (x) (divo (build 4) (build 3) x __)) + '((x.0 (1)))) +(test-check 'divo-3 + (solution (x) (divo (build 4) (build 4) x __)) + '((x.0 (1)))) +(test-check 'divo-4 + (solution (x y) (divo (build 4) (build 5) x y)) + '((x.0 ()) (y.0 (0 0 1)))) + + +(test-check 'divo-33-1 + (solution (x) (divo (build 33) (build 3) x __)) + `((x.0 ,(build 11)))) +(test-check 'divo-33-2 + (solution (x) (divo (build 33) x (build 11) __)) + `((x.0 ,(build 3)))) +(test-check 'divo-33-3 + (solution (x) (divo x (build 3) (build 11) __)) + `((x.0 ,(build 33)))) +(test-check 'divo-33-5 + (solution (x y) (divo (build 33) (build 5) x y)) + `((x.0 ,(build 6)) (y.0 ,(build 3)))) + + +(test-check 'divo-5-4 + (solve 3 (x y) (divo x (build 5) y (build 4))) + '(((x.0 (0 0 1)) (y.0 ())) + ((x.0 (0 0 0 0 0 0 1)) (y.0 (0 0 1 1))) + ((x.0 (1 0 0 0 1 1)) (y.0 (1 0 0 1)))) +) +(test-check 'divo-5-5 + (solve 3 (x y) (divo x (build 5) y (build 5))) + '()) + + +(test (x) (divo x (build 5) __ (build 4))) +(test (x) (divo x (build 5) (build 3) (build 4))) +(test (x) (divo x __ (build 3) (build 4))) +(test-check 'div-fail-2 (test (x) (divo (build 5) x (build 7) __)) '()) + +(test-check "all numbers such as 5/Z = 1" + (solve 7 (w) + (_exists (z) (all (divo (build 5) z (build 1) __) + (project (z) (== `(,(trans z)) w))))) + '(((w.0 (5))) ((w.0 (3))) ((w.0 (4))))) + +(test-check "all inexact factorizations of 12" + (set-equal? + (solve 100 (w) + (_exists (m q r n) + (all + (== n (build 12)) + (0 + ((x.0 (1)) (y.0 (1)) (z.0 (1)) (r.0 ())) ; 1 = 1*1 + 0 + ((x.0 (0 1)) (y.0 (1)) (z.0 (0 1)) (r.0 ())) ; 2 = 1*2 + 0 + ((x.0 (0 1)) (y.0 (1 1)) (z.0 ()) (r.0 (0 1))) ; 2 = 3*0 + 2 +)) + +(test-check 'div-even + (solve 3 (y z r) (divo `(0 . ,y) (build 2) z r)) + '(((y.0 (1)) (z.0 (1)) (r.0 ())) + ((y.0 (0 1)) (z.0 (0 1)) (r.0 ())) + ((y.0 (1 1)) (z.0 (1 1)) (r.0 ()))) +) + +(test-check 'div-even-fail + (solve 3 (y z r) (divo `(0 . ,y) (build 2) z '(1))) + '() +) + +(test-check 'div-odd + (solve 3 (y z) (divo `(1 0 . ,y) (build 2) z '(1))) + '(((y.0 (0 1)) (z.0 (0 0 1))) ; 9 = 2*4 + 1 + ((y.0 (1)) (z.0 (0 1))) ; 5 = 2*2 + 1 + ((y.0 (0 0 1)) (z.0 (0 0 0 1)))) ; 17 = 8*2 + 1 +) + +(test-check 'div-odd-fail + (solve 3 (y z r) (divo `(1 0 . ,y) (build 2) z '())) + '() +) + +(test-check 'div-enum-sample + (solve 1 (n m q r) + (all (divo n m q r) + (== n (build 10)) (== m (build 2)) (== q (build 5)) + (== r '()))) + '(((n.0 (0 1 0 1)) (m.0 (0 1)) (q.0 (1 0 1)) (r.0 ()))) +) + +; the latter takes awfully long time +'(test-check 'div-enum-sample-1 + (solve 1 (n m q r) + (all (divo n m q r) + (== n (build 10)) (== m (build 3)) (== q (build 3)) + (== r '(1)))) + '(((n.0 (1 1 1)) (m.0 (0 1)) (q.0 (1 1)) (r.0 (1)))) +) + +; check that divo(N,M,Q,R) recursively enumerates all +; numbers such as N=M*Q+R, R m n)) + (do ((q 0 (+ 1 q))) ((> q n)) + (do ((r 0 (+ 1 r))) ((>= r m)) + (let ((n (+ (* m q) r))) + (test-check + (string-append "enumerability: " (number->string n) + "=" (number->string m) "*" (number->string q) + "+" (number->string r)) + (solve 1 (n1 m1 q1 r1) + (all (divo n1 m1 q1 r1) + (== n1 (build n)) (== m1 (build m)) + (== q1 (build q)) (== r1 (build r)) + )) + `(((n1.0 ,(build n)) (m1.0 ,(build m)) + (q1.0 ,(build q)) (r1.0 ,(build r)))))))))) + + +; quite dubious tests. The problem is actually in =ol and
                  elements car) + +(define lattice->cmp cdr) + +; Select elements of a list which pass some test. +(define zulu-select + (lambda (test lst) + (define select-a + (lambda (ac lst) + (if (null? lst) + (reverse! ac) + (select-a + (let ((head (car lst))) + (if (test head) + (cons head ac) + ac)) + (cdr lst))))) + (select-a '() lst))) + +(define reverse! + (letrec ((rotate + (lambda (fo fum) + (let ((next (cdr fo))) + (set-cdr! fo fum) + (if (null? next) + fo + (rotate next fo)))))) + (lambda (lst) + (if (null? lst) + '() + (rotate lst '()))))) + +; Select elements of a list which pass some test and map a function +; over the result. Note, only efficiency prevents this from being the +; composition of select and map. +(define select-map + (lambda (test func lst) + (define select-a + (lambda (ac lst) + (if (null? lst) + (reverse! ac) + (select-a + (let ((head (car lst))) + (if (test head) + (cons (func head) + ac) + ac)) + (cdr lst))))) + (select-a '() lst))) + + + +; This version of map-and tail-recurses on the last test. +(define map-and + (lambda (proc lst) + (if (null? lst) + #t + (letrec ((drudge + (lambda (lst) + (let ((rest (cdr lst))) + (if (null? rest) + (proc (car lst)) + (and (proc (car lst)) + (drudge rest))))))) + (drudge lst))))) + +(define (maps-1 source target pas new) + (let ((scmp (lattice->cmp source)) + (tcmp (lattice->cmp target))) + (let ((less + (select-map + (lambda (p) + (eq? 'less + (scmp (car p) new))) + cdr + pas)) + (more + (select-map + (lambda (p) + (eq? 'more + (scmp (car p) new))) + cdr + pas))) + (zulu-select + (lambda (t) + (and + (map-and + (lambda (t2) + (memq (tcmp t2 t) '(less equal))) + less) + (map-and + (lambda (t2) + (memq (tcmp t2 t) '(more equal))) + more))) + (lattice->elements target))))) + +(define (maps-rest source target pas rest to-1 to-collect) + (if (null? rest) + (to-1 pas) + (let ((next (car rest)) + (rest (cdr rest))) + (to-collect + (map + (lambda (x) + (maps-rest source target + (cons + (cons next x) + pas) + rest + to-1 + to-collect)) + (maps-1 source target pas next)))))) + +(define (maps source target) + (make-lattice + (maps-rest source + target + '() + (lattice->elements source) + (lambda (x) (list (map cdr x))) + (lambda (x) (apply append x))) + (lexico (lattice->cmp target)))) + +(define (count-maps source target) + (maps-rest source + target + '() + (lattice->elements source) + (lambda (x) 1) + sum)) + +(define (sum lst) + (if (null? lst) + 0 + (+ (car lst) (sum (cdr lst))))) + +(define (run) + (let* ((l2 + (make-lattice '(low high) + (lambda (lhs rhs) + (case lhs + ((low) + (case rhs + ((low) + 'equal) + ((high) + 'less) + (else + (error 'make-lattice "base" rhs)))) + ((high) + (case rhs + ((low) + 'more) + ((high) + 'equal) + (else + (error 'make-lattice "base" rhs)))) + (else + (error 'make-lattice "base" lhs)))))) + (l3 (maps l2 l2)) + (l4 (maps l3 l3))) + (count-maps l2 l2) + (count-maps l3 l3) + (count-maps l2 l3) + (count-maps l3 l2) + (count-maps l4 l4))) + +(time (run)) diff --git a/benchmarks/gabriel/lattice2.sch b/benchmarks/gabriel/lattice2.sch new file mode 100644 index 00000000..482ed678 --- /dev/null +++ b/benchmarks/gabriel/lattice2.sch @@ -0,0 +1,205 @@ +;; Like "lattice.sch", but uses `reverse' instead of +;; defining `reverse!' (to avoid `set-cdr!') + +;;; LATTICE -- Obtained from Andrew Wright. + +; Given a comparison routine that returns one of +; less +; more +; equal +; uncomparable +; return a new comparison routine that applies to sequences. +(define lexico + (lambda (base) + (define lex-fixed + (lambda (fixed lhs rhs) + (define check + (lambda (lhs rhs) + (if (null? lhs) + fixed + (let ((probe + (base (car lhs) + (car rhs)))) + (if (or (eq? probe 'equal) + (eq? probe fixed)) + (check (cdr lhs) + (cdr rhs)) + 'uncomparable))))) + (check lhs rhs))) + (define lex-first + (lambda (lhs rhs) + (if (null? lhs) + 'equal + (let ((probe + (base (car lhs) + (car rhs)))) + (case probe + ((less more) + (lex-fixed probe + (cdr lhs) + (cdr rhs))) + ((equal) + (lex-first (cdr lhs) + (cdr rhs))) + ((uncomparable) + 'uncomparable)))))) + lex-first)) + +(define (make-lattice elem-list cmp-func) + (cons elem-list cmp-func)) + +(define lattice->elements car) + +(define lattice->cmp cdr) + +; Select elements of a list which pass some test. +(define zulu-select + (lambda (test lst) + (define select-a + (lambda (ac lst) + (if (null? lst) + (reverse ac) + (select-a + (let ((head (car lst))) + (if (test head) + (cons head ac) + ac)) + (cdr lst))))) + (select-a '() lst))) + +; Select elements of a list which pass some test and map a function +; over the result. Note, only efficiency prevents this from being the +; composition of select and map. +(define select-map + (lambda (test func lst) + (define select-a + (lambda (ac lst) + (if (null? lst) + (reverse ac) + (select-a + (let ((head (car lst))) + (if (test head) + (cons (func head) + ac) + ac)) + (cdr lst))))) + (select-a '() lst))) + + + +; This version of map-and tail-recurses on the last test. +(define map-and + (lambda (proc lst) + (if (null? lst) + #t + (letrec ((drudge + (lambda (lst) + (let ((rest (cdr lst))) + (if (null? rest) + (proc (car lst)) + (and (proc (car lst)) + (drudge rest))))))) + (drudge lst))))) + +(define (maps-1 source target pas new) + (let ((scmp (lattice->cmp source)) + (tcmp (lattice->cmp target))) + (let ((less + (select-map + (lambda (p) + (eq? 'less + (scmp (car p) new))) + cdr + pas)) + (more + (select-map + (lambda (p) + (eq? 'more + (scmp (car p) new))) + cdr + pas))) + (zulu-select + (lambda (t) + (and + (map-and + (lambda (t2) + (memq (tcmp t2 t) '(less equal))) + less) + (map-and + (lambda (t2) + (memq (tcmp t2 t) '(more equal))) + more))) + (lattice->elements target))))) + +(define (maps-rest source target pas rest to-1 to-collect) + (if (null? rest) + (to-1 pas) + (let ((next (car rest)) + (rest (cdr rest))) + (to-collect + (map + (lambda (x) + (maps-rest source target + (cons + (cons next x) + pas) + rest + to-1 + to-collect)) + (maps-1 source target pas next)))))) + +(define (maps source target) + (make-lattice + (maps-rest source + target + '() + (lattice->elements source) + (lambda (x) (list (map cdr x))) + (lambda (x) (apply append x))) + (lexico (lattice->cmp target)))) + +(define (count-maps source target) + (maps-rest source + target + '() + (lattice->elements source) + (lambda (x) 1) + sum)) + +(define (sum lst) + (if (null? lst) + 0 + (+ (car lst) (sum (cdr lst))))) + +(define (run) + (let* ((l2 + (make-lattice '(low high) + (lambda (lhs rhs) + (case lhs + ((low) + (case rhs + ((low) + 'equal) + ((high) + 'less) + (else + (error 'make-lattice "base" rhs)))) + ((high) + (case rhs + ((low) + 'more) + ((high) + 'equal) + (else + (error 'make-lattice "base" rhs)))) + (else + (error 'make-lattice "base" lhs)))))) + (l3 (maps l2 l2)) + (l4 (maps l3 l3))) + (count-maps l2 l2) + (count-maps l3 l3) + (count-maps l2 l3) + (count-maps l3 l2) + (count-maps l4 l4))) + +(time (run)) diff --git a/benchmarks/gabriel/maze.sch b/benchmarks/gabriel/maze.sch new file mode 100644 index 00000000..e56bf17a --- /dev/null +++ b/benchmarks/gabriel/maze.sch @@ -0,0 +1,680 @@ +;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers. + +;------------------------------------------------------------------------------ +; Was file "rand.scm". + +; Minimal Standard Random Number Generator +; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version. +; better constants, as proposed by Park. +; By Ozan Yigit + +;;; Rehacked by Olin 4/1995. + +(define (random-state n) + (cons n #f)) + +(define (rand state) + (let ((seed (car state)) + (A 2813) ; 48271 + (M 8388607) ; 2147483647 + (Q 2787) ; 44488 + (R 2699)) ; 3399 + (let* ((hi (quotient seed Q)) + (lo (modulo seed Q)) + (test (- (* A lo) (* R hi))) + (val (if (> test 0) test (+ test M)))) + (set-car! state val) + val))) + +(define (random-int n state) + (modulo (rand state) n)) + +; poker test +; seed 1 +; cards 0-9 inclusive (random 10) +; five cards per hand +; 10000 hands +; +; Poker Hand Example Probability Calculated +; 5 of a kind (aaaaa) 0.0001 0 +; 4 of a kind (aaaab) 0.0045 0.0053 +; Full house (aaabb) 0.009 0.0093 +; 3 of a kind (aaabc) 0.072 0.0682 +; two pairs (aabbc) 0.108 0.1104 +; Pair (aabcd) 0.504 0.501 +; Bust (abcde) 0.3024 0.3058 + +; (define (random n) +; (let* ((M 2147483647) +; (slop (modulo M n))) +; (let loop ((r (rand))) +; (if (> r slop) +; (modulo r n) +; (loop (rand)))))) +; +; (define (rngtest) +; (display "implementation ") +; (srand 1) +; (let loop ((n 0)) +; (if (< n 10000) +; (begin +; (rand) +; (loop (1+ n))))) +; (if (= *seed* 399268537) +; (display "looks correct.") +; (begin +; (display "failed.") +; (newline) +; (display " current seed ") (display *seed*) +; (newline) +; (display " correct seed 399268537"))) +; (newline)) + +;------------------------------------------------------------------------------ +; Was file "uf.scm". + +;;; Tarjan's amortised union-find data structure. +;;; Copyright (c) 1995 by Olin Shivers. + +;;; This data structure implements disjoint sets of elements. +;;; Four operations are supported. The implementation is extremely +;;; fast -- any sequence of N operations can be performed in time +;;; so close to linear it's laughable how close it is. See your +;;; intro data structures book for more. The operations are: +;;; +;;; - (base-set nelts) -> set +;;; Returns a new set, of size NELTS. +;;; +;;; - (set-size s) -> integer +;;; Returns the number of elements in set S. +;;; +;;; - (union! set1 set2) +;;; Unions the two sets -- SET1 and SET2 are now considered the same set +;;; by SET-EQUAL?. +;;; +;;; - (set-equal? set1 set2) +;;; Returns true <==> the two sets are the same. + +;;; Representation: a set is a cons cell. Every set has a "representative" +;;; cons cell, reached by chasing cdr links until we find the cons with +;;; cdr = (). Set equality is determined by comparing representatives using +;;; EQ?. A representative's car contains the number of elements in the set. + +;;; The speed of the algorithm comes because when we chase links to find +;;; representatives, we collapse links by changing all the cells in the path +;;; we followed to point directly to the representative, so that next time +;;; we walk the cdr-chain, we'll go directly to the representative in one hop. + + +(define (base-set nelts) (cons nelts '())) + +;;; Sets are chained together through cdr links. Last guy in the chain +;;; is the root of the set. + +(define (get-set-root s) + (let lp ((r s)) ; Find the last pair + (let ((next (cdr r))) ; in the list. That's + (cond ((pair? next) (lp next)) ; the root r. + + (else + (if (not (eq? r s)) ; Now zip down the list again, + (let lp ((x s)) ; changing everyone's cdr to r. + (let ((next (cdr x))) + (cond ((not (eq? r next)) + (set-cdr! x r) + (lp next)))))) + r))))) ; Then return r. + +(define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2))) + +(define (set-size s) (car (get-set-root s))) + +(define (union! s1 s2) + (let* ((r1 (get-set-root s1)) + (r2 (get-set-root s2)) + (n1 (set-size r1)) + (n2 (set-size r2)) + (n (+ n1 n2))) + + (cond ((> n1 n2) + (set-cdr! r2 r1) + (set-car! r1 n)) + (else + (set-cdr! r1 r2) + (set-car! r2 n))))) + +;------------------------------------------------------------------------------ +; Was file "maze.scm". + +;;; Building mazes with union/find disjoint sets. +;;; Copyright (c) 1995 by Olin Shivers. + +;;; This is the algorithmic core of the maze constructor. +;;; External dependencies: +;;; - RANDOM-INT +;;; - Union/find code +;;; - bitwise logical functions + +; (define-record wall +; owner ; Cell that owns this wall. +; neighbor ; The other cell bordering this wall. +; bit) ; Integer -- a bit identifying this wall in OWNER's cell. + +; (define-record cell +; reachable ; Union/find set -- all reachable cells. +; id ; Identifying info (e.g., the coords of the cell). +; (walls -1) ; A bitset telling which walls are still standing. +; (parent #f) ; For DFS spanning tree construction. +; (mark #f)) ; For marking the solution path. + +(define (make-wall owner neighbor bit) + (vector 'wall owner neighbor bit)) + +(define (wall:owner o) (vector-ref o 1)) +(define (set-wall:owner o v) (vector-set! o 1 v)) +(define (wall:neighbor o) (vector-ref o 2)) +(define (set-wall:neighbor o v) (vector-set! o 2 v)) +(define (wall:bit o) (vector-ref o 3)) +(define (set-wall:bit o v) (vector-set! o 3 v)) + +(define (make-cell reachable id) + (vector 'cell reachable id -1 #f #f)) + +(define (cell:reachable o) (vector-ref o 1)) +(define (set-cell:reachable o v) (vector-set! o 1 v)) +(define (cell:id o) (vector-ref o 2)) +(define (set-cell:id o v) (vector-set! o 2 v)) +(define (cell:walls o) (vector-ref o 3)) +(define (set-cell:walls o v) (vector-set! o 3 v)) +(define (cell:parent o) (vector-ref o 4)) +(define (set-cell:parent o v) (vector-set! o 4 v)) +(define (cell:mark o) (vector-ref o 5)) +(define (set-cell:mark o v) (vector-set! o 5 v)) + +;;; Iterates in reverse order. + +(define (vec-for-each proc v) + (let lp ((i (- (vector-length v) 1))) + (cond ((>= i 0) + (proc (vector-ref v i)) + (lp (- i 1)))))) + + +;;; Randomly permute a vector. + +(define (permute-vec! v random-state) + (let lp ((i (- (vector-length v) 1))) + (cond ((> i 1) + (let ((elt-i (vector-ref v i)) + (j (random-int i random-state))) ; j in [0,i) + (vector-set! v i (vector-ref v j)) + (vector-set! v j elt-i)) + (lp (- i 1))))) + v) + + +;;; This is the core of the algorithm. + +(define (dig-maze walls ncells) + (call-with-current-continuation + (lambda (quit) + (vec-for-each + (lambda (wall) ; For each wall, + (let* ((c1 (wall:owner wall)) ; find the cells on + (set1 (cell:reachable c1)) + + (c2 (wall:neighbor wall)) ; each side of the wall + (set2 (cell:reachable c2))) + + ;; If there is no path from c1 to c2, knock down the + ;; wall and union the two sets of reachable cells. + ;; If the new set of reachable cells is the whole set + ;; of cells, quit. + (if (not (set-equal? set1 set2)) + (let ((walls (cell:walls c1)) + (wall-mask (bitwise-not (wall:bit wall)))) + (union! set1 set2) + (set-cell:walls c1 (bitwise-and walls wall-mask)) + (if (= (set-size set1) ncells) (quit #f)))))) + walls)))) + + +;;; Some simple DFS routines useful for determining path length +;;; through the maze. + +;;; Build a DFS tree from ROOT. +;;; (DO-CHILDREN proc maze node) applies PROC to each of NODE's children. +;;; We assume there are no loops in the maze; if this is incorrect, the +;;; algorithm will diverge. + +(define (dfs-maze maze root do-children) + (let search ((node root) (parent #f)) + (set-cell:parent node parent) + (do-children (lambda (child) + (if (not (eq? child parent)) + (search child node))) + maze node))) + +;;; Move the root to NEW-ROOT. + +(define (reroot-maze new-root) + (let lp ((node new-root) (new-parent #f)) + (let ((old-parent (cell:parent node))) + (set-cell:parent node new-parent) + (if old-parent (lp old-parent node))))) + +;;; How far from CELL to the root? + +(define (path-length cell) + (do ((len 0 (+ len 1)) + (node (cell:parent cell) (cell:parent node))) + ((not node) len))) + +;;; Mark the nodes from NODE back to root. Used to mark the winning path. + +(define (mark-path node) + (let lp ((node node)) + (set-cell:mark node #t) + (cond ((cell:parent node) => lp)))) + +;------------------------------------------------------------------------------ +; Was file "harr.scm". + +;;; Hex arrays +;;; Copyright (c) 1995 by Olin Shivers. + +;;; External dependencies: +;;; - define-record + +;;; ___ ___ ___ +;;; / \ / \ / \ +;;; ___/ A \___/ A \___/ A \___ +;;; / \ / \ / \ / \ +;;; / A \___/ A \___/ A \___/ A \ +;;; \ / \ / \ / \ / +;;; \___/ \___/ \___/ \___/ +;;; / \ / \ / \ / \ +;;; / \___/ \___/ \___/ \ +;;; \ / \ / \ / \ / +;;; \___/ \___/ \___/ \___/ +;;; / \ / \ / \ / \ +;;; / \___/ \___/ \___/ \ +;;; \ / \ / \ / \ / +;;; \___/ \___/ \___/ \___/ + +;;; Hex arrays are indexed by the (x,y) coord of the center of the hexagonal +;;; element. Hexes are three wide and two high; e.g., to get from the center +;;; of an elt to its {NW, N, NE} neighbors, add {(-3,1), (0,2), (3,1)} +;;; respectively. +;;; +;;; Hex arrays are represented with a matrix, essentially made by shoving the +;;; odd columns down a half-cell so things line up. The mapping is as follows: +;;; Center coord row/column +;;; ------------ ---------- +;;; (x, y) -> (y/2, x/3) +;;; (3c, 2r + c&1) <- (r, c) + + +; (define-record harr +; nrows +; ncols +; elts) + +(define (make-harr nrows ncols elts) + (vector 'harr nrows ncols elts)) + +(define (harr:nrows o) (vector-ref o 1)) +(define (set-harr:nrows o v) (vector-set! o 1 v)) +(define (harr:ncols o) (vector-ref o 2)) +(define (set-harr:ncols o v) (vector-set! o 2 v)) +(define (harr:elts o) (vector-ref o 3)) +(define (set-harr:elts o v) (vector-set! o 3 v)) + +(define (harr r c) + (make-harr r c (make-vector (* r c)))) + + + +(define (href ha x y) + (let ((r (quotient y 2)) + (c (quotient x 3))) + (vector-ref (harr:elts ha) + (+ (* (harr:ncols ha) r) c)))) + +(define (hset! ha x y val) + (let ((r (quotient y 2)) + (c (quotient x 3))) + (vector-set! (harr:elts ha) + (+ (* (harr:ncols ha) r) c) + val))) + +(define (href/rc ha r c) + (vector-ref (harr:elts ha) + (+ (* (harr:ncols ha) r) c))) + +;;; Create a nrows x ncols hex array. The elt centered on coord (x, y) +;;; is the value returned by (PROC x y). + +(define (harr-tabulate nrows ncols proc) + (let ((v (make-vector (* nrows ncols)))) + + (do ((r (- nrows 1) (- r 1))) + ((< r 0)) + (do ((c 0 (+ c 1)) + (i (* r ncols) (+ i 1))) + ((= c ncols)) + (vector-set! v i (proc (* 3 c) (+ (* 2 r) (bitwise-and c 1)))))) + + (make-harr nrows ncols v))) + + +(define (harr-for-each proc harr) + (vec-for-each proc (harr:elts harr))) + +;------------------------------------------------------------------------------ +; Was file "hex.scm". + +;;; Hexagonal hackery for maze generation. +;;; Copyright (c) 1995 by Olin Shivers. + +;;; External dependencies: +;;; - cell and wall records +;;; - Functional Postscript for HEXES->PATH +;;; - logical functions for bit hacking +;;; - hex array code. + +;;; To have the maze span (0,0) to (1,1): +;;; (scale (/ (+ 1 (* 3 ncols))) (/ (+ 1 (* 2 nrows))) +;;; (translate (point 2 1) maze)) + +;;; Every elt of the hex array manages his SW, S, and SE wall. +;;; Terminology: - An even column is one whose column index is even. That +;;; means the first, third, ... columns (indices 0, 2, ...). +;;; - An odd column is one whose column index is odd. That +;;; means the second, fourth... columns (indices 1, 3, ...). +;;; The even/odd flip-flop is confusing; be careful to keep it +;;; straight. The *even* columns are the low ones. The *odd* +;;; columns are the high ones. +;;; _ _ +;;; _/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ +;;; 0 1 2 3 + +(define south-west 1) +(define south 2) +(define south-east 4) + +(define (gen-maze-array r c) + (harr-tabulate r c (lambda (x y) (make-cell (base-set 1) (cons x y))))) + +;;; This could be made more efficient. +(define (make-wall-vec harr) + (let* ((nrows (harr:nrows harr)) + (ncols (harr:ncols harr)) + (xmax (* 3 (- ncols 1))) + + ;; Accumulate walls. + (walls '()) + (add-wall (lambda (o n b) ; owner neighbor bit + (set! walls (cons (make-wall o n b) walls))))) + + ;; Do everything but the bottom row. + (do ((x (* (- ncols 1) 3) (- x 3))) + ((< x 0)) + (do ((y (+ (* (- nrows 1) 2) (bitwise-and x 1)) + (- y 2))) + ((<= y 1)) ; Don't do bottom row. + (let ((hex (href harr x y))) + (if (not (zero? x)) + (add-wall hex (href harr (- x 3) (- y 1)) south-west)) + (add-wall hex (href harr x (- y 2)) south) + (if (< x xmax) + (add-wall hex (href harr (+ x 3) (- y 1)) south-east))))) + + ;; Do the SE and SW walls of the odd columns on the bottom row. + ;; If the rightmost bottom hex lies in an odd column, however, + ;; don't add it's SE wall -- it's a corner hex, and has no SE neighbor. + (if (> ncols 1) + (let ((rmoc-x (+ 3 (* 6 (quotient (- ncols 2) 2))))) + ;; Do rightmost odd col. + (let ((rmoc-hex (href harr rmoc-x 1))) + (if (< rmoc-x xmax) ; Not a corner -- do E wall. + (add-wall rmoc-hex (href harr xmax 0) south-east)) + (add-wall rmoc-hex (href harr (- rmoc-x 3) 0) south-west)) + + (do ((x (- rmoc-x 6) ; Do the rest of the bottom row's odd cols. + (- x 6))) + ((< x 3)) ; 3 is X coord of leftmost odd column. + (add-wall (href harr x 1) (href harr (- x 3) 0) south-west) + (add-wall (href harr x 1) (href harr (+ x 3) 0) south-east)))) + + (list->vector walls))) + + +;;; Find the cell ctop from the top row, and the cell cbot from the bottom +;;; row such that cbot is furthest from ctop. +;;; Return [ctop-x, ctop-y, cbot-x, cbot-y]. + +(define (pick-entrances harr) + (dfs-maze harr (href/rc harr 0 0) for-each-hex-child) + (let ((nrows (harr:nrows harr)) + (ncols (harr:ncols harr))) + (let tp-lp ((max-len -1) + (entrance #f) + (exit #f) + (tcol (- ncols 1))) + (if (< tcol 0) (vector entrance exit) + (let ((top-cell (href/rc harr (- nrows 1) tcol))) + (reroot-maze top-cell) + (let ((result + (let bt-lp ((max-len max-len) + (entrance entrance) + (exit exit) + (bcol (- ncols 1))) +; (format #t "~a ~a ~a ~a~%" max-len entrance exit bcol) + (if (< bcol 0) (vector max-len entrance exit) + (let ((this-len (path-length (href/rc harr 0 bcol)))) + (if (> this-len max-len) + (bt-lp this-len tcol bcol (- bcol 1)) + (bt-lp max-len entrance exit (- bcol 1)))))))) + (let ((max-len (vector-ref result 0)) + (entrance (vector-ref result 1)) + (exit (vector-ref result 2))) + (tp-lp max-len entrance exit (- tcol 1))))))))) + + + +;;; Apply PROC to each node reachable from CELL. +(define (for-each-hex-child proc harr cell) + (let* ((walls (cell:walls cell)) + (id (cell:id cell)) + (x (car id)) + (y (cdr id)) + (nr (harr:nrows harr)) + (nc (harr:ncols harr)) + (maxy (* 2 (- nr 1))) + (maxx (* 3 (- nc 1)))) + (if (not (bit-test walls south-west)) (proc (href harr (- x 3) (- y 1)))) + (if (not (bit-test walls south)) (proc (href harr x (- y 2)))) + (if (not (bit-test walls south-east)) (proc (href harr (+ x 3) (- y 1)))) + + ;; NW neighbor, if there is one (we may be in col 1, or top row/odd col) + (if (and (> x 0) ; Not in first column. + (or (<= y maxy) ; Not on top row or + (zero? (modulo x 6)))) ; not in an odd column. + (let ((nw (href harr (- x 3) (+ y 1)))) + (if (not (bit-test (cell:walls nw) south-east)) (proc nw)))) + + ;; N neighbor, if there is one (we may be on top row). + (if (< y maxy) ; Not on top row + (let ((n (href harr x (+ y 2)))) + (if (not (bit-test (cell:walls n) south)) (proc n)))) + + ;; NE neighbor, if there is one (we may be in last col, or top row/odd col) + (if (and (< x maxx) ; Not in last column. + (or (<= y maxy) ; Not on top row or + (zero? (modulo x 6)))) ; not in an odd column. + (let ((ne (href harr (+ x 3) (+ y 1)))) + (if (not (bit-test (cell:walls ne) south-west)) (proc ne)))))) + + + +;;; The top-level +(define (make-maze nrows ncols) + (let* ((cells (gen-maze-array nrows ncols)) + (walls (permute-vec! (make-wall-vec cells) (random-state 20)))) + (dig-maze walls (* nrows ncols)) + (let ((result (pick-entrances cells))) + (let ((entrance (vector-ref result 0)) + (exit (vector-ref result 1))) + (let* ((exit-cell (href/rc cells 0 exit)) + (walls (cell:walls exit-cell))) + (reroot-maze (href/rc cells (- nrows 1) entrance)) + (mark-path exit-cell) + (set-cell:walls exit-cell (bitwise-and walls (bitwise-not south))) + (vector cells entrance exit)))))) + + +(define (pmaze nrows ncols) + (let ((result (make-maze nrows ncols))) + (let ((cells (vector-ref result 0)) + (entrance (vector-ref result 1)) + (exit (vector-ref result 2))) + (print-hexmaze cells entrance)))) + +;------------------------------------------------------------------------------ +; Was file "hexprint.scm". + +;;; Print out a hex array with characters. +;;; Copyright (c) 1995 by Olin Shivers. + +;;; External dependencies: +;;; - hex array code +;;; - hex cell code + +;;; _ _ +;;; _/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ + +;;; Top part of top row looks like this: +;;; _ _ _ _ +;;; _/ \_/ \/ \_/ \ +;;; / + +(define output #f) ; the list of all characters written out, in reverse order. + +(define (write-ch c) + (set! output (cons c output))) + +(define (print-hexmaze harr entrance) + (let* ((nrows (harr:nrows harr)) + (ncols (harr:ncols harr)) + (ncols2 (* 2 (quotient ncols 2)))) + + ;; Print out the flat tops for the top row's odd cols. + (do ((c 1 (+ c 2))) + ((>= c ncols)) +; (display " ") + (write-ch #\space) + (write-ch #\space) + (write-ch #\space) + (write-ch (if (= c entrance) #\space #\_))) +; (newline) + (write-ch #\newline) + + ;; Print out the slanted tops for the top row's odd cols + ;; and the flat tops for the top row's even cols. + (write-ch #\space) + (do ((c 0 (+ c 2))) + ((>= c ncols2)) +; (format #t "~a/~a\\" +; (if (= c entrance) #\space #\_) +; (dot/space harr (- nrows 1) (+ c 1))) + (write-ch (if (= c entrance) #\space #\_)) + (write-ch #\/) + (write-ch (dot/space harr (- nrows 1) (+ c 1))) + (write-ch #\\)) + (if (odd? ncols) + (write-ch (if (= entrance (- ncols 1)) #\space #\_))) +; (newline) + (write-ch #\newline) + + (do ((r (- nrows 1) (- r 1))) + ((< r 0)) + + ;; Do the bottoms for row r's odd cols. + (write-ch #\/) + (do ((c 1 (+ c 2))) + ((>= c ncols2)) + ;; The dot/space for the even col just behind c. + (write-ch (dot/space harr r (- c 1))) + (display-hexbottom (cell:walls (href/rc harr r c)))) + + (cond ((odd? ncols) + (write-ch (dot/space harr r (- ncols 1))) + (write-ch #\\))) +; (newline) + (write-ch #\newline) + + ;; Do the bottoms for row r's even cols. + (do ((c 0 (+ c 2))) + ((>= c ncols2)) + (display-hexbottom (cell:walls (href/rc harr r c))) + ;; The dot/space is for the odd col just after c, on row below. + (write-ch (dot/space harr (- r 1) (+ c 1)))) + + (cond ((odd? ncols) + (display-hexbottom (cell:walls (href/rc harr r (- ncols 1))))) + ((not (zero? r)) (write-ch #\\))) +; (newline) + (write-ch #\newline)))) + +(define (bit-test j bit) + (not (zero? (bitwise-and j bit)))) + +;;; Return a . if harr[r,c] is marked, otherwise a space. +;;; We use the dot to mark the solution path. +(define (dot/space harr r c) + (if (and (>= r 0) (cell:mark (href/rc harr r c))) #\. #\space)) + +;;; Print a \_/ hex bottom. +(define (display-hexbottom hexwalls) + (write-ch (if (bit-test hexwalls south-west) #\\ #\space)) + (write-ch (if (bit-test hexwalls south ) #\_ #\space)) + (write-ch (if (bit-test hexwalls south-east) #\/ #\space))) + +;;; _ _ +;;; _/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \_/ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \_/ + +;------------------------------------------------------------------------------ + +(let ((input (with-input-from-file "input.txt" read))) + (time (let loop ((n 1000) (v 0)) + (if (zero? n) + (list->string v) + (begin + (set! output '()) + (pmaze 20 (if input 7 0)) + (loop (- n 1) output)))))) diff --git a/benchmarks/gabriel/maze2.sch b/benchmarks/gabriel/maze2.sch new file mode 100644 index 00000000..4a2a9168 --- /dev/null +++ b/benchmarks/gabriel/maze2.sch @@ -0,0 +1,683 @@ +;; Like "maze.sch", but avoids `set-car!' and `set-cdr!' by using +;; vectors for mutable records. + +;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers. + +;------------------------------------------------------------------------------ +; Was file "rand.scm". + +; Minimal Standard Random Number Generator +; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version. +; better constants, as proposed by Park. +; By Ozan Yigit + +;;; Rehacked by Olin 4/1995. + +(define (random-state n) + (vector n)) + +(define (rand state) + (let ((seed (vector-ref state 0)) + (A 2813) ; 48271 + (M 8388607) ; 2147483647 + (Q 2787) ; 44488 + (R 2699)) ; 3399 + (let* ((hi (quotient seed Q)) + (lo (modulo seed Q)) + (test (- (* A lo) (* R hi))) + (val (if (> test 0) test (+ test M)))) + (vector-set! state 0 val) + val))) + +(define (random-int n state) + (modulo (rand state) n)) + +; poker test +; seed 1 +; cards 0-9 inclusive (random 10) +; five cards per hand +; 10000 hands +; +; Poker Hand Example Probability Calculated +; 5 of a kind (aaaaa) 0.0001 0 +; 4 of a kind (aaaab) 0.0045 0.0053 +; Full house (aaabb) 0.009 0.0093 +; 3 of a kind (aaabc) 0.072 0.0682 +; two pairs (aabbc) 0.108 0.1104 +; Pair (aabcd) 0.504 0.501 +; Bust (abcde) 0.3024 0.3058 + +; (define (random n) +; (let* ((M 2147483647) +; (slop (modulo M n))) +; (let loop ((r (rand))) +; (if (> r slop) +; (modulo r n) +; (loop (rand)))))) +; +; (define (rngtest) +; (display "implementation ") +; (srand 1) +; (let loop ((n 0)) +; (if (< n 10000) +; (begin +; (rand) +; (loop (1+ n))))) +; (if (= *seed* 399268537) +; (display "looks correct.") +; (begin +; (display "failed.") +; (newline) +; (display " current seed ") (display *seed*) +; (newline) +; (display " correct seed 399268537"))) +; (newline)) + +;------------------------------------------------------------------------------ +; Was file "uf.scm". + +;;; Tarjan's amortised union-find data structure. +;;; Copyright (c) 1995 by Olin Shivers. + +;;; This data structure implements disjoint sets of elements. +;;; Four operations are supported. The implementation is extremely +;;; fast -- any sequence of N operations can be performed in time +;;; so close to linear it's laughable how close it is. See your +;;; intro data structures book for more. The operations are: +;;; +;;; - (base-set nelts) -> set +;;; Returns a new set, of size NELTS. +;;; +;;; - (set-size s) -> integer +;;; Returns the number of elements in set S. +;;; +;;; - (union! set1 set2) +;;; Unions the two sets -- SET1 and SET2 are now considered the same set +;;; by SET-EQUAL?. +;;; +;;; - (set-equal? set1 set2) +;;; Returns true <==> the two sets are the same. + +;;; Representation: a set is a cons cell. Every set has a "representative" +;;; cons cell, reached by chasing cdr links until we find the cons with +;;; cdr = (). Set equality is determined by comparing representatives using +;;; EQ?. A representative's car contains the number of elements in the set. + +;;; The speed of the algorithm comes because when we chase links to find +;;; representatives, we collapse links by changing all the cells in the path +;;; we followed to point directly to the representative, so that next time +;;; we walk the cdr-chain, we'll go directly to the representative in one hop. + + +(define (base-set nelts) (vector nelts '())) + +;;; Sets are chained together through cdr links. Last guy in the chain +;;; is the root of the set. + +(define (get-set-root s) + (let lp ((r s)) ; Find the last pair + (let ((next (vector-ref r 1))) ; in the list. That's + (cond ((vector? next) (lp next)) ; the root r. + + (else + (if (not (eq? r s)) ; Now zip down the list again, + (let lp ((x s)) ; changing everyone's cdr to r. + (let ((next (vector-ref x 1))) + (cond ((not (eq? r next)) + (vector-set! x 1 r) + (lp next)))))) + r))))) ; Then return r. + +(define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2))) + +(define (set-size s) (vector-ref (get-set-root s) 0)) + +(define (union! s1 s2) + (let* ((r1 (get-set-root s1)) + (r2 (get-set-root s2)) + (n1 (set-size r1)) + (n2 (set-size r2)) + (n (+ n1 n2))) + + (cond ((> n1 n2) + (vector-set! r2 1 r1) + (vector-set! r1 1 n)) + (else + (vector-set! r1 1 r2) + (vector-set! r2 1 n))))) + +;------------------------------------------------------------------------------ +; Was file "maze.scm". + +;;; Building mazes with union/find disjoint sets. +;;; Copyright (c) 1995 by Olin Shivers. + +;;; This is the algorithmic core of the maze constructor. +;;; External dependencies: +;;; - RANDOM-INT +;;; - Union/find code +;;; - bitwise logical functions + +; (define-record wall +; owner ; Cell that owns this wall. +; neighbor ; The other cell bordering this wall. +; bit) ; Integer -- a bit identifying this wall in OWNER's cell. + +; (define-record cell +; reachable ; Union/find set -- all reachable cells. +; id ; Identifying info (e.g., the coords of the cell). +; (walls -1) ; A bitset telling which walls are still standing. +; (parent #f) ; For DFS spanning tree construction. +; (mark #f)) ; For marking the solution path. + +(define (make-wall owner neighbor bit) + (vector 'wall owner neighbor bit)) + +(define (wall:owner o) (vector-ref o 1)) +(define (set-wall:owner o v) (vector-set! o 1 v)) +(define (wall:neighbor o) (vector-ref o 2)) +(define (set-wall:neighbor o v) (vector-set! o 2 v)) +(define (wall:bit o) (vector-ref o 3)) +(define (set-wall:bit o v) (vector-set! o 3 v)) + +(define (make-cell reachable id) + (vector 'cell reachable id -1 #f #f)) + +(define (cell:reachable o) (vector-ref o 1)) +(define (set-cell:reachable o v) (vector-set! o 1 v)) +(define (cell:id o) (vector-ref o 2)) +(define (set-cell:id o v) (vector-set! o 2 v)) +(define (cell:walls o) (vector-ref o 3)) +(define (set-cell:walls o v) (vector-set! o 3 v)) +(define (cell:parent o) (vector-ref o 4)) +(define (set-cell:parent o v) (vector-set! o 4 v)) +(define (cell:mark o) (vector-ref o 5)) +(define (set-cell:mark o v) (vector-set! o 5 v)) + +;;; Iterates in reverse order. + +(define (vec-for-each proc v) + (let lp ((i (- (vector-length v) 1))) + (cond ((>= i 0) + (proc (vector-ref v i)) + (lp (- i 1)))))) + + +;;; Randomly permute a vector. + +(define (permute-vec! v random-state) + (let lp ((i (- (vector-length v) 1))) + (cond ((> i 1) + (let ((elt-i (vector-ref v i)) + (j (random-int i random-state))) ; j in [0,i) + (vector-set! v i (vector-ref v j)) + (vector-set! v j elt-i)) + (lp (- i 1))))) + v) + + +;;; This is the core of the algorithm. + +(define (dig-maze walls ncells) + (call-with-current-continuation + (lambda (quit) + (vec-for-each + (lambda (wall) ; For each wall, + (let* ((c1 (wall:owner wall)) ; find the cells on + (set1 (cell:reachable c1)) + + (c2 (wall:neighbor wall)) ; each side of the wall + (set2 (cell:reachable c2))) + + ;; If there is no path from c1 to c2, knock down the + ;; wall and union the two sets of reachable cells. + ;; If the new set of reachable cells is the whole set + ;; of cells, quit. + (if (not (set-equal? set1 set2)) + (let ((walls (cell:walls c1)) + (wall-mask (bitwise-not (wall:bit wall)))) + (union! set1 set2) + (set-cell:walls c1 (bitwise-and walls wall-mask)) + (if (= (set-size set1) ncells) (quit #f)))))) + walls)))) + + +;;; Some simple DFS routines useful for determining path length +;;; through the maze. + +;;; Build a DFS tree from ROOT. +;;; (DO-CHILDREN proc maze node) applies PROC to each of NODE's children. +;;; We assume there are no loops in the maze; if this is incorrect, the +;;; algorithm will diverge. + +(define (dfs-maze maze root do-children) + (let search ((node root) (parent #f)) + (set-cell:parent node parent) + (do-children (lambda (child) + (if (not (eq? child parent)) + (search child node))) + maze node))) + +;;; Move the root to NEW-ROOT. + +(define (reroot-maze new-root) + (let lp ((node new-root) (new-parent #f)) + (let ((old-parent (cell:parent node))) + (set-cell:parent node new-parent) + (if old-parent (lp old-parent node))))) + +;;; How far from CELL to the root? + +(define (path-length cell) + (do ((len 0 (+ len 1)) + (node (cell:parent cell) (cell:parent node))) + ((not node) len))) + +;;; Mark the nodes from NODE back to root. Used to mark the winning path. + +(define (mark-path node) + (let lp ((node node)) + (set-cell:mark node #t) + (cond ((cell:parent node) => lp)))) + +;------------------------------------------------------------------------------ +; Was file "harr.scm". + +;;; Hex arrays +;;; Copyright (c) 1995 by Olin Shivers. + +;;; External dependencies: +;;; - define-record + +;;; ___ ___ ___ +;;; / \ / \ / \ +;;; ___/ A \___/ A \___/ A \___ +;;; / \ / \ / \ / \ +;;; / A \___/ A \___/ A \___/ A \ +;;; \ / \ / \ / \ / +;;; \___/ \___/ \___/ \___/ +;;; / \ / \ / \ / \ +;;; / \___/ \___/ \___/ \ +;;; \ / \ / \ / \ / +;;; \___/ \___/ \___/ \___/ +;;; / \ / \ / \ / \ +;;; / \___/ \___/ \___/ \ +;;; \ / \ / \ / \ / +;;; \___/ \___/ \___/ \___/ + +;;; Hex arrays are indexed by the (x,y) coord of the center of the hexagonal +;;; element. Hexes are three wide and two high; e.g., to get from the center +;;; of an elt to its {NW, N, NE} neighbors, add {(-3,1), (0,2), (3,1)} +;;; respectively. +;;; +;;; Hex arrays are represented with a matrix, essentially made by shoving the +;;; odd columns down a half-cell so things line up. The mapping is as follows: +;;; Center coord row/column +;;; ------------ ---------- +;;; (x, y) -> (y/2, x/3) +;;; (3c, 2r + c&1) <- (r, c) + + +; (define-record harr +; nrows +; ncols +; elts) + +(define (make-harr nrows ncols elts) + (vector 'harr nrows ncols elts)) + +(define (harr:nrows o) (vector-ref o 1)) +(define (set-harr:nrows o v) (vector-set! o 1 v)) +(define (harr:ncols o) (vector-ref o 2)) +(define (set-harr:ncols o v) (vector-set! o 2 v)) +(define (harr:elts o) (vector-ref o 3)) +(define (set-harr:elts o v) (vector-set! o 3 v)) + +(define (harr r c) + (make-harr r c (make-vector (* r c)))) + + + +(define (href ha x y) + (let ((r (quotient y 2)) + (c (quotient x 3))) + (vector-ref (harr:elts ha) + (+ (* (harr:ncols ha) r) c)))) + +(define (hset! ha x y val) + (let ((r (quotient y 2)) + (c (quotient x 3))) + (vector-set! (harr:elts ha) + (+ (* (harr:ncols ha) r) c) + val))) + +(define (href/rc ha r c) + (vector-ref (harr:elts ha) + (+ (* (harr:ncols ha) r) c))) + +;;; Create a nrows x ncols hex array. The elt centered on coord (x, y) +;;; is the value returned by (PROC x y). + +(define (harr-tabulate nrows ncols proc) + (let ((v (make-vector (* nrows ncols)))) + + (do ((r (- nrows 1) (- r 1))) + ((< r 0)) + (do ((c 0 (+ c 1)) + (i (* r ncols) (+ i 1))) + ((= c ncols)) + (vector-set! v i (proc (* 3 c) (+ (* 2 r) (bitwise-and c 1)))))) + + (make-harr nrows ncols v))) + + +(define (harr-for-each proc harr) + (vec-for-each proc (harr:elts harr))) + +;------------------------------------------------------------------------------ +; Was file "hex.scm". + +;;; Hexagonal hackery for maze generation. +;;; Copyright (c) 1995 by Olin Shivers. + +;;; External dependencies: +;;; - cell and wall records +;;; - Functional Postscript for HEXES->PATH +;;; - logical functions for bit hacking +;;; - hex array code. + +;;; To have the maze span (0,0) to (1,1): +;;; (scale (/ (+ 1 (* 3 ncols))) (/ (+ 1 (* 2 nrows))) +;;; (translate (point 2 1) maze)) + +;;; Every elt of the hex array manages his SW, S, and SE wall. +;;; Terminology: - An even column is one whose column index is even. That +;;; means the first, third, ... columns (indices 0, 2, ...). +;;; - An odd column is one whose column index is odd. That +;;; means the second, fourth... columns (indices 1, 3, ...). +;;; The even/odd flip-flop is confusing; be careful to keep it +;;; straight. The *even* columns are the low ones. The *odd* +;;; columns are the high ones. +;;; _ _ +;;; _/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ +;;; 0 1 2 3 + +(define south-west 1) +(define south 2) +(define south-east 4) + +(define (gen-maze-array r c) + (harr-tabulate r c (lambda (x y) (make-cell (base-set 1) (cons x y))))) + +;;; This could be made more efficient. +(define (make-wall-vec harr) + (let* ((nrows (harr:nrows harr)) + (ncols (harr:ncols harr)) + (xmax (* 3 (- ncols 1))) + + ;; Accumulate walls. + (walls '()) + (add-wall (lambda (o n b) ; owner neighbor bit + (set! walls (cons (make-wall o n b) walls))))) + + ;; Do everything but the bottom row. + (do ((x (* (- ncols 1) 3) (- x 3))) + ((< x 0)) + (do ((y (+ (* (- nrows 1) 2) (bitwise-and x 1)) + (- y 2))) + ((<= y 1)) ; Don't do bottom row. + (let ((hex (href harr x y))) + (if (not (zero? x)) + (add-wall hex (href harr (- x 3) (- y 1)) south-west)) + (add-wall hex (href harr x (- y 2)) south) + (if (< x xmax) + (add-wall hex (href harr (+ x 3) (- y 1)) south-east))))) + + ;; Do the SE and SW walls of the odd columns on the bottom row. + ;; If the rightmost bottom hex lies in an odd column, however, + ;; don't add it's SE wall -- it's a corner hex, and has no SE neighbor. + (if (> ncols 1) + (let ((rmoc-x (+ 3 (* 6 (quotient (- ncols 2) 2))))) + ;; Do rightmost odd col. + (let ((rmoc-hex (href harr rmoc-x 1))) + (if (< rmoc-x xmax) ; Not a corner -- do E wall. + (add-wall rmoc-hex (href harr xmax 0) south-east)) + (add-wall rmoc-hex (href harr (- rmoc-x 3) 0) south-west)) + + (do ((x (- rmoc-x 6) ; Do the rest of the bottom row's odd cols. + (- x 6))) + ((< x 3)) ; 3 is X coord of leftmost odd column. + (add-wall (href harr x 1) (href harr (- x 3) 0) south-west) + (add-wall (href harr x 1) (href harr (+ x 3) 0) south-east)))) + + (list->vector walls))) + + +;;; Find the cell ctop from the top row, and the cell cbot from the bottom +;;; row such that cbot is furthest from ctop. +;;; Return [ctop-x, ctop-y, cbot-x, cbot-y]. + +(define (pick-entrances harr) + (dfs-maze harr (href/rc harr 0 0) for-each-hex-child) + (let ((nrows (harr:nrows harr)) + (ncols (harr:ncols harr))) + (let tp-lp ((max-len -1) + (entrance #f) + (exit #f) + (tcol (- ncols 1))) + (if (< tcol 0) (vector entrance exit) + (let ((top-cell (href/rc harr (- nrows 1) tcol))) + (reroot-maze top-cell) + (let ((result + (let bt-lp ((max-len max-len) + (entrance entrance) + (exit exit) + (bcol (- ncols 1))) +; (format #t "~a ~a ~a ~a~%" max-len entrance exit bcol) + (if (< bcol 0) (vector max-len entrance exit) + (let ((this-len (path-length (href/rc harr 0 bcol)))) + (if (> this-len max-len) + (bt-lp this-len tcol bcol (- bcol 1)) + (bt-lp max-len entrance exit (- bcol 1)))))))) + (let ((max-len (vector-ref result 0)) + (entrance (vector-ref result 1)) + (exit (vector-ref result 2))) + (tp-lp max-len entrance exit (- tcol 1))))))))) + + + +;;; Apply PROC to each node reachable from CELL. +(define (for-each-hex-child proc harr cell) + (let* ((walls (cell:walls cell)) + (id (cell:id cell)) + (x (car id)) + (y (cdr id)) + (nr (harr:nrows harr)) + (nc (harr:ncols harr)) + (maxy (* 2 (- nr 1))) + (maxx (* 3 (- nc 1)))) + (if (not (bit-test walls south-west)) (proc (href harr (- x 3) (- y 1)))) + (if (not (bit-test walls south)) (proc (href harr x (- y 2)))) + (if (not (bit-test walls south-east)) (proc (href harr (+ x 3) (- y 1)))) + + ;; NW neighbor, if there is one (we may be in col 1, or top row/odd col) + (if (and (> x 0) ; Not in first column. + (or (<= y maxy) ; Not on top row or + (zero? (modulo x 6)))) ; not in an odd column. + (let ((nw (href harr (- x 3) (+ y 1)))) + (if (not (bit-test (cell:walls nw) south-east)) (proc nw)))) + + ;; N neighbor, if there is one (we may be on top row). + (if (< y maxy) ; Not on top row + (let ((n (href harr x (+ y 2)))) + (if (not (bit-test (cell:walls n) south)) (proc n)))) + + ;; NE neighbor, if there is one (we may be in last col, or top row/odd col) + (if (and (< x maxx) ; Not in last column. + (or (<= y maxy) ; Not on top row or + (zero? (modulo x 6)))) ; not in an odd column. + (let ((ne (href harr (+ x 3) (+ y 1)))) + (if (not (bit-test (cell:walls ne) south-west)) (proc ne)))))) + + + +;;; The top-level +(define (make-maze nrows ncols) + (let* ((cells (gen-maze-array nrows ncols)) + (walls (permute-vec! (make-wall-vec cells) (random-state 20)))) + (dig-maze walls (* nrows ncols)) + (let ((result (pick-entrances cells))) + (let ((entrance (vector-ref result 0)) + (exit (vector-ref result 1))) + (let* ((exit-cell (href/rc cells 0 exit)) + (walls (cell:walls exit-cell))) + (reroot-maze (href/rc cells (- nrows 1) entrance)) + (mark-path exit-cell) + (set-cell:walls exit-cell (bitwise-and walls (bitwise-not south))) + (vector cells entrance exit)))))) + + +(define (pmaze nrows ncols) + (let ((result (make-maze nrows ncols))) + (let ((cells (vector-ref result 0)) + (entrance (vector-ref result 1)) + (exit (vector-ref result 2))) + (print-hexmaze cells entrance)))) + +;------------------------------------------------------------------------------ +; Was file "hexprint.scm". + +;;; Print out a hex array with characters. +;;; Copyright (c) 1995 by Olin Shivers. + +;;; External dependencies: +;;; - hex array code +;;; - hex cell code + +;;; _ _ +;;; _/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ + +;;; Top part of top row looks like this: +;;; _ _ _ _ +;;; _/ \_/ \/ \_/ \ +;;; / + +(define output #f) ; the list of all characters written out, in reverse order. + +(define (write-ch c) + (set! output (cons c output))) + +(define (print-hexmaze harr entrance) + (let* ((nrows (harr:nrows harr)) + (ncols (harr:ncols harr)) + (ncols2 (* 2 (quotient ncols 2)))) + + ;; Print out the flat tops for the top row's odd cols. + (do ((c 1 (+ c 2))) + ((>= c ncols)) +; (display " ") + (write-ch #\space) + (write-ch #\space) + (write-ch #\space) + (write-ch (if (= c entrance) #\space #\_))) +; (newline) + (write-ch #\newline) + + ;; Print out the slanted tops for the top row's odd cols + ;; and the flat tops for the top row's even cols. + (write-ch #\space) + (do ((c 0 (+ c 2))) + ((>= c ncols2)) +; (format #t "~a/~a\\" +; (if (= c entrance) #\space #\_) +; (dot/space harr (- nrows 1) (+ c 1))) + (write-ch (if (= c entrance) #\space #\_)) + (write-ch #\/) + (write-ch (dot/space harr (- nrows 1) (+ c 1))) + (write-ch #\\)) + (if (odd? ncols) + (write-ch (if (= entrance (- ncols 1)) #\space #\_))) +; (newline) + (write-ch #\newline) + + (do ((r (- nrows 1) (- r 1))) + ((< r 0)) + + ;; Do the bottoms for row r's odd cols. + (write-ch #\/) + (do ((c 1 (+ c 2))) + ((>= c ncols2)) + ;; The dot/space for the even col just behind c. + (write-ch (dot/space harr r (- c 1))) + (display-hexbottom (cell:walls (href/rc harr r c)))) + + (cond ((odd? ncols) + (write-ch (dot/space harr r (- ncols 1))) + (write-ch #\\))) +; (newline) + (write-ch #\newline) + + ;; Do the bottoms for row r's even cols. + (do ((c 0 (+ c 2))) + ((>= c ncols2)) + (display-hexbottom (cell:walls (href/rc harr r c))) + ;; The dot/space is for the odd col just after c, on row below. + (write-ch (dot/space harr (- r 1) (+ c 1)))) + + (cond ((odd? ncols) + (display-hexbottom (cell:walls (href/rc harr r (- ncols 1))))) + ((not (zero? r)) (write-ch #\\))) +; (newline) + (write-ch #\newline)))) + +(define (bit-test j bit) + (not (zero? (bitwise-and j bit)))) + +;;; Return a . if harr[r,c] is marked, otherwise a space. +;;; We use the dot to mark the solution path. +(define (dot/space harr r c) + (if (and (>= r 0) (cell:mark (href/rc harr r c))) #\. #\space)) + +;;; Print a \_/ hex bottom. +(define (display-hexbottom hexwalls) + (write-ch (if (bit-test hexwalls south-west) #\\ #\space)) + (write-ch (if (bit-test hexwalls south ) #\_ #\space)) + (write-ch (if (bit-test hexwalls south-east) #\/ #\space))) + +;;; _ _ +;;; _/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \_/ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \ +;;; / \_/ \_/ +;;; \_/ \_/ \_/ + +;------------------------------------------------------------------------------ + +(let ((input (with-input-from-file "input.txt" read))) + (time (let loop ((n 1000) (v 0)) + (if (zero? n) + (list->string v) + (begin + (set! output '()) + (pmaze 20 (if input 7 0)) + (loop (- n 1) output)))))) diff --git a/benchmarks/gabriel/mazefun.sch b/benchmarks/gabriel/mazefun.sch new file mode 100644 index 00000000..bec2f56e --- /dev/null +++ b/benchmarks/gabriel/mazefun.sch @@ -0,0 +1,206 @@ +;;; MAZEFUN -- Constructs a maze in a purely functional way, +;;; written by Marc Feeley. + +(define iota + (lambda (n) + (iota-iter n '()))) + +(define iota-iter + (lambda (n lst) + (if (= n 0) + lst + (iota-iter (- n 1) (cons n lst))))) + +(define foldr + (lambda (f base lst) + + (define foldr-aux + (lambda (lst) + (if (null? lst) + base + (f (car lst) (foldr-aux (cdr lst)))))) + + (foldr-aux lst))) + +(define foldl + (lambda (f base lst) + + (define foldl-aux + (lambda (base lst) + (if (null? lst) + base + (foldl-aux (f base (car lst)) (cdr lst))))) + + (foldl-aux base lst))) + +(define for + (lambda (lo hi f) + + (define for-aux + (lambda (lo) + (if (< lo hi) + (cons (f lo) (for-aux (+ lo 1))) + '()))) + + (for-aux lo))) + +(define concat + (lambda (lists) + (foldr append '() lists))) + +(define list-read + (lambda (lst i) + (if (= i 0) + (car lst) + (list-read (cdr lst) (- i 1))))) + +(define list-write + (lambda (lst i val) + (if (= i 0) + (cons val (cdr lst)) + (cons (car lst) (list-write (cdr lst) (- i 1) val))))) + +(define list-remove-pos + (lambda (lst i) + (if (= i 0) + (cdr lst) + (cons (car lst) (list-remove-pos (cdr lst) (- i 1)))))) + +(define duplicates? + (lambda (lst) + (if (null? lst) + #f + (or (member (car lst) (cdr lst)) + (duplicates? (cdr lst)))))) + +; Manipulation de matrices. + +(define make-matrix + (lambda (n m init) + (for 0 n (lambda (i) (for 0 m (lambda (j) (init i j))))))) + +(define matrix-read + (lambda (mat i j) + (list-read (list-read mat i) j))) + +(define matrix-write + (lambda (mat i j val) + (list-write mat i (list-write (list-read mat i) j val)))) + +(define matrix-size + (lambda (mat) + (cons (length mat) (length (car mat))))) + +(define matrix-map + (lambda (f mat) + (map (lambda (lst) (map f lst)) mat))) + +(define initial-random 0) + +(define next-random + (lambda (current-random) + (remainder (+ (* current-random 3581) 12751) 131072))) + +(define shuffle + (lambda (lst) + (shuffle-aux lst initial-random))) + +(define shuffle-aux + (lambda (lst current-random) + (if (null? lst) + '() + (let ((new-random (next-random current-random))) + (let ((i (modulo new-random (length lst)))) + (cons (list-read lst i) + (shuffle-aux (list-remove-pos lst i) + new-random))))))) + +(define make-maze + (lambda (n m) ; n and m must be odd + (if (not (and (odd? n) (odd? m))) + 'error + (let ((cave + (make-matrix n m (lambda (i j) + (if (and (even? i) (even? j)) + (cons i j) + #f)))) + (possible-holes + (concat + (for 0 n (lambda (i) + (concat + (for 0 m (lambda (j) + (if (equal? (even? i) (even? j)) + '() + (list (cons i j))))))))))) + (cave-to-maze (pierce-randomly (shuffle possible-holes) cave)))))) + +(define cave-to-maze + (lambda (cave) + (matrix-map (lambda (x) (if x '_ '*)) cave))) + +(define pierce + (lambda (pos cave) + (let ((i (car pos)) (j (cdr pos))) + (matrix-write cave i j pos)))) + +(define pierce-randomly + (lambda (possible-holes cave) + (if (null? possible-holes) + cave + (let ((hole (car possible-holes))) + (pierce-randomly (cdr possible-holes) + (try-to-pierce hole cave)))))) + +(define try-to-pierce + (lambda (pos cave) + (let ((i (car pos)) (j (cdr pos))) + (let ((ncs (neighboring-cavities pos cave))) + (if (duplicates? + (map (lambda (nc) (matrix-read cave (car nc) (cdr nc))) ncs)) + cave + (pierce pos + (foldl (lambda (c nc) (change-cavity c nc pos)) + cave + ncs))))))) + +(define change-cavity + (lambda (cave pos new-cavity-id) + (let ((i (car pos)) (j (cdr pos))) + (change-cavity-aux cave pos new-cavity-id (matrix-read cave i j))))) + +(define change-cavity-aux + (lambda (cave pos new-cavity-id old-cavity-id) + (let ((i (car pos)) (j (cdr pos))) + (let ((cavity-id (matrix-read cave i j))) + (if (equal? cavity-id old-cavity-id) + (foldl (lambda (c nc) + (change-cavity-aux c nc new-cavity-id old-cavity-id)) + (matrix-write cave i j new-cavity-id) + (neighboring-cavities pos cave)) + cave))))) + +(define neighboring-cavities + (lambda (pos cave) + (let ((size (matrix-size cave))) + (let ((n (car size)) (m (cdr size))) + (let ((i (car pos)) (j (cdr pos))) + (append (if (and (> i 0) (matrix-read cave (- i 1) j)) + (list (cons (- i 1) j)) + '()) + (if (and (< i (- n 1)) (matrix-read cave (+ i 1) j)) + (list (cons (+ i 1) j)) + '()) + (if (and (> j 0) (matrix-read cave i (- j 1))) + (list (cons i (- j 1))) + '()) + (if (and (< j (- m 1)) (matrix-read cave i (+ j 1))) + (list (cons i (+ j 1))) + '()))))))) + + +(let ((input (with-input-from-file "input.txt" read))) + (time (let loop ((n 500) (v 0)) + (if (zero? n) + v + (loop (- n 1) + (make-maze 11 (if input 11 0))))))) diff --git a/benchmarks/gabriel/nboyer.sch b/benchmarks/gabriel/nboyer.sch new file mode 100644 index 00000000..c7e887a2 --- /dev/null +++ b/benchmarks/gabriel/nboyer.sch @@ -0,0 +1,759 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: nboyer.sch +; Description: The Boyer benchmark +; Author: Bob Boyer +; Created: 5-Apr-85 +; Modified: 10-Apr-85 14:52:20 (Bob Shaw) +; 22-Jul-87 (Will Clinger) +; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list) +; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules, +; rewrote to eliminate property lists, and added +; a scaling parameter suggested by Bob Boyer) +; 19-Mar-99 (Will Clinger -- cleaned up comments) +; 4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; NBOYER -- Logic programming benchmark, originally written by Bob Boyer. +;;; Fairly CONS intensive. + +; Note: The version of this benchmark that appears in Dick Gabriel's book +; contained several bugs that are corrected here. These bugs are discussed +; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp +; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are: +; +; The benchmark now returns a boolean result. +; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER +; in Common Lisp) +; ONE-WAY-UNIFY1 now treats numbers correctly +; ONE-WAY-UNIFY1-LST now treats empty lists correctly +; Rule 19 has been corrected (this rule was not touched by the original +; benchmark, but is used by this version) +; Rules 84 and 101 have been corrected (but these rules are never touched +; by the benchmark) +; +; According to Baker, these bug fixes make the benchmark 10-25% slower. +; Please do not compare the timings from this benchmark against those of +; the original benchmark. +; +; This version of the benchmark also prints the number of rewrites as a sanity +; check, because it is too easy for a buggy version to return the correct +; boolean result. The correct number of rewrites is +; +; n rewrites peak live storage (approximate, in bytes) +; 0 95024 520,000 +; 1 591777 2,085,000 +; 2 1813975 5,175,000 +; 3 5375678 +; 4 16445406 +; 5 51507739 + +; Nboyer is a 2-phase benchmark. +; The first phase attaches lemmas to symbols. This phase is not timed, +; but it accounts for very little of the runtime anyway. +; The second phase creates the test problem, and tests to see +; whether it is implied by the lemmas. + +(define (nboyer-benchmark . args) + (let ((n (if (null? args) 0 (car args)))) + (setup-boyer) + (time (test-boyer n)))) + +(define (setup-boyer) #t) ; assigned below +(define (test-boyer) #t) ; assigned below + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; The first phase. +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; In the original benchmark, it stored a list of lemmas on the +; property lists of symbols. +; In the new benchmark, it maintains an association list of +; symbols and symbol-records, and stores the list of lemmas +; within the symbol-records. + +(let () + + (define (setup) + (add-lemma-lst + (quote ((equal (compile form) + (reverse (codegen (optimize form) + (nil)))) + (equal (eqp x y) + (equal (fix x) + (fix y))) + (equal (greaterp x y) + (lessp y x)) + (equal (lesseqp x y) + (not (lessp y x))) + (equal (greatereqp x y) + (not (lessp x y))) + (equal (boolean x) + (or (equal x (t)) + (equal x (f)))) + (equal (iff x y) + (and (implies x y) + (implies y x))) + (equal (even1 x) + (if (zerop x) + (t) + (odd (sub1 x)))) + (equal (countps- l pred) + (countps-loop l pred (zero))) + (equal (fact- i) + (fact-loop i 1)) + (equal (reverse- x) + (reverse-loop x (nil))) + (equal (divides x y) + (zerop (remainder y x))) + (equal (assume-true var alist) + (cons (cons var (t)) + alist)) + (equal (assume-false var alist) + (cons (cons var (f)) + alist)) + (equal (tautology-checker x) + (tautologyp (normalize x) + (nil))) + (equal (falsify x) + (falsify1 (normalize x) + (nil))) + (equal (prime x) + (and (not (zerop x)) + (not (equal x (add1 (zero)))) + (prime1 x (sub1 x)))) + (equal (and p q) + (if p (if q (t) + (f)) + (f))) + (equal (or p q) + (if p (t) + (if q (t) + (f)))) + (equal (not p) + (if p (f) + (t))) + (equal (implies p q) + (if p (if q (t) + (f)) + (t))) + (equal (fix x) + (if (numberp x) + x + (zero))) + (equal (if (if a b c) + d e) + (if a (if b d e) + (if c d e))) + (equal (zerop x) + (or (equal x (zero)) + (not (numberp x)))) + (equal (plus (plus x y) + z) + (plus x (plus y z))) + (equal (equal (plus a b) + (zero)) + (and (zerop a) + (zerop b))) + (equal (difference x x) + (zero)) + (equal (equal (plus a b) + (plus a c)) + (equal (fix b) + (fix c))) + (equal (equal (zero) + (difference x y)) + (not (lessp y x))) + (equal (equal x (difference x y)) + (and (numberp x) + (or (equal x (zero)) + (zerop y)))) + (equal (meaning (plus-tree (append x y)) + a) + (plus (meaning (plus-tree x) + a) + (meaning (plus-tree y) + a))) + (equal (meaning (plus-tree (plus-fringe x)) + a) + (fix (meaning x a))) + (equal (append (append x y) + z) + (append x (append y z))) + (equal (reverse (append a b)) + (append (reverse b) + (reverse a))) + (equal (times x (plus y z)) + (plus (times x y) + (times x z))) + (equal (times (times x y) + z) + (times x (times y z))) + (equal (equal (times x y) + (zero)) + (or (zerop x) + (zerop y))) + (equal (exec (append x y) + pds envrn) + (exec y (exec x pds envrn) + envrn)) + (equal (mc-flatten x y) + (append (flatten x) + y)) + (equal (member x (append a b)) + (or (member x a) + (member x b))) + (equal (member x (reverse y)) + (member x y)) + (equal (length (reverse x)) + (length x)) + (equal (member a (intersect b c)) + (and (member a b) + (member a c))) + (equal (nth (zero) + i) + (zero)) + (equal (exp i (plus j k)) + (times (exp i j) + (exp i k))) + (equal (exp i (times j k)) + (exp (exp i j) + k)) + (equal (reverse-loop x y) + (append (reverse x) + y)) + (equal (reverse-loop x (nil)) + (reverse x)) + (equal (count-list z (sort-lp x y)) + (plus (count-list z x) + (count-list z y))) + (equal (equal (append a b) + (append a c)) + (equal b c)) + (equal (plus (remainder x y) + (times y (quotient x y))) + (fix x)) + (equal (power-eval (big-plus1 l i base) + base) + (plus (power-eval l base) + i)) + (equal (power-eval (big-plus x y i base) + base) + (plus i (plus (power-eval x base) + (power-eval y base)))) + (equal (remainder y 1) + (zero)) + (equal (lessp (remainder x y) + y) + (not (zerop y))) + (equal (remainder x x) + (zero)) + (equal (lessp (quotient i j) + i) + (and (not (zerop i)) + (or (zerop j) + (not (equal j 1))))) + (equal (lessp (remainder x y) + x) + (and (not (zerop y)) + (not (zerop x)) + (not (lessp x y)))) + (equal (power-eval (power-rep i base) + base) + (fix i)) + (equal (power-eval (big-plus (power-rep i base) + (power-rep j base) + (zero) + base) + base) + (plus i j)) + (equal (gcd x y) + (gcd y x)) + (equal (nth (append a b) + i) + (append (nth a i) + (nth b (difference i (length a))))) + (equal (difference (plus x y) + x) + (fix y)) + (equal (difference (plus y x) + x) + (fix y)) + (equal (difference (plus x y) + (plus x z)) + (difference y z)) + (equal (times x (difference c w)) + (difference (times c x) + (times w x))) + (equal (remainder (times x z) + z) + (zero)) + (equal (difference (plus b (plus a c)) + a) + (plus b c)) + (equal (difference (add1 (plus y z)) + z) + (add1 y)) + (equal (lessp (plus x y) + (plus x z)) + (lessp y z)) + (equal (lessp (times x z) + (times y z)) + (and (not (zerop z)) + (lessp x y))) + (equal (lessp y (plus x y)) + (not (zerop x))) + (equal (gcd (times x z) + (times y z)) + (times z (gcd x y))) + (equal (value (normalize x) + a) + (value x a)) + (equal (equal (flatten x) + (cons y (nil))) + (and (nlistp x) + (equal x y))) + (equal (listp (gopher x)) + (listp x)) + (equal (samefringe x y) + (equal (flatten x) + (flatten y))) + (equal (equal (greatest-factor x y) + (zero)) + (and (or (zerop y) + (equal y 1)) + (equal x (zero)))) + (equal (equal (greatest-factor x y) + 1) + (equal x 1)) + (equal (numberp (greatest-factor x y)) + (not (and (or (zerop y) + (equal y 1)) + (not (numberp x))))) + (equal (times-list (append x y)) + (times (times-list x) + (times-list y))) + (equal (prime-list (append x y)) + (and (prime-list x) + (prime-list y))) + (equal (equal z (times w z)) + (and (numberp z) + (or (equal z (zero)) + (equal w 1)))) + (equal (greatereqp x y) + (not (lessp x y))) + (equal (equal x (times x y)) + (or (equal x (zero)) + (and (numberp x) + (equal y 1)))) + (equal (remainder (times y x) + y) + (zero)) + (equal (equal (times a b) + 1) + (and (not (equal a (zero))) + (not (equal b (zero))) + (numberp a) + (numberp b) + (equal (sub1 a) + (zero)) + (equal (sub1 b) + (zero)))) + (equal (lessp (length (delete x l)) + (length l)) + (member x l)) + (equal (sort2 (delete x l)) + (delete x (sort2 l))) + (equal (dsort x) + (sort2 x)) + (equal (length (cons x1 + (cons x2 + (cons x3 (cons x4 + (cons x5 + (cons x6 x7))))))) + (plus 6 (length x7))) + (equal (difference (add1 (add1 x)) + 2) + (fix x)) + (equal (quotient (plus x (plus x y)) + 2) + (plus x (quotient y 2))) + (equal (sigma (zero) + i) + (quotient (times i (add1 i)) + 2)) + (equal (plus x (add1 y)) + (if (numberp y) + (add1 (plus x y)) + (add1 x))) + (equal (equal (difference x y) + (difference z y)) + (if (lessp x y) + (not (lessp y z)) + (if (lessp z y) + (not (lessp y x)) + (equal (fix x) + (fix z))))) + (equal (meaning (plus-tree (delete x y)) + a) + (if (member x y) + (difference (meaning (plus-tree y) + a) + (meaning x a)) + (meaning (plus-tree y) + a))) + (equal (times x (add1 y)) + (if (numberp y) + (plus x (times x y)) + (fix x))) + (equal (nth (nil) + i) + (if (zerop i) + (nil) + (zero))) + (equal (last (append a b)) + (if (listp b) + (last b) + (if (listp a) + (cons (car (last a)) + b) + b))) + (equal (equal (lessp x y) + z) + (if (lessp x y) + (equal (t) z) + (equal (f) z))) + (equal (assignment x (append a b)) + (if (assignedp x a) + (assignment x a) + (assignment x b))) + (equal (car (gopher x)) + (if (listp x) + (car (flatten x)) + (zero))) + (equal (flatten (cdr (gopher x))) + (if (listp x) + (cdr (flatten x)) + (cons (zero) + (nil)))) + (equal (quotient (times y x) + y) + (if (zerop y) + (zero) + (fix x))) + (equal (get j (set i val mem)) + (if (eqp j i) + val + (get j mem))))))) + + (define (add-lemma-lst lst) + (cond ((null? lst) + #t) + (else (add-lemma (car lst)) + (add-lemma-lst (cdr lst))))) + + (define (add-lemma term) + (cond ((and (pair? term) + (eq? (car term) + (quote equal)) + (pair? (cadr term))) + (put (car (cadr term)) + (quote lemmas) + (cons + (translate-term term) + (get (car (cadr term)) (quote lemmas))))) + (else (error "ADD-LEMMA did not like term: " term)))) + + ; Translates a term by replacing its constructor symbols by symbol-records. + + (define (translate-term term) + (cond ((not (pair? term)) + term) + (else (cons (symbol->symbol-record (car term)) + (translate-args (cdr term)))))) + + (define (translate-args lst) + (cond ((null? lst) + '()) + (else (cons (translate-term (car lst)) + (translate-args (cdr lst)))))) + + ; For debugging only, so the use of MAP does not change + ; the first-order character of the benchmark. + + (define (untranslate-term term) + (cond ((not (pair? term)) + term) + (else (cons (get-name (car term)) + (map untranslate-term (cdr term)))))) + + ; A symbol-record is represented as a vector with two fields: + ; the symbol (for debugging) and + ; the list of lemmas associated with the symbol. + + (define (put sym property value) + (put-lemmas! (symbol->symbol-record sym) value)) + + (define (get sym property) + (get-lemmas (symbol->symbol-record sym))) + + (define (symbol->symbol-record sym) + (let ((x (assq sym *symbol-records-alist*))) + (if x + (cdr x) + (let ((r (make-symbol-record sym))) + (set! *symbol-records-alist* + (cons (cons sym r) + *symbol-records-alist*)) + r)))) + + ; Association list of symbols and symbol-records. + + (define *symbol-records-alist* '()) + + ; A symbol-record is represented as a vector with two fields: + ; the symbol (for debugging) and + ; the list of lemmas associated with the symbol. + + (define (make-symbol-record sym) + (vector sym '())) + + (define (put-lemmas! symbol-record lemmas) + (vector-set! symbol-record 1 lemmas)) + + (define (get-lemmas symbol-record) + (vector-ref symbol-record 1)) + + (define (get-name symbol-record) + (vector-ref symbol-record 0)) + + (define (symbol-record-equal? r1 r2) + (eq? r1 r2)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; + ; The second phase. + ; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (test n) + (let ((term + (apply-subst + (translate-alist + (quote ((x f (plus (plus a b) + (plus c (zero)))) + (y f (times (times a b) + (plus c d))) + (z f (reverse (append (append a b) + (nil)))) + (u equal (plus a b) + (difference x y)) + (w lessp (remainder a b) + (member a (length b)))))) + (translate-term + (do ((term + (quote (implies (and (implies x y) + (and (implies y z) + (and (implies z u) + (implies u w)))) + (implies x w))) + (list 'or term '(f))) + (n n (- n 1))) + ((zero? n) term)))))) + (tautp term))) + + (define (translate-alist alist) + (cond ((null? alist) + '()) + (else (cons (cons (caar alist) + (translate-term (cdar alist))) + (translate-alist (cdr alist)))))) + + (define (apply-subst alist term) + (cond ((not (pair? term)) + (let ((temp-temp (assq term alist))) + (if temp-temp + (cdr temp-temp) + term))) + (else (cons (car term) + (apply-subst-lst alist (cdr term)))))) + + (define (apply-subst-lst alist lst) + (cond ((null? lst) + '()) + (else (cons (apply-subst alist (car lst)) + (apply-subst-lst alist (cdr lst)))))) + + (define (tautp x) + (tautologyp (rewrite x) + '() '())) + + (define (tautologyp x true-lst false-lst) + (cond ((truep x true-lst) + #t) + ((falsep x false-lst) + #f) + ((not (pair? x)) + #f) + ((eq? (car x) if-constructor) + (cond ((truep (cadr x) + true-lst) + (tautologyp (caddr x) + true-lst false-lst)) + ((falsep (cadr x) + false-lst) + (tautologyp (cadddr x) + true-lst false-lst)) + (else (and (tautologyp (caddr x) + (cons (cadr x) + true-lst) + false-lst) + (tautologyp (cadddr x) + true-lst + (cons (cadr x) + false-lst)))))) + (else #f))) + + (define if-constructor '*) ; becomes (symbol->symbol-record 'if) + + (define rewrite-count 0) ; sanity check + + (define (rewrite term) + (set! rewrite-count (+ rewrite-count 1)) + (cond ((not (pair? term)) + term) + (else (rewrite-with-lemmas (cons (car term) + (rewrite-args (cdr term))) + (get-lemmas (car term)))))) + + (define (rewrite-args lst) + (cond ((null? lst) + '()) + (else (cons (rewrite (car lst)) + (rewrite-args (cdr lst)))))) + + (define (rewrite-with-lemmas term lst) + (cond ((null? lst) + term) + ((one-way-unify term (cadr (car lst))) + (rewrite (apply-subst unify-subst (caddr (car lst))))) + (else (rewrite-with-lemmas term (cdr lst))))) + + (define unify-subst '*) + + (define (one-way-unify term1 term2) + (begin (set! unify-subst '()) + (one-way-unify1 term1 term2))) + + (define (one-way-unify1 term1 term2) + (cond ((not (pair? term2)) + (let ((temp-temp (assq term2 unify-subst))) + (cond (temp-temp + (term-equal? term1 (cdr temp-temp))) + ((number? term2) ; This bug fix makes + (equal? term1 term2)) ; nboyer 10-25% slower! + (else + (set! unify-subst (cons (cons term2 term1) + unify-subst)) + #t)))) + ((not (pair? term1)) + #f) + ((eq? (car term1) + (car term2)) + (one-way-unify1-lst (cdr term1) + (cdr term2))) + (else #f))) + + (define (one-way-unify1-lst lst1 lst2) + (cond ((null? lst1) + (null? lst2)) + ((null? lst2) + #f) + ((one-way-unify1 (car lst1) + (car lst2)) + (one-way-unify1-lst (cdr lst1) + (cdr lst2))) + (else #f))) + + (define (falsep x lst) + (or (term-equal? x false-term) + (term-member? x lst))) + + (define (truep x lst) + (or (term-equal? x true-term) + (term-member? x lst))) + + (define false-term '*) ; becomes (translate-term '(f)) + (define true-term '*) ; becomes (translate-term '(t)) + + ; The next two procedures were in the original benchmark + ; but were never used. + + (define (trans-of-implies n) + (translate-term + (list (quote implies) + (trans-of-implies1 n) + (list (quote implies) + 0 n)))) + + (define (trans-of-implies1 n) + (cond ((equal? n 1) + (list (quote implies) + 0 1)) + (else (list (quote and) + (list (quote implies) + (- n 1) + n) + (trans-of-implies1 (- n 1)))))) + + ; Translated terms can be circular structures, which can't be + ; compared using Scheme's equal? and member procedures, so we + ; use these instead. + + (define (term-equal? x y) + (cond ((pair? x) + (and (pair? y) + (symbol-record-equal? (car x) (car y)) + (term-args-equal? (cdr x) (cdr y)))) + (else (equal? x y)))) + + (define (term-args-equal? lst1 lst2) + (cond ((null? lst1) + (null? lst2)) + ((null? lst2) + #f) + ((term-equal? (car lst1) (car lst2)) + (term-args-equal? (cdr lst1) (cdr lst2))) + (else #f))) + + (define (term-member? x lst) + (cond ((null? lst) + #f) + ((term-equal? x (car lst)) + #t) + (else (term-member? x (cdr lst))))) + + (set! setup-boyer + (lambda () + (set! *symbol-records-alist* '()) + (set! if-constructor (symbol->symbol-record 'if)) + (set! false-term (translate-term '(f))) + (set! true-term (translate-term '(t))) + (setup))) + + (set! test-boyer + (lambda (n) + (set! rewrite-count 0) + (let ((answer (test n))) + (write rewrite-count) + (display " rewrites") + (newline) + (if answer + rewrite-count + #f))))) + +(nboyer-benchmark 4) + diff --git a/benchmarks/gabriel/nestedloop.sch b/benchmarks/gabriel/nestedloop.sch new file mode 100644 index 00000000..64c6c056 --- /dev/null +++ b/benchmarks/gabriel/nestedloop.sch @@ -0,0 +1,64 @@ + +;; Imperative body: +(define (loops n) + (let ((result 0)) + (let loop1 ((i1 1)) + (if (> i1 n) + 'done + (begin + (let loop2 ((i2 1)) + (if (> i2 n) + 'done + (begin + (let loop3 ((i3 1)) + (if (> i3 n) + 'done + (begin + (let loop4 ((i4 1)) + (if (> i4 n) + 'done + (begin + (let loop5 ((i5 1)) + (if (> i5 n) + 'done + (begin + (let loop6 ((i6 1)) + (if (> i6 n) + 'done + (begin + (set! result (+ result 1)) + (loop6 (+ i6 1))))) + (loop5 (+ i5 1))))) + (loop4 (+ i4 1))))) + (loop3 (+ i3 1))))) + (loop2 (+ i2 1))))) + (loop1 (+ i1 1))))) + result)) + +;; Functional body: +(define (func-loops n) + (let loop1 ((i1 1)(result 0)) + (if (> i1 n) + result + (let loop2 ((i2 1)(result result)) + (if (> i2 n) + (loop1 (+ i1 1) result) + (let loop3 ((i3 1)(result result)) + (if (> i3 n) + (loop2 (+ i2 1) result) + (let loop4 ((i4 1)(result result)) + (if (> i4 n) + (loop3 (+ i3 1) result) + (let loop5 ((i5 1)(result result)) + (if (> i5 n) + (loop4 (+ i4 1) result) + (let loop6 ((i6 1)(result result)) + (if (> i6 n) + (loop5 (+ i5 1) result) + (loop6 (+ i6 1) (+ result 1))))))))))))))) + +(let ((cnt (if (with-input-from-file "input.txt" read) 18 1))) + (time (list + (loops cnt) + (func-loops cnt)))) + diff --git a/benchmarks/gabriel/nfa.sch b/benchmarks/gabriel/nfa.sch new file mode 100644 index 00000000..b00dcd07 --- /dev/null +++ b/benchmarks/gabriel/nfa.sch @@ -0,0 +1,53 @@ +; The recursive-nfa benchmark. (Figure 45, page 143.) + +;; Changed by Matthew 2006/08/21 to move string->list out of the loop + + +(define (recursive-nfa input) + + (define (state0 input) + (or (state1 input) (state3 input) #f)) + + (define (state1 input) + (and (not (null? input)) + (or (and (char=? (car input) #\a) + (state1 (cdr input))) + (and (char=? (car input) #\c) + (state1 input)) + (state2 input)))) + + (define (state2 input) + (and (not (null? input)) + (char=? (car input) #\b) + (not (null? (cdr input))) + (char=? (cadr input) #\c) + (not (null? (cddr input))) + (char=? (caddr input) #\d) + 'state2)) + + (define (state3 input) + (and (not (null? input)) + (or (and (char=? (car input) #\a) + (state3 (cdr input))) + (state4 input)))) + + (define (state4 input) + (and (not (null? input)) + (char=? (car input) #\b) + (not (null? (cdr input))) + (char=? (cadr input) #\c) + 'state4)) + + (or (state0 input) + 'fail)) + +(time (let ((input (string->list (string-append (make-string 133 #\a) "bc")))) + (let loop ((n 150000)) + (if (zero? n) + 'done + (begin + (recursive-nfa input) + (loop (- n 1))))))) + + + diff --git a/benchmarks/gabriel/nothing.sch b/benchmarks/gabriel/nothing.sch new file mode 100644 index 00000000..d3cd0721 --- /dev/null +++ b/benchmarks/gabriel/nothing.sch @@ -0,0 +1 @@ +(time 1) diff --git a/benchmarks/gabriel/nqueens.sch b/benchmarks/gabriel/nqueens.sch new file mode 100644 index 00000000..26a6f851 --- /dev/null +++ b/benchmarks/gabriel/nqueens.sch @@ -0,0 +1,36 @@ +;;; NQUEENS -- Compute number of solutions to 8-queens problem. +;; 2006/08 -- renamed `try' to `try-it' to avoid Bigloo collision (mflatt) + +(define trace? #f) + +(define (nqueens n) + + (define (one-to n) + (let loop ((i n) (l '())) + (if (= i 0) l (loop (- i 1) (cons i l))))) + + (define (try-it x y z) + (if (null? x) + (if (null? y) + (begin (if trace? (begin (write z) (newline))) 1) + 0) + (+ (if (ok? (car x) 1 z) + (try-it (append (cdr x) y) '() (cons (car x) z)) + 0) + (try-it (cdr x) (cons (car x) y) z)))) + + (define (ok? row dist placed) + (if (null? placed) + #t + (and (not (= (car placed) (+ row dist))) + (not (= (car placed) (- row dist))) + (ok? row (+ dist 1) (cdr placed))))) + + (try-it (one-to n) '() '())) + +(let ((input (with-input-from-file "input.txt" read))) + (time + (let loop ((n 500) (v 0)) + (if (zero? n) + v + (loop (- n 1) (nqueens (if input 8 0))))))) diff --git a/benchmarks/gabriel/nucleic2.sch b/benchmarks/gabriel/nucleic2.sch new file mode 100644 index 00000000..4c3c347a --- /dev/null +++ b/benchmarks/gabriel/nucleic2.sch @@ -0,0 +1,3508 @@ +; File: "nucleic2.scm" +; +; Author: Marc Feeley (feeley@iro.umontreal.ca) +; Last modification by Feeley: June 6, 1994. +; Modified for R5RS Scheme by William D Clinger: 22 October 1996. +; Last modification by Clinger: 19 March 1999. +; +; This program is a modified version of the program described in +; +; M. Feeley, M. Turcotte, G. Lapalme. Using Multilisp for Solving +; Constraint Satisfaction Problems: an Application to Nucleic Acid 3D +; Structure Determination. Lisp and Symbolic Computation 7(2/3), +; 231-246, 1994. +; +; The differences between this program and the original are described in +; +; P.H. Hartel, M. Feeley, et al. Benchmarking Implementations of +; Functional Languages with "Pseudoknot", a Float-Intensive Benchmark. +; Journal of Functional Programming 6(4), 621-655, 1996. + +; This procedure uses Marc Feeley's run-benchmark procedure to time +; the benchmark. + +; PORTABILITY. +; +; This program should run in any R5RS-conforming implementation of Scheme. +; To run this program in an implementation that does not support the R5RS +; macro system, however, you will have to place a single quotation mark (') +; on the following line and also modify the "SYSTEM DEPENDENT CODE" below. + +; ********** R5RS Scheme + +(begin + +(define-syntax FLOAT+ (syntax-rules () ((FLOAT+ x ...) (+ x ...)))) +(define-syntax FLOAT- (syntax-rules () ((FLOAT- x ...) (- x ...)))) +(define-syntax FLOAT* (syntax-rules () ((FLOAT* x ...) (* x ...)))) +(define-syntax FLOAT/ (syntax-rules () ((FLOAT/ x ...) (/ x ...)))) +(define-syntax FLOAT= (syntax-rules () ((FLOAT= x y) (= x y)))) +(define-syntax FLOAT< (syntax-rules () ((FLOAT< x y) (< x y)))) +(define-syntax FLOAT<= (syntax-rules () ((FLOAT<= x y) (<= x y)))) +(define-syntax FLOAT> (syntax-rules () ((FLOAT> x y) (> x y)))) +(define-syntax FLOAT>= (syntax-rules () ((FLOAT>= x y) (>= x y)))) +(define-syntax FLOATsin (syntax-rules () ((FLOATsin x) (sin x)))) +(define-syntax FLOATcos (syntax-rules () ((FLOATcos x) (cos x)))) +(define-syntax FLOATatan (syntax-rules () ((FLOATatan x) (atan x)))) +(define-syntax FLOATsqrt (syntax-rules () ((FLOATsqrt x) (sqrt x)))) + +(define-syntax FUTURE (syntax-rules () ((FUTURE x) x))) +(define-syntax TOUCH (syntax-rules () ((TOUCH x) x))) + +(define-syntax define-structure + (syntax-rules () + ((define-structure #f + name make make-constant (select1 ...) (set1 ...)) + (begin (define-syntax make + (syntax-rules () + ((make select1 ...) + (vector select1 ...)))) + (define-syntax make-constant + (syntax-rules () + ; The vectors that are passed to make-constant aren't quoted. + ((make-constant . args) + (constant-maker make . args)))) + (define-selectors (select1 ...) + (0 1 2 3 4 5 6 7 8 9 + 10 11 12 13 14 15 16 17 18 19 + 20 21 22 23 24 25 26 27 28 29 + 30 31 32 33 34 35 36 37 38 39 + 40 41 42 43 44 45 46 47 48 49)) + (define-setters (set1 ...) + (0 1 2 3 4 5 6 7 8 9 + 10 11 12 13 14 15 16 17 18 19 + 20 21 22 23 24 25 26 27 28 29 + 30 31 32 33 34 35 36 37 38 39 + 40 41 42 43 44 45 46 47 48 49)))) + ((define-structure pred? + name make make-constant (select1 ...) (set1 ...)) + (begin (define-syntax pred? + (syntax-rules () + ((pred? v) + (and (vector? v) (eq? (vector-ref v 0) 'name))))) + (define-syntax make + (syntax-rules () + ((make select1 ...) + (vector 'name select1 ...)))) + (define-syntax make-constant + (syntax-rules () + ; The vectors that are passed to make-constant aren't quoted. + ((make-constant . args) + (constant-maker make . args)))) + (define-selectors (select1 ...) + (1 2 3 4 5 6 7 8 9 + 10 11 12 13 14 15 16 17 18 19 + 20 21 22 23 24 25 26 27 28 29 + 30 31 32 33 34 35 36 37 38 39 + 40 41 42 43 44 45 46 47 48 49)) + (define-setters (set1 ...) + (1 2 3 4 5 6 7 8 9 + 10 11 12 13 14 15 16 17 18 19 + 20 21 22 23 24 25 26 27 28 29 + 30 31 32 33 34 35 36 37 38 39 + 40 41 42 43 44 45 46 47 48 49)))))) +(define-syntax constant-maker + (syntax-rules () + ; The quotation marks are added here. + ((constant-maker make arg ...) + (make 'arg ...)))) +(define-syntax define-selectors + (syntax-rules () + ((define-selectors (select) (i i1 ...)) + (define-syntax select + (syntax-rules () + ((select v) (vector-ref v i))))) + ((define-selectors (select select1 ...) (i i1 ...)) + (begin (define-syntax select + (syntax-rules () + ((select v) (vector-ref v i)))) + (define-selectors (select1 ...) (i1 ...)))))) +(define-syntax define-setters + (syntax-rules () + ((define-setters (set) (i i1 ...)) + (define-syntax set + (syntax-rules () + ((set v x) (vector-set! v i x))))) + ((define-setters (set set1 ...) (i i1 ...)) + (begin (define-syntax set + (syntax-rules () + ((set v x) (vector-set! v i x)))) + (define-setters (set1 ...) (i1 ...)))))) + +(define-structure #f pt + make-pt make-constant-pt + (pt-x pt-y pt-z) + (pt-x-set! pt-y-set! pt-z-set!)) + +(define-structure #f tfo + make-tfo make-constant-tfo + (tfo-a tfo-b tfo-c tfo-d tfo-e tfo-f tfo-g tfo-h tfo-i tfo-tx tfo-ty tfo-tz) + (tfo-a-set! tfo-b-set! tfo-c-set! tfo-d-set! tfo-e-set! tfo-f-set! + tfo-g-set! tfo-h-set! tfo-i-set! tfo-tx-set! tfo-ty-set! tfo-tz-set!)) + +(define-structure nuc? nuc + make-nuc make-constant-nuc + (nuc-dgf-base-tfo ; defines the standard position for wc and wc-dumas + nuc-P-O3*-275-tfo ; defines the standard position for the connect function + nuc-P-O3*-180-tfo + nuc-P-O3*-60-tfo + nuc-P nuc-O1P nuc-O2P nuc-O5* nuc-C5* + nuc-H5* nuc-H5** + nuc-C4* nuc-H4* nuc-O4* nuc-C1* nuc-H1* + nuc-C2* nuc-H2** + nuc-O2* nuc-H2* nuc-C3* nuc-H3* nuc-O3* + nuc-N1 nuc-N3 nuc-C2 nuc-C4 nuc-C5 nuc-C6) + (nuc-dgf-base-tfo-set! + nuc-P-O3*-275-tfo-set! + nuc-P-O3*-180-tfo-set! + nuc-P-O3*-60-tfo-set! + nuc-P-set! nuc-O1P-set! nuc-O2P-set! nuc-O5*-set! nuc-C5*-set! + nuc-H5*-set! nuc-H5**-set! + nuc-C4*-set! nuc-H4*-set! nuc-O4*-set! nuc-C1*-set! nuc-H1*-set! + nuc-C2*-set! nuc-H2**-set! + nuc-O2*-set! nuc-H2*-set! nuc-C3*-set! nuc-H3*-set! nuc-O3*-set! + nuc-N1-set! nuc-N3-set! nuc-C2-set! nuc-C4-set! nuc-C5-set! nuc-C6-set!)) + +(define-structure rA? rA + make-rA make-constant-rA + (rA-dgf-base-tfo ; defines the standard position for wc and wc-dumas + rA-P-O3*-275-tfo ; defines the standard position for the connect function + rA-P-O3*-180-tfo + rA-P-O3*-60-tfo + rA-P rA-O1P rA-O2P rA-O5* rA-C5* + rA-H5* rA-H5** + rA-C4* rA-H4* rA-O4* rA-C1* rA-H1* + rA-C2* rA-H2** + rA-O2* rA-H2* rA-C3* rA-H3* rA-O3* + rA-N1 rA-N3 rA-C2 rA-C4 rA-C5 rA-C6 + rA-N6 rA-N7 rA-N9 rA-C8 + rA-H2 rA-H61 rA-H62 rA-H8) + (rA-dgf-base-tfo-set! + rA-P-O3*-275-tfo-set! + rA-P-O3*-180-tfo-set! + rA-P-O3*-60-tfo-set! + rA-P-set! rA-O1P-set! rA-O2P-set! rA-O5*-set! rA-C5*-set! + rA-H5*-set! rA-H5**-set! + rA-C4*-set! rA-H4*-set! rA-O4*-set! rA-C1*-set! rA-H1*-set! + rA-C2*-set! rA-H2**-set! + rA-O2*-set! rA-H2*-set! rA-C3*-set! rA-H3*-set! rA-O3*-set! + rA-N1-set! rA-N3-set! rA-C2-set! rA-C4-set! rA-C5-set! rA-C6-set! + rA-N6-set! rA-N7-set! rA-N9-set! rA-C8-set! + rA-H2-set! rA-H61-set! rA-H62-set! rA-H8-set!)) + +(define-structure rC? rC + make-rC make-constant-rC + (rC-dgf-base-tfo ; defines the standard position for wc and wc-dumas + rC-P-O3*-275-tfo ; defines the standard position for the connect function + rC-P-O3*-180-tfo + rC-P-O3*-60-tfo + rC-P rC-O1P rC-O2P rC-O5* rC-C5* + rC-H5* rC-H5** + rC-C4* rC-H4* rC-O4* rC-C1* rC-H1* + rC-C2* rC-H2** + rC-O2* rC-H2* rC-C3* rC-H3* rC-O3* + rC-N1 rC-N3 rC-C2 rC-C4 rC-C5 rC-C6 + rC-N4 rC-O2 rC-H41 rC-H42 rC-H5 rC-H6) + (rC-dgf-base-tfo-set! + rC-P-O3*-275-tfo-set! + rC-P-O3*-180-tfo-set! + rC-P-O3*-60-tfo-set! + rC-P-set! rC-O1P-set! rC-O2P-set! rC-O5*-set! rC-C5*-set! + rC-H5*-set! rC-H5**-set! + rC-C4*-set! rC-H4*-set! rC-O4*-set! rC-C1*-set! rC-H1*-set! + rC-C2*-set! rC-H2**-set! + rC-O2*-set! rC-H2*-set! rC-C3*-set! rC-H3*-set! rC-O3*-set! + rC-N1-set! rC-N3-set! rC-C2-set! rC-C4-set! rC-C5-set! rC-C6-set! + rC-N4-set! rC-O2-set! rC-H41-set! rC-H42-set! rC-H5-set! rC-H6-set!)) + +(define-structure rG? rG + make-rG make-constant-rG + (rG-dgf-base-tfo ; defines the standard position for wc and wc-dumas + rG-P-O3*-275-tfo ; defines the standard position for the connect function + rG-P-O3*-180-tfo + rG-P-O3*-60-tfo + rG-P rG-O1P rG-O2P rG-O5* rG-C5* + rG-H5* rG-H5** + rG-C4* rG-H4* rG-O4* rG-C1* rG-H1* + rG-C2* rG-H2** + rG-O2* rG-H2* rG-C3* rG-H3* rG-O3* + rG-N1 rG-N3 rG-C2 rG-C4 rG-C5 rG-C6 + rG-N2 rG-N7 rG-N9 rG-C8 rG-O6 + rG-H1 rG-H21 rG-H22 rG-H8) + (rG-dgf-base-tfo-set! + rG-P-O3*-275-tfo-set! + rG-P-O3*-180-tfo-set! + rG-P-O3*-60-tfo-set! + rG-P-set! rG-O1P-set! rG-O2P-set! rG-O5*-set! rG-C5*-set! + rG-H5*-set! rG-H5**-set! + rG-C4*-set! rG-H4*-set! rG-O4*-set! rG-C1*-set! rG-H1*-set! + rG-C2*-set! rG-H2**-set! + rG-O2*-set! rG-H2*-set! rG-C3*-set! rG-H3*-set! rG-O3*-set! + rG-N1-set! rG-N3-set! rG-C2-set! rG-C4-set! rG-C5-set! rG-C6-set! + rG-N2-set! rG-N7-set! rG-N9-set! rG-C8-set! rG-O6-set! + rG-H1-set! rG-H21-set! rG-H22-set! rG-H8-set!)) + +(define-structure rU? rU + make-rU make-constant-rU + (rU-dgf-base-tfo ; defines the standard position for wc and wc-dumas + rU-P-O3*-275-tfo ; defines the standard position for the connect function + rU-P-O3*-180-tfo + rU-P-O3*-60-tfo + rU-P rU-O1P rU-O2P rU-O5* rU-C5* + rU-H5* rU-H5** + rU-C4* rU-H4* rU-O4* rU-C1* rU-H1* + rU-C2* rU-H2** + rU-O2* rU-H2* rU-C3* rU-H3* rU-O3* + rU-N1 rU-N3 rU-C2 rU-C4 rU-C5 rU-C6 + rU-O2 rU-O4 rU-H3 rU-H5 rU-H6) + (rU-dgf-base-tfo-set! + rU-P-O3*-275-tfo-set! + rU-P-O3*-180-tfo-set! + rU-P-O3*-60-tfo-set! + rU-P-set! rU-O1P-set! rU-O2P-set! rU-O5*-set! rU-C5*-set! + rU-H5*-set! rU-H5**-set! + rU-C4*-set! rU-H4*-set! rU-O4*-set! rU-C1*-set! rU-H1*-set! + rU-C2*-set! rU-H2**-set! + rU-O2*-set! rU-H2*-set! rU-C3*-set! rU-H3*-set! rU-O3*-set! + rU-N1-set! rU-N3-set! rU-C2-set! rU-C4-set! rU-C5-set! rU-C6-set! + rU-O2-set! rU-O4-set! rU-H3-set! rU-H5-set! rU-H6-set!)) + +(define-structure #f var + make-var make-constant-var + (var-id var-tfo var-nuc) + (var-id-set! var-tfo-set! var-nuc-set!)) + +; Comment out the next three syntax definitions if you want +; lazy computation. + +(define-syntax mk-var + (syntax-rules () + ((mk-var i tfo nuc) + (make-var i tfo nuc)))) + +(define-syntax absolute-pos + (syntax-rules () + ((absolute-pos var p) + (tfo-apply (var-tfo var) p)))) + +(define-syntax lazy-computation-of + (syntax-rules () + ((lazy-computation-of expr) + expr))) + +; Uncomment the next three syntax definitions if you want +; lazy computation. + +; (define-syntax mk-var +; (syntax-rules () +; ((mk-var i tfo nuc) +; (make-var i tfo (make-relative-nuc tfo nuc))))) +; +; (define-syntax absolute-pos +; (syntax-rules () +; ((absolute-pos var p) +; (force p)))) +; +; (define-syntax lazy-computation-of +; (syntax-rules () +; ((lazy-computation-of expr) +; (delay expr)))) + +(define-syntax atom-pos + (syntax-rules () + ((atom-pos atom var) + (let ((v var)) + (absolute-pos v (atom (var-nuc v))))))) + +) + +; -- MATH UTILITIES ----------------------------------------------------------- + +(define constant-pi 3.14159265358979323846) +(define constant-minus-pi -3.14159265358979323846) +(define constant-pi/2 1.57079632679489661923) +(define constant-minus-pi/2 -1.57079632679489661923) + +(define (math-atan2 y x) + (cond ((FLOAT> x 0.0) + (FLOATatan (FLOAT/ y x))) + ((FLOAT< y 0.0) + (if (FLOAT= x 0.0) + constant-minus-pi/2 + (FLOAT+ (FLOATatan (FLOAT/ y x)) constant-minus-pi))) + (else + (if (FLOAT= x 0.0) + constant-pi/2 + (FLOAT+ (FLOATatan (FLOAT/ y x)) constant-pi))))) + +; -- POINTS ------------------------------------------------------------------- + +(define (pt-sub p1 p2) + (make-pt (FLOAT- (pt-x p1) (pt-x p2)) + (FLOAT- (pt-y p1) (pt-y p2)) + (FLOAT- (pt-z p1) (pt-z p2)))) + +(define (pt-dist p1 p2) + (let ((dx (FLOAT- (pt-x p1) (pt-x p2))) + (dy (FLOAT- (pt-y p1) (pt-y p2))) + (dz (FLOAT- (pt-z p1) (pt-z p2)))) + (FLOATsqrt (FLOAT+ (FLOAT* dx dx) (FLOAT* dy dy) (FLOAT* dz dz))))) + +(define (pt-phi p) + (let* ((x (pt-x p)) + (y (pt-y p)) + (z (pt-z p)) + (b (math-atan2 x z))) + (math-atan2 (FLOAT+ (FLOAT* (FLOATcos b) z) (FLOAT* (FLOATsin b) x)) y))) + +(define (pt-theta p) + (math-atan2 (pt-x p) (pt-z p))) + +; -- COORDINATE TRANSFORMATIONS ----------------------------------------------- + +; The notation for the transformations follows "Paul, R.P. (1981) Robot +; Manipulators. MIT Press." with the exception that our transformation +; matrices don't have the perspective terms and are the transpose of +; Paul's one. See also "M\"antyl\"a, M. (1985) An Introduction to +; Solid Modeling, Computer Science Press" Appendix A. +; +; The components of a transformation matrix are named like this: +; +; a b c +; d e f +; g h i +; tx ty tz +; +; The components tx, ty, and tz are the translation vector. + +(define tfo-id ; the identity transformation matrix + '#(1.0 0.0 0.0 + 0.0 1.0 0.0 + 0.0 0.0 1.0 + 0.0 0.0 0.0)) + +; The function "tfo-apply" multiplies a transformation matrix, tfo, by a +; point vector, p. The result is a new point. + +(define (tfo-apply tfo p) + (let ((x (pt-x p)) + (y (pt-y p)) + (z (pt-z p))) + (make-pt + (FLOAT+ (FLOAT* x (tfo-a tfo)) + (FLOAT* y (tfo-d tfo)) + (FLOAT* z (tfo-g tfo)) + (tfo-tx tfo)) + (FLOAT+ (FLOAT* x (tfo-b tfo)) + (FLOAT* y (tfo-e tfo)) + (FLOAT* z (tfo-h tfo)) + (tfo-ty tfo)) + (FLOAT+ (FLOAT* x (tfo-c tfo)) + (FLOAT* y (tfo-f tfo)) + (FLOAT* z (tfo-i tfo)) + (tfo-tz tfo))))) + +; The function "tfo-combine" multiplies two transformation matrices A and B. +; The result is a new matrix which cumulates the transformations described +; by A and B. + +(define (tfo-combine A B) + (make-tfo + (FLOAT+ (FLOAT* (tfo-a A) (tfo-a B)) + (FLOAT* (tfo-b A) (tfo-d B)) + (FLOAT* (tfo-c A) (tfo-g B))) + (FLOAT+ (FLOAT* (tfo-a A) (tfo-b B)) + (FLOAT* (tfo-b A) (tfo-e B)) + (FLOAT* (tfo-c A) (tfo-h B))) + (FLOAT+ (FLOAT* (tfo-a A) (tfo-c B)) + (FLOAT* (tfo-b A) (tfo-f B)) + (FLOAT* (tfo-c A) (tfo-i B))) + (FLOAT+ (FLOAT* (tfo-d A) (tfo-a B)) + (FLOAT* (tfo-e A) (tfo-d B)) + (FLOAT* (tfo-f A) (tfo-g B))) + (FLOAT+ (FLOAT* (tfo-d A) (tfo-b B)) + (FLOAT* (tfo-e A) (tfo-e B)) + (FLOAT* (tfo-f A) (tfo-h B))) + (FLOAT+ (FLOAT* (tfo-d A) (tfo-c B)) + (FLOAT* (tfo-e A) (tfo-f B)) + (FLOAT* (tfo-f A) (tfo-i B))) + (FLOAT+ (FLOAT* (tfo-g A) (tfo-a B)) + (FLOAT* (tfo-h A) (tfo-d B)) + (FLOAT* (tfo-i A) (tfo-g B))) + (FLOAT+ (FLOAT* (tfo-g A) (tfo-b B)) + (FLOAT* (tfo-h A) (tfo-e B)) + (FLOAT* (tfo-i A) (tfo-h B))) + (FLOAT+ (FLOAT* (tfo-g A) (tfo-c B)) + (FLOAT* (tfo-h A) (tfo-f B)) + (FLOAT* (tfo-i A) (tfo-i B))) + (FLOAT+ (FLOAT* (tfo-tx A) (tfo-a B)) + (FLOAT* (tfo-ty A) (tfo-d B)) + (FLOAT* (tfo-tz A) (tfo-g B)) + (tfo-tx B)) + (FLOAT+ (FLOAT* (tfo-tx A) (tfo-b B)) + (FLOAT* (tfo-ty A) (tfo-e B)) + (FLOAT* (tfo-tz A) (tfo-h B)) + (tfo-ty B)) + (FLOAT+ (FLOAT* (tfo-tx A) (tfo-c B)) + (FLOAT* (tfo-ty A) (tfo-f B)) + (FLOAT* (tfo-tz A) (tfo-i B)) + (tfo-tz B)))) + +; The function "tfo-inv-ortho" computes the inverse of a homogeneous +; transformation matrix. + +(define (tfo-inv-ortho tfo) + (let* ((tx (tfo-tx tfo)) + (ty (tfo-ty tfo)) + (tz (tfo-tz tfo))) + (make-tfo + (tfo-a tfo) (tfo-d tfo) (tfo-g tfo) + (tfo-b tfo) (tfo-e tfo) (tfo-h tfo) + (tfo-c tfo) (tfo-f tfo) (tfo-i tfo) + (FLOAT- (FLOAT+ (FLOAT* (tfo-a tfo) tx) + (FLOAT* (tfo-b tfo) ty) + (FLOAT* (tfo-c tfo) tz))) + (FLOAT- (FLOAT+ (FLOAT* (tfo-d tfo) tx) + (FLOAT* (tfo-e tfo) ty) + (FLOAT* (tfo-f tfo) tz))) + (FLOAT- (FLOAT+ (FLOAT* (tfo-g tfo) tx) + (FLOAT* (tfo-h tfo) ty) + (FLOAT* (tfo-i tfo) tz)))))) + +; Given three points p1, p2, and p3, the function "tfo-align" computes +; a transformation matrix such that point p1 gets mapped to (0,0,0), p2 gets +; mapped to the Y axis and p3 gets mapped to the YZ plane. + +(define (tfo-align p1 p2 p3) + (let* ((x1 (pt-x p1)) (y1 (pt-y p1)) (z1 (pt-z p1)) + (x3 (pt-x p3)) (y3 (pt-y p3)) (z3 (pt-z p3)) + (x31 (FLOAT- x3 x1)) (y31 (FLOAT- y3 y1)) (z31 (FLOAT- z3 z1)) + (rotpY (pt-sub p2 p1)) + (Phi (pt-phi rotpY)) + (Theta (pt-theta rotpY)) + (sinP (FLOATsin Phi)) + (sinT (FLOATsin Theta)) + (cosP (FLOATcos Phi)) + (cosT (FLOATcos Theta)) + (sinPsinT (FLOAT* sinP sinT)) + (sinPcosT (FLOAT* sinP cosT)) + (cosPsinT (FLOAT* cosP sinT)) + (cosPcosT (FLOAT* cosP cosT)) + (rotpZ + (make-pt + (FLOAT- (FLOAT* cosT x31) + (FLOAT* sinT z31)) + (FLOAT+ (FLOAT* sinPsinT x31) + (FLOAT* cosP y31) + (FLOAT* sinPcosT z31)) + (FLOAT+ (FLOAT* cosPsinT x31) + (FLOAT- (FLOAT* sinP y31)) + (FLOAT* cosPcosT z31)))) + (Rho (pt-theta rotpZ)) + (cosR (FLOATcos Rho)) + (sinR (FLOATsin Rho)) + (x (FLOAT+ (FLOAT- (FLOAT* x1 cosT)) + (FLOAT* z1 sinT))) + (y (FLOAT- (FLOAT- (FLOAT- (FLOAT* x1 sinPsinT)) + (FLOAT* y1 cosP)) + (FLOAT* z1 sinPcosT))) + (z (FLOAT- (FLOAT+ (FLOAT- (FLOAT* x1 cosPsinT)) + (FLOAT* y1 sinP)) + (FLOAT* z1 cosPcosT)))) + (make-tfo + (FLOAT- (FLOAT* cosT cosR) (FLOAT* cosPsinT sinR)) + sinPsinT + (FLOAT+ (FLOAT* cosT sinR) (FLOAT* cosPsinT cosR)) + (FLOAT* sinP sinR) + cosP + (FLOAT- (FLOAT* sinP cosR)) + (FLOAT- (FLOAT- (FLOAT* sinT cosR)) (FLOAT* cosPcosT sinR)) + sinPcosT + (FLOAT+ (FLOAT- (FLOAT* sinT sinR)) (FLOAT* cosPcosT cosR)) + (FLOAT- (FLOAT* x cosR) (FLOAT* z sinR)) + y + (FLOAT+ (FLOAT* x sinR) (FLOAT* z cosR))))) + +; -- NUCLEIC ACID CONFORMATIONS DATA BASE ------------------------------------- + +; Numbering of atoms follows the paper: +; +; IUPAC-IUB Joint Commission on Biochemical Nomenclature (JCBN) +; (1983) Abbreviations and Symbols for the Description of +; Conformations of Polynucleotide Chains. Eur. J. Biochem 131, +; 9-15. +; +; In the atom names, we have used "*" instead of "'". + +; Define part common to all 4 nucleotide types. + +; Define remaining atoms for each nucleotide type. + +; Database of nucleotide conformations: + +(define rA + (make-constant-rA + #( -0.0018 -0.8207 0.5714 ; dgf-base-tfo + 0.2679 -0.5509 -0.7904 + 0.9634 0.1517 0.2209 + 0.0073 8.4030 0.6232) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 5.4550 8.2120 -2.8810) ; C5* + #( 5.4546 8.8508 -1.9978) ; H5* + #( 5.7588 8.6625 -3.8259) ; H5** + #( 6.4970 7.1480 -2.5980) ; C4* + #( 7.4896 7.5919 -2.5214) ; H4* + #( 6.1630 6.4860 -1.3440) ; O4* + #( 6.5400 5.1200 -1.4190) ; C1* + #( 7.2763 4.9681 -0.6297) ; H1* + #( 7.1940 4.8830 -2.7770) ; C2* + #( 6.8667 3.9183 -3.1647) ; H2** + #( 8.5860 5.0910 -2.6140) ; O2* + #( 8.9510 4.7626 -1.7890) ; H2* + #( 6.5720 6.0040 -3.6090) ; C3* + #( 5.5636 5.7066 -3.8966) ; H3* + #( 7.3801 6.3562 -4.7350) ; O3* + #( 4.7150 0.4910 -0.1360) ; N1 + #( 6.3490 2.1730 -0.6020) ; N3 + #( 5.9530 0.9650 -0.2670) ; C2 + #( 5.2900 2.9790 -0.8260) ; C4 + #( 3.9720 2.6390 -0.7330) ; C5 + #( 3.6770 1.3160 -0.3660) ; C6 + #( 2.4280 0.8450 -0.2360) ; N6 + #( 3.1660 3.7290 -1.0360) ; N7 + #( 5.3170 4.2990 -1.1930) ; N9 + #( 4.0100 4.6780 -1.2990) ; C8 + #( 6.6890 0.1903 -0.0518) ; H2 + #( 1.6470 1.4460 -0.4040) ; H61 + #( 2.2780 -0.1080 -0.0280) ; H62 + #( 3.4421 5.5744 -1.5482) ; H8 + )) + +(define rA01 + (make-constant-rA + #( -0.0043 -0.8175 0.5759 ; dgf-base-tfo + 0.2617 -0.5567 -0.7884 + 0.9651 0.1473 0.2164 + 0.0359 8.3929 0.5532) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 5.4352 8.2183 -2.7757) ; C5* + #( 5.3830 8.7883 -1.8481) ; H5* + #( 5.7729 8.7436 -3.6691) ; H5** + #( 6.4830 7.1518 -2.5252) ; C4* + #( 7.4749 7.5972 -2.4482) ; H4* + #( 6.1626 6.4620 -1.2827) ; O4* + #( 6.5431 5.0992 -1.3905) ; C1* + #( 7.2871 4.9328 -0.6114) ; H1* + #( 7.1852 4.8935 -2.7592) ; C2* + #( 6.8573 3.9363 -3.1645) ; H2** + #( 8.5780 5.1025 -2.6046) ; O2* + #( 8.9516 4.7577 -1.7902) ; H2* + #( 6.5522 6.0300 -3.5612) ; C3* + #( 5.5420 5.7356 -3.8459) ; H3* + #( 7.3487 6.4089 -4.6867) ; O3* + #( 4.7442 0.4514 -0.1390) ; N1 + #( 6.3687 2.1459 -0.5926) ; N3 + #( 5.9795 0.9335 -0.2657) ; C2 + #( 5.3052 2.9471 -0.8125) ; C4 + #( 3.9891 2.5987 -0.7230) ; C5 + #( 3.7016 1.2717 -0.3647) ; C6 + #( 2.4553 0.7925 -0.2390) ; N6 + #( 3.1770 3.6859 -1.0198) ; N7 + #( 5.3247 4.2695 -1.1710) ; N9 + #( 4.0156 4.6415 -1.2759) ; C8 + #( 6.7198 0.1618 -0.0547) ; H2 + #( 1.6709 1.3900 -0.4039) ; H61 + #( 2.3107 -0.1627 -0.0373) ; H62 + #( 3.4426 5.5361 -1.5199) ; H8 + )) + +(define rA02 + (make-constant-rA + #( 0.5566 0.0449 0.8296 ; dgf-base-tfo + 0.5125 0.7673 -0.3854 + -0.6538 0.6397 0.4041 + -9.1161 -3.7679 -2.9968) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.5778 6.6594 -4.0364) ; C5* + #( 4.9220 7.1963 -4.9204) ; H5* + #( 3.7996 5.9091 -4.1764) ; H5** + #( 5.7873 5.8869 -3.5482) ; C4* + #( 6.0405 5.0875 -4.2446) ; H4* + #( 6.9135 6.8036 -3.4310) ; O4* + #( 7.7293 6.4084 -2.3392) ; C1* + #( 8.7078 6.1815 -2.7624) ; H1* + #( 7.1305 5.1418 -1.7347) ; C2* + #( 7.2040 5.1982 -0.6486) ; H2** + #( 7.7417 4.0392 -2.3813) ; O2* + #( 8.6785 4.1443 -2.5630) ; H2* + #( 5.6666 5.2728 -2.1536) ; C3* + #( 5.1747 5.9805 -1.4863) ; H3* + #( 4.9997 4.0086 -2.1973) ; O3* + #( 10.3245 8.5459 1.5467) ; N1 + #( 9.8051 6.9432 -0.1497) ; N3 + #( 10.5175 7.4328 0.8408) ; C2 + #( 8.7523 7.7422 -0.4228) ; C4 + #( 8.4257 8.9060 0.2099) ; C5 + #( 9.2665 9.3242 1.2540) ; C6 + #( 9.0664 10.4462 1.9610) ; N6 + #( 7.2750 9.4537 -0.3428) ; N7 + #( 7.7962 7.5519 -1.3859) ; N9 + #( 6.9479 8.6157 -1.2771) ; C8 + #( 11.4063 6.9047 1.1859) ; H2 + #( 8.2845 11.0341 1.7552) ; H61 + #( 9.6584 10.6647 2.7198) ; H62 + #( 6.0430 8.9853 -1.7594) ; H8 + )) + +(define rA03 + (make-constant-rA + #( -0.5021 0.0731 0.8617 ; dgf-base-tfo + -0.8112 0.3054 -0.4986 + -0.2996 -0.9494 -0.0940 + 6.4273 -5.1944 -3.7807) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.1214 6.7116 -1.9049) ; C5* + #( 3.3465 5.9610 -2.0607) ; H5* + #( 4.0789 7.2928 -0.9837) ; H5** + #( 5.4170 5.9293 -1.8186) ; C4* + #( 5.4506 5.3400 -0.9023) ; H4* + #( 5.5067 5.0417 -2.9703) ; O4* + #( 6.8650 4.9152 -3.3612) ; C1* + #( 7.1090 3.8577 -3.2603) ; H1* + #( 7.7152 5.7282 -2.3894) ; C2* + #( 8.5029 6.2356 -2.9463) ; H2** + #( 8.1036 4.8568 -1.3419) ; O2* + #( 8.3270 3.9651 -1.6184) ; H2* + #( 6.7003 6.7565 -1.8911) ; C3* + #( 6.5898 7.5329 -2.6482) ; H3* + #( 7.0505 7.2878 -0.6105) ; O3* + #( 9.6740 4.7656 -7.6614) ; N1 + #( 9.0739 4.3013 -5.3941) ; N3 + #( 9.8416 4.2192 -6.4581) ; C2 + #( 7.9885 5.0632 -5.6446) ; C4 + #( 7.6822 5.6856 -6.8194) ; C5 + #( 8.5831 5.5215 -7.8840) ; C6 + #( 8.4084 6.0747 -9.0933) ; N6 + #( 6.4857 6.3816 -6.7035) ; N7 + #( 6.9740 5.3703 -4.7760) ; N9 + #( 6.1133 6.1613 -5.4808) ; C8 + #( 10.7627 3.6375 -6.4220) ; H2 + #( 7.6031 6.6390 -9.2733) ; H61 + #( 9.1004 5.9708 -9.7893) ; H62 + #( 5.1705 6.6830 -5.3167) ; H8 + )) + +(define rA04 + (make-constant-rA + #( -0.5426 -0.8175 0.1929 ; dgf-base-tfo + 0.8304 -0.5567 -0.0237 + 0.1267 0.1473 0.9809 + -0.5075 8.3929 0.2229) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 5.4352 8.2183 -2.7757) ; C5* + #( 5.3830 8.7883 -1.8481) ; H5* + #( 5.7729 8.7436 -3.6691) ; H5** + #( 6.4830 7.1518 -2.5252) ; C4* + #( 7.4749 7.5972 -2.4482) ; H4* + #( 6.1626 6.4620 -1.2827) ; O4* + #( 6.5431 5.0992 -1.3905) ; C1* + #( 7.2871 4.9328 -0.6114) ; H1* + #( 7.1852 4.8935 -2.7592) ; C2* + #( 6.8573 3.9363 -3.1645) ; H2** + #( 8.5780 5.1025 -2.6046) ; O2* + #( 8.9516 4.7577 -1.7902) ; H2* + #( 6.5522 6.0300 -3.5612) ; C3* + #( 5.5420 5.7356 -3.8459) ; H3* + #( 7.3487 6.4089 -4.6867) ; O3* + #( 3.6343 2.6680 2.0783) ; N1 + #( 5.4505 3.9805 1.2446) ; N3 + #( 4.7540 3.3816 2.1851) ; C2 + #( 4.8805 3.7951 0.0354) ; C4 + #( 3.7416 3.0925 -0.2305) ; C5 + #( 3.0873 2.4980 0.8606) ; C6 + #( 1.9600 1.7805 0.7462) ; N6 + #( 3.4605 3.1184 -1.5906) ; N7 + #( 5.3247 4.2695 -1.1710) ; N9 + #( 4.4244 3.8244 -2.0953) ; C8 + #( 5.0814 3.4352 3.2234) ; H2 + #( 1.5423 1.6454 -0.1520) ; H61 + #( 1.5716 1.3398 1.5392) ; H62 + #( 4.2675 3.8876 -3.1721) ; H8 + )) + +(define rA05 + (make-constant-rA + #( -0.5891 0.0449 0.8068 ; dgf-base-tfo + 0.5375 0.7673 0.3498 + -0.6034 0.6397 -0.4762 + -0.3019 -3.7679 -9.5913) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.5778 6.6594 -4.0364) ; C5* + #( 4.9220 7.1963 -4.9204) ; H5* + #( 3.7996 5.9091 -4.1764) ; H5** + #( 5.7873 5.8869 -3.5482) ; C4* + #( 6.0405 5.0875 -4.2446) ; H4* + #( 6.9135 6.8036 -3.4310) ; O4* + #( 7.7293 6.4084 -2.3392) ; C1* + #( 8.7078 6.1815 -2.7624) ; H1* + #( 7.1305 5.1418 -1.7347) ; C2* + #( 7.2040 5.1982 -0.6486) ; H2** + #( 7.7417 4.0392 -2.3813) ; O2* + #( 8.6785 4.1443 -2.5630) ; H2* + #( 5.6666 5.2728 -2.1536) ; C3* + #( 5.1747 5.9805 -1.4863) ; H3* + #( 4.9997 4.0086 -2.1973) ; O3* + #( 10.2594 10.6774 -1.0056) ; N1 + #( 9.7528 8.7080 -2.2631) ; N3 + #( 10.4471 9.7876 -1.9791) ; C2 + #( 8.7271 8.5575 -1.3991) ; C4 + #( 8.4100 9.3803 -0.3580) ; C5 + #( 9.2294 10.5030 -0.1574) ; C6 + #( 9.0349 11.3951 0.8250) ; N6 + #( 7.2891 8.9068 0.3121) ; N7 + #( 7.7962 7.5519 -1.3859) ; N9 + #( 6.9702 7.8292 -0.3353) ; C8 + #( 11.3132 10.0537 -2.5851) ; H2 + #( 8.2741 11.2784 1.4629) ; H61 + #( 9.6733 12.1368 0.9529) ; H62 + #( 6.0888 7.3990 0.1403) ; H8 + )) + +(define rA06 + (make-constant-rA + #( -0.9815 0.0731 -0.1772 ; dgf-base-tfo + 0.1912 0.3054 -0.9328 + -0.0141 -0.9494 -0.3137 + 5.7506 -5.1944 4.7470) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.1214 6.7116 -1.9049) ; C5* + #( 3.3465 5.9610 -2.0607) ; H5* + #( 4.0789 7.2928 -0.9837) ; H5** + #( 5.4170 5.9293 -1.8186) ; C4* + #( 5.4506 5.3400 -0.9023) ; H4* + #( 5.5067 5.0417 -2.9703) ; O4* + #( 6.8650 4.9152 -3.3612) ; C1* + #( 7.1090 3.8577 -3.2603) ; H1* + #( 7.7152 5.7282 -2.3894) ; C2* + #( 8.5029 6.2356 -2.9463) ; H2** + #( 8.1036 4.8568 -1.3419) ; O2* + #( 8.3270 3.9651 -1.6184) ; H2* + #( 6.7003 6.7565 -1.8911) ; C3* + #( 6.5898 7.5329 -2.6482) ; H3* + #( 7.0505 7.2878 -0.6105) ; O3* + #( 6.6624 3.5061 -8.2986) ; N1 + #( 6.5810 3.2570 -5.9221) ; N3 + #( 6.5151 2.8263 -7.1625) ; C2 + #( 6.8364 4.5817 -5.8882) ; C4 + #( 7.0116 5.4064 -6.9609) ; C5 + #( 6.9173 4.8260 -8.2361) ; C6 + #( 7.0668 5.5163 -9.3763) ; N6 + #( 7.2573 6.7070 -6.5394) ; N7 + #( 6.9740 5.3703 -4.7760) ; N9 + #( 7.2238 6.6275 -5.2453) ; C8 + #( 6.3146 1.7741 -7.3641) ; H2 + #( 7.2568 6.4972 -9.3456) ; H61 + #( 7.0437 5.0478 -10.2446) ; H62 + #( 7.4108 7.6227 -4.8418) ; H8 + )) + +(define rA07 + (make-constant-rA + #( 0.2379 0.1310 -0.9624 ; dgf-base-tfo + -0.5876 -0.7696 -0.2499 + -0.7734 0.6249 -0.1061 + 30.9870 -26.9344 42.6416) + #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo + 0.2952 -0.9481 -0.1180 + 0.5882 0.2777 -0.7595 + -58.8919 -11.3095 6.0866) + #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo + 0.9731 -0.0359 -0.2275 + -0.2290 -0.2532 -0.9399 + 3.5401 -29.7913 52.2796) + #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo + -0.1183 0.1805 -0.9764 + 0.4380 -0.8730 -0.2145 + 19.9023 54.8054 15.2799) + #( 41.8210 8.3880 43.5890) ; P + #( 42.5400 8.0450 44.8330) ; O1P + #( 42.2470 9.6920 42.9910) ; O2P + #( 40.2550 8.2030 43.7340) ; O5* + #( 39.3505 8.4697 42.6565) ; C5* + #( 39.1377 7.5433 42.1230) ; H5* + #( 39.7203 9.3119 42.0717) ; H5** + #( 38.0405 8.9195 43.2869) ; C4* + #( 37.3687 9.3036 42.5193) ; H4* + #( 37.4319 7.8146 43.9387) ; O4* + #( 37.1959 8.1354 45.3237) ; C1* + #( 36.1788 8.5202 45.3970) ; H1* + #( 38.1721 9.2328 45.6504) ; C2* + #( 39.1555 8.7939 45.8188) ; H2** + #( 37.7862 10.0617 46.7013) ; O2* + #( 37.3087 9.6229 47.4092) ; H2* + #( 38.1844 10.0268 44.3367) ; C3* + #( 39.1578 10.5054 44.2289) ; H3* + #( 37.0547 10.9127 44.3441) ; O3* + #( 34.8811 4.2072 47.5784) ; N1 + #( 35.1084 6.1336 46.1818) ; N3 + #( 34.4108 5.1360 46.7207) ; C2 + #( 36.3908 6.1224 46.6053) ; C4 + #( 36.9819 5.2334 47.4697) ; C5 + #( 36.1786 4.1985 48.0035) ; C6 + #( 36.6103 3.2749 48.8452) ; N6 + #( 38.3236 5.5522 47.6595) ; N7 + #( 37.3887 7.0024 46.2437) ; N9 + #( 38.5055 6.6096 46.9057) ; C8 + #( 33.3553 5.0152 46.4771) ; H2 + #( 37.5730 3.2804 49.1507) ; H61 + #( 35.9775 2.5638 49.1828) ; H62 + #( 39.5461 6.9184 47.0041) ; H8 + )) + +(define rA08 + (make-constant-rA + #( 0.1084 -0.0895 -0.9901 ; dgf-base-tfo + 0.9789 -0.1638 0.1220 + -0.1731 -0.9824 0.0698 + -2.9039 47.2655 33.0094) + #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo + 0.2952 -0.9481 -0.1180 + 0.5882 0.2777 -0.7595 + -58.8919 -11.3095 6.0866) + #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo + 0.9731 -0.0359 -0.2275 + -0.2290 -0.2532 -0.9399 + 3.5401 -29.7913 52.2796) + #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo + -0.1183 0.1805 -0.9764 + 0.4380 -0.8730 -0.2145 + 19.9023 54.8054 15.2799) + #( 41.8210 8.3880 43.5890) ; P + #( 42.5400 8.0450 44.8330) ; O1P + #( 42.2470 9.6920 42.9910) ; O2P + #( 40.2550 8.2030 43.7340) ; O5* + #( 39.4850 8.9301 44.6977) ; C5* + #( 39.0638 9.8199 44.2296) ; H5* + #( 40.0757 9.0713 45.6029) ; H5** + #( 38.3102 8.0414 45.0789) ; C4* + #( 37.7842 8.4637 45.9351) ; H4* + #( 37.4200 7.9453 43.9769) ; O4* + #( 37.2249 6.5609 43.6273) ; C1* + #( 36.3360 6.2168 44.1561) ; H1* + #( 38.4347 5.8414 44.1590) ; C2* + #( 39.2688 5.9974 43.4749) ; H2** + #( 38.2344 4.4907 44.4348) ; O2* + #( 37.6374 4.0386 43.8341) ; H2* + #( 38.6926 6.6079 45.4637) ; C3* + #( 39.7585 6.5640 45.6877) ; H3* + #( 37.8238 6.0705 46.4723) ; O3* + #( 33.9162 6.2598 39.7758) ; N1 + #( 34.6709 6.5759 42.0215) ; N3 + #( 33.7257 6.5186 41.0858) ; C2 + #( 35.8935 6.3324 41.5018) ; C4 + #( 36.2105 6.0601 40.1932) ; C5 + #( 35.1538 6.0151 39.2537) ; C6 + #( 35.3088 5.7642 37.9649) ; N6 + #( 37.5818 5.8677 40.0507) ; N7 + #( 37.0932 6.3197 42.1810) ; N9 + #( 38.0509 6.0354 41.2635) ; C8 + #( 32.6830 6.6898 41.3532) ; H2 + #( 36.2305 5.5855 37.5925) ; H61 + #( 34.5056 5.7512 37.3528) ; H62 + #( 39.1318 5.8993 41.2285) ; H8 + )) + +(define rA09 + (make-constant-rA + #( 0.8467 0.4166 -0.3311 ; dgf-base-tfo + -0.3962 0.9089 0.1303 + 0.3552 0.0209 0.9346 + -42.7319 -26.6223 -29.8163) + #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo + 0.2952 -0.9481 -0.1180 + 0.5882 0.2777 -0.7595 + -58.8919 -11.3095 6.0866) + #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo + 0.9731 -0.0359 -0.2275 + -0.2290 -0.2532 -0.9399 + 3.5401 -29.7913 52.2796) + #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo + -0.1183 0.1805 -0.9764 + 0.4380 -0.8730 -0.2145 + 19.9023 54.8054 15.2799) + #( 41.8210 8.3880 43.5890) ; P + #( 42.5400 8.0450 44.8330) ; O1P + #( 42.2470 9.6920 42.9910) ; O2P + #( 40.2550 8.2030 43.7340) ; O5* + #( 39.3505 8.4697 42.6565) ; C5* + #( 39.1377 7.5433 42.1230) ; H5* + #( 39.7203 9.3119 42.0717) ; H5** + #( 38.0405 8.9195 43.2869) ; C4* + #( 37.6479 8.1347 43.9335) ; H4* + #( 38.2691 10.0933 44.0524) ; O4* + #( 37.3999 11.1488 43.5973) ; C1* + #( 36.5061 11.1221 44.2206) ; H1* + #( 37.0364 10.7838 42.1836) ; C2* + #( 37.8636 11.0489 41.5252) ; H2** + #( 35.8275 11.3133 41.7379) ; O2* + #( 35.6214 12.1896 42.0714) ; H2* + #( 36.9316 9.2556 42.2837) ; C3* + #( 37.1778 8.8260 41.3127) ; H3* + #( 35.6285 8.9334 42.7926) ; O3* + #( 38.1482 15.2833 46.4641) ; N1 + #( 37.3641 13.0968 45.9007) ; N3 + #( 37.5032 14.1288 46.7300) ; C2 + #( 37.9570 13.3377 44.7113) ; C4 + #( 38.6397 14.4660 44.3267) ; C5 + #( 38.7473 15.5229 45.2609) ; C6 + #( 39.3720 16.6649 45.0297) ; N6 + #( 39.1079 14.3351 43.0223) ; N7 + #( 38.0132 12.4868 43.6280) ; N9 + #( 38.7058 13.1402 42.6620) ; C8 + #( 37.0731 14.0857 47.7306) ; H2 + #( 39.8113 16.8281 44.1350) ; H61 + #( 39.4100 17.3741 45.7478) ; H62 + #( 39.0412 12.9660 41.6397) ; H8 + )) + +(define rA10 + (make-constant-rA + #( 0.7063 0.6317 -0.3196 ; dgf-base-tfo + -0.0403 -0.4149 -0.9090 + -0.7068 0.6549 -0.2676 + 6.4402 -52.1496 30.8246) + #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo + 0.2952 -0.9481 -0.1180 + 0.5882 0.2777 -0.7595 + -58.8919 -11.3095 6.0866) + #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo + 0.9731 -0.0359 -0.2275 + -0.2290 -0.2532 -0.9399 + 3.5401 -29.7913 52.2796) + #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo + -0.1183 0.1805 -0.9764 + 0.4380 -0.8730 -0.2145 + 19.9023 54.8054 15.2799) + #( 41.8210 8.3880 43.5890) ; P + #( 42.5400 8.0450 44.8330) ; O1P + #( 42.2470 9.6920 42.9910) ; O2P + #( 40.2550 8.2030 43.7340) ; O5* + #( 39.4850 8.9301 44.6977) ; C5* + #( 39.0638 9.8199 44.2296) ; H5* + #( 40.0757 9.0713 45.6029) ; H5** + #( 38.3102 8.0414 45.0789) ; C4* + #( 37.7099 7.8166 44.1973) ; H4* + #( 38.8012 6.8321 45.6380) ; O4* + #( 38.2431 6.6413 46.9529) ; C1* + #( 37.3505 6.0262 46.8385) ; H1* + #( 37.8484 8.0156 47.4214) ; C2* + #( 38.7381 8.5406 47.7690) ; H2** + #( 36.8286 8.0368 48.3701) ; O2* + #( 36.8392 7.3063 48.9929) ; H2* + #( 37.3576 8.6512 46.1132) ; C3* + #( 37.5207 9.7275 46.1671) ; H3* + #( 35.9985 8.2392 45.9032) ; O3* + #( 39.9117 2.2278 48.8527) ; N1 + #( 38.6207 3.6941 47.4757) ; N3 + #( 38.9872 2.4888 47.9057) ; C2 + #( 39.2961 4.6720 48.1174) ; C4 + #( 40.2546 4.5307 49.0912) ; C5 + #( 40.5932 3.2189 49.4985) ; C6 + #( 41.4938 2.9317 50.4229) ; N6 + #( 40.7195 5.7755 49.5060) ; N7 + #( 39.1730 6.0305 47.9170) ; N9 + #( 40.0413 6.6250 48.7728) ; C8 + #( 38.5257 1.5960 47.4838) ; H2 + #( 41.9907 3.6753 50.8921) ; H61 + #( 41.6848 1.9687 50.6599) ; H62 + #( 40.3571 7.6321 49.0452) ; H8 + )) + +(define rAs + (list rA01 rA02 rA03 rA04 rA05 rA06 rA07 rA08 rA09 rA10)) + +(define rC + (make-constant-rC + #( -0.0359 -0.8071 0.5894 ; dgf-base-tfo + -0.2669 0.5761 0.7726 + -0.9631 -0.1296 -0.2361 + 0.1584 8.3434 0.5434) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2430 -8.2420 2.8260) ; C5* + #( 5.1974 -8.8497 1.9223) ; H5* + #( 5.5548 -8.7348 3.7469) ; H5** + #( 6.3140 -7.2060 2.5510) ; C4* + #( 7.2954 -7.6762 2.4898) ; H4* + #( 6.0140 -6.5420 1.2890) ; O4* + #( 6.4190 -5.1840 1.3620) ; C1* + #( 7.1608 -5.0495 0.5747) ; H1* + #( 7.0760 -4.9560 2.7270) ; C2* + #( 6.7770 -3.9803 3.1099) ; H2** + #( 8.4500 -5.1930 2.5810) ; O2* + #( 8.8309 -4.8755 1.7590) ; H2* + #( 6.4060 -6.0590 3.5580) ; C3* + #( 5.4021 -5.7313 3.8281) ; H3* + #( 7.1570 -6.4240 4.7070) ; O3* + #( 5.2170 -4.3260 1.1690) ; N1 + #( 4.2960 -2.2560 0.6290) ; N3 + #( 5.4330 -3.0200 0.7990) ; C2 + #( 2.9930 -2.6780 0.7940) ; C4 + #( 2.8670 -4.0630 1.1830) ; C5 + #( 3.9570 -4.8300 1.3550) ; C6 + #( 2.0187 -1.8047 0.5874) ; N4 + #( 6.5470 -2.5560 0.6290) ; O2 + #( 1.0684 -2.1236 0.7109) ; H41 + #( 2.2344 -0.8560 0.3162) ; H42 + #( 1.8797 -4.4972 1.3404) ; H5 + #( 3.8479 -5.8742 1.6480) ; H6 + )) + +(define rC01 + (make-constant-rC + #( -0.0137 -0.8012 0.5983 ; dgf-base-tfo + -0.2523 0.5817 0.7733 + -0.9675 -0.1404 -0.2101 + 0.2031 8.3874 0.4228) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2416 -8.2422 2.8181) ; C5* + #( 5.2050 -8.8128 1.8901) ; H5* + #( 5.5368 -8.7738 3.7227) ; H5** + #( 6.3232 -7.2037 2.6002) ; C4* + #( 7.3048 -7.6757 2.5577) ; H4* + #( 6.0635 -6.5092 1.3456) ; O4* + #( 6.4697 -5.1547 1.4629) ; C1* + #( 7.2354 -5.0043 0.7018) ; H1* + #( 7.0856 -4.9610 2.8521) ; C2* + #( 6.7777 -3.9935 3.2487) ; H2** + #( 8.4627 -5.1992 2.7423) ; O2* + #( 8.8693 -4.8638 1.9399) ; H2* + #( 6.3877 -6.0809 3.6362) ; C3* + #( 5.3770 -5.7562 3.8834) ; H3* + #( 7.1024 -6.4754 4.7985) ; O3* + #( 5.2764 -4.2883 1.2538) ; N1 + #( 4.3777 -2.2062 0.7229) ; N3 + #( 5.5069 -2.9779 0.9088) ; C2 + #( 3.0693 -2.6246 0.8500) ; C4 + #( 2.9279 -4.0146 1.2149) ; C5 + #( 4.0101 -4.7892 1.4017) ; C6 + #( 2.1040 -1.7437 0.6331) ; N4 + #( 6.6267 -2.5166 0.7728) ; O2 + #( 1.1496 -2.0600 0.7287) ; H41 + #( 2.3303 -0.7921 0.3815) ; H42 + #( 1.9353 -4.4465 1.3419) ; H5 + #( 3.8895 -5.8371 1.6762) ; H6 + )) + +(define rC02 + (make-constant-rC + #( 0.5141 0.0246 0.8574 ; dgf-base-tfo + -0.5547 -0.7529 0.3542 + 0.6542 -0.6577 -0.3734 + -9.1111 -3.4598 -3.2939) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 4.3825 -6.6585 4.0489) ; C5* + #( 4.6841 -7.2019 4.9443) ; H5* + #( 3.6189 -5.8889 4.1625) ; H5** + #( 5.6255 -5.9175 3.5998) ; C4* + #( 5.8732 -5.1228 4.3034) ; H4* + #( 6.7337 -6.8605 3.5222) ; O4* + #( 7.5932 -6.4923 2.4548) ; C1* + #( 8.5661 -6.2983 2.9064) ; H1* + #( 7.0527 -5.2012 1.8322) ; C2* + #( 7.1627 -5.2525 0.7490) ; H2** + #( 7.6666 -4.1249 2.4880) ; O2* + #( 8.5944 -4.2543 2.6981) ; H2* + #( 5.5661 -5.3029 2.2009) ; C3* + #( 5.0841 -6.0018 1.5172) ; H3* + #( 4.9062 -4.0452 2.2042) ; O3* + #( 7.6298 -7.6136 1.4752) ; N1 + #( 8.6945 -8.7046 -0.2857) ; N3 + #( 8.6943 -7.6514 0.6066) ; C2 + #( 7.7426 -9.6987 -0.3801) ; C4 + #( 6.6642 -9.5742 0.5722) ; C5 + #( 6.6391 -8.5592 1.4526) ; C6 + #( 7.9033 -10.6371 -1.3010) ; N4 + #( 9.5840 -6.8186 0.6136) ; O2 + #( 7.2009 -11.3604 -1.3619) ; H41 + #( 8.7058 -10.6168 -1.9140) ; H42 + #( 5.8585 -10.3083 0.5822) ; H5 + #( 5.8197 -8.4773 2.1667) ; H6 + )) + +(define rC03 + (make-constant-rC + #( -0.4993 0.0476 0.8651 ; dgf-base-tfo + 0.8078 -0.3353 0.4847 + 0.3132 0.9409 0.1290 + 6.2989 -5.2303 -3.8577) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 3.9938 -6.7042 1.9023) ; C5* + #( 3.2332 -5.9343 2.0319) ; H5* + #( 3.9666 -7.2863 0.9812) ; H5** + #( 5.3098 -5.9546 1.8564) ; C4* + #( 5.3863 -5.3702 0.9395) ; H4* + #( 5.3851 -5.0642 3.0076) ; O4* + #( 6.7315 -4.9724 3.4462) ; C1* + #( 7.0033 -3.9202 3.3619) ; H1* + #( 7.5997 -5.8018 2.4948) ; C2* + #( 8.3627 -6.3254 3.0707) ; H2** + #( 8.0410 -4.9501 1.4724) ; O2* + #( 8.2781 -4.0644 1.7570) ; H2* + #( 6.5701 -6.8129 1.9714) ; C3* + #( 6.4186 -7.5809 2.7299) ; H3* + #( 6.9357 -7.3841 0.7235) ; O3* + #( 6.8024 -5.4718 4.8475) ; N1 + #( 7.9218 -5.5700 6.8877) ; N3 + #( 7.8908 -5.0886 5.5944) ; C2 + #( 6.9789 -6.3827 7.4823) ; C4 + #( 5.8742 -6.7319 6.6202) ; C5 + #( 5.8182 -6.2769 5.3570) ; C6 + #( 7.1702 -6.7511 8.7402) ; N4 + #( 8.7747 -4.3728 5.1568) ; O2 + #( 6.4741 -7.3461 9.1662) ; H41 + #( 7.9889 -6.4396 9.2429) ; H42 + #( 5.0736 -7.3713 6.9922) ; H5 + #( 4.9784 -6.5473 4.7170) ; H6 + )) + +(define rC04 + (make-constant-rC + #( -0.5669 -0.8012 0.1918 ; dgf-base-tfo + -0.8129 0.5817 0.0273 + -0.1334 -0.1404 -0.9811 + -0.3279 8.3874 0.3355) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2416 -8.2422 2.8181) ; C5* + #( 5.2050 -8.8128 1.8901) ; H5* + #( 5.5368 -8.7738 3.7227) ; H5** + #( 6.3232 -7.2037 2.6002) ; C4* + #( 7.3048 -7.6757 2.5577) ; H4* + #( 6.0635 -6.5092 1.3456) ; O4* + #( 6.4697 -5.1547 1.4629) ; C1* + #( 7.2354 -5.0043 0.7018) ; H1* + #( 7.0856 -4.9610 2.8521) ; C2* + #( 6.7777 -3.9935 3.2487) ; H2** + #( 8.4627 -5.1992 2.7423) ; O2* + #( 8.8693 -4.8638 1.9399) ; H2* + #( 6.3877 -6.0809 3.6362) ; C3* + #( 5.3770 -5.7562 3.8834) ; H3* + #( 7.1024 -6.4754 4.7985) ; O3* + #( 5.2764 -4.2883 1.2538) ; N1 + #( 3.8961 -3.0896 -0.1893) ; N3 + #( 5.0095 -3.8907 -0.0346) ; C2 + #( 3.0480 -2.6632 0.8116) ; C4 + #( 3.4093 -3.1310 2.1292) ; C5 + #( 4.4878 -3.9124 2.3088) ; C6 + #( 2.0216 -1.8941 0.4804) ; N4 + #( 5.7005 -4.2164 -0.9842) ; O2 + #( 1.4067 -1.5873 1.2205) ; H41 + #( 1.8721 -1.6319 -0.4835) ; H42 + #( 2.8048 -2.8507 2.9918) ; H5 + #( 4.7491 -4.2593 3.3085) ; H6 + )) + +(define rC05 + (make-constant-rC + #( -0.6298 0.0246 0.7763 ; dgf-base-tfo + -0.5226 -0.7529 -0.4001 + 0.5746 -0.6577 0.4870 + -0.0208 -3.4598 -9.6882) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 4.3825 -6.6585 4.0489) ; C5* + #( 4.6841 -7.2019 4.9443) ; H5* + #( 3.6189 -5.8889 4.1625) ; H5** + #( 5.6255 -5.9175 3.5998) ; C4* + #( 5.8732 -5.1228 4.3034) ; H4* + #( 6.7337 -6.8605 3.5222) ; O4* + #( 7.5932 -6.4923 2.4548) ; C1* + #( 8.5661 -6.2983 2.9064) ; H1* + #( 7.0527 -5.2012 1.8322) ; C2* + #( 7.1627 -5.2525 0.7490) ; H2** + #( 7.6666 -4.1249 2.4880) ; O2* + #( 8.5944 -4.2543 2.6981) ; H2* + #( 5.5661 -5.3029 2.2009) ; C3* + #( 5.0841 -6.0018 1.5172) ; H3* + #( 4.9062 -4.0452 2.2042) ; O3* + #( 7.6298 -7.6136 1.4752) ; N1 + #( 8.5977 -9.5977 0.7329) ; N3 + #( 8.5951 -8.5745 1.6594) ; C2 + #( 7.7372 -9.7371 -0.3364) ; C4 + #( 6.7596 -8.6801 -0.4476) ; C5 + #( 6.7338 -7.6721 0.4408) ; C6 + #( 7.8849 -10.7881 -1.1289) ; N4 + #( 9.3993 -8.5377 2.5743) ; O2 + #( 7.2499 -10.8809 -1.9088) ; H41 + #( 8.6122 -11.4649 -0.9468) ; H42 + #( 6.0317 -8.6941 -1.2588) ; H5 + #( 5.9901 -6.8809 0.3459) ; H6 + )) + +(define rC06 + (make-constant-rC + #( -0.9837 0.0476 -0.1733 ; dgf-base-tfo + -0.1792 -0.3353 0.9249 + -0.0141 0.9409 0.3384 + 5.7793 -5.2303 4.5997) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 3.9938 -6.7042 1.9023) ; C5* + #( 3.2332 -5.9343 2.0319) ; H5* + #( 3.9666 -7.2863 0.9812) ; H5** + #( 5.3098 -5.9546 1.8564) ; C4* + #( 5.3863 -5.3702 0.9395) ; H4* + #( 5.3851 -5.0642 3.0076) ; O4* + #( 6.7315 -4.9724 3.4462) ; C1* + #( 7.0033 -3.9202 3.3619) ; H1* + #( 7.5997 -5.8018 2.4948) ; C2* + #( 8.3627 -6.3254 3.0707) ; H2** + #( 8.0410 -4.9501 1.4724) ; O2* + #( 8.2781 -4.0644 1.7570) ; H2* + #( 6.5701 -6.8129 1.9714) ; C3* + #( 6.4186 -7.5809 2.7299) ; H3* + #( 6.9357 -7.3841 0.7235) ; O3* + #( 6.8024 -5.4718 4.8475) ; N1 + #( 6.6920 -5.0495 7.1354) ; N3 + #( 6.6201 -4.5500 5.8506) ; C2 + #( 6.9254 -6.3614 7.4926) ; C4 + #( 7.1046 -7.2543 6.3718) ; C5 + #( 7.0391 -6.7951 5.1106) ; C6 + #( 6.9614 -6.6648 8.7815) ; N4 + #( 6.4083 -3.3696 5.6340) ; O2 + #( 7.1329 -7.6280 9.0324) ; H41 + #( 6.8204 -5.9469 9.4777) ; H42 + #( 7.2954 -8.3135 6.5440) ; H5 + #( 7.1753 -7.4798 4.2735) ; H6 + )) + +(define rC07 + (make-constant-rC + #( 0.0033 0.2720 -0.9623 ; dgf-base-tfo + 0.3013 -0.9179 -0.2584 + -0.9535 -0.2891 -0.0850 + 43.0403 13.7233 34.5710) + #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo + 0.0302 -0.7316 0.6811 + 0.3938 -0.6176 -0.6808 + -48.4330 26.3254 13.6383) + #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo + 0.7581 0.4893 0.4311 + 0.6345 -0.4010 -0.6607 + -31.9784 -13.4285 44.9650) + #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo + -0.6890 0.5694 -0.4484 + 0.3694 -0.2564 -0.8932 + 12.1105 30.8774 46.0946) + #( 33.3400 11.0980 46.1750) ; P + #( 34.5130 10.2320 46.4660) ; O1P + #( 33.4130 12.3960 46.9340) ; O2P + #( 31.9810 10.3390 46.4820) ; O5* + #( 30.8152 11.1619 46.2003) ; C5* + #( 30.4519 10.9454 45.1957) ; H5* + #( 31.0379 12.2016 46.4400) ; H5** + #( 29.7081 10.7448 47.1428) ; C4* + #( 28.8710 11.4416 47.0982) ; H4* + #( 29.2550 9.4394 46.8162) ; O4* + #( 29.3907 8.5625 47.9460) ; C1* + #( 28.4416 8.5669 48.4819) ; H1* + #( 30.4468 9.2031 48.7952) ; C2* + #( 31.4222 8.9651 48.3709) ; H2** + #( 30.3701 8.9157 50.1624) ; O2* + #( 30.0652 8.0304 50.3740) ; H2* + #( 30.1622 10.6879 48.6120) ; C3* + #( 31.0952 11.2399 48.7254) ; H3* + #( 29.1076 11.1535 49.4702) ; O3* + #( 29.7883 7.2209 47.5235) ; N1 + #( 29.1825 5.0438 46.8275) ; N3 + #( 28.8008 6.2912 47.2263) ; C2 + #( 30.4888 4.6890 46.7186) ; C4 + #( 31.5034 5.6405 47.0249) ; C5 + #( 31.1091 6.8691 47.4156) ; C6 + #( 30.8109 3.4584 46.3336) ; N4 + #( 27.6171 6.5989 47.3189) ; O2 + #( 31.7923 3.2301 46.2638) ; H41 + #( 30.0880 2.7857 46.1215) ; H42 + #( 32.5542 5.3634 46.9395) ; H5 + #( 31.8523 7.6279 47.6603) ; H6 + )) + +(define rC08 + (make-constant-rC + #( 0.0797 -0.6026 -0.7941 ; dgf-base-tfo + 0.7939 0.5201 -0.3150 + 0.6028 -0.6054 0.5198 + -36.8341 41.5293 1.6628) + #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo + 0.0302 -0.7316 0.6811 + 0.3938 -0.6176 -0.6808 + -48.4330 26.3254 13.6383) + #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo + 0.7581 0.4893 0.4311 + 0.6345 -0.4010 -0.6607 + -31.9784 -13.4285 44.9650) + #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo + -0.6890 0.5694 -0.4484 + 0.3694 -0.2564 -0.8932 + 12.1105 30.8774 46.0946) + #( 33.3400 11.0980 46.1750) ; P + #( 34.5130 10.2320 46.4660) ; O1P + #( 33.4130 12.3960 46.9340) ; O2P + #( 31.9810 10.3390 46.4820) ; O5* + #( 31.8779 9.9369 47.8760) ; C5* + #( 31.3239 10.6931 48.4322) ; H5* + #( 32.8647 9.6624 48.2489) ; H5** + #( 31.0429 8.6773 47.9401) ; C4* + #( 31.0779 8.2331 48.9349) ; H4* + #( 29.6956 8.9669 47.5983) ; O4* + #( 29.2784 8.1700 46.4782) ; C1* + #( 28.8006 7.2731 46.8722) ; H1* + #( 30.5544 7.7940 45.7875) ; C2* + #( 30.8837 8.6410 45.1856) ; H2** + #( 30.5100 6.6007 45.0582) ; O2* + #( 29.6694 6.4168 44.6326) ; H2* + #( 31.5146 7.5954 46.9527) ; C3* + #( 32.5255 7.8261 46.6166) ; H3* + #( 31.3876 6.2951 47.5516) ; O3* + #( 28.3976 8.9302 45.5933) ; N1 + #( 26.2155 9.6135 44.9910) ; N3 + #( 27.0281 8.8961 45.8192) ; C2 + #( 26.7044 10.3489 43.9595) ; C4 + #( 28.1088 10.3837 43.7247) ; C5 + #( 28.8978 9.6708 44.5535) ; C6 + #( 25.8715 11.0249 43.1749) ; N4 + #( 26.5733 8.2371 46.7484) ; O2 + #( 26.2707 11.5609 42.4177) ; H41 + #( 24.8760 10.9939 43.3427) ; H42 + #( 28.5089 10.9722 42.8990) ; H5 + #( 29.9782 9.6687 44.4097) ; H6 + )) + +(define rC09 + (make-constant-rC + #( 0.8727 0.4760 -0.1091 ; dgf-base-tfo + -0.4188 0.6148 -0.6682 + -0.2510 0.6289 0.7359 + -8.1687 -52.0761 -25.0726) + #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo + 0.0302 -0.7316 0.6811 + 0.3938 -0.6176 -0.6808 + -48.4330 26.3254 13.6383) + #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo + 0.7581 0.4893 0.4311 + 0.6345 -0.4010 -0.6607 + -31.9784 -13.4285 44.9650) + #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo + -0.6890 0.5694 -0.4484 + 0.3694 -0.2564 -0.8932 + 12.1105 30.8774 46.0946) + #( 33.3400 11.0980 46.1750) ; P + #( 34.5130 10.2320 46.4660) ; O1P + #( 33.4130 12.3960 46.9340) ; O2P + #( 31.9810 10.3390 46.4820) ; O5* + #( 30.8152 11.1619 46.2003) ; C5* + #( 30.4519 10.9454 45.1957) ; H5* + #( 31.0379 12.2016 46.4400) ; H5** + #( 29.7081 10.7448 47.1428) ; C4* + #( 29.4506 9.6945 47.0059) ; H4* + #( 30.1045 10.9634 48.4885) ; O4* + #( 29.1794 11.8418 49.1490) ; C1* + #( 28.4388 11.2210 49.6533) ; H1* + #( 28.5211 12.6008 48.0367) ; C2* + #( 29.1947 13.3949 47.7147) ; H2** + #( 27.2316 13.0683 48.3134) ; O2* + #( 27.0851 13.3391 49.2227) ; H2* + #( 28.4131 11.5507 46.9391) ; C3* + #( 28.4451 12.0512 45.9713) ; H3* + #( 27.2707 10.6955 47.1097) ; O3* + #( 29.8751 12.7405 50.0682) ; N1 + #( 30.7172 13.1841 52.2328) ; N3 + #( 30.0617 12.3404 51.3847) ; C2 + #( 31.1834 14.3941 51.8297) ; C4 + #( 30.9913 14.8074 50.4803) ; C5 + #( 30.3434 13.9610 49.6548) ; C6 + #( 31.8090 15.1847 52.6957) ; N4 + #( 29.6470 11.2494 51.7616) ; O2 + #( 32.1422 16.0774 52.3606) ; H41 + #( 31.9392 14.8893 53.6527) ; H42 + #( 31.3632 15.7771 50.1491) ; H5 + #( 30.1742 14.2374 48.6141) ; H6 + )) + +(define rC10 + (make-constant-rC + #( 0.1549 0.8710 -0.4663 ; dgf-base-tfo + 0.6768 -0.4374 -0.5921 + -0.7197 -0.2239 -0.6572 + 25.2447 -14.1920 50.3201) + #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo + 0.0302 -0.7316 0.6811 + 0.3938 -0.6176 -0.6808 + -48.4330 26.3254 13.6383) + #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo + 0.7581 0.4893 0.4311 + 0.6345 -0.4010 -0.6607 + -31.9784 -13.4285 44.9650) + #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo + -0.6890 0.5694 -0.4484 + 0.3694 -0.2564 -0.8932 + 12.1105 30.8774 46.0946) + #( 33.3400 11.0980 46.1750) ; P + #( 34.5130 10.2320 46.4660) ; O1P + #( 33.4130 12.3960 46.9340) ; O2P + #( 31.9810 10.3390 46.4820) ; O5* + #( 31.8779 9.9369 47.8760) ; C5* + #( 31.3239 10.6931 48.4322) ; H5* + #( 32.8647 9.6624 48.2489) ; H5** + #( 31.0429 8.6773 47.9401) ; C4* + #( 30.0440 8.8473 47.5383) ; H4* + #( 31.6749 7.6351 47.2119) ; O4* + #( 31.9159 6.5022 48.0616) ; C1* + #( 31.0691 5.8243 47.9544) ; H1* + #( 31.9300 7.0685 49.4493) ; C2* + #( 32.9024 7.5288 49.6245) ; H2** + #( 31.5672 6.1750 50.4632) ; O2* + #( 31.8416 5.2663 50.3200) ; H2* + #( 30.8618 8.1514 49.3749) ; C3* + #( 31.1122 8.9396 50.0850) ; H3* + #( 29.5351 7.6245 49.5409) ; O3* + #( 33.1890 5.8629 47.7343) ; N1 + #( 34.4004 4.2636 46.4828) ; N3 + #( 33.2062 4.8497 46.7851) ; C2 + #( 35.5600 4.6374 47.0822) ; C4 + #( 35.5444 5.6751 48.0577) ; C5 + #( 34.3565 6.2450 48.3432) ; C6 + #( 36.6977 4.0305 46.7598) ; N4 + #( 32.1661 4.5034 46.2348) ; O2 + #( 37.5405 4.3347 47.2259) ; H41 + #( 36.7033 3.2923 46.0706) ; H42 + #( 36.4713 5.9811 48.5428) ; H5 + #( 34.2986 7.0426 49.0839) ; H6 + )) + +(define rCs + (list rC01 rC02 rC03 rC04 rC05 rC06 rC07 rC08 rC09 rC10)) + +(define rG + (make-constant-rG + #( -0.0018 -0.8207 0.5714 ; dgf-base-tfo + 0.2679 -0.5509 -0.7904 + 0.9634 0.1517 0.2209 + 0.0073 8.4030 0.6232) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 5.4550 8.2120 -2.8810) ; C5* + #( 5.4546 8.8508 -1.9978) ; H5* + #( 5.7588 8.6625 -3.8259) ; H5** + #( 6.4970 7.1480 -2.5980) ; C4* + #( 7.4896 7.5919 -2.5214) ; H4* + #( 6.1630 6.4860 -1.3440) ; O4* + #( 6.5400 5.1200 -1.4190) ; C1* + #( 7.2763 4.9681 -0.6297) ; H1* + #( 7.1940 4.8830 -2.7770) ; C2* + #( 6.8667 3.9183 -3.1647) ; H2** + #( 8.5860 5.0910 -2.6140) ; O2* + #( 8.9510 4.7626 -1.7890) ; H2* + #( 6.5720 6.0040 -3.6090) ; C3* + #( 5.5636 5.7066 -3.8966) ; H3* + #( 7.3801 6.3562 -4.7350) ; O3* + #( 4.7150 0.4910 -0.1360) ; N1 + #( 6.3490 2.1730 -0.6020) ; N3 + #( 5.9530 0.9650 -0.2670) ; C2 + #( 5.2900 2.9790 -0.8260) ; C4 + #( 3.9720 2.6390 -0.7330) ; C5 + #( 3.6770 1.3160 -0.3660) ; C6 + #( 6.8426 0.0056 -0.0019) ; N2 + #( 3.1660 3.7290 -1.0360) ; N7 + #( 5.3170 4.2990 -1.1930) ; N9 + #( 4.0100 4.6780 -1.2990) ; C8 + #( 2.4280 0.8450 -0.2360) ; O6 + #( 4.6151 -0.4677 0.1305) ; H1 + #( 6.6463 -0.9463 0.2729) ; H21 + #( 7.8170 0.2642 -0.0640) ; H22 + #( 3.4421 5.5744 -1.5482) ; H8 + )) + +(define rG01 + (make-constant-rG + #( -0.0043 -0.8175 0.5759 ; dgf-base-tfo + 0.2617 -0.5567 -0.7884 + 0.9651 0.1473 0.2164 + 0.0359 8.3929 0.5532) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 5.4352 8.2183 -2.7757) ; C5* + #( 5.3830 8.7883 -1.8481) ; H5* + #( 5.7729 8.7436 -3.6691) ; H5** + #( 6.4830 7.1518 -2.5252) ; C4* + #( 7.4749 7.5972 -2.4482) ; H4* + #( 6.1626 6.4620 -1.2827) ; O4* + #( 6.5431 5.0992 -1.3905) ; C1* + #( 7.2871 4.9328 -0.6114) ; H1* + #( 7.1852 4.8935 -2.7592) ; C2* + #( 6.8573 3.9363 -3.1645) ; H2** + #( 8.5780 5.1025 -2.6046) ; O2* + #( 8.9516 4.7577 -1.7902) ; H2* + #( 6.5522 6.0300 -3.5612) ; C3* + #( 5.5420 5.7356 -3.8459) ; H3* + #( 7.3487 6.4089 -4.6867) ; O3* + #( 4.7442 0.4514 -0.1390) ; N1 + #( 6.3687 2.1459 -0.5926) ; N3 + #( 5.9795 0.9335 -0.2657) ; C2 + #( 5.3052 2.9471 -0.8125) ; C4 + #( 3.9891 2.5987 -0.7230) ; C5 + #( 3.7016 1.2717 -0.3647) ; C6 + #( 6.8745 -0.0224 -0.0058) ; N2 + #( 3.1770 3.6859 -1.0198) ; N7 + #( 5.3247 4.2695 -1.1710) ; N9 + #( 4.0156 4.6415 -1.2759) ; C8 + #( 2.4553 0.7925 -0.2390) ; O6 + #( 4.6497 -0.5095 0.1212) ; H1 + #( 6.6836 -0.9771 0.2627) ; H21 + #( 7.8474 0.2424 -0.0653) ; H22 + #( 3.4426 5.5361 -1.5199) ; H8 + )) + +(define rG02 + (make-constant-rG + #( 0.5566 0.0449 0.8296 ; dgf-base-tfo + 0.5125 0.7673 -0.3854 + -0.6538 0.6397 0.4041 + -9.1161 -3.7679 -2.9968) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.5778 6.6594 -4.0364) ; C5* + #( 4.9220 7.1963 -4.9204) ; H5* + #( 3.7996 5.9091 -4.1764) ; H5** + #( 5.7873 5.8869 -3.5482) ; C4* + #( 6.0405 5.0875 -4.2446) ; H4* + #( 6.9135 6.8036 -3.4310) ; O4* + #( 7.7293 6.4084 -2.3392) ; C1* + #( 8.7078 6.1815 -2.7624) ; H1* + #( 7.1305 5.1418 -1.7347) ; C2* + #( 7.2040 5.1982 -0.6486) ; H2** + #( 7.7417 4.0392 -2.3813) ; O2* + #( 8.6785 4.1443 -2.5630) ; H2* + #( 5.6666 5.2728 -2.1536) ; C3* + #( 5.1747 5.9805 -1.4863) ; H3* + #( 4.9997 4.0086 -2.1973) ; O3* + #( 10.3245 8.5459 1.5467) ; N1 + #( 9.8051 6.9432 -0.1497) ; N3 + #( 10.5175 7.4328 0.8408) ; C2 + #( 8.7523 7.7422 -0.4228) ; C4 + #( 8.4257 8.9060 0.2099) ; C5 + #( 9.2665 9.3242 1.2540) ; C6 + #( 11.6077 6.7966 1.2752) ; N2 + #( 7.2750 9.4537 -0.3428) ; N7 + #( 7.7962 7.5519 -1.3859) ; N9 + #( 6.9479 8.6157 -1.2771) ; C8 + #( 9.0664 10.4462 1.9610) ; O6 + #( 10.9838 8.7524 2.2697) ; H1 + #( 12.2274 7.0896 2.0170) ; H21 + #( 11.8502 5.9398 0.7984) ; H22 + #( 6.0430 8.9853 -1.7594) ; H8 + )) + +(define rG03 + (make-constant-rG + #( -0.5021 0.0731 0.8617 ; dgf-base-tfo + -0.8112 0.3054 -0.4986 + -0.2996 -0.9494 -0.0940 + 6.4273 -5.1944 -3.7807) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.1214 6.7116 -1.9049) ; C5* + #( 3.3465 5.9610 -2.0607) ; H5* + #( 4.0789 7.2928 -0.9837) ; H5** + #( 5.4170 5.9293 -1.8186) ; C4* + #( 5.4506 5.3400 -0.9023) ; H4* + #( 5.5067 5.0417 -2.9703) ; O4* + #( 6.8650 4.9152 -3.3612) ; C1* + #( 7.1090 3.8577 -3.2603) ; H1* + #( 7.7152 5.7282 -2.3894) ; C2* + #( 8.5029 6.2356 -2.9463) ; H2** + #( 8.1036 4.8568 -1.3419) ; O2* + #( 8.3270 3.9651 -1.6184) ; H2* + #( 6.7003 6.7565 -1.8911) ; C3* + #( 6.5898 7.5329 -2.6482) ; H3* + #( 7.0505 7.2878 -0.6105) ; O3* + #( 9.6740 4.7656 -7.6614) ; N1 + #( 9.0739 4.3013 -5.3941) ; N3 + #( 9.8416 4.2192 -6.4581) ; C2 + #( 7.9885 5.0632 -5.6446) ; C4 + #( 7.6822 5.6856 -6.8194) ; C5 + #( 8.5831 5.5215 -7.8840) ; C6 + #( 10.9733 3.5117 -6.4286) ; N2 + #( 6.4857 6.3816 -6.7035) ; N7 + #( 6.9740 5.3703 -4.7760) ; N9 + #( 6.1133 6.1613 -5.4808) ; C8 + #( 8.4084 6.0747 -9.0933) ; O6 + #( 10.3759 4.5855 -8.3504) ; H1 + #( 11.6254 3.3761 -7.1879) ; H21 + #( 11.1917 3.0460 -5.5593) ; H22 + #( 5.1705 6.6830 -5.3167) ; H8 + )) + +(define rG04 + (make-constant-rG + #( -0.5426 -0.8175 0.1929 ; dgf-base-tfo + 0.8304 -0.5567 -0.0237 + 0.1267 0.1473 0.9809 + -0.5075 8.3929 0.2229) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 5.4352 8.2183 -2.7757) ; C5* + #( 5.3830 8.7883 -1.8481) ; H5* + #( 5.7729 8.7436 -3.6691) ; H5** + #( 6.4830 7.1518 -2.5252) ; C4* + #( 7.4749 7.5972 -2.4482) ; H4* + #( 6.1626 6.4620 -1.2827) ; O4* + #( 6.5431 5.0992 -1.3905) ; C1* + #( 7.2871 4.9328 -0.6114) ; H1* + #( 7.1852 4.8935 -2.7592) ; C2* + #( 6.8573 3.9363 -3.1645) ; H2** + #( 8.5780 5.1025 -2.6046) ; O2* + #( 8.9516 4.7577 -1.7902) ; H2* + #( 6.5522 6.0300 -3.5612) ; C3* + #( 5.5420 5.7356 -3.8459) ; H3* + #( 7.3487 6.4089 -4.6867) ; O3* + #( 3.6343 2.6680 2.0783) ; N1 + #( 5.4505 3.9805 1.2446) ; N3 + #( 4.7540 3.3816 2.1851) ; C2 + #( 4.8805 3.7951 0.0354) ; C4 + #( 3.7416 3.0925 -0.2305) ; C5 + #( 3.0873 2.4980 0.8606) ; C6 + #( 5.1433 3.4373 3.4609) ; N2 + #( 3.4605 3.1184 -1.5906) ; N7 + #( 5.3247 4.2695 -1.1710) ; N9 + #( 4.4244 3.8244 -2.0953) ; C8 + #( 1.9600 1.7805 0.7462) ; O6 + #( 3.2489 2.2879 2.9191) ; H1 + #( 4.6785 3.0243 4.2568) ; H21 + #( 5.9823 3.9654 3.6539) ; H22 + #( 4.2675 3.8876 -3.1721) ; H8 + )) + +(define rG05 + (make-constant-rG + #( -0.5891 0.0449 0.8068 ; dgf-base-tfo + 0.5375 0.7673 0.3498 + -0.6034 0.6397 -0.4762 + -0.3019 -3.7679 -9.5913) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.5778 6.6594 -4.0364) ; C5* + #( 4.9220 7.1963 -4.9204) ; H5* + #( 3.7996 5.9091 -4.1764) ; H5** + #( 5.7873 5.8869 -3.5482) ; C4* + #( 6.0405 5.0875 -4.2446) ; H4* + #( 6.9135 6.8036 -3.4310) ; O4* + #( 7.7293 6.4084 -2.3392) ; C1* + #( 8.7078 6.1815 -2.7624) ; H1* + #( 7.1305 5.1418 -1.7347) ; C2* + #( 7.2040 5.1982 -0.6486) ; H2** + #( 7.7417 4.0392 -2.3813) ; O2* + #( 8.6785 4.1443 -2.5630) ; H2* + #( 5.6666 5.2728 -2.1536) ; C3* + #( 5.1747 5.9805 -1.4863) ; H3* + #( 4.9997 4.0086 -2.1973) ; O3* + #( 10.2594 10.6774 -1.0056) ; N1 + #( 9.7528 8.7080 -2.2631) ; N3 + #( 10.4471 9.7876 -1.9791) ; C2 + #( 8.7271 8.5575 -1.3991) ; C4 + #( 8.4100 9.3803 -0.3580) ; C5 + #( 9.2294 10.5030 -0.1574) ; C6 + #( 11.5110 10.1256 -2.7114) ; N2 + #( 7.2891 8.9068 0.3121) ; N7 + #( 7.7962 7.5519 -1.3859) ; N9 + #( 6.9702 7.8292 -0.3353) ; C8 + #( 9.0349 11.3951 0.8250) ; O6 + #( 10.9013 11.4422 -0.9512) ; H1 + #( 12.1031 10.9341 -2.5861) ; H21 + #( 11.7369 9.5180 -3.4859) ; H22 + #( 6.0888 7.3990 0.1403) ; H8 + )) + +(define rG06 + (make-constant-rG + #( -0.9815 0.0731 -0.1772 ; dgf-base-tfo + 0.1912 0.3054 -0.9328 + -0.0141 -0.9494 -0.3137 + 5.7506 -5.1944 4.7470) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.1214 6.7116 -1.9049) ; C5* + #( 3.3465 5.9610 -2.0607) ; H5* + #( 4.0789 7.2928 -0.9837) ; H5** + #( 5.4170 5.9293 -1.8186) ; C4* + #( 5.4506 5.3400 -0.9023) ; H4* + #( 5.5067 5.0417 -2.9703) ; O4* + #( 6.8650 4.9152 -3.3612) ; C1* + #( 7.1090 3.8577 -3.2603) ; H1* + #( 7.7152 5.7282 -2.3894) ; C2* + #( 8.5029 6.2356 -2.9463) ; H2** + #( 8.1036 4.8568 -1.3419) ; O2* + #( 8.3270 3.9651 -1.6184) ; H2* + #( 6.7003 6.7565 -1.8911) ; C3* + #( 6.5898 7.5329 -2.6482) ; H3* + #( 7.0505 7.2878 -0.6105) ; O3* + #( 6.6624 3.5061 -8.2986) ; N1 + #( 6.5810 3.2570 -5.9221) ; N3 + #( 6.5151 2.8263 -7.1625) ; C2 + #( 6.8364 4.5817 -5.8882) ; C4 + #( 7.0116 5.4064 -6.9609) ; C5 + #( 6.9173 4.8260 -8.2361) ; C6 + #( 6.2717 1.5402 -7.4250) ; N2 + #( 7.2573 6.7070 -6.5394) ; N7 + #( 6.9740 5.3703 -4.7760) ; N9 + #( 7.2238 6.6275 -5.2453) ; C8 + #( 7.0668 5.5163 -9.3763) ; O6 + #( 6.5754 2.9964 -9.1545) ; H1 + #( 6.1908 1.1105 -8.3354) ; H21 + #( 6.1346 0.9352 -6.6280) ; H22 + #( 7.4108 7.6227 -4.8418) ; H8 + )) + +(define rG07 + (make-constant-rG + #( 0.0894 -0.6059 0.7905 ; dgf-base-tfo + -0.6810 0.5420 0.4924 + -0.7268 -0.5824 -0.3642 + 34.1424 45.9610 -11.8600) + #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo + -0.0427 0.2409 -0.9696 + 0.5010 -0.8345 -0.2294 + 4.0167 54.5377 12.4779) + #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo + -0.2867 -0.7872 -0.5460 + 0.8834 0.0032 -0.4686 + -52.9020 18.6313 -0.6709) + #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo + 0.9040 -0.4236 -0.0582 + -0.1007 -0.0786 -0.9918 + -7.6624 -25.2080 49.5181) + #( 31.3810 0.1400 47.5810) ; P + #( 29.9860 0.6630 47.6290) ; O1P + #( 31.7210 -0.6460 48.8090) ; O2P + #( 32.4940 1.2540 47.2740) ; O5* + #( 33.8709 0.7918 47.2113) ; C5* + #( 34.1386 0.5870 46.1747) ; H5* + #( 34.0186 -0.0095 47.9353) ; H5** + #( 34.7297 1.9687 47.6685) ; C4* + #( 35.7723 1.6845 47.8113) ; H4* + #( 34.6455 2.9768 46.6660) ; O4* + #( 34.1690 4.1829 47.2627) ; C1* + #( 35.0437 4.7633 47.5560) ; H1* + #( 33.4145 3.7532 48.4954) ; C2* + #( 32.4340 3.3797 48.2001) ; H2** + #( 33.3209 4.6953 49.5217) ; O2* + #( 33.2374 5.6059 49.2295) ; H2* + #( 34.2724 2.5970 48.9773) ; C3* + #( 33.6373 1.8935 49.5157) ; H3* + #( 35.3453 3.1884 49.7285) ; O3* + #( 34.0511 7.8930 43.7791) ; N1 + #( 34.9937 6.3369 45.3199) ; N3 + #( 35.0882 7.3126 44.4200) ; C2 + #( 33.7190 5.9650 45.5374) ; C4 + #( 32.5845 6.4770 44.9458) ; C5 + #( 32.7430 7.5179 43.9914) ; C6 + #( 36.3030 7.7827 44.1036) ; N2 + #( 31.4499 5.8335 45.4368) ; N7 + #( 33.2760 4.9817 46.4043) ; N9 + #( 31.9235 4.9639 46.2934) ; C8 + #( 31.8602 8.1000 43.3695) ; O6 + #( 34.2623 8.6223 43.1283) ; H1 + #( 36.5188 8.5081 43.4347) ; H21 + #( 37.0888 7.3524 44.5699) ; H22 + #( 31.0815 4.4201 46.7218) ; H8 + )) + +(define rG08 + (make-constant-rG + #( 0.2224 0.6335 0.7411 ; dgf-base-tfo + -0.3644 -0.6510 0.6659 + 0.9043 -0.4181 0.0861 + -47.6824 -0.5823 -31.7554) + #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo + -0.0427 0.2409 -0.9696 + 0.5010 -0.8345 -0.2294 + 4.0167 54.5377 12.4779) + #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo + -0.2867 -0.7872 -0.5460 + 0.8834 0.0032 -0.4686 + -52.9020 18.6313 -0.6709) + #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo + 0.9040 -0.4236 -0.0582 + -0.1007 -0.0786 -0.9918 + -7.6624 -25.2080 49.5181) + #( 31.3810 0.1400 47.5810) ; P + #( 29.9860 0.6630 47.6290) ; O1P + #( 31.7210 -0.6460 48.8090) ; O2P + #( 32.4940 1.2540 47.2740) ; O5* + #( 32.5924 2.3488 48.2255) ; C5* + #( 33.3674 2.1246 48.9584) ; H5* + #( 31.5994 2.5917 48.6037) ; H5** + #( 33.0722 3.5577 47.4258) ; C4* + #( 33.0310 4.4778 48.0089) ; H4* + #( 34.4173 3.3055 47.0316) ; O4* + #( 34.5056 3.3910 45.6094) ; C1* + #( 34.7881 4.4152 45.3663) ; H1* + #( 33.1122 3.1198 45.1010) ; C2* + #( 32.9230 2.0469 45.1369) ; H2** + #( 32.7946 3.6590 43.8529) ; O2* + #( 33.5170 3.6707 43.2207) ; H2* + #( 32.2730 3.8173 46.1566) ; C3* + #( 31.3094 3.3123 46.2244) ; H3* + #( 32.2391 5.2039 45.7807) ; O3* + #( 39.3337 2.7157 44.1441) ; N1 + #( 37.4430 3.8242 45.0824) ; N3 + #( 38.7276 3.7646 44.7403) ; C2 + #( 36.7791 2.6963 44.7704) ; C4 + #( 37.2860 1.5653 44.1678) ; C5 + #( 38.6647 1.5552 43.8235) ; C6 + #( 39.5123 4.8216 44.9936) ; N2 + #( 36.2829 0.6110 44.0078) ; N7 + #( 35.4394 2.4314 44.9931) ; N9 + #( 35.2180 1.1815 44.5128) ; C8 + #( 39.2907 0.6514 43.2796) ; O6 + #( 40.3076 2.8048 43.9352) ; H1 + #( 40.4994 4.9066 44.7977) ; H21 + #( 39.0738 5.6108 45.4464) ; H22 + #( 34.3856 0.4842 44.4185) ; H8 + )) + +(define rG09 + (make-constant-rG + #( -0.9699 -0.1688 -0.1753 ; dgf-base-tfo + -0.1050 -0.3598 0.9271 + -0.2196 0.9176 0.3312 + 45.6217 -38.9484 -12.3208) + #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo + -0.0427 0.2409 -0.9696 + 0.5010 -0.8345 -0.2294 + 4.0167 54.5377 12.4779) + #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo + -0.2867 -0.7872 -0.5460 + 0.8834 0.0032 -0.4686 + -52.9020 18.6313 -0.6709) + #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo + 0.9040 -0.4236 -0.0582 + -0.1007 -0.0786 -0.9918 + -7.6624 -25.2080 49.5181) + #( 31.3810 0.1400 47.5810) ; P + #( 29.9860 0.6630 47.6290) ; O1P + #( 31.7210 -0.6460 48.8090) ; O2P + #( 32.4940 1.2540 47.2740) ; O5* + #( 33.8709 0.7918 47.2113) ; C5* + #( 34.1386 0.5870 46.1747) ; H5* + #( 34.0186 -0.0095 47.9353) ; H5** + #( 34.7297 1.9687 47.6685) ; C4* + #( 34.5880 2.8482 47.0404) ; H4* + #( 34.3575 2.2770 49.0081) ; O4* + #( 35.5157 2.1993 49.8389) ; C1* + #( 35.9424 3.2010 49.8893) ; H1* + #( 36.4701 1.2820 49.1169) ; C2* + #( 36.1545 0.2498 49.2683) ; H2** + #( 37.8262 1.4547 49.4008) ; O2* + #( 38.0227 1.6945 50.3094) ; H2* + #( 36.2242 1.6797 47.6725) ; C3* + #( 36.4297 0.8197 47.0351) ; H3* + #( 37.0289 2.8480 47.4426) ; O3* + #( 34.3005 3.5042 54.6070) ; N1 + #( 34.7693 3.7936 52.2874) ; N3 + #( 34.4484 4.2541 53.4939) ; C2 + #( 34.9354 2.4584 52.2785) ; C4 + #( 34.8092 1.5915 53.3422) ; C5 + #( 34.4646 2.1367 54.6085) ; C6 + #( 34.2514 5.5708 53.6503) ; N2 + #( 35.0641 0.2835 52.9337) ; N7 + #( 35.2669 1.6690 51.1915) ; N9 + #( 35.3288 0.3954 51.6563) ; C8 + #( 34.3151 1.5317 55.6650) ; O6 + #( 34.0623 3.9797 55.4539) ; H1 + #( 33.9950 6.0502 54.5016) ; H21 + #( 34.3512 6.1432 52.8242) ; H22 + #( 35.5414 -0.6006 51.2679) ; H8 + )) + +(define rG10 + (make-constant-rG + #( -0.0980 -0.9723 0.2122 ; dgf-base-tfo + -0.9731 0.1383 0.1841 + -0.2083 -0.1885 -0.9597 + 17.8469 38.8265 37.0475) + #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo + -0.0427 0.2409 -0.9696 + 0.5010 -0.8345 -0.2294 + 4.0167 54.5377 12.4779) + #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo + -0.2867 -0.7872 -0.5460 + 0.8834 0.0032 -0.4686 + -52.9020 18.6313 -0.6709) + #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo + 0.9040 -0.4236 -0.0582 + -0.1007 -0.0786 -0.9918 + -7.6624 -25.2080 49.5181) + #( 31.3810 0.1400 47.5810) ; P + #( 29.9860 0.6630 47.6290) ; O1P + #( 31.7210 -0.6460 48.8090) ; O2P + #( 32.4940 1.2540 47.2740) ; O5* + #( 32.5924 2.3488 48.2255) ; C5* + #( 33.3674 2.1246 48.9584) ; H5* + #( 31.5994 2.5917 48.6037) ; H5** + #( 33.0722 3.5577 47.4258) ; C4* + #( 34.0333 3.3761 46.9447) ; H4* + #( 32.0890 3.8338 46.4332) ; O4* + #( 31.6377 5.1787 46.5914) ; C1* + #( 32.2499 5.8016 45.9392) ; H1* + #( 31.9167 5.5319 48.0305) ; C2* + #( 31.1507 5.0820 48.6621) ; H2** + #( 32.0865 6.8890 48.3114) ; O2* + #( 31.5363 7.4819 47.7942) ; H2* + #( 33.2398 4.8224 48.2563) ; C3* + #( 33.3166 4.5570 49.3108) ; H3* + #( 34.2528 5.7056 47.7476) ; O3* + #( 28.2782 6.3049 42.9364) ; N1 + #( 30.4001 5.8547 43.9258) ; N3 + #( 29.6195 6.1568 42.8913) ; C2 + #( 29.7005 5.7006 45.0649) ; C4 + #( 28.3383 5.8221 45.2343) ; C5 + #( 27.5519 6.1461 44.0958) ; C6 + #( 30.1838 6.3385 41.6890) ; N2 + #( 27.9936 5.5926 46.5651) ; N7 + #( 30.2046 5.3825 46.3136) ; N9 + #( 29.1371 5.3398 47.1506) ; C8 + #( 26.3361 6.3024 44.0495) ; O6 + #( 27.8122 6.5394 42.0833) ; H1 + #( 29.7125 6.5595 40.8235) ; H21 + #( 31.1859 6.2231 41.6389) ; H22 + #( 28.9406 5.1504 48.2059) ; H8 + )) + +(define rGs + (list rG01 rG02 rG03 rG04 rG05 rG06 rG07 rG08 rG09 rG10)) + +(define rU + (make-constant-rU + #( -0.0359 -0.8071 0.5894 ; dgf-base-tfo + -0.2669 0.5761 0.7726 + -0.9631 -0.1296 -0.2361 + 0.1584 8.3434 0.5434) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2430 -8.2420 2.8260) ; C5* + #( 5.1974 -8.8497 1.9223) ; H5* + #( 5.5548 -8.7348 3.7469) ; H5** + #( 6.3140 -7.2060 2.5510) ; C4* + #( 7.2954 -7.6762 2.4898) ; H4* + #( 6.0140 -6.5420 1.2890) ; O4* + #( 6.4190 -5.1840 1.3620) ; C1* + #( 7.1608 -5.0495 0.5747) ; H1* + #( 7.0760 -4.9560 2.7270) ; C2* + #( 6.7770 -3.9803 3.1099) ; H2** + #( 8.4500 -5.1930 2.5810) ; O2* + #( 8.8309 -4.8755 1.7590) ; H2* + #( 6.4060 -6.0590 3.5580) ; C3* + #( 5.4021 -5.7313 3.8281) ; H3* + #( 7.1570 -6.4240 4.7070) ; O3* + #( 5.2170 -4.3260 1.1690) ; N1 + #( 4.2960 -2.2560 0.6290) ; N3 + #( 5.4330 -3.0200 0.7990) ; C2 + #( 2.9930 -2.6780 0.7940) ; C4 + #( 2.8670 -4.0630 1.1830) ; C5 + #( 3.9570 -4.8300 1.3550) ; C6 + #( 6.5470 -2.5560 0.6290) ; O2 + #( 2.0540 -1.9000 0.6130) ; O4 + #( 4.4300 -1.3020 0.3600) ; H3 + #( 1.9590 -4.4570 1.3250) ; H5 + #( 3.8460 -5.7860 1.6240) ; H6 + )) + +(define rU01 + (make-constant-rU + #( -0.0137 -0.8012 0.5983 ; dgf-base-tfo + -0.2523 0.5817 0.7733 + -0.9675 -0.1404 -0.2101 + 0.2031 8.3874 0.4228) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2416 -8.2422 2.8181) ; C5* + #( 5.2050 -8.8128 1.8901) ; H5* + #( 5.5368 -8.7738 3.7227) ; H5** + #( 6.3232 -7.2037 2.6002) ; C4* + #( 7.3048 -7.6757 2.5577) ; H4* + #( 6.0635 -6.5092 1.3456) ; O4* + #( 6.4697 -5.1547 1.4629) ; C1* + #( 7.2354 -5.0043 0.7018) ; H1* + #( 7.0856 -4.9610 2.8521) ; C2* + #( 6.7777 -3.9935 3.2487) ; H2** + #( 8.4627 -5.1992 2.7423) ; O2* + #( 8.8693 -4.8638 1.9399) ; H2* + #( 6.3877 -6.0809 3.6362) ; C3* + #( 5.3770 -5.7562 3.8834) ; H3* + #( 7.1024 -6.4754 4.7985) ; O3* + #( 5.2764 -4.2883 1.2538) ; N1 + #( 4.3777 -2.2062 0.7229) ; N3 + #( 5.5069 -2.9779 0.9088) ; C2 + #( 3.0693 -2.6246 0.8500) ; C4 + #( 2.9279 -4.0146 1.2149) ; C5 + #( 4.0101 -4.7892 1.4017) ; C6 + #( 6.6267 -2.5166 0.7728) ; O2 + #( 2.1383 -1.8396 0.6581) ; O4 + #( 4.5223 -1.2489 0.4716) ; H3 + #( 2.0151 -4.4065 1.3290) ; H5 + #( 3.8886 -5.7486 1.6535) ; H6 + )) + +(define rU02 + (make-constant-rU + #( 0.5141 0.0246 0.8574 ; dgf-base-tfo + -0.5547 -0.7529 0.3542 + 0.6542 -0.6577 -0.3734 + -9.1111 -3.4598 -3.2939) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 4.3825 -6.6585 4.0489) ; C5* + #( 4.6841 -7.2019 4.9443) ; H5* + #( 3.6189 -5.8889 4.1625) ; H5** + #( 5.6255 -5.9175 3.5998) ; C4* + #( 5.8732 -5.1228 4.3034) ; H4* + #( 6.7337 -6.8605 3.5222) ; O4* + #( 7.5932 -6.4923 2.4548) ; C1* + #( 8.5661 -6.2983 2.9064) ; H1* + #( 7.0527 -5.2012 1.8322) ; C2* + #( 7.1627 -5.2525 0.7490) ; H2** + #( 7.6666 -4.1249 2.4880) ; O2* + #( 8.5944 -4.2543 2.6981) ; H2* + #( 5.5661 -5.3029 2.2009) ; C3* + #( 5.0841 -6.0018 1.5172) ; H3* + #( 4.9062 -4.0452 2.2042) ; O3* + #( 7.6298 -7.6136 1.4752) ; N1 + #( 8.6945 -8.7046 -0.2857) ; N3 + #( 8.6943 -7.6514 0.6066) ; C2 + #( 7.7426 -9.6987 -0.3801) ; C4 + #( 6.6642 -9.5742 0.5722) ; C5 + #( 6.6391 -8.5592 1.4526) ; C6 + #( 9.5840 -6.8186 0.6136) ; O2 + #( 7.8505 -10.5925 -1.2223) ; O4 + #( 9.4601 -8.7514 -0.9277) ; H3 + #( 5.9281 -10.2509 0.5782) ; H5 + #( 5.8831 -8.4931 2.1028) ; H6 + )) + +(define rU03 + (make-constant-rU + #( -0.4993 0.0476 0.8651 ; dgf-base-tfo + 0.8078 -0.3353 0.4847 + 0.3132 0.9409 0.1290 + 6.2989 -5.2303 -3.8577) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 3.9938 -6.7042 1.9023) ; C5* + #( 3.2332 -5.9343 2.0319) ; H5* + #( 3.9666 -7.2863 0.9812) ; H5** + #( 5.3098 -5.9546 1.8564) ; C4* + #( 5.3863 -5.3702 0.9395) ; H4* + #( 5.3851 -5.0642 3.0076) ; O4* + #( 6.7315 -4.9724 3.4462) ; C1* + #( 7.0033 -3.9202 3.3619) ; H1* + #( 7.5997 -5.8018 2.4948) ; C2* + #( 8.3627 -6.3254 3.0707) ; H2** + #( 8.0410 -4.9501 1.4724) ; O2* + #( 8.2781 -4.0644 1.7570) ; H2* + #( 6.5701 -6.8129 1.9714) ; C3* + #( 6.4186 -7.5809 2.7299) ; H3* + #( 6.9357 -7.3841 0.7235) ; O3* + #( 6.8024 -5.4718 4.8475) ; N1 + #( 7.9218 -5.5700 6.8877) ; N3 + #( 7.8908 -5.0886 5.5944) ; C2 + #( 6.9789 -6.3827 7.4823) ; C4 + #( 5.8742 -6.7319 6.6202) ; C5 + #( 5.8182 -6.2769 5.3570) ; C6 + #( 8.7747 -4.3728 5.1568) ; O2 + #( 7.1154 -6.7509 8.6509) ; O4 + #( 8.7055 -5.3037 7.4491) ; H3 + #( 5.1416 -7.3178 6.9665) ; H5 + #( 5.0441 -6.5310 4.7784) ; H6 + )) + +(define rU04 + (make-constant-rU + #( -0.5669 -0.8012 0.1918 ; dgf-base-tfo + -0.8129 0.5817 0.0273 + -0.1334 -0.1404 -0.9811 + -0.3279 8.3874 0.3355) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2416 -8.2422 2.8181) ; C5* + #( 5.2050 -8.8128 1.8901) ; H5* + #( 5.5368 -8.7738 3.7227) ; H5** + #( 6.3232 -7.2037 2.6002) ; C4* + #( 7.3048 -7.6757 2.5577) ; H4* + #( 6.0635 -6.5092 1.3456) ; O4* + #( 6.4697 -5.1547 1.4629) ; C1* + #( 7.2354 -5.0043 0.7018) ; H1* + #( 7.0856 -4.9610 2.8521) ; C2* + #( 6.7777 -3.9935 3.2487) ; H2** + #( 8.4627 -5.1992 2.7423) ; O2* + #( 8.8693 -4.8638 1.9399) ; H2* + #( 6.3877 -6.0809 3.6362) ; C3* + #( 5.3770 -5.7562 3.8834) ; H3* + #( 7.1024 -6.4754 4.7985) ; O3* + #( 5.2764 -4.2883 1.2538) ; N1 + #( 3.8961 -3.0896 -0.1893) ; N3 + #( 5.0095 -3.8907 -0.0346) ; C2 + #( 3.0480 -2.6632 0.8116) ; C4 + #( 3.4093 -3.1310 2.1292) ; C5 + #( 4.4878 -3.9124 2.3088) ; C6 + #( 5.7005 -4.2164 -0.9842) ; O2 + #( 2.0800 -1.9458 0.5503) ; O4 + #( 3.6834 -2.7882 -1.1190) ; H3 + #( 2.8508 -2.8721 2.9172) ; H5 + #( 4.7188 -4.2247 3.2295) ; H6 + )) + +(define rU05 + (make-constant-rU + #( -0.6298 0.0246 0.7763 ; dgf-base-tfo + -0.5226 -0.7529 -0.4001 + 0.5746 -0.6577 0.4870 + -0.0208 -3.4598 -9.6882) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 4.3825 -6.6585 4.0489) ; C5* + #( 4.6841 -7.2019 4.9443) ; H5* + #( 3.6189 -5.8889 4.1625) ; H5** + #( 5.6255 -5.9175 3.5998) ; C4* + #( 5.8732 -5.1228 4.3034) ; H4* + #( 6.7337 -6.8605 3.5222) ; O4* + #( 7.5932 -6.4923 2.4548) ; C1* + #( 8.5661 -6.2983 2.9064) ; H1* + #( 7.0527 -5.2012 1.8322) ; C2* + #( 7.1627 -5.2525 0.7490) ; H2** + #( 7.6666 -4.1249 2.4880) ; O2* + #( 8.5944 -4.2543 2.6981) ; H2* + #( 5.5661 -5.3029 2.2009) ; C3* + #( 5.0841 -6.0018 1.5172) ; H3* + #( 4.9062 -4.0452 2.2042) ; O3* + #( 7.6298 -7.6136 1.4752) ; N1 + #( 8.5977 -9.5977 0.7329) ; N3 + #( 8.5951 -8.5745 1.6594) ; C2 + #( 7.7372 -9.7371 -0.3364) ; C4 + #( 6.7596 -8.6801 -0.4476) ; C5 + #( 6.7338 -7.6721 0.4408) ; C6 + #( 9.3993 -8.5377 2.5743) ; O2 + #( 7.8374 -10.6990 -1.1008) ; O4 + #( 9.2924 -10.3081 0.8477) ; H3 + #( 6.0932 -8.6982 -1.1929) ; H5 + #( 6.0481 -6.9515 0.3446) ; H6 + )) + +(define rU06 + (make-constant-rU + #( -0.9837 0.0476 -0.1733 ; dgf-base-tfo + -0.1792 -0.3353 0.9249 + -0.0141 0.9409 0.3384 + 5.7793 -5.2303 4.5997) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 3.9938 -6.7042 1.9023) ; C5* + #( 3.2332 -5.9343 2.0319) ; H5* + #( 3.9666 -7.2863 0.9812) ; H5** + #( 5.3098 -5.9546 1.8564) ; C4* + #( 5.3863 -5.3702 0.9395) ; H4* + #( 5.3851 -5.0642 3.0076) ; O4* + #( 6.7315 -4.9724 3.4462) ; C1* + #( 7.0033 -3.9202 3.3619) ; H1* + #( 7.5997 -5.8018 2.4948) ; C2* + #( 8.3627 -6.3254 3.0707) ; H2** + #( 8.0410 -4.9501 1.4724) ; O2* + #( 8.2781 -4.0644 1.7570) ; H2* + #( 6.5701 -6.8129 1.9714) ; C3* + #( 6.4186 -7.5809 2.7299) ; H3* + #( 6.9357 -7.3841 0.7235) ; O3* + #( 6.8024 -5.4718 4.8475) ; N1 + #( 6.6920 -5.0495 7.1354) ; N3 + #( 6.6201 -4.5500 5.8506) ; C2 + #( 6.9254 -6.3614 7.4926) ; C4 + #( 7.1046 -7.2543 6.3718) ; C5 + #( 7.0391 -6.7951 5.1106) ; C6 + #( 6.4083 -3.3696 5.6340) ; O2 + #( 6.9679 -6.6901 8.6800) ; O4 + #( 6.5626 -4.3957 7.8812) ; H3 + #( 7.2781 -8.2254 6.5350) ; H5 + #( 7.1657 -7.4312 4.3503) ; H6 + )) + +(define rU07 + (make-constant-rU + #( -0.9434 0.3172 0.0971 ; dgf-base-tfo + 0.2294 0.4125 0.8816 + 0.2396 0.8539 -0.4619 + 8.3625 -52.7147 1.3745) + #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo + -0.8297 0.4733 -0.2959 + 0.4850 0.8737 0.0379 + -14.7774 -45.2464 21.9088) + #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo + -0.5932 -0.6591 0.4624 + -0.7980 0.4055 -0.4458 + 43.7634 4.3296 28.4890) + #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo + 0.6803 0.3317 0.6536 + -0.1673 -0.7979 0.5791 + -17.1858 41.4390 -27.0751) + #( 21.3880 15.0780 45.5770) ; P + #( 21.9980 14.5500 46.8210) ; O1P + #( 21.1450 14.0270 44.5420) ; O2P + #( 22.1250 16.3600 44.9460) ; O5* + #( 21.5037 16.8594 43.7323) ; C5* + #( 20.8147 17.6663 43.9823) ; H5* + #( 21.1086 16.0230 43.1557) ; H5** + #( 22.5654 17.4874 42.8616) ; C4* + #( 22.1584 17.7243 41.8785) ; H4* + #( 23.0557 18.6826 43.4751) ; O4* + #( 24.4788 18.6151 43.6455) ; C1* + #( 24.9355 19.0840 42.7739) ; H1* + #( 24.7958 17.1427 43.6474) ; C2* + #( 24.5652 16.7400 44.6336) ; H2** + #( 26.1041 16.8773 43.2455) ; O2* + #( 26.7516 17.5328 43.5149) ; H2* + #( 23.8109 16.5979 42.6377) ; C3* + #( 23.5756 15.5686 42.9084) ; H3* + #( 24.2890 16.7447 41.2729) ; O3* + #( 24.9420 19.2174 44.8923) ; N1 + #( 25.2655 20.5636 44.8883) ; N3 + #( 25.1663 21.2219 43.8561) ; C2 + #( 25.6911 21.1219 46.0494) ; C4 + #( 25.8051 20.4068 47.2048) ; C5 + #( 26.2093 20.9962 48.2534) ; C6 + #( 25.4692 19.0221 47.2053) ; O2 + #( 25.0502 18.4827 46.0370) ; O4 + #( 25.9599 22.1772 46.0966) ; H3 + #( 25.5545 18.4409 48.1234) ; H5 + #( 24.7854 17.4265 45.9883) ; H6 + )) + +(define rU08 + (make-constant-rU + #( -0.0080 -0.7928 0.6094 ; dgf-base-tfo + -0.7512 0.4071 0.5197 + -0.6601 -0.4536 -0.5988 + 44.1482 30.7036 2.1088) + #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo + -0.8297 0.4733 -0.2959 + 0.4850 0.8737 0.0379 + -14.7774 -45.2464 21.9088) + #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo + -0.5932 -0.6591 0.4624 + -0.7980 0.4055 -0.4458 + 43.7634 4.3296 28.4890) + #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo + 0.6803 0.3317 0.6536 + -0.1673 -0.7979 0.5791 + -17.1858 41.4390 -27.0751) + #( 21.3880 15.0780 45.5770) ; P + #( 21.9980 14.5500 46.8210) ; O1P + #( 21.1450 14.0270 44.5420) ; O2P + #( 22.1250 16.3600 44.9460) ; O5* + #( 23.5096 16.1227 44.5783) ; C5* + #( 23.5649 15.8588 43.5222) ; H5* + #( 23.9621 15.4341 45.2919) ; H5** + #( 24.2805 17.4138 44.7151) ; C4* + #( 25.3492 17.2309 44.6030) ; H4* + #( 23.8497 18.3471 43.7208) ; O4* + #( 23.4090 19.5681 44.3321) ; C1* + #( 24.2595 20.2496 44.3524) ; H1* + #( 23.0418 19.1813 45.7407) ; C2* + #( 22.0532 18.7224 45.7273) ; H2** + #( 23.1307 20.2521 46.6291) ; O2* + #( 22.8888 21.1051 46.2611) ; H2* + #( 24.0799 18.1326 46.0700) ; C3* + #( 23.6490 17.4370 46.7900) ; H3* + #( 25.3329 18.7227 46.5109) ; O3* + #( 22.2515 20.1624 43.6698) ; N1 + #( 22.4760 21.0609 42.6406) ; N3 + #( 23.6229 21.3462 42.3061) ; C2 + #( 21.3986 21.6081 42.0236) ; C4 + #( 20.1189 21.3012 42.3804) ; C5 + #( 19.1599 21.8516 41.7578) ; C6 + #( 19.8919 20.3745 43.4387) ; O2 + #( 20.9790 19.8423 44.0440) ; O4 + #( 21.5235 22.3222 41.2097) ; H3 + #( 18.8732 20.1200 43.7312) ; H5 + #( 20.8545 19.1313 44.8608) ; H6 + )) + +(define rU09 + (make-constant-rU + #( -0.0317 0.1374 0.9900 ; dgf-base-tfo + -0.3422 -0.9321 0.1184 + 0.9391 -0.3351 0.0765 + -32.1929 25.8198 -28.5088) + #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo + -0.8297 0.4733 -0.2959 + 0.4850 0.8737 0.0379 + -14.7774 -45.2464 21.9088) + #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo + -0.5932 -0.6591 0.4624 + -0.7980 0.4055 -0.4458 + 43.7634 4.3296 28.4890) + #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo + 0.6803 0.3317 0.6536 + -0.1673 -0.7979 0.5791 + -17.1858 41.4390 -27.0751) + #( 21.3880 15.0780 45.5770) ; P + #( 21.9980 14.5500 46.8210) ; O1P + #( 21.1450 14.0270 44.5420) ; O2P + #( 22.1250 16.3600 44.9460) ; O5* + #( 21.5037 16.8594 43.7323) ; C5* + #( 20.8147 17.6663 43.9823) ; H5* + #( 21.1086 16.0230 43.1557) ; H5** + #( 22.5654 17.4874 42.8616) ; C4* + #( 23.0565 18.3036 43.3915) ; H4* + #( 23.5375 16.5054 42.4925) ; O4* + #( 23.6574 16.4257 41.0649) ; C1* + #( 24.4701 17.0882 40.7671) ; H1* + #( 22.3525 16.9643 40.5396) ; C2* + #( 21.5993 16.1799 40.6133) ; H2** + #( 22.4693 17.4849 39.2515) ; O2* + #( 23.0899 17.0235 38.6827) ; H2* + #( 22.0341 18.0633 41.5279) ; C3* + #( 20.9509 18.1709 41.5846) ; H3* + #( 22.7249 19.3020 41.2100) ; O3* + #( 23.8580 15.0648 40.5757) ; N1 + #( 25.1556 14.5982 40.4523) ; N3 + #( 26.1047 15.3210 40.7448) ; C2 + #( 25.3391 13.3315 40.0020) ; C4 + #( 24.2974 12.5148 39.6749) ; C5 + #( 24.5450 11.3410 39.2610) ; C6 + #( 22.9633 12.9979 39.8053) ; O2 + #( 22.8009 14.2648 40.2524) ; O4 + #( 26.3414 12.9194 39.8855) ; H3 + #( 22.1227 12.3533 39.5486) ; H5 + #( 21.7989 14.6788 40.3650) ; H6 + )) + +(define rU10 + (make-constant-rU + #( -0.9674 0.1021 -0.2318 ; dgf-base-tfo + -0.2514 -0.2766 0.9275 + 0.0306 0.9555 0.2933 + 27.8571 -42.1305 -24.4563) + #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo + -0.8297 0.4733 -0.2959 + 0.4850 0.8737 0.0379 + -14.7774 -45.2464 21.9088) + #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo + -0.5932 -0.6591 0.4624 + -0.7980 0.4055 -0.4458 + 43.7634 4.3296 28.4890) + #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo + 0.6803 0.3317 0.6536 + -0.1673 -0.7979 0.5791 + -17.1858 41.4390 -27.0751) + #( 21.3880 15.0780 45.5770) ; P + #( 21.9980 14.5500 46.8210) ; O1P + #( 21.1450 14.0270 44.5420) ; O2P + #( 22.1250 16.3600 44.9460) ; O5* + #( 23.5096 16.1227 44.5783) ; C5* + #( 23.5649 15.8588 43.5222) ; H5* + #( 23.9621 15.4341 45.2919) ; H5** + #( 24.2805 17.4138 44.7151) ; C4* + #( 23.8509 18.1819 44.0720) ; H4* + #( 24.2506 17.8583 46.0741) ; O4* + #( 25.5830 18.0320 46.5775) ; C1* + #( 25.8569 19.0761 46.4256) ; H1* + #( 26.4410 17.1555 45.7033) ; C2* + #( 26.3459 16.1253 46.0462) ; H2** + #( 27.7649 17.5888 45.6478) ; O2* + #( 28.1004 17.9719 46.4616) ; H2* + #( 25.7796 17.2997 44.3513) ; C3* + #( 25.9478 16.3824 43.7871) ; H3* + #( 26.2154 18.4984 43.6541) ; O3* + #( 25.7321 17.6281 47.9726) ; N1 + #( 25.5136 18.5779 48.9560) ; N3 + #( 25.2079 19.7276 48.6503) ; C2 + #( 25.6482 18.1987 50.2518) ; C4 + #( 25.9847 16.9266 50.6092) ; C5 + #( 26.0918 16.6439 51.8416) ; C6 + #( 26.2067 15.9515 49.5943) ; O2 + #( 26.0713 16.3497 48.3080) ; O4 + #( 25.4890 18.9105 51.0618) ; H3 + #( 26.4742 14.9310 49.8682) ; H5 + #( 26.2346 15.6394 47.4975) ; H6 + )) + +(define rUs + (list rU01 rU02 rU03 rU04 rU05 rU06 rU07 rU08 rU09 rU10)) + +(define rG* + (make-constant-rG + #( -0.2067 -0.0264 0.9780 ; dgf-base-tfo + 0.9770 -0.0586 0.2049 + 0.0519 0.9979 0.0379 + 1.0331 -46.8078 -36.4742) + #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo + -0.0427 0.2409 -0.9696 + 0.5010 -0.8345 -0.2294 + 4.0167 54.5377 12.4779) + #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo + -0.2867 -0.7872 -0.5460 + 0.8834 0.0032 -0.4686 + -52.9020 18.6313 -0.6709) + #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo + 0.9040 -0.4236 -0.0582 + -0.1007 -0.0786 -0.9918 + -7.6624 -25.2080 49.5181) + #( 31.3810 0.1400 47.5810) ; P + #( 29.9860 0.6630 47.6290) ; O1P + #( 31.7210 -0.6460 48.8090) ; O2P + #( 32.4940 1.2540 47.2740) ; O5* + #( 32.1610 2.2370 46.2560) ; C5* + #( 31.2986 2.8190 46.5812) ; H5* + #( 32.0980 1.7468 45.2845) ; H5** + #( 33.3476 3.1959 46.1947) ; C4* + #( 33.2668 3.8958 45.3630) ; H4* + #( 33.3799 3.9183 47.4216) ; O4* + #( 34.6515 3.7222 48.0398) ; C1* + #( 35.2947 4.5412 47.7180) ; H1* + #( 35.1756 2.4228 47.4827) ; C2* + #( 34.6778 1.5937 47.9856) ; H2** + #( 36.5631 2.2672 47.4798) ; O2* + #( 37.0163 2.6579 48.2305) ; H2* + #( 34.6953 2.5043 46.0448) ; C3* + #( 34.5444 1.4917 45.6706) ; H3* + #( 35.6679 3.3009 45.3487) ; O3* + #( 37.4804 4.0914 52.2559) ; N1 + #( 36.9670 4.1312 49.9281) ; N3 + #( 37.8045 4.2519 50.9550) ; C2 + #( 35.7171 3.8264 50.3222) ; C4 + #( 35.2668 3.6420 51.6115) ; C5 + #( 36.2037 3.7829 52.6706) ; C6 + #( 39.0869 4.5552 50.7092) ; N2 + #( 33.9075 3.3338 51.6102) ; N7 + #( 34.6126 3.6358 49.5108) ; N9 + #( 33.5805 3.3442 50.3425) ; C8 + #( 35.9958 3.6512 53.8724) ; O6 + #( 38.2106 4.2053 52.9295) ; H1 + #( 39.8218 4.6863 51.3896) ; H21 + #( 39.3420 4.6857 49.7407) ; H22 + #( 32.5194 3.1070 50.2664) ; H8 + )) + +(define rU* + (make-constant-rU + #( -0.0109 0.5907 0.8068 ; dgf-base-tfo + 0.2217 -0.7853 0.5780 + 0.9751 0.1852 -0.1224 + -1.4225 -11.0956 -2.5217) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2430 -8.2420 2.8260) ; C5* + #( 5.1974 -8.8497 1.9223) ; H5* + #( 5.5548 -8.7348 3.7469) ; H5** + #( 6.3140 -7.2060 2.5510) ; C4* + #( 5.8744 -6.2116 2.4731) ; H4* + #( 7.2798 -7.2260 3.6420) ; O4* + #( 8.5733 -6.9410 3.1329) ; C1* + #( 8.9047 -6.0374 3.6446) ; H1* + #( 8.4429 -6.6596 1.6327) ; C2* + #( 9.2880 -7.1071 1.1096) ; H2** + #( 8.2502 -5.2799 1.4754) ; O2* + #( 8.7676 -4.7284 2.0667) ; H2* + #( 7.1642 -7.4416 1.3021) ; C3* + #( 7.4125 -8.5002 1.2260) ; H3* + #( 6.5160 -6.9772 0.1267) ; O3* + #( 9.4531 -8.1107 3.4087) ; N1 + #( 11.5931 -9.0015 3.6357) ; N3 + #( 10.8101 -7.8950 3.3748) ; C2 + #( 11.1439 -10.2744 3.9206) ; C4 + #( 9.7056 -10.4026 3.9332) ; C5 + #( 8.9192 -9.3419 3.6833) ; C6 + #( 11.3013 -6.8063 3.1326) ; O2 + #( 11.9431 -11.1876 4.1375) ; O4 + #( 12.5840 -8.8673 3.6158) ; H3 + #( 9.2891 -11.2898 4.1313) ; H5 + #( 7.9263 -9.4537 3.6977) ; H6 + )) + + + +; -- PARTIAL INSTANTIATIONS --------------------------------------------------- + +(define (get-var id lst) + (let ((v (car lst))) + (if (= id (var-id v)) + v + (get-var id (cdr lst))))) + +(define (make-relative-nuc tfo n) + (cond ((rA? n) + (make-rA + (nuc-dgf-base-tfo n) + (nuc-P-O3*-275-tfo n) + (nuc-P-O3*-180-tfo n) + (nuc-P-O3*-60-tfo n) + (lazy-computation-of (tfo-apply tfo (nuc-P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O1P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5** n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2** n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-N1 n))) + (lazy-computation-of (tfo-apply tfo (nuc-N3 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C6 n))) + (lazy-computation-of (tfo-apply tfo (rA-N6 n))) + (lazy-computation-of (tfo-apply tfo (rA-N7 n))) + (lazy-computation-of (tfo-apply tfo (rA-N9 n))) + (lazy-computation-of (tfo-apply tfo (rA-C8 n))) + (lazy-computation-of (tfo-apply tfo (rA-H2 n))) + (lazy-computation-of (tfo-apply tfo (rA-H61 n))) + (lazy-computation-of (tfo-apply tfo (rA-H62 n))) + (lazy-computation-of (tfo-apply tfo (rA-H8 n))))) + ((rC? n) + (make-rC + (nuc-dgf-base-tfo n) + (nuc-P-O3*-275-tfo n) + (nuc-P-O3*-180-tfo n) + (nuc-P-O3*-60-tfo n) + (lazy-computation-of (tfo-apply tfo (nuc-P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O1P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5** n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2** n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-N1 n))) + (lazy-computation-of (tfo-apply tfo (nuc-N3 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C6 n))) + (lazy-computation-of (tfo-apply tfo (rC-N4 n))) + (lazy-computation-of (tfo-apply tfo (rC-O2 n))) + (lazy-computation-of (tfo-apply tfo (rC-H41 n))) + (lazy-computation-of (tfo-apply tfo (rC-H42 n))) + (lazy-computation-of (tfo-apply tfo (rC-H5 n))) + (lazy-computation-of (tfo-apply tfo (rC-H6 n))))) + ((rG? n) + (make-rG + (nuc-dgf-base-tfo n) + (nuc-P-O3*-275-tfo n) + (nuc-P-O3*-180-tfo n) + (nuc-P-O3*-60-tfo n) + (lazy-computation-of (tfo-apply tfo (nuc-P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O1P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5** n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2** n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-N1 n))) + (lazy-computation-of (tfo-apply tfo (nuc-N3 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C6 n))) + (lazy-computation-of (tfo-apply tfo (rG-N2 n))) + (lazy-computation-of (tfo-apply tfo (rG-N7 n))) + (lazy-computation-of (tfo-apply tfo (rG-N9 n))) + (lazy-computation-of (tfo-apply tfo (rG-C8 n))) + (lazy-computation-of (tfo-apply tfo (rG-O6 n))) + (lazy-computation-of (tfo-apply tfo (rG-H1 n))) + (lazy-computation-of (tfo-apply tfo (rG-H21 n))) + (lazy-computation-of (tfo-apply tfo (rG-H22 n))) + (lazy-computation-of (tfo-apply tfo (rG-H8 n))))) + (else + (make-rU + (nuc-dgf-base-tfo n) + (nuc-P-O3*-275-tfo n) + (nuc-P-O3*-180-tfo n) + (nuc-P-O3*-60-tfo n) + (lazy-computation-of (tfo-apply tfo (nuc-P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O1P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5** n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2** n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-N1 n))) + (lazy-computation-of (tfo-apply tfo (nuc-N3 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C6 n))) + (lazy-computation-of (tfo-apply tfo (rU-O2 n))) + (lazy-computation-of (tfo-apply tfo (rU-O4 n))) + (lazy-computation-of (tfo-apply tfo (rU-H3 n))) + (lazy-computation-of (tfo-apply tfo (rU-H5 n))) + (lazy-computation-of (tfo-apply tfo (rU-H6 n))))))) + +; -- SEARCH ------------------------------------------------------------------- + +; Sequential backtracking algorithm + +(define (search partial-inst domains constraint?) + (if (null? domains) + (list partial-inst) + (let ((remaining-domains (cdr domains))) + + (define (try-assignments lst) + (if (null? lst) + '() + (let ((var (car lst))) + (if (constraint? var partial-inst) + (let* ((subsols1 + (search + (cons var partial-inst) + remaining-domains + constraint?)) + (subsols2 + (try-assignments (cdr lst)))) + (append subsols1 subsols2)) + (try-assignments (cdr lst)))))) + + (try-assignments ((car domains) partial-inst))))) + +; -- DOMAINS ------------------------------------------------------------------ + +; Primary structure: strand A CUGCCACGUCUG, strand B CAGACGUGGCAG +; +; Secondary structure: strand A CUGCCACGUCUG +; |||||||||||| +; GACGGUGCAGAC strand B +; +; Tertiary structure: +; +; 5' end of strand A C1----G12 3' end of strand B +; U2-------A11 +; G3-------C10 +; C4-----G9 +; C5---G8 +; A6 +; G6-C7 +; C5----G8 +; A4-------U9 +; G3--------C10 +; A2-------U11 +; 5' end of strand B C1----G12 3' end of strand A +; +; "helix", "stacked" and "connected" describe the spatial relationship +; between two consecutive nucleotides. E.g. the nucleotides C1 and U2 +; from the strand A. +; +; "wc" (stands for Watson-Crick and is a type of base-pairing), +; and "wc-dumas" describe the spatial relationship between +; nucleotides from two chains that are growing in opposite directions. +; E.g. the nucleotides C1 from strand A and G12 from strand B. + +; Dynamic Domains + +; Given, +; "ref" a nucleotide which is already positioned, +; "nuc" the nucleotide to be placed, +; and "tfo" a transformation matrix which expresses the desired +; relationship between "ref" and "nuc", +; the function "dgf-base" computes the transformation matrix that +; places the nucleotide "nuc" in the given relationship to "ref". + +(define (dgf-base tfo ref nuc) + (let* ((ref-nuc (var-nuc ref)) + (align + (tfo-inv-ortho + (cond ((rA? ref-nuc) + (tfo-align (atom-pos nuc-C1* ref) + (atom-pos rA-N9 ref) + (atom-pos nuc-C4 ref))) + ((rC? ref-nuc) + (tfo-align (atom-pos nuc-C1* ref) + (atom-pos nuc-N1 ref) + (atom-pos nuc-C2 ref))) + ((rG? ref-nuc) + (tfo-align (atom-pos nuc-C1* ref) + (atom-pos rG-N9 ref) + (atom-pos nuc-C4 ref))) + (else + (tfo-align (atom-pos nuc-C1* ref) + (atom-pos nuc-N1 ref) + (atom-pos nuc-C2 ref))))))) + (tfo-combine (nuc-dgf-base-tfo nuc) + (tfo-combine tfo align)))) + +; Placement of first nucleotide. + +(define (reference nuc i) + (lambda (partial-inst) + (list (mk-var i tfo-id nuc)))) + +; The transformation matrix for wc is from: +; +; Chandrasekaran R. et al (1989) A Re-Examination of the Crystal +; Structure of A-DNA Using Fiber Diffraction Data. J. Biomol. +; Struct. & Dynamics 6(6):1189-1202. + +(define wc-tfo + '#(-1.0000 0.0028 -0.0019 + 0.0028 0.3468 -0.9379 + -0.0019 -0.9379 -0.3468 + -0.0080 6.0730 8.7208)) + +(define (wc nuc i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (tfo (dgf-base wc-tfo ref nuc))) + (list (mk-var i tfo nuc))))) + +(define wc-Dumas-tfo + '#(-0.9737 -0.1834 0.1352 + -0.1779 0.2417 -0.9539 + 0.1422 -0.9529 -0.2679 + 0.4837 6.2649 8.0285)) + +(define (wc-Dumas nuc i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (tfo (dgf-base wc-Dumas-tfo ref nuc))) + (list (mk-var i tfo nuc))))) + +(define helix5*-tfo + '#( 0.9886 -0.0961 0.1156 + 0.1424 0.8452 -0.5152 + -0.0482 0.5258 0.8492 + -3.8737 0.5480 3.8024)) + +(define (helix5* nuc i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (tfo (dgf-base helix5*-tfo ref nuc))) + (list (mk-var i tfo nuc))))) + +(define helix3*-tfo + '#( 0.9886 0.1424 -0.0482 + -0.0961 0.8452 0.5258 + 0.1156 -0.5152 0.8492 + 3.4426 2.0474 -3.7042)) + +(define (helix3* nuc i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (tfo (dgf-base helix3*-tfo ref nuc))) + (list (mk-var i tfo nuc))))) + +(define G37-A38-tfo + '#( 0.9991 0.0164 -0.0387 + -0.0375 0.7616 -0.6470 + 0.0189 0.6478 0.7615 + -3.3018 0.9975 2.5585)) + +(define (G37-A38 nuc i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (tfo (dgf-base G37-A38-tfo ref nuc))) + (mk-var i tfo nuc)))) + +(define (stacked5* nuc i j) + (lambda (partial-inst) + (cons ((G37-A38 nuc i j) partial-inst) + ((helix5* nuc i j) partial-inst)))) + +(define A38-G37-tfo + '#( 0.9991 -0.0375 0.0189 + 0.0164 0.7616 0.6478 + -0.0387 -0.6470 0.7615 + 3.3819 0.7718 -2.5321)) + +(define (A38-G37 nuc i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (tfo (dgf-base A38-G37-tfo ref nuc))) + (mk-var i tfo nuc)))) + +(define (stacked3* nuc i j) + (lambda (partial-inst) + (cons ((A38-G37 nuc i j) partial-inst) + ((helix3* nuc i j) partial-inst)))) + +(define (P-O3* nucs i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (align + (tfo-inv-ortho + (tfo-align (atom-pos nuc-O3* ref) + (atom-pos nuc-C3* ref) + (atom-pos nuc-C4* ref))))) + (let loop ((lst nucs) (domains '())) + (if (null? lst) + domains + (let ((nuc (car lst))) + (let ((tfo-60 (tfo-combine (nuc-P-O3*-60-tfo nuc) align)) + (tfo-180 (tfo-combine (nuc-P-O3*-180-tfo nuc) align)) + (tfo-275 (tfo-combine (nuc-P-O3*-275-tfo nuc) align))) + (loop (cdr lst) + (cons (mk-var i tfo-60 nuc) + (cons (mk-var i tfo-180 nuc) + (cons (mk-var i tfo-275 nuc) domains))))))))))) + +; -- PROBLEM STATEMENT -------------------------------------------------------- + +; Define anticodon problem -- Science 253:1255 Figure 3a, 3b and 3c + +(define anticodon-domains + (list + (reference rC 27 ) + (helix5* rC 28 27) + (helix5* rA 29 28) + (helix5* rG 30 29) + (helix5* rA 31 30) + (wc rU 39 31) + (helix5* rC 40 39) + (helix5* rU 41 40) + (helix5* rG 42 41) + (helix5* rG 43 42) + (stacked3* rA 38 39) + (stacked3* rG 37 38) + (stacked3* rA 36 37) + (stacked3* rA 35 36) + (stacked3* rG 34 35);<-. Distance + (P-O3* rCs 32 31); | Constraint + (P-O3* rUs 33 32);<-' 3.0 Angstroms + )) + +; Anticodon constraint + +(define (anticodon-constraint? v partial-inst) + (if (= (var-id v) 33) + (let ((p (atom-pos nuc-P (get-var 34 partial-inst))) ; P in nucleotide 34 + (o3* (atom-pos nuc-O3* v))) ; O3' in nucl. 33 + (FLOAT<= (pt-dist p o3*) 3.0)) ; check distance + #t)) + +(define (anticodon) + (search '() anticodon-domains anticodon-constraint?)) + +; Define pseudoknot problem -- Science 253:1255 Figure 4a and 4b + +(define pseudoknot-domains + (list + (reference rA 23 ) + (wc-Dumas rU 8 23) + (helix3* rG 22 23) + (wc-Dumas rC 9 22) + (helix3* rG 21 22) + (wc-Dumas rC 10 21) + (helix3* rC 20 21) + (wc-Dumas rG 11 20) + (helix3* rU* 19 20);<-. + (wc-Dumas rA 12 19); | Distance +; ; | Constraint +; Helix 1 ; | 4.0 Angstroms + (helix3* rC 3 19); | + (wc-Dumas rG 13 3); | + (helix3* rC 2 3); | + (wc-Dumas rG 14 2); | + (helix3* rC 1 2); | + (wc-Dumas rG* 15 1); | +; ; | +; L2 LOOP ; | + (P-O3* rUs 16 15); | + (P-O3* rCs 17 16); | + (P-O3* rAs 18 17);<-' +; +; L1 LOOP + (helix3* rU 7 8);<-. + (P-O3* rCs 4 3); | Constraint + (stacked5* rU 5 4); | 4.5 Angstroms + (stacked5* rC 6 5);<-' + )) + +; Pseudoknot constraint + +(define (pseudoknot-constraint? v partial-inst) + (case (var-id v) + ((18) + (let ((p (atom-pos nuc-P (get-var 19 partial-inst))) + (o3* (atom-pos nuc-O3* v))) + (FLOAT<= (pt-dist p o3*) 4.0))) + ((6) + (let ((p (atom-pos nuc-P (get-var 7 partial-inst))) + (o3* (atom-pos nuc-O3* v))) + (FLOAT<= (pt-dist p o3*) 4.5))) + (else + #t))) + +(define (pseudoknot) + (search '() pseudoknot-domains pseudoknot-constraint?)) + +; -- TESTING ----------------------------------------------------------------- + +(define (list-of-atoms n) + (append (list-of-common-atoms n) + (list-of-specific-atoms n))) + +(define (list-of-common-atoms n) + (list + (nuc-P n) + (nuc-O1P n) + (nuc-O2P n) + (nuc-O5* n) + (nuc-C5* n) + (nuc-H5* n) + (nuc-H5** n) + (nuc-C4* n) + (nuc-H4* n) + (nuc-O4* n) + (nuc-C1* n) + (nuc-H1* n) + (nuc-C2* n) + (nuc-H2** n) + (nuc-O2* n) + (nuc-H2* n) + (nuc-C3* n) + (nuc-H3* n) + (nuc-O3* n) + (nuc-N1 n) + (nuc-N3 n) + (nuc-C2 n) + (nuc-C4 n) + (nuc-C5 n) + (nuc-C6 n))) + +(define (list-of-specific-atoms n) + (cond ((rA? n) + (list + (rA-N6 n) + (rA-N7 n) + (rA-N9 n) + (rA-C8 n) + (rA-H2 n) + (rA-H61 n) + (rA-H62 n) + (rA-H8 n))) + ((rC? n) + (list + (rC-N4 n) + (rC-O2 n) + (rC-H41 n) + (rC-H42 n) + (rC-H5 n) + (rC-H6 n))) + ((rG? n) + (list + (rG-N2 n) + (rG-N7 n) + (rG-N9 n) + (rG-C8 n) + (rG-O6 n) + (rG-H1 n) + (rG-H21 n) + (rG-H22 n) + (rG-H8 n))) + (else + (list + (rU-O2 n) + (rU-O4 n) + (rU-H3 n) + (rU-H5 n) + (rU-H6 n))))) + +(define (var-most-distant-atom v) + + (define (distance pos) + (let ((abs-pos (absolute-pos v pos))) + (let ((x (pt-x abs-pos)) (y (pt-y abs-pos)) (z (pt-z abs-pos))) + (FLOATsqrt (FLOAT+ (FLOAT* x x) (FLOAT* y y) (FLOAT* z z)))))) + + (maximum (map distance (list-of-atoms (var-nuc v))))) + +(define (sol-most-distant-atom s) + (maximum (map var-most-distant-atom s))) + +(define (most-distant-atom sols) + (maximum (map sol-most-distant-atom sols))) + +(define (maximum lst) + (let loop ((m (car lst)) (l (cdr lst))) + (if (null? l) + m + (let ((x (car l))) + (loop (if (FLOAT> x m) x m) (cdr l)))))) + +(define (check) + (length (pseudoknot))) + +(define (run) + (most-distant-atom (pseudoknot))) + +; To run program, evaluate: (run) + +(time (let loop ((i 10)) (if (zero? i) 'done (begin (run) (loop (- i 1)))))) diff --git a/benchmarks/gabriel/paraffins.sch b/benchmarks/gabriel/paraffins.sch new file mode 100644 index 00000000..708a85ad --- /dev/null +++ b/benchmarks/gabriel/paraffins.sch @@ -0,0 +1,175 @@ +;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms. + +(define (gen n) + (let* ((n/2 (quotient n 2)) + (radicals (make-vector (+ n/2 1) '(H)))) + + (define (rads-of-size n) + (let loop1 ((ps + (three-partitions (- n 1))) + (lst + '())) + (if (null? ps) + lst + (let* ((p (car ps)) + (nc1 (vector-ref p 0)) + (nc2 (vector-ref p 1)) + (nc3 (vector-ref p 2))) + (let loop2 ((rads1 + (vector-ref radicals nc1)) + (lst + (loop1 (cdr ps) + lst))) + (if (null? rads1) + lst + (let loop3 ((rads2 + (if (= nc1 nc2) + rads1 + (vector-ref radicals nc2))) + (lst + (loop2 (cdr rads1) + lst))) + (if (null? rads2) + lst + (let loop4 ((rads3 + (if (= nc2 nc3) + rads2 + (vector-ref radicals nc3))) + (lst + (loop3 (cdr rads2) + lst))) + (if (null? rads3) + lst + (cons (vector 'C + (car rads1) + (car rads2) + (car rads3)) + (loop4 (cdr rads3) + lst)))))))))))) + + (define (bcp-generator j) + (if (odd? j) + '() + (let loop1 ((rads1 + (vector-ref radicals (quotient j 2))) + (lst + '())) + (if (null? rads1) + lst + (let loop2 ((rads2 + rads1) + (lst + (loop1 (cdr rads1) + lst))) + (if (null? rads2) + lst + (cons (vector 'BCP + (car rads1) + (car rads2)) + (loop2 (cdr rads2) + lst)))))))) + + (define (ccp-generator j) + (let loop1 ((ps + (four-partitions (- j 1))) + (lst + '())) + (if (null? ps) + lst + (let* ((p (car ps)) + (nc1 (vector-ref p 0)) + (nc2 (vector-ref p 1)) + (nc3 (vector-ref p 2)) + (nc4 (vector-ref p 3))) + (let loop2 ((rads1 + (vector-ref radicals nc1)) + (lst + (loop1 (cdr ps) + lst))) + (if (null? rads1) + lst + (let loop3 ((rads2 + (if (= nc1 nc2) + rads1 + (vector-ref radicals nc2))) + (lst + (loop2 (cdr rads1) + lst))) + (if (null? rads2) + lst + (let loop4 ((rads3 + (if (= nc2 nc3) + rads2 + (vector-ref radicals nc3))) + (lst + (loop3 (cdr rads2) + lst))) + (if (null? rads3) + lst + (let loop5 ((rads4 + (if (= nc3 nc4) + rads3 + (vector-ref radicals nc4))) + (lst + (loop4 (cdr rads3) + lst))) + (if (null? rads4) + lst + (cons (vector 'CCP + (car rads1) + (car rads2) + (car rads3) + (car rads4)) + (loop5 (cdr rads4) + lst)))))))))))))) + + (let loop ((i 1)) + (if (> i n/2) + (vector (bcp-generator n) + (ccp-generator n)) + (begin + (vector-set! radicals i (rads-of-size i)) + (loop (+ i 1))))))) + +(define (three-partitions m) + (let loop1 ((lst '()) + (nc1 (quotient m 3))) + (if (< nc1 0) + lst + (let loop2 ((lst lst) + (nc2 (quotient (- m nc1) 2))) + (if (< nc2 nc1) + (loop1 lst + (- nc1 1)) + (loop2 (cons (vector nc1 nc2 (- m (+ nc1 nc2))) lst) + (- nc2 1))))))) + +(define (four-partitions m) + (let loop1 ((lst '()) + (nc1 (quotient m 4))) + (if (< nc1 0) + lst + (let loop2 ((lst lst) + (nc2 (quotient (- m nc1) 3))) + (if (< nc2 nc1) + (loop1 lst + (- nc1 1)) + (let ((start (max nc2 (- (quotient (+ m 1) 2) (+ nc1 nc2))))) + (let loop3 ((lst lst) + (nc3 (quotient (- m (+ nc1 nc2)) 2))) + (if (< nc3 start) + (loop2 lst (- nc2 1)) + (loop3 (cons (vector nc1 nc2 nc3 (- m (+ nc1 (+ nc2 nc3)))) lst) + (- nc3 1)))))))))) + +(define (nb n) + (let ((x (gen n))) + (+ (length (vector-ref x 0)) + (length (vector-ref x 1))))) + +(let ((input (with-input-from-file "input.txt" read))) + (time + (let loop ((n 100) (v 0)) + (if (zero? n) + v + (loop (- n 1) (nb (if input 17 0))))))) diff --git a/benchmarks/gabriel/peval.sch b/benchmarks/gabriel/peval.sch new file mode 100644 index 00000000..40d50471 --- /dev/null +++ b/benchmarks/gabriel/peval.sch @@ -0,0 +1,633 @@ +;;; PEVAL -- A simple partial evaluator for Scheme, written by Marc Feeley. + +;------------------------------------------------------------------------------ + +; Utilities + +(define (every? pred? l) + (let loop ((l l)) + (or (null? l) (and (pred? (car l)) (loop (cdr l)))))) + +(define (some? pred? l) + (let loop ((l l)) + (if (null? l) #f (or (pred? (car l)) (loop (cdr l)))))) + +(define (map2 f l1 l2) + (let loop ((l1 l1) (l2 l2)) + (if (pair? l1) + (cons (f (car l1) (car l2)) (loop (cdr l1) (cdr l2))) + '()))) + +(define (get-last-pair l) + (let loop ((l l)) + (let ((x (cdr l))) (if (pair? x) (loop x) l)))) + +;------------------------------------------------------------------------------ +; +; The partial evaluator. + +(define (partial-evaluate proc args) + (peval (alphatize proc '()) args)) + +(define (alphatize exp env) ; return a copy of 'exp' where each bound var has + (define (alpha exp) ; been renamed (to prevent aliasing problems) + (cond ((const-expr? exp) + (quot (const-value exp))) + ((symbol? exp) + (let ((x (assq exp env))) (if x (cdr x) exp))) + ((or (eq? (car exp) 'if) (eq? (car exp) 'begin)) + (cons (car exp) (map alpha (cdr exp)))) + ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec)) + (let ((new-env (new-variables (map car (cadr exp)) env))) + (list (car exp) + (map (lambda (x) + (list (cdr (assq (car x) new-env)) + (if (eq? (car exp) 'let) + (alpha (cadr x)) + (alphatize (cadr x) new-env)))) + (cadr exp)) + (alphatize (caddr exp) new-env)))) + ((eq? (car exp) 'lambda) + (let ((new-env (new-variables (cadr exp) env))) + (list 'lambda + (map (lambda (x) (cdr (assq x new-env))) (cadr exp)) + (alphatize (caddr exp) new-env)))) + (else + (map alpha exp)))) + (alpha exp)) + +(define (const-expr? expr) ; is 'expr' a constant expression? + (and (not (symbol? expr)) + (or (not (pair? expr)) + (eq? (car expr) 'quote)))) + +(define (const-value expr) ; return the value of a constant expression + (if (pair? expr) ; then it must be a quoted constant + (cadr expr) + expr)) + +(define (quot val) ; make a quoted constant whose value is 'val' + (list 'quote val)) + +(define (new-variables parms env) + (append (map (lambda (x) (cons x (new-variable x))) parms) env)) + +(define *current-num* 0) + +(define (new-variable name) + (set! *current-num* (+ *current-num* 1)) + (string->symbol + (string-append (symbol->string name) + "_" + (number->string *current-num*)))) + +;------------------------------------------------------------------------------ +; +; (peval proc args) will transform a procedure that is known to be called +; with constants as some of its arguments into a specialized procedure that +; is 'equivalent' but accepts only the non-constant parameters. 'proc' is the +; list representation of a lambda-expression and 'args' is a list of values, +; one for each parameter of the lambda-expression. A special value (i.e. +; 'not-constant') is used to indicate an argument that is not a constant. +; The returned procedure is one that has as parameters the parameters of the +; original procedure which are NOT passed constants. Constants will have been +; substituted for the constant parameters that are referenced in the body +; of the procedure. +; +; For example: +; +; (peval +; '(lambda (x y z) (f z x y)) ; the procedure +; (list 1 not-constant #t)) ; the knowledge about x, y and z +; +; will return: (lambda (y) (f '#t '1 y)) + +(define (peval proc args) + (simplify! + (let ((parms (cadr proc)) ; get the parameter list + (body (caddr proc))) ; get the body of the procedure + (list 'lambda + (remove-constant parms args) ; remove the constant parameters + (beta-subst ; in the body, replace variable refs to the constant + body ; parameters by the corresponding constant + (map2 (lambda (x y) (if (not-constant? y) '(()) (cons x (quot y)))) + parms + args)))))) + +(define not-constant (list '?)) ; special value indicating non-constant parms. + +(define (not-constant? x) (eq? x not-constant)) + +(define (remove-constant l a) ; remove from list 'l' all elements whose + (cond ((null? l) ; corresponding element in 'a' is a constant + '()) + ((not-constant? (car a)) + (cons (car l) (remove-constant (cdr l) (cdr a)))) + (else + (remove-constant (cdr l) (cdr a))))) + +(define (extract-constant l a) ; extract from list 'l' all elements whose + (cond ((null? l) ; corresponding element in 'a' is a constant + '()) + ((not-constant? (car a)) + (extract-constant (cdr l) (cdr a))) + (else + (cons (car l) (extract-constant (cdr l) (cdr a)))))) + +(define (beta-subst exp env) ; return a modified 'exp' where each var named in + (define (bs exp) ; 'env' is replaced by the corresponding expr (it + (cond ((const-expr? exp) ; is assumed that the code has been alphatized) + (quot (const-value exp))) + ((symbol? exp) + (let ((x (assq exp env))) + (if x (cdr x) exp))) + ((or (eq? (car exp) 'if) (eq? (car exp) 'begin)) + (cons (car exp) (map bs (cdr exp)))) + ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec)) + (list (car exp) + (map (lambda (x) (list (car x) (bs (cadr x)))) (cadr exp)) + (bs (caddr exp)))) + ((eq? (car exp) 'lambda) + (list 'lambda + (cadr exp) + (bs (caddr exp)))) + (else + (map bs exp)))) + (bs exp)) + +;------------------------------------------------------------------------------ +; +; The expression simplifier. + +(define (simplify! exp) ; simplify the expression 'exp' destructively (it + ; is assumed that the code has been alphatized) + (define (simp! where env) + + (define (s! where) + (let ((exp (car where))) + + (cond ((const-expr? exp)) ; leave constants the way they are + + ((symbol? exp)) ; leave variable references the way they are + + ((eq? (car exp) 'if) ; dead code removal for conditionals + (s! (cdr exp)) ; simplify the predicate + (if (const-expr? (cadr exp)) ; is the predicate a constant? + (begin + (set-car! where + (if (memq (const-value (cadr exp)) '(#f ())) ; false? + (if (= (length exp) 3) ''() (cadddr exp)) + (caddr exp))) + (s! where)) + (for-each! s! (cddr exp)))) ; simplify consequent and alt. + + ((eq? (car exp) 'begin) + (for-each! s! (cdr exp)) + (let loop ((exps exp)) ; remove all useless expressions + (if (not (null? (cddr exps))) ; not last expression? + (let ((x (cadr exps))) + (loop (if (or (const-expr? x) + (symbol? x) + (and (pair? x) (eq? (car x) 'lambda))) + (begin (set-cdr! exps (cddr exps)) exps) + (cdr exps)))))) + (if (null? (cddr exp)) ; only one expression in the begin? + (set-car! where (cadr exp)))) + + ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec)) + (let ((new-env (cons exp env))) + (define (keep i) + (if (>= i (length (cadar where))) + '() + (let* ((var (car (list-ref (cadar where) i))) + (val (cadr (assq var (cadar where)))) + (refs (ref-count (car where) var)) + (self-refs (ref-count val var)) + (total-refs (- (car refs) (car self-refs))) + (oper-refs (- (cadr refs) (cadr self-refs)))) + (cond ((= total-refs 0) + (keep (+ i 1))) + ((or (const-expr? val) + (symbol? val) + (and (pair? val) + (eq? (car val) 'lambda) + (= total-refs 1) + (= oper-refs 1) + (= (car self-refs) 0)) + (and (caddr refs) + (= total-refs 1))) + (set-car! where + (beta-subst (car where) + (list (cons var val)))) + (keep (+ i 1))) + (else + (cons var (keep (+ i 1)))))))) + (simp! (cddr exp) new-env) + (for-each! (lambda (x) (simp! (cdar x) new-env)) (cadr exp)) + (let ((to-keep (keep 0))) + (if (< (length to-keep) (length (cadar where))) + (begin + (if (null? to-keep) + (set-car! where (caddar where)) + (set-car! (cdar where) + (map (lambda (v) (assq v (cadar where))) to-keep))) + (s! where)) + (if (null? to-keep) + (set-car! where (caddar where))))))) + + ((eq? (car exp) 'lambda) + (simp! (cddr exp) (cons exp env))) + + (else + (for-each! s! exp) + (cond ((symbol? (car exp)) ; is the operator position a var ref? + (let ((frame (binding-frame (car exp) env))) + (if frame ; is it a bound variable? + (let ((proc (bound-expr (car exp) frame))) + (if (and (pair? proc) + (eq? (car proc) 'lambda) + (some? const-expr? (cdr exp))) + (let* ((args (arg-pattern (cdr exp))) + (new-proc (peval proc args)) + (new-args (remove-constant (cdr exp) args))) + (set-car! where + (cons (add-binding new-proc frame (car exp)) + new-args))))) + (set-car! where + (constant-fold-global (car exp) (cdr exp)))))) + ((not (pair? (car exp)))) + ((eq? (caar exp) 'lambda) + (set-car! where + (list 'let + (map2 list (cadar exp) (cdr exp)) + (caddar exp))) + (s! where))))))) + + (s! where)) + + (define (remove-empty-calls! where env) + + (define (rec! where) + (let ((exp (car where))) + + (cond ((const-expr? exp)) + ((symbol? exp)) + ((eq? (car exp) 'if) + (rec! (cdr exp)) + (rec! (cddr exp)) + (rec! (cdddr exp))) + ((eq? (car exp) 'begin) + (for-each! rec! (cdr exp))) + ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec)) + (let ((new-env (cons exp env))) + (remove-empty-calls! (cddr exp) new-env) + (for-each! (lambda (x) (remove-empty-calls! (cdar x) new-env)) + (cadr exp)))) + ((eq? (car exp) 'lambda) + (rec! (cddr exp))) + (else + (for-each! rec! (cdr exp)) + (if (and (null? (cdr exp)) (symbol? (car exp))) + (let ((frame (binding-frame (car exp) env))) + (if frame ; is it a bound variable? + (let ((proc (bound-expr (car exp) frame))) + (if (and (pair? proc) + (eq? (car proc) 'lambda)) + (begin + (set! changed? #t) + (set-car! where (caddr proc)))))))))))) + + (rec! where)) + + (define changed? #f) + + (let ((x (list exp))) + (let loop () + (set! changed? #f) + (simp! x '()) + (remove-empty-calls! x '()) + (if changed? (loop) (car x))))) + +(define (ref-count exp var) ; compute how many references to variable 'var' + (let ((total 0) ; are contained in 'exp' + (oper 0) + (always-evaled #t)) + (define (rc exp ae) + (cond ((const-expr? exp)) + ((symbol? exp) + (if (eq? exp var) + (begin + (set! total (+ total 1)) + (set! always-evaled (and ae always-evaled))))) + ((eq? (car exp) 'if) + (rc (cadr exp) ae) + (for-each (lambda (x) (rc x #f)) (cddr exp))) + ((eq? (car exp) 'begin) + (for-each (lambda (x) (rc x ae)) (cdr exp))) + ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec)) + (for-each (lambda (x) (rc (cadr x) ae)) (cadr exp)) + (rc (caddr exp) ae)) + ((eq? (car exp) 'lambda) + (rc (caddr exp) #f)) + (else + (for-each (lambda (x) (rc x ae)) exp) + (if (symbol? (car exp)) + (if (eq? (car exp) var) (set! oper (+ oper 1))))))) + (rc exp #t) + (list total oper always-evaled))) + +(define (binding-frame var env) + (cond ((null? env) #f) + ((or (eq? (caar env) 'let) (eq? (caar env) 'letrec)) + (if (assq var (cadar env)) (car env) (binding-frame var (cdr env)))) + ((eq? (caar env) 'lambda) + (if (memq var (cadar env)) (car env) (binding-frame var (cdr env)))) + (else + '(fatal-error "ill-formed environment")))) + +(define (bound-expr var frame) + (cond ((or (eq? (car frame) 'let) (eq? (car frame) 'letrec)) + (cadr (assq var (cadr frame)))) + ((eq? (car frame) 'lambda) + not-constant) + (else + '(fatal-error "ill-formed frame")))) + +(define (add-binding val frame name) + (define (find-val val bindings) + (cond ((null? bindings) #f) + ((equal? val (cadar bindings)) ; *kludge* equal? is not exactly what + (caar bindings)) ; we want... + (else + (find-val val (cdr bindings))))) + (or (find-val val (cadr frame)) + (let ((var (new-variable name))) + (set-cdr! (get-last-pair (cadr frame)) (list (list var val))) + var))) + +(define (for-each! proc! l) ; call proc! on each CONS CELL in the list 'l' + (if (not (null? l)) + (begin (proc! l) (for-each! proc! (cdr l))))) + +(define (arg-pattern exps) ; return the argument pattern (i.e. the list of + (if (null? exps) ; constants in 'exps' but with the not-constant + '() ; value wherever the corresponding expression in + (cons (if (const-expr? (car exps)) ; 'exps' is not a constant) + (const-value (car exps)) + not-constant) + (arg-pattern (cdr exps))))) + +;------------------------------------------------------------------------------ +; +; Knowledge about primitive procedures. + +(define *primitives* + (list + (cons 'car (lambda (args) + (and (= (length args) 1) + (pair? (car args)) + (quot (car (car args)))))) + (cons 'cdr (lambda (args) + (and (= (length args) 1) + (pair? (car args)) + (quot (cdr (car args)))))) + (cons '+ (lambda (args) + (and (every? number? args) + (quot (sum args 0))))) + (cons '* (lambda (args) + (and (every? number? args) + (quot (product args 1))))) + (cons '- (lambda (args) + (and (> (length args) 0) + (every? number? args) + (quot (if (null? (cdr args)) + (- (car args)) + (- (car args) (sum (cdr args) 0))))))) + (cons '/ (lambda (args) + (and (> (length args) 1) + (every? number? args) + (quot (if (null? (cdr args)) + (/ (car args)) + (/ (car args) (product (cdr args) 1))))))) + (cons '< (lambda (args) + (and (= (length args) 2) + (every? number? args) + (quot (< (car args) (cadr args)))))) + (cons '= (lambda (args) + (and (= (length args) 2) + (every? number? args) + (quot (= (car args) (cadr args)))))) + (cons '> (lambda (args) + (and (= (length args) 2) + (every? number? args) + (quot (> (car args) (cadr args)))))) + (cons 'eq? (lambda (args) + (and (= (length args) 2) + (quot (eq? (car args) (cadr args)))))) + (cons 'not (lambda (args) + (and (= (length args) 1) + (quot (not (car args)))))) + (cons 'null? (lambda (args) + (and (= (length args) 1) + (quot (null? (car args)))))) + (cons 'pair? (lambda (args) + (and (= (length args) 1) + (quot (pair? (car args)))))) + (cons 'symbol? (lambda (args) + (and (= (length args) 1) + (quot (symbol? (car args)))))) + ) +) + +(define (sum lst n) + (if (null? lst) + n + (sum (cdr lst) (+ n (car lst))))) + +(define (product lst n) + (if (null? lst) + n + (product (cdr lst) (* n (car lst))))) + +(define (reduce-global name args) + (let ((x (assq name *primitives*))) + (and x ((cdr x) args)))) + +(define (constant-fold-global name exprs) + + (define (flatten args op) + (cond ((null? args) + '()) + ((and (pair? (car args)) (eq? (caar args) op)) + (append (flatten (cdar args) op) (flatten (cdr args) op))) + (else + (cons (car args) (flatten (cdr args) op))))) + + (let ((args (if (or (eq? name '+) (eq? name '*)) ; associative ops + (flatten exprs name) + exprs))) + (or (and (every? const-expr? args) + (reduce-global name (map const-value args))) + (let ((pattern (arg-pattern args))) + (let ((non-const (remove-constant args pattern)) + (const (map const-value (extract-constant args pattern)))) + (cond ((eq? name '+) ; + is commutative + (let ((x (reduce-global '+ const))) + (if x + (let ((y (const-value x))) + (cons '+ + (if (= y 0) non-const (cons x non-const)))) + (cons name args)))) + ((eq? name '*) ; * is commutative + (let ((x (reduce-global '* const))) + (if x + (let ((y (const-value x))) + (cons '* + (if (= y 1) non-const (cons x non-const)))) + (cons name args)))) + ((eq? name 'cons) + (cond ((and (const-expr? (cadr args)) + (null? (const-value (cadr args)))) + (list 'list (car args))) + ((and (pair? (cadr args)) + (eq? (car (cadr args)) 'list)) + (cons 'list (cons (car args) (cdr (cadr args))))) + (else + (cons name args)))) + (else + (cons name args)))))))) + +;------------------------------------------------------------------------------ +; +; Examples: + +(define (try-peval proc args) + (partial-evaluate proc args)) + +; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +(define example1 + '(lambda (a b c) + (if (null? a) b (+ (car a) c)))) + +;(try-peval example1 (list '(10 11) not-constant '1)) + +; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +(define example2 + '(lambda (x y) + (let ((q (lambda (a b) (if (< a 0) b (- 10 b))))) + (if (< x 0) (q (- y) (- x)) (q y x))))) + +;(try-peval example2 (list not-constant '1)) + +; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +(define example3 + '(lambda (l n) + (letrec ((add-list + (lambda (l n) + (if (null? l) + '() + (cons (+ (car l) n) (add-list (cdr l) n)))))) + (add-list l n)))) + +;(try-peval example3 (list not-constant '1)) + +;(try-peval example3 (list '(1 2 3) not-constant)) + +; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +(define example4 + '(lambda (exp env) + (letrec ((eval + (lambda (exp env) + (letrec ((eval-list + (lambda (l env) + (if (null? l) + '() + (cons (eval (car l) env) + (eval-list (cdr l) env)))))) + (if (symbol? exp) (lookup exp env) + (if (not (pair? exp)) exp + (if (eq? (car exp) 'quote) (car (cdr exp)) + (apply (eval (car exp) env) + (eval-list (cdr exp) env))))))))) + (eval exp env)))) + +;(try-peval example4 (list 'x not-constant)) + +;(try-peval example4 (list '(f 1 2 3) not-constant)) + +; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +(define example5 + '(lambda (a b) + (letrec ((funct + (lambda (x) + (+ x b (if (< x 1) 0 (funct (- x 1))))))) + (funct a)))) + +;(try-peval example5 (list '5 not-constant)) + +; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +(define example6 + '(lambda () + (letrec ((fib + (lambda (x) + (if (< x 2) x (+ (fib (- x 1)) (fib (- x 2))))))) + (fib 10)))) + +;(try-peval example6 '()) + +; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +(define example7 + '(lambda (input) + (letrec ((copy (lambda (in) + (if (pair? in) + (cons (copy (car in)) + (copy (cdr in))) + in)))) + (copy input)))) + +;(try-peval example7 (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z))) + +; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +(define example8 + '(lambda (input) + (letrec ((reverse (lambda (in result) + (if (pair? in) + (reverse (cdr in) (cons (car in) result)) + result)))) + (reverse input '())))) + +;(try-peval example8 (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z))) + +; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +(define (test init) + (set! *current-num* init) + (list (try-peval example1 (list '(10 11) not-constant '1)) + (try-peval example2 (list not-constant '1)) + (try-peval example3 (list not-constant '1)) + (try-peval example3 (list '(1 2 3) not-constant)) + (try-peval example4 (list 'x not-constant)) + (try-peval example4 (list '(f 1 2 3) not-constant)) + (try-peval example5 (list '5 not-constant)) + (try-peval example6 '()) + (try-peval + example7 + (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z))) + (try-peval + example8 + (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z))))) + +(let ((input (with-input-from-file "input.txt" read))) + (time + (let loop ((n 60) (v 0)) + (if (zero? n) + v + (loop (- n 1) (test (if input 0 17))))))) diff --git a/benchmarks/gabriel/puzzle.sch b/benchmarks/gabriel/puzzle.sch new file mode 100644 index 00000000..69cb0690 --- /dev/null +++ b/benchmarks/gabriel/puzzle.sch @@ -0,0 +1,171 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: puzzle.sch +; Description: PUZZLE benchmark +; Author: Richard Gabriel, after Forrest Baskett +; Created: 12-Apr-85 +; Modified: 12-Apr-85 14:20:23 (Bob Shaw) +; 11-Aug-87 (Will Clinger) +; 22-Jan-88 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (iota n) + (do ((n n (- n 1)) + (list '() (cons (- n 1) list))) + ((zero? n) list))) + +;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal. + +(define size 1048575) +(define classmax 3) +(define typemax 12) + +(define *iii* 0) +(define *kount* 0) +(define *d* 8) + +(define *piececount* (make-vector (+ classmax 1) 0)) +(define *class* (make-vector (+ typemax 1) 0)) +(define *piecemax* (make-vector (+ typemax 1) 0)) +(define *puzzle* (make-vector (+ size 1))) +(define *p* (make-vector (+ typemax 1))) +(define nothing + (for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1)))) + (iota (+ typemax 1)))) + +(define (fit i j) + (let ((end (vector-ref *piecemax* i))) + (do ((k 0 (+ k 1))) + ((or (> k end) + (and (vector-ref (vector-ref *p* i) k) + (vector-ref *puzzle* (+ j k)))) + (if (> k end) #t #f))))) + +(define (place i j) + (let ((end (vector-ref *piecemax* i))) + (do ((k 0 (+ k 1))) + ((> k end)) + (cond ((vector-ref (vector-ref *p* i) k) + (vector-set! *puzzle* (+ j k) #t) + #t))) + (vector-set! *piececount* + (vector-ref *class* i) + (- (vector-ref *piececount* (vector-ref *class* i)) 1)) + (do ((k j (+ k 1))) + ((or (> k size) (not (vector-ref *puzzle* k))) + ; (newline) + ; (display "*Puzzle* filled") + (if (> k size) 0 k))))) + +(define (puzzle-remove i j) + (let ((end (vector-ref *piecemax* i))) + (do ((k 0 (+ k 1))) + ((> k end)) + (cond ((vector-ref (vector-ref *p* i) k) + (vector-set! *puzzle* (+ j k) #f) + #f))) + (vector-set! *piececount* + (vector-ref *class* i) + (+ (vector-ref *piececount* (vector-ref *class* i)) 1)))) + + +(define (trial j) + (let ((k 0)) + (call-with-current-continuation + (lambda (return) + (do ((i 0 (+ i 1))) + ((> i typemax) (set! *kount* (+ *kount* 1)) '()) + (cond + ((not + (zero? + (vector-ref *piececount* (vector-ref *class* i)))) + (cond + ((fit i j) + (set! k (place i j)) + (cond + ((or (trial k) (zero? k)) + ;(trial-output (+ i 1) (+ k 1)) + (set! *kount* (+ *kount* 1)) + (return #t)) + (else (puzzle-remove i j)))))))))))) + +(define (trial-output x y) + (newline) + (display (string-append "Piece " + (number->string x '(int)) + " at " + (number->string y '(int)) + "."))) + +(define (definePiece iclass ii jj kk) + (let ((index 0)) + (do ((i 0 (+ i 1))) + ((> i ii)) + (do ((j 0 (+ j 1))) + ((> j jj)) + (do ((k 0 (+ k 1))) + ((> k kk)) + (set! index (+ i (* *d* (+ j (* *d* k))))) + (vector-set! (vector-ref *p* *iii*) index #t)))) + (vector-set! *class* *iii* iclass) + (vector-set! *piecemax* *iii* index) + (cond ((not (= *iii* typemax)) + (set! *iii* (+ *iii* 1)))))) + +(define (start) + (do ((m 0 (+ m 1))) + ((> m size)) + (vector-set! *puzzle* m #t)) + (do ((i 1 (+ i 1))) + ((> i 5)) + (do ((j 1 (+ j 1))) + ((> j 5)) + (do ((k 1 (+ k 1))) + ((> k 5)) + (vector-set! *puzzle* (+ i (* *d* (+ j (* *d* k)))) #f)))) + (do ((i 0 (+ i 1))) + ((> i typemax)) + (do ((m 0 (+ m 1))) + ((> m size)) + (vector-set! (vector-ref *p* i) m #f))) + (set! *iii* 0) + (definePiece 0 3 1 0) + (definePiece 0 1 0 3) + (definePiece 0 0 3 1) + (definePiece 0 1 3 0) + (definePiece 0 3 0 1) + (definePiece 0 0 1 3) + + (definePiece 1 2 0 0) + (definePiece 1 0 2 0) + (definePiece 1 0 0 2) + + (definePiece 2 1 1 0) + (definePiece 2 1 0 1) + (definePiece 2 0 1 1) + + (definePiece 3 1 1 1) + + (vector-set! *piececount* 0 13) + (vector-set! *piececount* 1 3) + (vector-set! *piececount* 2 1) + (vector-set! *piececount* 3 1) + (let ((m (+ (* *d* (+ *d* 1)) 1)) + (n 0)) + (cond ((fit 0 m) (set! n (place 0 m))) + (else (begin (newline) (display "Error.")))) + (cond ((trial n) + (begin (newline) + (display "Success in ") + (write *kount*) + (display " trials.") + (newline) + 'ok)) + (else (begin (newline) (display "Failure.")))))) + +;;; call: (start) + +(time (start)) + + diff --git a/benchmarks/gabriel/run.sh b/benchmarks/gabriel/run.sh new file mode 100755 index 00000000..36dba94f --- /dev/null +++ b/benchmarks/gabriel/run.sh @@ -0,0 +1,16 @@ +#!/bin/sh + +BENCHDIR=$(dirname $0) +if [ "${BENCHDIR%%/*}" == "." ]; then + BENCHDIR=$(pwd)${BENCHDIR#.} +fi +CHIBIHOME=${BENCHDIR%%/benchmarks/gabriel} +CHIBI="${CHIBI:-${CHIBIHOME}/chibi-scheme} -I$CHIBIHOME" + +cd $BENCHDIR +for t in *.sch; do + echo "${t%%.sch}" + LD_LIBRARY_PATH="$CHIBIHOME" DYLD_LIBRARY_PATH="$CHIBIHOME" \ + $CHIBI -I"$CHIBIHOME/lib" -lchibi-prelude.scm $t +done +cd - diff --git a/benchmarks/gabriel/sboyer.sch b/benchmarks/gabriel/sboyer.sch new file mode 100644 index 00000000..37befe9d --- /dev/null +++ b/benchmarks/gabriel/sboyer.sch @@ -0,0 +1,774 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: sboyer.sch +; Description: The Boyer benchmark +; Author: Bob Boyer +; Created: 5-Apr-85 +; Modified: 10-Apr-85 14:52:20 (Bob Shaw) +; 22-Jul-87 (Will Clinger) +; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list) +; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules, +; rewrote to eliminate property lists, and added +; a scaling parameter suggested by Bob Boyer) +; 19-Mar-99 (Will Clinger -- cleaned up comments) +; 4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; SBOYER -- Logic programming benchmark, originally written by Bob Boyer. +;;; Much less CONS-intensive than NBOYER because it uses Henry Baker's +;;; "sharing cons". + +; Note: The version of this benchmark that appears in Dick Gabriel's book +; contained several bugs that are corrected here. These bugs are discussed +; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp +; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are: +; +; The benchmark now returns a boolean result. +; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER +; in Common Lisp) +; ONE-WAY-UNIFY1 now treats numbers correctly +; ONE-WAY-UNIFY1-LST now treats empty lists correctly +; Rule 19 has been corrected (this rule was not touched by the original +; benchmark, but is used by this version) +; Rules 84 and 101 have been corrected (but these rules are never touched +; by the benchmark) +; +; According to Baker, these bug fixes make the benchmark 10-25% slower. +; Please do not compare the timings from this benchmark against those of +; the original benchmark. +; +; This version of the benchmark also prints the number of rewrites as a sanity +; check, because it is too easy for a buggy version to return the correct +; boolean result. The correct number of rewrites is +; +; n rewrites peak live storage (approximate, in bytes) +; 0 95024 +; 1 591777 +; 2 1813975 +; 3 5375678 +; 4 16445406 +; 5 51507739 + +; Sboyer is a 2-phase benchmark. +; The first phase attaches lemmas to symbols. This phase is not timed, +; but it accounts for very little of the runtime anyway. +; The second phase creates the test problem, and tests to see +; whether it is implied by the lemmas. + +(define (sboyer-benchmark . args) + (let ((n (if (null? args) 0 (car args)))) + (setup-boyer) + (time (test-boyer n)))) + +(define (setup-boyer) #t) ; assigned below +(define (test-boyer) #t) ; assigned below + +(define (id x) x) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; The first phase. +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; In the original benchmark, it stored a list of lemmas on the +; property lists of symbols. +; In the new benchmark, it maintains an association list of +; symbols and symbol-records, and stores the list of lemmas +; within the symbol-records. + +(let () + + (define (setup) + (add-lemma-lst + (quote ((equal (compile form) + (reverse (codegen (optimize form) + (nil)))) + (equal (eqp x y) + (equal (fix x) + (fix y))) + (equal (greaterp x y) + (lessp y x)) + (equal (lesseqp x y) + (not (lessp y x))) + (equal (greatereqp x y) + (not (lessp x y))) + (equal (boolean x) + (or (equal x (t)) + (equal x (f)))) + (equal (iff x y) + (and (implies x y) + (implies y x))) + (equal (even1 x) + (if (zerop x) + (t) + (odd (sub1 x)))) + (equal (countps- l pred) + (countps-loop l pred (zero))) + (equal (fact- i) + (fact-loop i 1)) + (equal (reverse- x) + (reverse-loop x (nil))) + (equal (divides x y) + (zerop (remainder y x))) + (equal (assume-true var alist) + (cons (cons var (t)) + alist)) + (equal (assume-false var alist) + (cons (cons var (f)) + alist)) + (equal (tautology-checker x) + (tautologyp (normalize x) + (nil))) + (equal (falsify x) + (falsify1 (normalize x) + (nil))) + (equal (prime x) + (and (not (zerop x)) + (not (equal x (add1 (zero)))) + (prime1 x (sub1 x)))) + (equal (and p q) + (if p (if q (t) + (f)) + (f))) + (equal (or p q) + (if p (t) + (if q (t) + (f)))) + (equal (not p) + (if p (f) + (t))) + (equal (implies p q) + (if p (if q (t) + (f)) + (t))) + (equal (fix x) + (if (numberp x) + x + (zero))) + (equal (if (if a b c) + d e) + (if a (if b d e) + (if c d e))) + (equal (zerop x) + (or (equal x (zero)) + (not (numberp x)))) + (equal (plus (plus x y) + z) + (plus x (plus y z))) + (equal (equal (plus a b) + (zero)) + (and (zerop a) + (zerop b))) + (equal (difference x x) + (zero)) + (equal (equal (plus a b) + (plus a c)) + (equal (fix b) + (fix c))) + (equal (equal (zero) + (difference x y)) + (not (lessp y x))) + (equal (equal x (difference x y)) + (and (numberp x) + (or (equal x (zero)) + (zerop y)))) + (equal (meaning (plus-tree (append x y)) + a) + (plus (meaning (plus-tree x) + a) + (meaning (plus-tree y) + a))) + (equal (meaning (plus-tree (plus-fringe x)) + a) + (fix (meaning x a))) + (equal (append (append x y) + z) + (append x (append y z))) + (equal (reverse (append a b)) + (append (reverse b) + (reverse a))) + (equal (times x (plus y z)) + (plus (times x y) + (times x z))) + (equal (times (times x y) + z) + (times x (times y z))) + (equal (equal (times x y) + (zero)) + (or (zerop x) + (zerop y))) + (equal (exec (append x y) + pds envrn) + (exec y (exec x pds envrn) + envrn)) + (equal (mc-flatten x y) + (append (flatten x) + y)) + (equal (member x (append a b)) + (or (member x a) + (member x b))) + (equal (member x (reverse y)) + (member x y)) + (equal (length (reverse x)) + (length x)) + (equal (member a (intersect b c)) + (and (member a b) + (member a c))) + (equal (nth (zero) + i) + (zero)) + (equal (exp i (plus j k)) + (times (exp i j) + (exp i k))) + (equal (exp i (times j k)) + (exp (exp i j) + k)) + (equal (reverse-loop x y) + (append (reverse x) + y)) + (equal (reverse-loop x (nil)) + (reverse x)) + (equal (count-list z (sort-lp x y)) + (plus (count-list z x) + (count-list z y))) + (equal (equal (append a b) + (append a c)) + (equal b c)) + (equal (plus (remainder x y) + (times y (quotient x y))) + (fix x)) + (equal (power-eval (big-plus1 l i base) + base) + (plus (power-eval l base) + i)) + (equal (power-eval (big-plus x y i base) + base) + (plus i (plus (power-eval x base) + (power-eval y base)))) + (equal (remainder y 1) + (zero)) + (equal (lessp (remainder x y) + y) + (not (zerop y))) + (equal (remainder x x) + (zero)) + (equal (lessp (quotient i j) + i) + (and (not (zerop i)) + (or (zerop j) + (not (equal j 1))))) + (equal (lessp (remainder x y) + x) + (and (not (zerop y)) + (not (zerop x)) + (not (lessp x y)))) + (equal (power-eval (power-rep i base) + base) + (fix i)) + (equal (power-eval (big-plus (power-rep i base) + (power-rep j base) + (zero) + base) + base) + (plus i j)) + (equal (gcd x y) + (gcd y x)) + (equal (nth (append a b) + i) + (append (nth a i) + (nth b (difference i (length a))))) + (equal (difference (plus x y) + x) + (fix y)) + (equal (difference (plus y x) + x) + (fix y)) + (equal (difference (plus x y) + (plus x z)) + (difference y z)) + (equal (times x (difference c w)) + (difference (times c x) + (times w x))) + (equal (remainder (times x z) + z) + (zero)) + (equal (difference (plus b (plus a c)) + a) + (plus b c)) + (equal (difference (add1 (plus y z)) + z) + (add1 y)) + (equal (lessp (plus x y) + (plus x z)) + (lessp y z)) + (equal (lessp (times x z) + (times y z)) + (and (not (zerop z)) + (lessp x y))) + (equal (lessp y (plus x y)) + (not (zerop x))) + (equal (gcd (times x z) + (times y z)) + (times z (gcd x y))) + (equal (value (normalize x) + a) + (value x a)) + (equal (equal (flatten x) + (cons y (nil))) + (and (nlistp x) + (equal x y))) + (equal (listp (gopher x)) + (listp x)) + (equal (samefringe x y) + (equal (flatten x) + (flatten y))) + (equal (equal (greatest-factor x y) + (zero)) + (and (or (zerop y) + (equal y 1)) + (equal x (zero)))) + (equal (equal (greatest-factor x y) + 1) + (equal x 1)) + (equal (numberp (greatest-factor x y)) + (not (and (or (zerop y) + (equal y 1)) + (not (numberp x))))) + (equal (times-list (append x y)) + (times (times-list x) + (times-list y))) + (equal (prime-list (append x y)) + (and (prime-list x) + (prime-list y))) + (equal (equal z (times w z)) + (and (numberp z) + (or (equal z (zero)) + (equal w 1)))) + (equal (greatereqp x y) + (not (lessp x y))) + (equal (equal x (times x y)) + (or (equal x (zero)) + (and (numberp x) + (equal y 1)))) + (equal (remainder (times y x) + y) + (zero)) + (equal (equal (times a b) + 1) + (and (not (equal a (zero))) + (not (equal b (zero))) + (numberp a) + (numberp b) + (equal (sub1 a) + (zero)) + (equal (sub1 b) + (zero)))) + (equal (lessp (length (delete x l)) + (length l)) + (member x l)) + (equal (sort2 (delete x l)) + (delete x (sort2 l))) + (equal (dsort x) + (sort2 x)) + (equal (length (cons x1 + (cons x2 + (cons x3 (cons x4 + (cons x5 + (cons x6 x7))))))) + (plus 6 (length x7))) + (equal (difference (add1 (add1 x)) + 2) + (fix x)) + (equal (quotient (plus x (plus x y)) + 2) + (plus x (quotient y 2))) + (equal (sigma (zero) + i) + (quotient (times i (add1 i)) + 2)) + (equal (plus x (add1 y)) + (if (numberp y) + (add1 (plus x y)) + (add1 x))) + (equal (equal (difference x y) + (difference z y)) + (if (lessp x y) + (not (lessp y z)) + (if (lessp z y) + (not (lessp y x)) + (equal (fix x) + (fix z))))) + (equal (meaning (plus-tree (delete x y)) + a) + (if (member x y) + (difference (meaning (plus-tree y) + a) + (meaning x a)) + (meaning (plus-tree y) + a))) + (equal (times x (add1 y)) + (if (numberp y) + (plus x (times x y)) + (fix x))) + (equal (nth (nil) + i) + (if (zerop i) + (nil) + (zero))) + (equal (last (append a b)) + (if (listp b) + (last b) + (if (listp a) + (cons (car (last a)) + b) + b))) + (equal (equal (lessp x y) + z) + (if (lessp x y) + (equal (t) z) + (equal (f) z))) + (equal (assignment x (append a b)) + (if (assignedp x a) + (assignment x a) + (assignment x b))) + (equal (car (gopher x)) + (if (listp x) + (car (flatten x)) + (zero))) + (equal (flatten (cdr (gopher x))) + (if (listp x) + (cdr (flatten x)) + (cons (zero) + (nil)))) + (equal (quotient (times y x) + y) + (if (zerop y) + (zero) + (fix x))) + (equal (get j (set i val mem)) + (if (eqp j i) + val + (get j mem))))))) + + (define (add-lemma-lst lst) + (cond ((null? lst) + #t) + (else (add-lemma (car lst)) + (add-lemma-lst (cdr lst))))) + + (define (add-lemma term) + (cond ((and (pair? term) + (eq? (car term) + (quote equal)) + (pair? (cadr term))) + (put (car (cadr term)) + (quote lemmas) + (cons + (translate-term term) + (get (car (cadr term)) (quote lemmas))))) + (else (error "ADD-LEMMA did not like term: " term)))) + + ; Translates a term by replacing its constructor symbols by symbol-records. + + (define (translate-term term) + (cond ((not (pair? term)) + term) + (else (cons (symbol->symbol-record (car term)) + (translate-args (cdr term)))))) + + (define (translate-args lst) + (cond ((null? lst) + '()) + (else (cons (translate-term (car lst)) + (translate-args (cdr lst)))))) + + ; For debugging only, so the use of MAP does not change + ; the first-order character of the benchmark. + + (define (untranslate-term term) + (cond ((not (pair? term)) + term) + (else (cons (get-name (car term)) + (map untranslate-term (cdr term)))))) + + ; A symbol-record is represented as a vector with two fields: + ; the symbol (for debugging) and + ; the list of lemmas associated with the symbol. + + (define (put sym property value) + (put-lemmas! (symbol->symbol-record sym) value)) + + (define (get sym property) + (get-lemmas (symbol->symbol-record sym))) + + (define (symbol->symbol-record sym) + (let ((x (assq sym *symbol-records-alist*))) + (if x + (cdr x) + (let ((r (make-symbol-record sym))) + (set! *symbol-records-alist* + (cons (cons sym r) + *symbol-records-alist*)) + r)))) + + ; Association list of symbols and symbol-records. + + (define *symbol-records-alist* '()) + + ; A symbol-record is represented as a vector with two fields: + ; the symbol (for debugging) and + ; the list of lemmas associated with the symbol. + + (define (make-symbol-record sym) + (vector sym '())) + + (define (put-lemmas! symbol-record lemmas) + (vector-set! symbol-record 1 lemmas)) + + (define (get-lemmas symbol-record) + (vector-ref symbol-record 1)) + + (define (get-name symbol-record) + (vector-ref symbol-record 0)) + + (define (symbol-record-equal? r1 r2) + (eq? r1 r2)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; + ; The second phase. + ; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (test n) + (let ((term + (apply-subst + (translate-alist + (quote ((x f (plus (plus a b) + (plus c (zero)))) + (y f (times (times a b) + (plus c d))) + (z f (reverse (append (append a b) + (nil)))) + (u equal (plus a b) + (difference x y)) + (w lessp (remainder a b) + (member a (length b)))))) + (translate-term + (do ((term + (quote (implies (and (implies x y) + (and (implies y z) + (and (implies z u) + (implies u w)))) + (implies x w))) + (list 'or term '(f))) + (n n (- n 1))) + ((zero? n) term)))))) + (tautp term))) + + (define (translate-alist alist) + (cond ((null? alist) + '()) + (else (cons (cons (caar alist) + (translate-term (cdar alist))) + (translate-alist (cdr alist)))))) + + (define (apply-subst alist term) + (cond ((not (pair? term)) + (let ((temp-temp (assq term alist))) + (if temp-temp + (cdr temp-temp) + term))) + (else (cons (car term) + (apply-subst-lst alist (cdr term)))))) + + (define (apply-subst-lst alist lst) + (cond ((null? lst) + '()) + (else (cons (apply-subst alist (car lst)) + (apply-subst-lst alist (cdr lst)))))) + + (define (tautp x) + (tautologyp (rewrite x) + '() '())) + + (define (tautologyp x true-lst false-lst) + (cond ((truep x true-lst) + #t) + ((falsep x false-lst) + #f) + ((not (pair? x)) + #f) + ((eq? (car x) if-constructor) + (cond ((truep (cadr x) + true-lst) + (tautologyp (caddr x) + true-lst false-lst)) + ((falsep (cadr x) + false-lst) + (tautologyp (cadddr x) + true-lst false-lst)) + (else (and (tautologyp (caddr x) + (cons (cadr x) + true-lst) + false-lst) + (tautologyp (cadddr x) + true-lst + (cons (cadr x) + false-lst)))))) + (else #f))) + + (define if-constructor '*) ; becomes (symbol->symbol-record 'if) + + (define rewrite-count 0) ; sanity check + + ; The next procedure is Henry Baker's sharing CONS, which avoids + ; allocation if the result is already in hand. + ; The REWRITE and REWRITE-ARGS procedures have been modified to + ; use SCONS instead of CONS. + + (define (scons x y original) + (if (and (eq? x (car original)) + (eq? y (cdr original))) + original + (cons x y))) + + (define (rewrite term) + (set! rewrite-count (+ rewrite-count 1)) + (cond ((not (pair? term)) + term) + (else (rewrite-with-lemmas (scons (car term) + (rewrite-args (cdr term)) + term) + (get-lemmas (car term)))))) + + (define (rewrite-args lst) + (cond ((null? lst) + '()) + (else (scons (rewrite (car lst)) + (rewrite-args (cdr lst)) + lst)))) + + (define (rewrite-with-lemmas term lst) + (cond ((null? lst) + term) + ((one-way-unify term (cadr (car lst))) + (rewrite ( apply-subst unify-subst (caddr (car lst))))) + (else (rewrite-with-lemmas term (cdr lst))))) + + (define unify-subst '*) + + (define (one-way-unify term1 term2) + (begin (set! unify-subst '()) + (one-way-unify1 term1 term2))) + + (define (one-way-unify1 term1 term2) + (cond ((not (pair? term2)) + (let ((temp-temp (assq term2 unify-subst))) + (cond (temp-temp + (term-equal? term1 (cdr temp-temp))) + ((number? term2) ; This bug fix makes + (equal? term1 term2)) ; nboyer 10-25% slower! + (else + (set! unify-subst (cons (cons term2 term1) + unify-subst)) + #t)))) + ((not (pair? term1)) + #f) + ((eq? (car term1) + (car term2)) + (one-way-unify1-lst (cdr term1) + (cdr term2))) + (else #f))) + + (define (one-way-unify1-lst lst1 lst2) + (cond ((null? lst1) + (null? lst2)) + ((null? lst2) + #f) + ((one-way-unify1 (car lst1) + (car lst2)) + (one-way-unify1-lst (cdr lst1) + (cdr lst2))) + (else #f))) + + (define (falsep x lst) + (or (term-equal? x false-term) + (term-member? x lst))) + + (define (truep x lst) + (or (term-equal? x true-term) + (term-member? x lst))) + + (define false-term '*) ; becomes (translate-term '(f)) + (define true-term '*) ; becomes (translate-term '(t)) + + ; The next two procedures were in the original benchmark + ; but were never used. + + (define (trans-of-implies n) + (translate-term + (list (quote implies) + (trans-of-implies1 n) + (list (quote implies) + 0 n)))) + + (define (trans-of-implies1 n) + (cond ((equal? n 1) + (list (quote implies) + 0 1)) + (else (list (quote and) + (list (quote implies) + (- n 1) + n) + (trans-of-implies1 (- n 1)))))) + + ; Translated terms can be circular structures, which can't be + ; compared using Scheme's equal? and member procedures, so we + ; use these instead. + + (define (term-equal? x y) + (cond ((pair? x) + (and (pair? y) + (symbol-record-equal? (car x) (car y)) + (term-args-equal? (cdr x) (cdr y)))) + (else (equal? x y)))) + + (define (term-args-equal? lst1 lst2) + (cond ((null? lst1) + (null? lst2)) + ((null? lst2) + #f) + ((term-equal? (car lst1) (car lst2)) + (term-args-equal? (cdr lst1) (cdr lst2))) + (else #f))) + + (define (term-member? x lst) + (cond ((null? lst) + #f) + ((term-equal? x (car lst)) + #t) + (else (term-member? x (cdr lst))))) + + (set! setup-boyer + (lambda () + (set! *symbol-records-alist* '()) + (set! if-constructor (symbol->symbol-record 'if)) + (set! false-term (translate-term '(f))) + (set! true-term (translate-term '(t))) + (setup))) + + (set! test-boyer + (lambda (n) + (set! rewrite-count 0) + (let ((answer (test n))) + (write rewrite-count) + (display " rewrites") + (newline) + (if answer + rewrite-count + #f))))) + +(sboyer-benchmark 5) diff --git a/benchmarks/gabriel/scheme.sch b/benchmarks/gabriel/scheme.sch new file mode 100644 index 00000000..ac891d53 --- /dev/null +++ b/benchmarks/gabriel/scheme.sch @@ -0,0 +1,1077 @@ +;;; SCHEME -- A Scheme interpreter evaluating a sort, written by Marc Feeley. + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-eval expr) + (let ((code (scheme-comp expr scheme-global-environment))) + (code #f))) + +(define scheme-global-environment + (cons '() ; environment chain + '())) ; macros + +(define (scheme-add-macro name proc) + (set-cdr! scheme-global-environment + (cons (cons name proc) (cdr scheme-global-environment))) + name) + +(define (scheme-error msg . args) + 'error) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (lst->vector l) + (let* ((n (length l)) + (v (make-vector n))) + (let loop ((l l) (i 0)) + (if (pair? l) + (begin + (vector-set! v i (car l)) + (loop (cdr l) (+ i 1))) + v)))) + +(define (vector->lst v) + (let loop ((l '()) (i (- (vector-length v) 1))) + (if (< i 0) + l + (loop (cons (vector-ref v i) l) (- i 1))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define scheme-syntactic-keywords + '(quote quasiquote unquote unquote-splicing + lambda if set! cond => else and or + case let let* letrec begin do define + define-macro)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (push-frame frame env) + (if (null? frame) + env + (cons (cons (car env) frame) (cdr env)))) + +(define (lookup-var name env) + (let loop1 ((chain (car env)) (up 0)) + (if (null? chain) + name + (let loop2 ((chain chain) + (up up) + (frame (cdr chain)) + (over 1)) + (cond ((null? frame) + (loop1 (car chain) (+ up 1))) + ((eq? (car frame) name) + (cons up over)) + (else + (loop2 chain up (cdr frame) (+ over 1)))))))) + +(define (macro? name env) + (assq name (cdr env))) + +(define (push-macro name proc env) + (cons (car env) (cons (cons name proc) (cdr env)))) + +(define (lookup-macro name env) + (cdr (assq name (cdr env)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (variable x) + (if (not (symbol? x)) + (scheme-error "Identifier expected" x)) + (if (memq x scheme-syntactic-keywords) + (scheme-error "Variable name can not be a syntactic keyword" x))) + +(define (shape form n) + (let loop ((form form) (n n) (l form)) + (cond ((<= n 0)) + ((pair? l) + (loop form (- n 1) (cdr l))) + (else + (scheme-error "Ill-constructed form" form))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (macro-expand expr env) + (apply (lookup-macro (car expr) env) (cdr expr))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-var expr env) + (variable expr) + (gen-var-ref (lookup-var expr env))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-self-eval expr env) + (gen-cst expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quote expr env) + (shape expr 2) + (gen-cst (cadr expr))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quasiquote expr env) + (comp-quasiquotation (cadr expr) 1 env)) + +(define (comp-quasiquotation form level env) + (cond ((= level 0) + (scheme-comp form env)) + ((pair? form) + (cond + ((eq? (car form) 'quasiquote) + (comp-quasiquotation-list form (+ level 1) env)) + ((eq? (car form) 'unquote) + (if (= level 1) + (scheme-comp (cadr form) env) + (comp-quasiquotation-list form (- level 1) env))) + ((eq? (car form) 'unquote-splicing) + (if (= level 1) + (scheme-error "Ill-placed 'unquote-splicing'" form)) + (comp-quasiquotation-list form (- level 1) env)) + (else + (comp-quasiquotation-list form level env)))) + ((vector? form) + (gen-vector-form + (comp-quasiquotation-list (vector->lst form) level env))) + (else + (gen-cst form)))) + +(define (comp-quasiquotation-list l level env) + (if (pair? l) + (let ((first (car l))) + (if (= level 1) + (if (unquote-splicing? first) + (begin + (shape first 2) + (gen-append-form (scheme-comp (cadr first) env) + (comp-quasiquotation (cdr l) 1 env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env)))) + (comp-quasiquotation l level env))) + +(define (unquote-splicing? x) + (if (pair? x) + (if (eq? (car x) 'unquote-splicing) #t #f) + #f)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote expr env) + (scheme-error "Ill-placed 'unquote'" expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote-splicing expr env) + (scheme-error "Ill-placed 'unquote-splicing'" expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-set! expr env) + (shape expr 3) + (variable (cadr expr)) + (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-lambda expr env) + (shape expr 3) + (let ((parms (cadr expr))) + (let ((frame (parms->frame parms))) + (let ((nb-vars (length frame)) + (code (comp-body (cddr expr) (push-frame frame env)))) + (if (rest-param? parms) + (gen-lambda-rest nb-vars code) + (gen-lambda nb-vars code)))))) + +(define (parms->frame parms) + (cond ((null? parms) + '()) + ((pair? parms) + (let ((x (car parms))) + (variable x) + (cons x (parms->frame (cdr parms))))) + (else + (variable parms) + (list parms)))) + +(define (rest-param? parms) + (cond ((pair? parms) + (rest-param? (cdr parms))) + ((null? parms) + #f) + (else + #t))) + +(define (comp-body body env) + + (define (letrec-defines vars vals body env) + (if (pair? body) + + (let ((expr (car body))) + (cond ((not (pair? expr)) + (letrec-defines* vars vals body env)) + ((macro? (car expr) env) + (letrec-defines vars + vals + (cons (macro-expand expr env) (cdr body)) + env)) + (else + (cond + ((eq? (car expr) 'begin) + (letrec-defines vars + vals + (append (cdr expr) (cdr body)) + env)) + ((eq? (car expr) 'define) + (let ((x (definition-name expr))) + (variable x) + (letrec-defines (cons x vars) + (cons (definition-value expr) vals) + (cdr body) + env))) + ((eq? (car expr) 'define-macro) + (let ((x (definition-name expr))) + (letrec-defines vars + vals + (cdr body) + (push-macro + x + (scheme-eval (definition-value expr)) + env)))) + (else + (letrec-defines* vars vals body env)))))) + + (scheme-error "Body must contain at least one evaluable expression"))) + + (define (letrec-defines* vars vals body env) + (if (null? vars) + (comp-sequence body env) + (comp-letrec-aux vars vals body env))) + + (letrec-defines '() '() body env)) + +(define (definition-name expr) + (shape expr 3) + (let ((pattern (cadr expr))) + (let ((name (if (pair? pattern) (car pattern) pattern))) + (if (not (symbol? name)) + (scheme-error "Identifier expected" name)) + name))) + +(define (definition-value expr) + (let ((pattern (cadr expr))) + (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-if expr env) + (shape expr 3) + (let ((code1 (scheme-comp (cadr expr) env)) + (code2 (scheme-comp (caddr expr) env))) + (if (pair? (cdddr expr)) + (gen-if code1 code2 (scheme-comp (cadddr expr) env)) + (gen-when code1 code2)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-cond expr env) + (comp-cond-aux (cdr expr) env)) + +(define (comp-cond-aux clauses env) + (if (pair? clauses) + (let ((clause (car clauses))) + (shape clause 1) + (cond ((eq? (car clause) 'else) + (shape clause 2) + (comp-sequence (cdr clause) env)) + ((not (pair? (cdr clause))) + (gen-or (scheme-comp (car clause) env) + (comp-cond-aux (cdr clauses) env))) + ((eq? (cadr clause) '=>) + (shape clause 3) + (gen-cond-send (scheme-comp (car clause) env) + (scheme-comp (caddr clause) env) + (comp-cond-aux (cdr clauses) env))) + (else + (gen-if (scheme-comp (car clause) env) + (comp-sequence (cdr clause) env) + (comp-cond-aux (cdr clauses) env))))) + (gen-cst '()))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-and expr env) + (let ((rest (cdr expr))) + (if (pair? rest) (comp-and-aux rest env) (gen-cst #t)))) + +(define (comp-and-aux l env) + (let ((code (scheme-comp (car l) env)) + (rest (cdr l))) + (if (pair? rest) (gen-and code (comp-and-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-or expr env) + (let ((rest (cdr expr))) + (if (pair? rest) (comp-or-aux rest env) (gen-cst #f)))) + +(define (comp-or-aux l env) + (let ((code (scheme-comp (car l) env)) + (rest (cdr l))) + (if (pair? rest) (gen-or code (comp-or-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-case expr env) + (shape expr 3) + (gen-case (scheme-comp (cadr expr) env) + (comp-case-aux (cddr expr) env))) + +(define (comp-case-aux clauses env) + (if (pair? clauses) + (let ((clause (car clauses))) + (shape clause 2) + (if (eq? (car clause) 'else) + (gen-case-else (comp-sequence (cdr clause) env)) + (gen-case-clause (car clause) + (comp-sequence (cdr clause) env) + (comp-case-aux (cdr clauses) env)))) + (gen-case-else (gen-cst '())))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let expr env) + (shape expr 3) + (let ((x (cadr expr))) + (cond ((symbol? x) + (shape expr 4) + (let ((y (caddr expr))) + (let ((proc (cons 'lambda (cons (bindings->vars y) (cdddr expr))))) + (scheme-comp (cons (list 'letrec (list (list x proc)) x) + (bindings->vals y)) + env)))) + ((pair? x) + (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr))) + (bindings->vals x)) + env)) + (else + (comp-body (cddr expr) env))))) + +(define (bindings->vars bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (shape binding 2) + (let ((x (car binding))) + (variable x) + (cons x (bindings->vars (cdr bindings))))) + '())) + +(define (bindings->vals bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (cons (cadr binding) (bindings->vals (cdr bindings)))) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let* expr env) + (shape expr 3) + (let ((bindings (cadr expr))) + (if (pair? bindings) + (scheme-comp (list 'let + (list (car bindings)) + (cons 'let* (cons (cdr bindings) (cddr expr)))) + env) + (comp-body (cddr expr) env)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-letrec expr env) + (shape expr 3) + (let ((bindings (cadr expr))) + (comp-letrec-aux (bindings->vars bindings) + (bindings->vals bindings) + (cddr expr) + env))) + +(define (comp-letrec-aux vars vals body env) + (if (pair? vars) + (let ((new-env (push-frame vars env))) + (gen-letrec (comp-vals vals new-env) + (comp-body body new-env))) + (comp-body body env))) + +(define (comp-vals l env) + (if (pair? l) + (cons (scheme-comp (car l) env) (comp-vals (cdr l) env)) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-begin expr env) + (shape expr 2) + (comp-sequence (cdr expr) env)) + +(define (comp-sequence exprs env) + (if (pair? exprs) + (comp-sequence-aux exprs env) + (gen-cst '()))) + +(define (comp-sequence-aux exprs env) + (let ((code (scheme-comp (car exprs) env)) + (rest (cdr exprs))) + (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-do expr env) + (shape expr 3) + (let ((bindings (cadr expr)) + (exit (caddr expr))) + (shape exit 1) + (let* ((vars (bindings->vars bindings)) + (new-env1 (push-frame '(#f) env)) + (new-env2 (push-frame vars new-env1))) + (gen-letrec + (list + (gen-lambda + (length vars) + (gen-if + (scheme-comp (car exit) new-env2) + (comp-sequence (cdr exit) new-env2) + (gen-sequence + (comp-sequence (cdddr expr) new-env2) + (gen-combination + (gen-var-ref '(1 . 1)) + (comp-vals (bindings->steps bindings) new-env2)))))) + (gen-combination + (gen-var-ref '(0 . 1)) + (comp-vals (bindings->vals bindings) new-env1)))))) + +(define (bindings->steps bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (cons (if (pair? (cddr binding)) (caddr binding) (car binding)) + (bindings->steps (cdr bindings)))) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define expr env) + (shape expr 3) + (let ((pattern (cadr expr))) + (let ((x (if (pair? pattern) (car pattern) pattern))) + (variable x) + (gen-sequence + (gen-var-set (lookup-var x env) + (scheme-comp (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)) + env)) + (gen-cst x))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define-macro expr env) + (let ((x (definition-name expr))) + (gen-macro x (scheme-eval (definition-value expr))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-combination expr env) + (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env))) + +;------------------------------------------------------------------------------ + +(define (gen-var-ref var) + (if (pair? var) + (gen-rte-ref (car var) (cdr var)) + (gen-glo-ref (scheme-global-var var)))) + +(define (gen-rte-ref up over) + (case up + ((0) (gen-slot-ref-0 over)) + ((1) (gen-slot-ref-1 over)) + (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over))))) + +(define (gen-slot-ref-0 i) + (case i + ((0) (lambda (rte) (vector-ref rte 0))) + ((1) (lambda (rte) (vector-ref rte 1))) + ((2) (lambda (rte) (vector-ref rte 2))) + ((3) (lambda (rte) (vector-ref rte 3))) + (else (lambda (rte) (vector-ref rte i))))) + +(define (gen-slot-ref-1 i) + (case i + ((0) (lambda (rte) (vector-ref (vector-ref rte 0) 0))) + ((1) (lambda (rte) (vector-ref (vector-ref rte 0) 1))) + ((2) (lambda (rte) (vector-ref (vector-ref rte 0) 2))) + ((3) (lambda (rte) (vector-ref (vector-ref rte 0) 3))) + (else (lambda (rte) (vector-ref (vector-ref rte 0) i))))) + +(define (gen-slot-ref-up-2 code) + (lambda (rte) (code (vector-ref (vector-ref rte 0) 0)))) + +(define (gen-glo-ref i) + (lambda (rte) (scheme-global-var-ref i))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cst val) + (case val + ((()) (lambda (rte) '())) + ((#f) (lambda (rte) #f)) + ((#t) (lambda (rte) #t)) + ((-2) (lambda (rte) -2)) + ((-1) (lambda (rte) -1)) + ((0) (lambda (rte) 0)) + ((1) (lambda (rte) 1)) + ((2) (lambda (rte) 2)) + (else (lambda (rte) val)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-append-form code1 code2) + (lambda (rte) (append (code1 rte) (code2 rte)))) + +(define (gen-cons-form code1 code2) + (lambda (rte) (cons (code1 rte) (code2 rte)))) + +(define (gen-vector-form code) + (lambda (rte) (lst->vector (code rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-var-set var code) + (if (pair? var) + (gen-rte-set (car var) (cdr var) code) + (gen-glo-set (scheme-global-var var) code))) + +(define (gen-rte-set up over code) + (case up + ((0) (gen-slot-set-0 over code)) + ((1) (gen-slot-set-1 over code)) + (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code)))) + +(define (gen-slot-set-0 i code) + (case i + ((0) (lambda (rte) (vector-set! rte 0 (code rte)))) + ((1) (lambda (rte) (vector-set! rte 1 (code rte)))) + ((2) (lambda (rte) (vector-set! rte 2 (code rte)))) + ((3) (lambda (rte) (vector-set! rte 3 (code rte)))) + (else (lambda (rte) (vector-set! rte i (code rte)))))) + +(define (gen-slot-set-1 i code) + (case i + ((0) (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte)))) + ((1) (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte)))) + ((2) (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte)))) + ((3) (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte)))) + (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte)))))) + +(define (gen-slot-set-n up i code) + (case i + ((0) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte)))) + ((1) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte)))) + ((2) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte)))) + ((3) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte)))) + (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte)))))) + +(define (gen-glo-set i code) + (lambda (rte) (scheme-global-var-set! i (code rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-lambda-rest nb-vars body) + (case nb-vars + ((1) (gen-lambda-1-rest body)) + ((2) (gen-lambda-2-rest body)) + ((3) (gen-lambda-3-rest body)) + (else (gen-lambda-n-rest nb-vars body)))) + +(define (gen-lambda-1-rest body) + (lambda (rte) + (lambda a + (body (vector rte a))))) + +(define (gen-lambda-2-rest body) + (lambda (rte) + (lambda (a . b) + (body (vector rte a b))))) + +(define (gen-lambda-3-rest body) + (lambda (rte) + (lambda (a b . c) + (body (vector rte a b c))))) + +(define (gen-lambda-n-rest nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ((x (make-vector (+ nb-vars 1)))) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ((n nb-vars) (x x) (i 4) (l d)) + (if (< i n) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))) + (vector-set! x i l))) + (body x))))) + +(define (gen-lambda nb-vars body) + (case nb-vars + ((0) (gen-lambda-0 body)) + ((1) (gen-lambda-1 body)) + ((2) (gen-lambda-2 body)) + ((3) (gen-lambda-3 body)) + (else (gen-lambda-n nb-vars body)))) + +(define (gen-lambda-0 body) + (lambda (rte) + (lambda () + (body rte)))) + +(define (gen-lambda-1 body) + (lambda (rte) + (lambda (a) + (body (vector rte a))))) + +(define (gen-lambda-2 body) + (lambda (rte) + (lambda (a b) + (body (vector rte a b))))) + +(define (gen-lambda-3 body) + (lambda (rte) + (lambda (a b c) + (body (vector rte a b c))))) + +(define (gen-lambda-n nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ((x (make-vector (+ nb-vars 1)))) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ((n nb-vars) (x x) (i 4) (l d)) + (if (<= i n) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))))) + (body x))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-sequence code1 code2) + (lambda (rte) (code1 rte) (code2 rte))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-when code1 code2) + (lambda (rte) + (if (code1 rte) + (code2 rte) + '()))) + +(define (gen-if code1 code2 code3) + (lambda (rte) + (if (code1 rte) + (code2 rte) + (code3 rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cond-send code1 code2 code3) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + ((code2 rte) temp) + (code3 rte))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-and code1 code2) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + (code2 rte) + temp)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-or code1 code2) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + temp + (code2 rte))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-case code1 code2) + (lambda (rte) (code2 rte (code1 rte)))) + +(define (gen-case-clause datums code1 code2) + (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key)))) + +(define (gen-case-else code) + (lambda (rte key) (code rte))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-letrec vals body) + (let ((nb-vals (length vals))) + (case nb-vals + ((1) (gen-letrec-1 (car vals) body)) + ((2) (gen-letrec-2 (car vals) (cadr vals) body)) + ((3) (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body)) + (else (gen-letrec-n nb-vals vals body))))) + +(define (gen-letrec-1 val1 body) + (lambda (rte) + (let ((x (vector rte #f))) + (vector-set! x 1 (val1 x)) + (body x)))) + +(define (gen-letrec-2 val1 val2 body) + (lambda (rte) + (let ((x (vector rte #f #f))) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (body x)))) + +(define (gen-letrec-3 val1 val2 val3 body) + (lambda (rte) + (let ((x (vector rte #f #f #f))) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (vector-set! x 3 (val3 x)) + (body x)))) + +(define (gen-letrec-n nb-vals vals body) + (lambda (rte) + (let ((x (make-vector (+ nb-vals 1)))) + (vector-set! x 0 rte) + (let loop ((x x) (i 1) (l vals)) + (if (pair? l) + (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l))))) + (body x)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-macro name proc) + (lambda (rte) (scheme-add-macro name proc))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-combination oper args) + (case (length args) + ((0) (gen-combination-0 oper)) + ((1) (gen-combination-1 oper (car args))) + ((2) (gen-combination-2 oper (car args) (cadr args))) + ((3) (gen-combination-3 oper (car args) (cadr args) (caddr args))) + (else (gen-combination-n oper args)))) + +(define (gen-combination-0 oper) + (lambda (rte) ((oper rte)))) + +(define (gen-combination-1 oper arg1) + (lambda (rte) ((oper rte) (arg1 rte)))) + +(define (gen-combination-2 oper arg1 arg2) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte)))) + +(define (gen-combination-3 oper arg1 arg2 arg3) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte)))) + +(define (gen-combination-n oper args) + (lambda (rte) + (define (evaluate l rte) + (if (pair? l) + (cons ((car l) rte) (evaluate (cdr l) rte)) + '())) + (apply (oper rte) (evaluate args rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-comp expr env) + (cond ((symbol? expr) + (comp-var expr env)) + ((not (pair? expr)) + (comp-self-eval expr env)) + ((macro? (car expr) env) + (scheme-comp (macro-expand expr env) env)) + (else + (cond + ((eq? (car expr) 'quote) (comp-quote expr env)) + ((eq? (car expr) 'quasiquote) (comp-quasiquote expr env)) + ((eq? (car expr) 'unquote) (comp-unquote expr env)) + ((eq? (car expr) 'unquote-splicing) (comp-unquote-splicing expr env)) + ((eq? (car expr) 'set!) (comp-set! expr env)) + ((eq? (car expr) 'lambda) (comp-lambda expr env)) + ((eq? (car expr) 'if) (comp-if expr env)) + ((eq? (car expr) 'cond) (comp-cond expr env)) + ((eq? (car expr) 'and) (comp-and expr env)) + ((eq? (car expr) 'or) (comp-or expr env)) + ((eq? (car expr) 'case) (comp-case expr env)) + ((eq? (car expr) 'let) (comp-let expr env)) + ((eq? (car expr) 'let*) (comp-let* expr env)) + ((eq? (car expr) 'letrec) (comp-letrec expr env)) + ((eq? (car expr) 'begin) (comp-begin expr env)) + ((eq? (car expr) 'do) (comp-do expr env)) + ((eq? (car expr) 'define) (comp-define expr env)) + ((eq? (car expr) 'define-macro) (comp-define-macro expr env)) + (else (comp-combination expr env)))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-global-var name) + (let ((x (assq name scheme-global-variables))) + (if x + x + (let ((y (cons name '()))) + (set! scheme-global-variables (cons y scheme-global-variables)) + y)))) + +(define (scheme-global-var-ref i) + (cdr i)) + +(define (scheme-global-var-set! i val) + (set-cdr! i val) + '()) + +(define scheme-global-variables '()) + +(define (def-proc name value) + (scheme-global-var-set! + (scheme-global-var name) + value)) + +(define nothing + (begin +(def-proc 'not (lambda (x) (not x))) +(def-proc 'boolean? boolean?) +(def-proc 'eqv? eqv?) +(def-proc 'eq? eq?) +(def-proc 'equal? equal?) +(def-proc 'pair? (lambda (obj) (pair? obj))) +(def-proc 'cons (lambda (x y) (cons x y))) +(def-proc 'car (lambda (x) (car x))) +(def-proc 'cdr (lambda (x) (cdr x))) +(def-proc 'set-car! set-car!) +(def-proc 'set-cdr! set-cdr!) +(def-proc 'caar caar) +(def-proc 'cadr cadr) +(def-proc 'cdar cdar) +(def-proc 'cddr cddr) +(def-proc 'caaar caaar) +(def-proc 'caadr caadr) +(def-proc 'cadar cadar) +(def-proc 'caddr caddr) +(def-proc 'cdaar cdaar) +(def-proc 'cdadr cdadr) +(def-proc 'cddar cddar) +(def-proc 'cdddr cdddr) +(def-proc 'caaaar caaaar) +(def-proc 'caaadr caaadr) +(def-proc 'caadar caadar) +(def-proc 'caaddr caaddr) +(def-proc 'cadaar cadaar) +(def-proc 'cadadr cadadr) +(def-proc 'caddar caddar) +(def-proc 'cadddr cadddr) +(def-proc 'cdaaar cdaaar) +(def-proc 'cdaadr cdaadr) +(def-proc 'cdadar cdadar) +(def-proc 'cdaddr cdaddr) +(def-proc 'cddaar cddaar) +(def-proc 'cddadr cddadr) +(def-proc 'cdddar cdddar) +(def-proc 'cddddr cddddr) +(def-proc 'null? (lambda (x) (null? x))) +(def-proc 'list? list?) +(def-proc 'list list) +(def-proc 'length length) +(def-proc 'append append) +(def-proc 'reverse reverse) +(def-proc 'list-ref list-ref) +(def-proc 'memq memq) +(def-proc 'memv memv) +(def-proc 'member member) +(def-proc 'assq assq) +(def-proc 'assv assv) +(def-proc 'assoc assoc) +(def-proc 'symbol? symbol?) +(def-proc 'symbol->string symbol->string) +(def-proc 'string->symbol string->symbol) +(def-proc 'number? number?) +(def-proc 'complex? complex?) +(def-proc 'real? real?) +(def-proc 'rational? rational?) +(def-proc 'integer? integer?) +(def-proc 'exact? exact?) +(def-proc 'inexact? inexact?) +;(def-proc '= =) +;(def-proc '< <) +;(def-proc '> >) +;(def-proc '<= <=) +;(def-proc '>= >=) +;(def-proc 'zero? zero?) +;(def-proc 'positive? positive?) +;(def-proc 'negative? negative?) +;(def-proc 'odd? odd?) +;(def-proc 'even? even?) +(def-proc 'max max) +(def-proc 'min min) +;(def-proc '+ +) +;(def-proc '* *) +;(def-proc '- -) +(def-proc '/ /) +(def-proc 'abs abs) +;(def-proc 'quotient quotient) +;(def-proc 'remainder remainder) +;(def-proc 'modulo modulo) +(def-proc 'gcd gcd) +(def-proc 'lcm lcm) +;(def-proc 'numerator numerator) +;(def-proc 'denominator denominator) +(def-proc 'floor floor) +(def-proc 'ceiling ceiling) +(def-proc 'truncate truncate) +(def-proc 'round round) +;(def-proc 'rationalize rationalize) +(def-proc 'exp exp) +(def-proc 'log log) +(def-proc 'sin sin) +(def-proc 'cos cos) +(def-proc 'tan tan) +(def-proc 'asin asin) +(def-proc 'acos acos) +(def-proc 'atan atan) +(def-proc 'sqrt sqrt) +(def-proc 'expt expt) +;(def-proc 'make-rectangular make-rectangular) +;(def-proc 'make-polar make-polar) +;(def-proc 'real-part real-part) +;(def-proc 'imag-part imag-part) +;(def-proc 'magnitude magnitude) +;(def-proc 'angle angle) +(def-proc 'exact->inexact exact->inexact) +(def-proc 'inexact->exact inexact->exact) +(def-proc 'number->string number->string) +(def-proc 'string->number string->number) +(def-proc 'char? char?) +(def-proc 'char=? char=?) +(def-proc 'char? char>?) +(def-proc 'char<=? char<=?) +(def-proc 'char>=? char>=?) +(def-proc 'char-ci=? char-ci=?) +(def-proc 'char-ci? char-ci>?) +(def-proc 'char-ci<=? char-ci<=?) +(def-proc 'char-ci>=? char-ci>=?) +(def-proc 'char-alphabetic? char-alphabetic?) +(def-proc 'char-numeric? char-numeric?) +(def-proc 'char-whitespace? char-whitespace?) +(def-proc 'char-lower-case? char-lower-case?) +(def-proc 'char->integer char->integer) +(def-proc 'integer->char integer->char) +(def-proc 'char-upcase char-upcase) +(def-proc 'char-downcase char-downcase) +(def-proc 'string? string?) +(def-proc 'make-string make-string) +(def-proc 'string string) +(def-proc 'string-length string-length) +(def-proc 'string-ref string-ref) +(def-proc 'string-set! string-set!) +(def-proc 'string=? string=?) +(def-proc 'string? string>?) +(def-proc 'string<=? string<=?) +(def-proc 'string>=? string>=?) +(def-proc 'string-ci=? string-ci=?) +(def-proc 'string-ci? string-ci>?) +(def-proc 'string-ci<=? string-ci<=?) +(def-proc 'string-ci>=? string-ci>=?) +(def-proc 'substring substring) +(def-proc 'string-append string-append) +(def-proc 'vector? vector?) +(def-proc 'make-vector make-vector) +(def-proc 'vector vector) +(def-proc 'vector-length vector-length) +(def-proc 'vector-ref vector-ref) +(def-proc 'vector-set! vector-set!) +(def-proc 'procedure? procedure?) +(def-proc 'apply apply) +(def-proc 'map map) +(def-proc 'for-each for-each) +;(def-proc 'call-with-current-continuation call-with-current-continuation) +(def-proc 'call-with-input-file call-with-input-file) +(def-proc 'call-with-output-file call-with-output-file) +(def-proc 'input-port? input-port?) +(def-proc 'output-port? output-port?) +(def-proc 'current-input-port current-input-port) +(def-proc 'current-output-port current-output-port) +(def-proc 'open-input-file open-input-file) +(def-proc 'open-output-file open-output-file) +(def-proc 'close-input-port close-input-port) +(def-proc 'close-output-port close-output-port) +(def-proc 'eof-object? eof-object?) +(def-proc 'read read) +(def-proc 'read-char read-char) +(def-proc 'peek-char peek-char) +(def-proc 'write write) +(def-proc 'display display) +(def-proc 'newline newline) +(def-proc 'write-char write-char))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define expr1 + '(let () + + (define (sort-list obj pred) + + (define (loop l) + (if (and (pair? l) (pair? (cdr l))) + (split l '() '()) + l)) + + (define (split l one two) + (if (pair? l) + (split (cdr l) two (cons (car l) one)) + (merge (loop one) (loop two)))) + + (define (merge one two) + (cond ((null? one) two) + ((pred (car two) (car one)) + (cons (car two) + (merge (cdr two) one))) + (else + (cons (car one) + (merge (cdr one) two))))) + + (loop obj)) + + (sort-list '("one" "two" "three" "four" "five" "six" + "seven" "eight" "nine" "ten" "eleven" "twelve") + stringvector l) + (let* ((n (length l)) + (v (make-vector n))) + (let loop ((l l) (i 0)) + (if (pair? l) + (begin + (vector-set! v i (car l)) + (loop (cdr l) (+ i 1))) + v)))) + +(define (vector->lst v) + (let loop ((l '()) (i (- (vector-length v) 1))) + (if (< i 0) + l + (loop (cons (vector-ref v i) l) (- i 1))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define scheme-syntactic-keywords + '(quote quasiquote unquote unquote-splicing + lambda if set! cond => else and or + case let let* letrec begin do define + define-macro)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (push-frame frame env) + (if (null? frame) + env + (cons (cons (car env) frame) (cdr env)))) + +(define (lookup-var name env) + (let loop1 ((chain (car env)) (up 0)) + (if (null? chain) + name + (let loop2 ((chain chain) + (up up) + (frame (cdr chain)) + (over 1)) + (cond ((null? frame) + (loop1 (car chain) (+ up 1))) + ((eq? (car frame) name) + (cons up over)) + (else + (loop2 chain up (cdr frame) (+ over 1)))))))) + +(define (macro? name env) + (assq name (cdr env))) + +(define (push-macro name proc env) + (cons (car env) (cons (cons name proc) (cdr env)))) + +(define (lookup-macro name env) + (cdr (assq name (cdr env)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (variable x) + (if (not (symbol? x)) + (scheme-error "Identifier expected" x)) + (if (memq x scheme-syntactic-keywords) + (scheme-error "Variable name can not be a syntactic keyword" x))) + +(define (shape form n) + (let loop ((form form) (n n) (l form)) + (cond ((<= n 0)) + ((pair? l) + (loop form (- n 1) (cdr l))) + (else + (scheme-error "Ill-constructed form" form))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (macro-expand expr env) + (apply (lookup-macro (car expr) env) (cdr expr))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-var expr env) + (variable expr) + (gen-var-ref (lookup-var expr env))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-self-eval expr env) + (gen-cst expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quote expr env) + (shape expr 2) + (gen-cst (cadr expr))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quasiquote expr env) + (comp-quasiquotation (cadr expr) 1 env)) + +(define (comp-quasiquotation form level env) + (cond ((= level 0) + (scheme-comp form env)) + ((pair? form) + (cond + ((eq? (car form) 'quasiquote) + (comp-quasiquotation-list form (+ level 1) env)) + ((eq? (car form) 'unquote) + (if (= level 1) + (scheme-comp (cadr form) env) + (comp-quasiquotation-list form (- level 1) env))) + ((eq? (car form) 'unquote-splicing) + (if (= level 1) + (scheme-error "Ill-placed 'unquote-splicing'" form)) + (comp-quasiquotation-list form (- level 1) env)) + (else + (comp-quasiquotation-list form level env)))) + ((vector? form) + (gen-vector-form + (comp-quasiquotation-list (vector->lst form) level env))) + (else + (gen-cst form)))) + +(define (comp-quasiquotation-list l level env) + (if (pair? l) + (let ((first (car l))) + (if (= level 1) + (if (unquote-splicing? first) + (begin + (shape first 2) + (gen-append-form (scheme-comp (cadr first) env) + (comp-quasiquotation (cdr l) 1 env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env)))) + (comp-quasiquotation l level env))) + +(define (unquote-splicing? x) + (if (pair? x) + (if (eq? (car x) 'unquote-splicing) #t #f) + #f)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote expr env) + (scheme-error "Ill-placed 'unquote'" expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote-splicing expr env) + (scheme-error "Ill-placed 'unquote-splicing'" expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-set! expr env) + (shape expr 3) + (variable (cadr expr)) + (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-lambda expr env) + (shape expr 3) + (let ((parms (cadr expr))) + (let ((frame (parms->frame parms))) + (let ((nb-vars (length frame)) + (code (comp-body (cddr expr) (push-frame frame env)))) + (if (rest-param? parms) + (gen-lambda-rest nb-vars code) + (gen-lambda nb-vars code)))))) + +(define (parms->frame parms) + (cond ((null? parms) + '()) + ((pair? parms) + (let ((x (car parms))) + (variable x) + (cons x (parms->frame (cdr parms))))) + (else + (variable parms) + (list parms)))) + +(define (rest-param? parms) + (cond ((pair? parms) + (rest-param? (cdr parms))) + ((null? parms) + #f) + (else + #t))) + +(define (comp-body body env) + + (define (letrec-defines vars vals body env) + (if (pair? body) + + (let ((expr (car body))) + (cond ((not (pair? expr)) + (letrec-defines* vars vals body env)) + ((macro? (car expr) env) + (letrec-defines vars + vals + (cons (macro-expand expr env) (cdr body)) + env)) + (else + (cond + ((eq? (car expr) 'begin) + (letrec-defines vars + vals + (append (cdr expr) (cdr body)) + env)) + ((eq? (car expr) 'define) + (let ((x (definition-name expr))) + (variable x) + (letrec-defines (cons x vars) + (cons (definition-value expr) vals) + (cdr body) + env))) + ((eq? (car expr) 'define-macro) + (let ((x (definition-name expr))) + (letrec-defines vars + vals + (cdr body) + (push-macro + x + (scheme-eval (definition-value expr)) + env)))) + (else + (letrec-defines* vars vals body env)))))) + + (scheme-error "Body must contain at least one evaluable expression"))) + + (define (letrec-defines* vars vals body env) + (if (null? vars) + (comp-sequence body env) + (comp-letrec-aux vars vals body env))) + + (letrec-defines '() '() body env)) + +(define (definition-name expr) + (shape expr 3) + (let ((pattern (cadr expr))) + (let ((name (if (pair? pattern) (car pattern) pattern))) + (if (not (symbol? name)) + (scheme-error "Identifier expected" name)) + name))) + +(define (definition-value expr) + (let ((pattern (cadr expr))) + (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-if expr env) + (shape expr 3) + (let ((code1 (scheme-comp (cadr expr) env)) + (code2 (scheme-comp (caddr expr) env))) + (if (pair? (cdddr expr)) + (gen-if code1 code2 (scheme-comp (cadddr expr) env)) + (gen-when code1 code2)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-cond expr env) + (comp-cond-aux (cdr expr) env)) + +(define (comp-cond-aux clauses env) + (if (pair? clauses) + (let ((clause (car clauses))) + (shape clause 1) + (cond ((eq? (car clause) 'else) + (shape clause 2) + (comp-sequence (cdr clause) env)) + ((not (pair? (cdr clause))) + (gen-or (scheme-comp (car clause) env) + (comp-cond-aux (cdr clauses) env))) + ((eq? (cadr clause) '=>) + (shape clause 3) + (gen-cond-send (scheme-comp (car clause) env) + (scheme-comp (caddr clause) env) + (comp-cond-aux (cdr clauses) env))) + (else + (gen-if (scheme-comp (car clause) env) + (comp-sequence (cdr clause) env) + (comp-cond-aux (cdr clauses) env))))) + (gen-cst '()))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-and expr env) + (let ((rest (cdr expr))) + (if (pair? rest) (comp-and-aux rest env) (gen-cst #t)))) + +(define (comp-and-aux l env) + (let ((code (scheme-comp (car l) env)) + (rest (cdr l))) + (if (pair? rest) (gen-and code (comp-and-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-or expr env) + (let ((rest (cdr expr))) + (if (pair? rest) (comp-or-aux rest env) (gen-cst #f)))) + +(define (comp-or-aux l env) + (let ((code (scheme-comp (car l) env)) + (rest (cdr l))) + (if (pair? rest) (gen-or code (comp-or-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-case expr env) + (shape expr 3) + (gen-case (scheme-comp (cadr expr) env) + (comp-case-aux (cddr expr) env))) + +(define (comp-case-aux clauses env) + (if (pair? clauses) + (let ((clause (car clauses))) + (shape clause 2) + (if (eq? (car clause) 'else) + (gen-case-else (comp-sequence (cdr clause) env)) + (gen-case-clause (car clause) + (comp-sequence (cdr clause) env) + (comp-case-aux (cdr clauses) env)))) + (gen-case-else (gen-cst '())))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let expr env) + (shape expr 3) + (let ((x (cadr expr))) + (cond ((symbol? x) + (shape expr 4) + (let ((y (caddr expr))) + (let ((proc (cons 'lambda (cons (bindings->vars y) (cdddr expr))))) + (scheme-comp (cons (list 'letrec (list (list x proc)) x) + (bindings->vals y)) + env)))) + ((pair? x) + (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr))) + (bindings->vals x)) + env)) + (else + (comp-body (cddr expr) env))))) + +(define (bindings->vars bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (shape binding 2) + (let ((x (car binding))) + (variable x) + (cons x (bindings->vars (cdr bindings))))) + '())) + +(define (bindings->vals bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (cons (cadr binding) (bindings->vals (cdr bindings)))) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let* expr env) + (shape expr 3) + (let ((bindings (cadr expr))) + (if (pair? bindings) + (scheme-comp (list 'let + (list (car bindings)) + (cons 'let* (cons (cdr bindings) (cddr expr)))) + env) + (comp-body (cddr expr) env)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-letrec expr env) + (shape expr 3) + (let ((bindings (cadr expr))) + (comp-letrec-aux (bindings->vars bindings) + (bindings->vals bindings) + (cddr expr) + env))) + +(define (comp-letrec-aux vars vals body env) + (if (pair? vars) + (let ((new-env (push-frame vars env))) + (gen-letrec (comp-vals vals new-env) + (comp-body body new-env))) + (comp-body body env))) + +(define (comp-vals l env) + (if (pair? l) + (cons (scheme-comp (car l) env) (comp-vals (cdr l) env)) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-begin expr env) + (shape expr 2) + (comp-sequence (cdr expr) env)) + +(define (comp-sequence exprs env) + (if (pair? exprs) + (comp-sequence-aux exprs env) + (gen-cst '()))) + +(define (comp-sequence-aux exprs env) + (let ((code (scheme-comp (car exprs) env)) + (rest (cdr exprs))) + (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-do expr env) + (shape expr 3) + (let ((bindings (cadr expr)) + (exit (caddr expr))) + (shape exit 1) + (let* ((vars (bindings->vars bindings)) + (new-env1 (push-frame '(#f) env)) + (new-env2 (push-frame vars new-env1))) + (gen-letrec + (list + (gen-lambda + (length vars) + (gen-if + (scheme-comp (car exit) new-env2) + (comp-sequence (cdr exit) new-env2) + (gen-sequence + (comp-sequence (cdddr expr) new-env2) + (gen-combination + (gen-var-ref '(1 . 1)) + (comp-vals (bindings->steps bindings) new-env2)))))) + (gen-combination + (gen-var-ref '(0 . 1)) + (comp-vals (bindings->vals bindings) new-env1)))))) + +(define (bindings->steps bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (cons (if (pair? (cddr binding)) (caddr binding) (car binding)) + (bindings->steps (cdr bindings)))) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define expr env) + (shape expr 3) + (let ((pattern (cadr expr))) + (let ((x (if (pair? pattern) (car pattern) pattern))) + (variable x) + (gen-sequence + (gen-var-set (lookup-var x env) + (scheme-comp (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)) + env)) + (gen-cst x))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define-macro expr env) + (let ((x (definition-name expr))) + (gen-macro x (scheme-eval (definition-value expr))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-combination expr env) + (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env))) + +;------------------------------------------------------------------------------ + +(define (gen-var-ref var) + (if (pair? var) + (gen-rte-ref (car var) (cdr var)) + (gen-glo-ref (scheme-global-var var)))) + +(define (gen-rte-ref up over) + (case up + ((0) (gen-slot-ref-0 over)) + ((1) (gen-slot-ref-1 over)) + (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over))))) + +(define (gen-slot-ref-0 i) + (case i + ((0) (lambda (rte) (vector-ref rte 0))) + ((1) (lambda (rte) (vector-ref rte 1))) + ((2) (lambda (rte) (vector-ref rte 2))) + ((3) (lambda (rte) (vector-ref rte 3))) + (else (lambda (rte) (vector-ref rte i))))) + +(define (gen-slot-ref-1 i) + (case i + ((0) (lambda (rte) (vector-ref (vector-ref rte 0) 0))) + ((1) (lambda (rte) (vector-ref (vector-ref rte 0) 1))) + ((2) (lambda (rte) (vector-ref (vector-ref rte 0) 2))) + ((3) (lambda (rte) (vector-ref (vector-ref rte 0) 3))) + (else (lambda (rte) (vector-ref (vector-ref rte 0) i))))) + +(define (gen-slot-ref-up-2 code) + (lambda (rte) (code (vector-ref (vector-ref rte 0) 0)))) + +(define (gen-glo-ref i) + (lambda (rte) (scheme-global-var-ref i))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cst val) + (case val + ((()) (lambda (rte) '())) + ((#f) (lambda (rte) #f)) + ((#t) (lambda (rte) #t)) + ((-2) (lambda (rte) -2)) + ((-1) (lambda (rte) -1)) + ((0) (lambda (rte) 0)) + ((1) (lambda (rte) 1)) + ((2) (lambda (rte) 2)) + (else (lambda (rte) val)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-append-form code1 code2) + (lambda (rte) (append (code1 rte) (code2 rte)))) + +(define (gen-cons-form code1 code2) + (lambda (rte) (cons (code1 rte) (code2 rte)))) + +(define (gen-vector-form code) + (lambda (rte) (lst->vector (code rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-var-set var code) + (if (pair? var) + (gen-rte-set (car var) (cdr var) code) + (gen-glo-set (scheme-global-var var) code))) + +(define (gen-rte-set up over code) + (case up + ((0) (gen-slot-set-0 over code)) + ((1) (gen-slot-set-1 over code)) + (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code)))) + +(define (gen-slot-set-0 i code) + (case i + ((0) (lambda (rte) (vector-set! rte 0 (code rte)))) + ((1) (lambda (rte) (vector-set! rte 1 (code rte)))) + ((2) (lambda (rte) (vector-set! rte 2 (code rte)))) + ((3) (lambda (rte) (vector-set! rte 3 (code rte)))) + (else (lambda (rte) (vector-set! rte i (code rte)))))) + +(define (gen-slot-set-1 i code) + (case i + ((0) (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte)))) + ((1) (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte)))) + ((2) (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte)))) + ((3) (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte)))) + (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte)))))) + +(define (gen-slot-set-n up i code) + (case i + ((0) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte)))) + ((1) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte)))) + ((2) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte)))) + ((3) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte)))) + (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte)))))) + +(define (gen-glo-set i code) + (lambda (rte) (scheme-global-var-set! i (code rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-lambda-rest nb-vars body) + (case nb-vars + ((1) (gen-lambda-1-rest body)) + ((2) (gen-lambda-2-rest body)) + ((3) (gen-lambda-3-rest body)) + (else (gen-lambda-n-rest nb-vars body)))) + +(define (gen-lambda-1-rest body) + (lambda (rte) + (lambda a + (body (vector rte a))))) + +(define (gen-lambda-2-rest body) + (lambda (rte) + (lambda (a . b) + (body (vector rte a b))))) + +(define (gen-lambda-3-rest body) + (lambda (rte) + (lambda (a b . c) + (body (vector rte a b c))))) + +(define (gen-lambda-n-rest nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ((x (make-vector (+ nb-vars 1)))) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ((n nb-vars) (x x) (i 4) (l d)) + (if (< i n) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))) + (vector-set! x i l))) + (body x))))) + +(define (gen-lambda nb-vars body) + (case nb-vars + ((0) (gen-lambda-0 body)) + ((1) (gen-lambda-1 body)) + ((2) (gen-lambda-2 body)) + ((3) (gen-lambda-3 body)) + (else (gen-lambda-n nb-vars body)))) + +(define (gen-lambda-0 body) + (lambda (rte) + (lambda () + (body rte)))) + +(define (gen-lambda-1 body) + (lambda (rte) + (lambda (a) + (body (vector rte a))))) + +(define (gen-lambda-2 body) + (lambda (rte) + (lambda (a b) + (body (vector rte a b))))) + +(define (gen-lambda-3 body) + (lambda (rte) + (lambda (a b c) + (body (vector rte a b c))))) + +(define (gen-lambda-n nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ((x (make-vector (+ nb-vars 1)))) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ((n nb-vars) (x x) (i 4) (l d)) + (if (<= i n) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))))) + (body x))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-sequence code1 code2) + (lambda (rte) (code1 rte) (code2 rte))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-when code1 code2) + (lambda (rte) + (if (code1 rte) + (code2 rte) + '()))) + +(define (gen-if code1 code2 code3) + (lambda (rte) + (if (code1 rte) + (code2 rte) + (code3 rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cond-send code1 code2 code3) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + ((code2 rte) temp) + (code3 rte))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-and code1 code2) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + (code2 rte) + temp)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-or code1 code2) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + temp + (code2 rte))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-case code1 code2) + (lambda (rte) (code2 rte (code1 rte)))) + +(define (gen-case-clause datums code1 code2) + (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key)))) + +(define (gen-case-else code) + (lambda (rte key) (code rte))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-letrec vals body) + (let ((nb-vals (length vals))) + (case nb-vals + ((1) (gen-letrec-1 (car vals) body)) + ((2) (gen-letrec-2 (car vals) (cadr vals) body)) + ((3) (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body)) + (else (gen-letrec-n nb-vals vals body))))) + +(define (gen-letrec-1 val1 body) + (lambda (rte) + (let ((x (vector rte #f))) + (vector-set! x 1 (val1 x)) + (body x)))) + +(define (gen-letrec-2 val1 val2 body) + (lambda (rte) + (let ((x (vector rte #f #f))) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (body x)))) + +(define (gen-letrec-3 val1 val2 val3 body) + (lambda (rte) + (let ((x (vector rte #f #f #f))) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (vector-set! x 3 (val3 x)) + (body x)))) + +(define (gen-letrec-n nb-vals vals body) + (lambda (rte) + (let ((x (make-vector (+ nb-vals 1)))) + (vector-set! x 0 rte) + (let loop ((x x) (i 1) (l vals)) + (if (pair? l) + (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l))))) + (body x)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-macro name proc) + (lambda (rte) (scheme-add-macro name proc))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-combination oper args) + (case (length args) + ((0) (gen-combination-0 oper)) + ((1) (gen-combination-1 oper (car args))) + ((2) (gen-combination-2 oper (car args) (cadr args))) + ((3) (gen-combination-3 oper (car args) (cadr args) (caddr args))) + (else (gen-combination-n oper args)))) + +(define (gen-combination-0 oper) + (lambda (rte) ((oper rte)))) + +(define (gen-combination-1 oper arg1) + (lambda (rte) ((oper rte) (arg1 rte)))) + +(define (gen-combination-2 oper arg1 arg2) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte)))) + +(define (gen-combination-3 oper arg1 arg2 arg3) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte)))) + +(define (gen-combination-n oper args) + (lambda (rte) + (define (evaluate l rte) + (if (pair? l) + (cons ((car l) rte) (evaluate (cdr l) rte)) + '())) + (apply (oper rte) (evaluate args rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-comp expr env) + (cond ((symbol? expr) + (comp-var expr env)) + ((not (pair? expr)) + (comp-self-eval expr env)) + ((macro? (car expr) env) + (scheme-comp (macro-expand expr env) env)) + (else + (cond + ((eq? (car expr) 'quote) (comp-quote expr env)) + ((eq? (car expr) 'quasiquote) (comp-quasiquote expr env)) + ((eq? (car expr) 'unquote) (comp-unquote expr env)) + ((eq? (car expr) 'unquote-splicing) (comp-unquote-splicing expr env)) + ((eq? (car expr) 'set!) (comp-set! expr env)) + ((eq? (car expr) 'lambda) (comp-lambda expr env)) + ((eq? (car expr) 'if) (comp-if expr env)) + ((eq? (car expr) 'cond) (comp-cond expr env)) + ((eq? (car expr) 'and) (comp-and expr env)) + ((eq? (car expr) 'or) (comp-or expr env)) + ((eq? (car expr) 'case) (comp-case expr env)) + ((eq? (car expr) 'let) (comp-let expr env)) + ((eq? (car expr) 'let*) (comp-let* expr env)) + ((eq? (car expr) 'letrec) (comp-letrec expr env)) + ((eq? (car expr) 'begin) (comp-begin expr env)) + ((eq? (car expr) 'do) (comp-do expr env)) + ((eq? (car expr) 'define) (comp-define expr env)) + ((eq? (car expr) 'define-macro) (comp-define-macro expr env)) + (else (comp-combination expr env)))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-global-var name) + (let ((x (assq name scheme-global-variables))) + (if x + (cdr x) + (let ((y (vector '()))) + (set! scheme-global-variables (cons (cons name y) scheme-global-variables)) + y)))) + +(define (scheme-global-var-ref i) + (vector-ref i 0)) + +(define (scheme-global-var-set! i val) + (vector-set! i 0 val) + '()) + +(define scheme-global-variables '()) + +(define (def-proc name value) + (scheme-global-var-set! + (scheme-global-var name) + value)) + +(define nothing + (begin +(def-proc 'not (lambda (x) (not x))) +(def-proc 'boolean? boolean?) +(def-proc 'eqv? eqv?) +(def-proc 'eq? eq?) +(def-proc 'equal? equal?) +(def-proc 'pair? (lambda (obj) (pair? obj))) +(def-proc 'cons (lambda (x y) (cons x y))) +(def-proc 'car (lambda (x) (car x))) +(def-proc 'cdr (lambda (x) (cdr x))) +;(def-proc 'set-car! set-car!) +;(def-proc 'set-cdr! set-cdr!) +(def-proc 'caar caar) +(def-proc 'cadr cadr) +(def-proc 'cdar cdar) +(def-proc 'cddr cddr) +(def-proc 'caaar caaar) +(def-proc 'caadr caadr) +(def-proc 'cadar cadar) +(def-proc 'caddr caddr) +(def-proc 'cdaar cdaar) +(def-proc 'cdadr cdadr) +(def-proc 'cddar cddar) +(def-proc 'cdddr cdddr) +(def-proc 'caaaar caaaar) +(def-proc 'caaadr caaadr) +(def-proc 'caadar caadar) +(def-proc 'caaddr caaddr) +(def-proc 'cadaar cadaar) +(def-proc 'cadadr cadadr) +(def-proc 'caddar caddar) +(def-proc 'cadddr cadddr) +(def-proc 'cdaaar cdaaar) +(def-proc 'cdaadr cdaadr) +(def-proc 'cdadar cdadar) +(def-proc 'cdaddr cdaddr) +(def-proc 'cddaar cddaar) +(def-proc 'cddadr cddadr) +(def-proc 'cdddar cdddar) +(def-proc 'cddddr cddddr) +(def-proc 'null? (lambda (x) (null? x))) +(def-proc 'list? list?) +(def-proc 'list list) +(def-proc 'length length) +(def-proc 'append append) +(def-proc 'reverse reverse) +(def-proc 'list-ref list-ref) +(def-proc 'memq memq) +(def-proc 'memv memv) +(def-proc 'member member) +(def-proc 'assq assq) +(def-proc 'assv assv) +(def-proc 'assoc assoc) +(def-proc 'symbol? symbol?) +(def-proc 'symbol->string symbol->string) +(def-proc 'string->symbol string->symbol) +(def-proc 'number? number?) +(def-proc 'complex? complex?) +(def-proc 'real? real?) +(def-proc 'rational? rational?) +(def-proc 'integer? integer?) +(def-proc 'exact? exact?) +(def-proc 'inexact? inexact?) +;(def-proc '= =) +;(def-proc '< <) +;(def-proc '> >) +;(def-proc '<= <=) +;(def-proc '>= >=) +;(def-proc 'zero? zero?) +;(def-proc 'positive? positive?) +;(def-proc 'negative? negative?) +;(def-proc 'odd? odd?) +;(def-proc 'even? even?) +(def-proc 'max max) +(def-proc 'min min) +;(def-proc '+ +) +;(def-proc '* *) +;(def-proc '- -) +(def-proc '/ /) +(def-proc 'abs abs) +;(def-proc 'quotient quotient) +;(def-proc 'remainder remainder) +;(def-proc 'modulo modulo) +(def-proc 'gcd gcd) +(def-proc 'lcm lcm) +;(def-proc 'numerator numerator) +;(def-proc 'denominator denominator) +(def-proc 'floor floor) +(def-proc 'ceiling ceiling) +(def-proc 'truncate truncate) +(def-proc 'round round) +;(def-proc 'rationalize rationalize) +(def-proc 'exp exp) +(def-proc 'log log) +(def-proc 'sin sin) +(def-proc 'cos cos) +(def-proc 'tan tan) +(def-proc 'asin asin) +(def-proc 'acos acos) +(def-proc 'atan atan) +(def-proc 'sqrt sqrt) +(def-proc 'expt expt) +;(def-proc 'make-rectangular make-rectangular) +;(def-proc 'make-polar make-polar) +;(def-proc 'real-part real-part) +;(def-proc 'imag-part imag-part) +;(def-proc 'magnitude magnitude) +;(def-proc 'angle angle) +(def-proc 'exact->inexact exact->inexact) +(def-proc 'inexact->exact inexact->exact) +(def-proc 'number->string number->string) +(def-proc 'string->number string->number) +(def-proc 'char? char?) +(def-proc 'char=? char=?) +(def-proc 'char? char>?) +(def-proc 'char<=? char<=?) +(def-proc 'char>=? char>=?) +(def-proc 'char-ci=? char-ci=?) +(def-proc 'char-ci? char-ci>?) +(def-proc 'char-ci<=? char-ci<=?) +(def-proc 'char-ci>=? char-ci>=?) +(def-proc 'char-alphabetic? char-alphabetic?) +(def-proc 'char-numeric? char-numeric?) +(def-proc 'char-whitespace? char-whitespace?) +(def-proc 'char-lower-case? char-lower-case?) +(def-proc 'char->integer char->integer) +(def-proc 'integer->char integer->char) +(def-proc 'char-upcase char-upcase) +(def-proc 'char-downcase char-downcase) +(def-proc 'string? string?) +(def-proc 'make-string make-string) +(def-proc 'string string) +(def-proc 'string-length string-length) +(def-proc 'string-ref string-ref) +(def-proc 'string-set! string-set!) +(def-proc 'string=? string=?) +(def-proc 'string? string>?) +(def-proc 'string<=? string<=?) +(def-proc 'string>=? string>=?) +(def-proc 'string-ci=? string-ci=?) +(def-proc 'string-ci? string-ci>?) +(def-proc 'string-ci<=? string-ci<=?) +(def-proc 'string-ci>=? string-ci>=?) +(def-proc 'substring substring) +(def-proc 'string-append string-append) +(def-proc 'vector? vector?) +(def-proc 'make-vector make-vector) +(def-proc 'vector vector) +(def-proc 'vector-length vector-length) +(def-proc 'vector-ref vector-ref) +(def-proc 'vector-set! vector-set!) +(def-proc 'procedure? procedure?) +(def-proc 'apply apply) +(def-proc 'map map) +(def-proc 'for-each for-each) +;(def-proc 'call-with-current-continuation call-with-current-continuation) +(def-proc 'call-with-input-file call-with-input-file) +(def-proc 'call-with-output-file call-with-output-file) +(def-proc 'input-port? input-port?) +(def-proc 'output-port? output-port?) +(def-proc 'current-input-port current-input-port) +(def-proc 'current-output-port current-output-port) +(def-proc 'open-input-file open-input-file) +(def-proc 'open-output-file open-output-file) +(def-proc 'close-input-port close-input-port) +(def-proc 'close-output-port close-output-port) +(def-proc 'eof-object? eof-object?) +(def-proc 'read read) +(def-proc 'read-char read-char) +(def-proc 'peek-char peek-char) +(def-proc 'write write) +(def-proc 'display display) +(def-proc 'newline newline) +(def-proc 'write-char write-char))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define expr1 + '(let () + + (define (sort-list obj pred) + + (define (loop l) + (if (and (pair? l) (pair? (cdr l))) + (split l '() '()) + l)) + + (define (split l one two) + (if (pair? l) + (split (cdr l) two (cons (car l) one)) + (merge (loop one) (loop two)))) + + (define (merge one two) + (cond ((null? one) two) + ((pred (car two) (car one)) + (cons (car two) + (merge (cdr two) one))) + (else + (cons (car one) + (merge (cdr one) two))))) + + (loop obj)) + + (sort-list '("one" "two" "three" "four" "five" "six" + "seven" "eight" "nine" "ten" "eleven" "twelve") + string n 2) + (let* ((j (quotient n 2)) + (a (step j)) + (k (- n j)) + (b (step k))) + (merge!! a b less?))) + ((= n 2) + (let ((x (car seq)) + (y (cadr seq)) + (p seq)) + (set! seq (cddr seq)) + (if (less? y x) + (begin + (set-car! p y) + (set-car! (cdr p) x))) + (set-cdr! (cdr p) '()) + p)) + ((= n 1) + (let ((p seq)) + (set! seq (cdr seq)) + (set-cdr! p '()) + p)) + (else + '()))) + + (step (length seq))) + +(define (sort! seq less?) + (cond ((null? seq) + seq) + ((pair? seq) + (sort!! seq less?)) + ((vector? seq) + (do ((l (sort!! (vector->list seq) less?) (cdr l)) + (i 0 (+ i 1))) + ((null? l) seq) + (vector-set! seq i (car l)))) + (else + (error "sort!: not a valid sequence: " seq)))) + +(define (sort seq less?) + (cond ((null? seq) + seq) + ((pair? seq) + (sort!! (list-copy seq) less?)) + ((vector? seq) + (list->vector (sort!! (vector->list seq) less?))) + (else + (error "sort: not a valid sequence: " seq)))) + +; eof + + ; This is pretty much optimal for Larceny. + + (define (list-copy l) + (define (loop l prev) + (if (null? l) + #t + (let ((q (cons (car l) '()))) + (set-cdr! prev q) + (loop (cdr l) q)))) + (if (null? l) + l + (let ((first (cons (car l) '()))) + (loop (cdr l) first) + first))) + + sort)) + +(define *rand* 21) +(define (randm m) + (set! *rand* (remainder (* *rand* 17) m)) + *rand*) + +(define (rgen n m) + (let loop ((n n) (l '())) + (if (zero? n) + l + (loop (- n 1) (cons (randm m) l))))) + +(define (sort-benchmark sorter n) + (let ((l (rgen n 1000000))) + (time (length (sorter l <))))) + +(sort-benchmark sort1 1000000) + diff --git a/benchmarks/gabriel/tak.sch b/benchmarks/gabriel/tak.sch new file mode 100644 index 00000000..a795edce --- /dev/null +++ b/benchmarks/gabriel/tak.sch @@ -0,0 +1,28 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: tak.sch +; Description: TAK benchmark from the Gabriel tests +; Author: Richard Gabriel +; Created: 12-Apr-85 +; Modified: 12-Apr-85 09:58:18 (Bob Shaw) +; 22-Jul-87 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; TAK -- A vanilla version of the TAKeuchi function + +(define (tak x y z) + (if (not (< y x)) + z + (tak (tak (- x 1) y z) + (tak (- y 1) z x) + (tak (- z 1) x y)))) + +;;; call: (tak 18 12 6) + +(let ((input (with-input-from-file "input.txt" read))) + (time + (let loop ((n 500) (v 0)) + (if (zero? n) + v + (loop (- n 1) (tak 18 12 (if input 6 0))))))) diff --git a/benchmarks/gabriel/takl.sch b/benchmarks/gabriel/takl.sch new file mode 100644 index 00000000..79df0c0a --- /dev/null +++ b/benchmarks/gabriel/takl.sch @@ -0,0 +1,43 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: takl.sch +; Description: TAKL benchmark from the Gabriel tests +; Author: Richard Gabriel +; Created: 12-Apr-85 +; Modified: 12-Apr-85 10:07:00 (Bob Shaw) +; 22-Jul-87 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; TAKL -- The TAKeuchi function using lists as counters. + +(define (listn n) + (if (not (= 0 n)) + (cons n (listn (- n 1))) + '())) + +(define l18l (listn 18)) +(define l12l (listn 12)) +(define l6l (listn 2)) + +(define (mas x y z) + (if (not (shorterp y x)) + z + (mas (mas (cdr x) + y z) + (mas (cdr y) + z x) + (mas (cdr z) + x y)))) + +(define (shorterp x y) + (and (not (null? y)) + (or (null? x) + (shorterp (cdr x) + (cdr y))))) + +;;; call: (mas 18l 12l 6l) + + +(let ((v (if (with-input-from-file "input.txt" read) l6l '()))) + (time (mas l18l l12l v))) diff --git a/benchmarks/gabriel/takr.sch b/benchmarks/gabriel/takr.sch new file mode 100644 index 00000000..ef46d387 --- /dev/null +++ b/benchmarks/gabriel/takr.sch @@ -0,0 +1,525 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: takr.sch +; Description: TAKR benchmark +; Author: Richard Gabriel +; Created: 12-Apr-85 +; Modified: 12-Apr-85 10:12:43 (Bob Shaw) +; 22-Jul-87 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; TAKR -- 100 function (count `em) version of TAK that tries to defeat cache +;;; memory effects. Results should be the same as for TAK on stack machines. +;;; Distribution of calls is not completely flat. + +(define (tak0 x y z) + (cond ((not (< y x)) z) + (else (tak1 (tak37 (- x 1) y z) + (tak11 (- y 1) z x) + (tak17 (- z 1) x y))))) +(define (tak1 x y z) + (cond ((not (< y x)) z) + (else (tak2 (tak74 (- x 1) y z) + (tak22 (- y 1) z x) + (tak34 (- z 1) x y))))) +(define (tak2 x y z) + (cond ((not (< y x)) z) + (else (tak3 (tak11 (- x 1) y z) + (tak33 (- y 1) z x) + (tak51 (- z 1) x y))))) +(define (tak3 x y z) + (cond ((not (< y x)) z) + (else (tak4 (tak48 (- x 1) y z) + (tak44 (- y 1) z x) + (tak68 (- z 1) x y))))) +(define (tak4 x y z) + (cond ((not (< y x)) z) + (else (tak5 (tak85 (- x 1) y z) + (tak55 (- y 1) z x) + (tak85 (- z 1) x y))))) +(define (tak5 x y z) + (cond ((not (< y x)) z) + (else (tak6 (tak22 (- x 1) y z) + (tak66 (- y 1) z x) + (tak2 (- z 1) x y))))) +(define (tak6 x y z) + (cond ((not (< y x)) z) + (else (tak7 (tak59 (- x 1) y z) + (tak77 (- y 1) z x) + (tak19 (- z 1) x y))))) +(define (tak7 x y z) + (cond ((not (< y x)) z) + (else (tak8 (tak96 (- x 1) y z) + (tak88 (- y 1) z x) + (tak36 (- z 1) x y))))) +(define (tak8 x y z) + (cond ((not (< y x)) z) + (else (tak9 (tak33 (- x 1) y z) + (tak99 (- y 1) z x) + (tak53 (- z 1) x y))))) +(define (tak9 x y z) + (cond ((not (< y x)) z) + (else (tak10 (tak70 (- x 1) y z) + (tak10 (- y 1) z x) + (tak70 (- z 1) x y))))) +(define (tak10 x y z) + (cond ((not (< y x)) z) + (else (tak11 (tak7 (- x 1) y z) + (tak21 (- y 1) z x) + (tak87 (- z 1) x y))))) +(define (tak11 x y z) + (cond ((not (< y x)) z) + (else (tak12 (tak44 (- x 1) y z) + (tak32 (- y 1) z x) + (tak4 (- z 1) x y))))) +(define (tak12 x y z) + (cond ((not (< y x)) z) + (else (tak13 (tak81 (- x 1) y z) + (tak43 (- y 1) z x) + (tak21 (- z 1) x y))))) + +(define (tak13 x y z) + (cond ((not (< y x)) z) + (else (tak14 (tak18 (- x 1) y z) + (tak54 (- y 1) z x) + (tak38 (- z 1) x y))))) +(define (tak14 x y z) + (cond ((not (< y x)) z) + (else (tak15 (tak55 (- x 1) y z) + (tak65 (- y 1) z x) + (tak55 (- z 1) x y))))) +(define (tak15 x y z) + (cond ((not (< y x)) z) + (else (tak16 (tak92 (- x 1) y z) + (tak76 (- y 1) z x) + (tak72 (- z 1) x y))))) +(define (tak16 x y z) + (cond ((not (< y x)) z) + (else (tak17 (tak29 (- x 1) y z) + (tak87 (- y 1) z x) + (tak89 (- z 1) x y))))) +(define (tak17 x y z) + (cond ((not (< y x)) z) + (else (tak18 (tak66 (- x 1) y z) + (tak98 (- y 1) z x) + (tak6 (- z 1) x y))))) +(define (tak18 x y z) + (cond ((not (< y x)) z) + (else (tak19 (tak3 (- x 1) y z) + (tak9 (- y 1) z x) + (tak23 (- z 1) x y))))) +(define (tak19 x y z) + (cond ((not (< y x)) z) + (else (tak20 (tak40 (- x 1) y z) + (tak20 (- y 1) z x) + (tak40 (- z 1) x y))))) +(define (tak20 x y z) + (cond ((not (< y x)) z) + (else (tak21 (tak77 (- x 1) y z) + (tak31 (- y 1) z x) + (tak57 (- z 1) x y))))) +(define (tak21 x y z) + (cond ((not (< y x)) z) + (else (tak22 (tak14 (- x 1) y z) + (tak42 (- y 1) z x) + (tak74 (- z 1) x y))))) +(define (tak22 x y z) + (cond ((not (< y x)) z) + (else (tak23 (tak51 (- x 1) y z) + (tak53 (- y 1) z x) + (tak91 (- z 1) x y))))) +(define (tak23 x y z) + (cond ((not (< y x)) z) + (else (tak24 (tak88 (- x 1) y z) + (tak64 (- y 1) z x) + (tak8 (- z 1) x y))))) +(define (tak24 x y z) + (cond ((not (< y x)) z) + (else (tak25 (tak25 (- x 1) y z) + (tak75 (- y 1) z x) + (tak25 (- z 1) x y))))) +(define (tak25 x y z) + (cond ((not (< y x)) z) + (else (tak26 (tak62 (- x 1) y z) + (tak86 (- y 1) z x) + (tak42 (- z 1) x y))))) +(define (tak26 x y z) + (cond ((not (< y x)) z) + (else (tak27 (tak99 (- x 1) y z) + (tak97 (- y 1) z x) + (tak59 (- z 1) x y))))) +(define (tak27 x y z) + (cond ((not (< y x)) z) + (else (tak28 (tak36 (- x 1) y z) + (tak8 (- y 1) z x) + (tak76 (- z 1) x y))))) +(define (tak28 x y z) + (cond ((not (< y x)) z) + (else (tak29 (tak73 (- x 1) y z) + (tak19 (- y 1) z x) + (tak93 (- z 1) x y))))) +(define (tak29 x y z) + (cond ((not (< y x)) z) + (else (tak30 (tak10 (- x 1) y z) + (tak30 (- y 1) z x) + (tak10 (- z 1) x y))))) +(define (tak30 x y z) + (cond ((not (< y x)) z) + (else (tak31 (tak47 (- x 1) y z) + (tak41 (- y 1) z x) + (tak27 (- z 1) x y))))) +(define (tak31 x y z) + (cond ((not (< y x)) z) + (else (tak32 (tak84 (- x 1) y z) + (tak52 (- y 1) z x) + (tak44 (- z 1) x y))))) +(define (tak32 x y z) + (cond ((not (< y x)) z) + (else (tak33 (tak21 (- x 1) y z) + (tak63 (- y 1) z x) + (tak61 (- z 1) x y))))) +(define (tak33 x y z) + (cond ((not (< y x)) z) + (else (tak34 (tak58 (- x 1) y z) + (tak74 (- y 1) z x) + (tak78 (- z 1) x y))))) +(define (tak34 x y z) + (cond ((not (< y x)) z) + (else (tak35 (tak95 (- x 1) y z) + (tak85 (- y 1) z x) + (tak95 (- z 1) x y))))) +(define (tak35 x y z) + (cond ((not (< y x)) z) + (else (tak36 (tak32 (- x 1) y z) + (tak96 (- y 1) z x) + (tak12 (- z 1) x y))))) +(define (tak36 x y z) + (cond ((not (< y x)) z) + (else (tak37 (tak69 (- x 1) y z) + (tak7 (- y 1) z x) + (tak29 (- z 1) x y))))) +(define (tak37 x y z) + (cond ((not (< y x)) z) + (else (tak38 (tak6 (- x 1) y z) + (tak18 (- y 1) z x) + (tak46 (- z 1) x y))))) +(define (tak38 x y z) + (cond ((not (< y x)) z) + (else (tak39 (tak43 (- x 1) y z) + (tak29 (- y 1) z x) + (tak63 (- z 1) x y))))) +(define (tak39 x y z) + (cond ((not (< y x)) z) + (else (tak40 (tak80 (- x 1) y z) + (tak40 (- y 1) z x) + (tak80 (- z 1) x y))))) +(define (tak40 x y z) + (cond ((not (< y x)) z) + (else (tak41 (tak17 (- x 1) y z) + (tak51 (- y 1) z x) + (tak97 (- z 1) x y))))) +(define (tak41 x y z) + (cond ((not (< y x)) z) + (else (tak42 (tak54 (- x 1) y z) + (tak62 (- y 1) z x) + (tak14 (- z 1) x y))))) +(define (tak42 x y z) + (cond ((not (< y x)) z) + (else (tak43 (tak91 (- x 1) y z) + (tak73 (- y 1) z x) + (tak31 (- z 1) x y))))) +(define (tak43 x y z) + (cond ((not (< y x)) z) + (else (tak44 (tak28 (- x 1) y z) + (tak84 (- y 1) z x) + (tak48 (- z 1) x y))))) +(define (tak44 x y z) + (cond ((not (< y x)) z) + (else (tak45 (tak65 (- x 1) y z) + (tak95 (- y 1) z x) + (tak65 (- z 1) x y))))) +(define (tak45 x y z) + (cond ((not (< y x)) z) + (else (tak46 (tak2 (- x 1) y z) + (tak6 (- y 1) z x) + (tak82 (- z 1) x y))))) +(define (tak46 x y z) + (cond ((not (< y x)) z) + (else (tak47 (tak39 (- x 1) y z) + (tak17 (- y 1) z x) + (tak99 (- z 1) x y))))) +(define (tak47 x y z) + (cond ((not (< y x)) z) + (else (tak48 (tak76 (- x 1) y z) + (tak28 (- y 1) z x) + (tak16 (- z 1) x y))))) +(define (tak48 x y z) + (cond ((not (< y x)) z) + (else (tak49 (tak13 (- x 1) y z) + (tak39 (- y 1) z x) + (tak33 (- z 1) x y))))) +(define (tak49 x y z) + (cond ((not (< y x)) z) + (else (tak50 (tak50 (- x 1) y z) + (tak50 (- y 1) z x) + (tak50 (- z 1) x y))))) +(define (tak50 x y z) + (cond ((not (< y x)) z) + (else (tak51 (tak87 (- x 1) y z) + (tak61 (- y 1) z x) + (tak67 (- z 1) x y))))) +(define (tak51 x y z) + (cond ((not (< y x)) z) + (else (tak52 (tak24 (- x 1) y z) + (tak72 (- y 1) z x) + (tak84 (- z 1) x y))))) +(define (tak52 x y z) + (cond ((not (< y x)) z) + (else (tak53 (tak61 (- x 1) y z) + (tak83 (- y 1) z x) + (tak1 (- z 1) x y))))) +(define (tak53 x y z) + (cond ((not (< y x)) z) + (else (tak54 (tak98 (- x 1) y z) + (tak94 (- y 1) z x) + (tak18 (- z 1) x y))))) +(define (tak54 x y z) + (cond ((not (< y x)) z) + (else (tak55 (tak35 (- x 1) y z) + (tak5 (- y 1) z x) + (tak35 (- z 1) x y))))) +(define (tak55 x y z) + (cond ((not (< y x)) z) + (else (tak56 (tak72 (- x 1) y z) + (tak16 (- y 1) z x) + (tak52 (- z 1) x y))))) +(define (tak56 x y z) + (cond ((not (< y x)) z) + (else (tak57 (tak9 (- x 1) y z) + (tak27 (- y 1) z x) + (tak69 (- z 1) x y))))) +(define (tak57 x y z) + (cond ((not (< y x)) z) + (else (tak58 (tak46 (- x 1) y z) + (tak38 (- y 1) z x) + (tak86 (- z 1) x y))))) +(define (tak58 x y z) + (cond ((not (< y x)) z) + (else (tak59 (tak83 (- x 1) y z) + (tak49 (- y 1) z x) + (tak3 (- z 1) x y))))) +(define (tak59 x y z) + (cond ((not (< y x)) z) + (else (tak60 (tak20 (- x 1) y z) + (tak60 (- y 1) z x) + (tak20 (- z 1) x y))))) +(define (tak60 x y z) + (cond ((not (< y x)) z) + (else (tak61 (tak57 (- x 1) y z) + (tak71 (- y 1) z x) + (tak37 (- z 1) x y))))) +(define (tak61 x y z) + (cond ((not (< y x)) z) + (else (tak62 (tak94 (- x 1) y z) + (tak82 (- y 1) z x) + (tak54 (- z 1) x y))))) +(define (tak62 x y z) + (cond ((not (< y x)) z) + (else (tak63 (tak31 (- x 1) y z) + (tak93 (- y 1) z x) + (tak71 (- z 1) x y))))) +(define (tak63 x y z) + (cond ((not (< y x)) z) + (else (tak64 (tak68 (- x 1) y z) + (tak4 (- y 1) z x) + (tak88 (- z 1) x y))))) +(define (tak64 x y z) + (cond ((not (< y x)) z) + (else (tak65 (tak5 (- x 1) y z) + (tak15 (- y 1) z x) + (tak5 (- z 1) x y))))) +(define (tak65 x y z) + (cond ((not (< y x)) z) + (else (tak66 (tak42 (- x 1) y z) + (tak26 (- y 1) z x) + (tak22 (- z 1) x y))))) +(define (tak66 x y z) + (cond ((not (< y x)) z) + (else (tak67 (tak79 (- x 1) y z) + (tak37 (- y 1) z x) + (tak39 (- z 1) x y))))) +(define (tak67 x y z) + (cond ((not (< y x)) z) + (else (tak68 (tak16 (- x 1) y z) + (tak48 (- y 1) z x) + (tak56 (- z 1) x y))))) +(define (tak68 x y z) + (cond ((not (< y x)) z) + (else (tak69 (tak53 (- x 1) y z) + (tak59 (- y 1) z x) + (tak73 (- z 1) x y))))) +(define (tak69 x y z) + (cond ((not (< y x)) z) + (else (tak70 (tak90 (- x 1) y z) + (tak70 (- y 1) z x) + (tak90 (- z 1) x y))))) +(define (tak70 x y z) + (cond ((not (< y x)) z) + (else (tak71 (tak27 (- x 1) y z) + (tak81 (- y 1) z x) + (tak7 (- z 1) x y))))) +(define (tak71 x y z) + (cond ((not (< y x)) z) + (else (tak72 (tak64 (- x 1) y z) + (tak92 (- y 1) z x) + (tak24 (- z 1) x y))))) +(define (tak72 x y z) + (cond ((not (< y x)) z) + (else (tak73 (tak1 (- x 1) y z) + (tak3 (- y 1) z x) + (tak41 (- z 1) x y))))) +(define (tak73 x y z) + (cond ((not (< y x)) z) + (else (tak74 (tak38 (- x 1) y z) + (tak14 (- y 1) z x) + (tak58 (- z 1) x y))))) +(define (tak74 x y z) + (cond ((not (< y x)) z) + (else (tak75 (tak75 (- x 1) y z) + (tak25 (- y 1) z x) + (tak75 (- z 1) x y))))) +(define (tak75 x y z) + (cond ((not (< y x)) z) + (else (tak76 (tak12 (- x 1) y z) + (tak36 (- y 1) z x) + (tak92 (- z 1) x y))))) +(define (tak76 x y z) + (cond ((not (< y x)) z) + (else (tak77 (tak49 (- x 1) y z) + (tak47 (- y 1) z x) + (tak9 (- z 1) x y))))) +(define (tak77 x y z) + (cond ((not (< y x)) z) + (else (tak78 (tak86 (- x 1) y z) + (tak58 (- y 1) z x) + (tak26 (- z 1) x y))))) +(define (tak78 x y z) + (cond ((not (< y x)) z) + (else (tak79 (tak23 (- x 1) y z) + (tak69 (- y 1) z x) + (tak43 (- z 1) x y))))) +(define (tak79 x y z) + (cond ((not (< y x)) z) + (else (tak80 (tak60 (- x 1) y z) + (tak80 (- y 1) z x) + (tak60 (- z 1) x y))))) +(define (tak80 x y z) + (cond ((not (< y x)) z) + (else (tak81 (tak97 (- x 1) y z) + (tak91 (- y 1) z x) + (tak77 (- z 1) x y))))) +(define (tak81 x y z) + (cond ((not (< y x)) z) + (else (tak82 (tak34 (- x 1) y z) + (tak2 (- y 1) z x) + (tak94 (- z 1) x y))))) +(define (tak82 x y z) + (cond ((not (< y x)) z) + (else (tak83 (tak71 (- x 1) y z) + (tak13 (- y 1) z x) + (tak11 (- z 1) x y))))) +(define (tak83 x y z) + (cond ((not (< y x)) z) + (else (tak84 (tak8 (- x 1) y z) + (tak24 (- y 1) z x) + (tak28 (- z 1) x y))))) +(define (tak84 x y z) + (cond ((not (< y x)) z) + (else (tak85 (tak45 (- x 1) y z) + (tak35 (- y 1) z x) + (tak45 (- z 1) x y))))) +(define (tak85 x y z) + (cond ((not (< y x)) z) + (else (tak86 (tak82 (- x 1) y z) + (tak46 (- y 1) z x) + (tak62 (- z 1) x y))))) +(define (tak86 x y z) + (cond ((not (< y x)) z) + (else (tak87 (tak19 (- x 1) y z) + (tak57 (- y 1) z x) + (tak79 (- z 1) x y))))) +(define (tak87 x y z) + (cond ((not (< y x)) z) + (else (tak88 (tak56 (- x 1) y z) + (tak68 (- y 1) z x) + (tak96 (- z 1) x y))))) +(define (tak88 x y z) + (cond ((not (< y x)) z) + (else (tak89 (tak93 (- x 1) y z) + (tak79 (- y 1) z x) + (tak13 (- z 1) x y))))) +(define (tak89 x y z) + (cond ((not (< y x)) z) + (else (tak90 (tak30 (- x 1) y z) + (tak90 (- y 1) z x) + (tak30 (- z 1) x y))))) +(define (tak90 x y z) + (cond ((not (< y x)) z) + (else (tak91 (tak67 (- x 1) y z) + (tak1 (- y 1) z x) + (tak47 (- z 1) x y))))) +(define (tak91 x y z) + (cond ((not (< y x)) z) + (else (tak92 (tak4 (- x 1) y z) + (tak12 (- y 1) z x) + (tak64 (- z 1) x y))))) +(define (tak92 x y z) + (cond ((not (< y x)) z) + (else (tak93 (tak41 (- x 1) y z) + (tak23 (- y 1) z x) + (tak81 (- z 1) x y))))) +(define (tak93 x y z) + (cond ((not (< y x)) z) + (else (tak94 (tak78 (- x 1) y z) + (tak34 (- y 1) z x) + (tak98 (- z 1) x y))))) +(define (tak94 x y z) + (cond ((not (< y x)) z) + (else (tak95 (tak15 (- x 1) y z) + (tak45 (- y 1) z x) + (tak15 (- z 1) x y))))) +(define (tak95 x y z) + (cond ((not (< y x)) z) + (else (tak96 (tak52 (- x 1) y z) + (tak56 (- y 1) z x) + (tak32 (- z 1) x y))))) +(define (tak96 x y z) + (cond ((not (< y x)) z) + (else (tak97 (tak89 (- x 1) y z) + (tak67 (- y 1) z x) + (tak49 (- z 1) x y))))) +(define (tak97 x y z) + (cond ((not (< y x)) z) + (else (tak98 (tak26 (- x 1) y z) + (tak78 (- y 1) z x) + (tak66 (- z 1) x y))))) +(define (tak98 x y z) + (cond ((not (< y x)) z) + (else (tak99 (tak63 (- x 1) y z) + (tak89 (- y 1) z x) + (tak83 (- z 1) x y))))) +(define (tak99 x y z) + (cond ((not (< y x)) z) + (else (tak0 (tak0 (- x 1) y z) + (tak0 (- y 1) z x) + (tak0 (- z 1) x y))))) + +;;; call: (tak0 18 12 6) + +(let ((input (with-input-from-file "input.txt" read))) + (time + (let loop ((n 500) (v 0)) + (if (zero? n) + v + (loop (- n 1) (tak0 18 12 (if input 6 0))))))) diff --git a/benchmarks/gabriel/takr2.sch b/benchmarks/gabriel/takr2.sch new file mode 100644 index 00000000..c6deb8dc --- /dev/null +++ b/benchmarks/gabriel/takr2.sch @@ -0,0 +1,528 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: takr.sch +; Description: TAKR benchmark +; Author: Richard Gabriel +; Created: 12-Apr-85 +; Modified: 12-Apr-85 10:12:43 (Bob Shaw) +; 22-Jul-87 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; TAKR -- 100 function (count `em) version of TAK that tries to defeat cache +;;; memory effects. Results should be the same as for TAK on stack machines. +;;; Distribution of calls is not completely flat. + +(define (tak x y z) + (define (tak0 x y z) + (cond ((not (< y x)) z) + (else (tak1 (tak37 (- x 1) y z) + (tak11 (- y 1) z x) + (tak17 (- z 1) x y))))) + (define (tak1 x y z) + (cond ((not (< y x)) z) + (else (tak2 (tak74 (- x 1) y z) + (tak22 (- y 1) z x) + (tak34 (- z 1) x y))))) + (define (tak2 x y z) + (cond ((not (< y x)) z) + (else (tak3 (tak11 (- x 1) y z) + (tak33 (- y 1) z x) + (tak51 (- z 1) x y))))) + (define (tak3 x y z) + (cond ((not (< y x)) z) + (else (tak4 (tak48 (- x 1) y z) + (tak44 (- y 1) z x) + (tak68 (- z 1) x y))))) + (define (tak4 x y z) + (cond ((not (< y x)) z) + (else (tak5 (tak85 (- x 1) y z) + (tak55 (- y 1) z x) + (tak85 (- z 1) x y))))) + (define (tak5 x y z) + (cond ((not (< y x)) z) + (else (tak6 (tak22 (- x 1) y z) + (tak66 (- y 1) z x) + (tak2 (- z 1) x y))))) + (define (tak6 x y z) + (cond ((not (< y x)) z) + (else (tak7 (tak59 (- x 1) y z) + (tak77 (- y 1) z x) + (tak19 (- z 1) x y))))) + (define (tak7 x y z) + (cond ((not (< y x)) z) + (else (tak8 (tak96 (- x 1) y z) + (tak88 (- y 1) z x) + (tak36 (- z 1) x y))))) + (define (tak8 x y z) + (cond ((not (< y x)) z) + (else (tak9 (tak33 (- x 1) y z) + (tak99 (- y 1) z x) + (tak53 (- z 1) x y))))) + (define (tak9 x y z) + (cond ((not (< y x)) z) + (else (tak10 (tak70 (- x 1) y z) + (tak10 (- y 1) z x) + (tak70 (- z 1) x y))))) + (define (tak10 x y z) + (cond ((not (< y x)) z) + (else (tak11 (tak7 (- x 1) y z) + (tak21 (- y 1) z x) + (tak87 (- z 1) x y))))) + (define (tak11 x y z) + (cond ((not (< y x)) z) + (else (tak12 (tak44 (- x 1) y z) + (tak32 (- y 1) z x) + (tak4 (- z 1) x y))))) + (define (tak12 x y z) + (cond ((not (< y x)) z) + (else (tak13 (tak81 (- x 1) y z) + (tak43 (- y 1) z x) + (tak21 (- z 1) x y))))) + + (define (tak13 x y z) + (cond ((not (< y x)) z) + (else (tak14 (tak18 (- x 1) y z) + (tak54 (- y 1) z x) + (tak38 (- z 1) x y))))) + (define (tak14 x y z) + (cond ((not (< y x)) z) + (else (tak15 (tak55 (- x 1) y z) + (tak65 (- y 1) z x) + (tak55 (- z 1) x y))))) + (define (tak15 x y z) + (cond ((not (< y x)) z) + (else (tak16 (tak92 (- x 1) y z) + (tak76 (- y 1) z x) + (tak72 (- z 1) x y))))) + (define (tak16 x y z) + (cond ((not (< y x)) z) + (else (tak17 (tak29 (- x 1) y z) + (tak87 (- y 1) z x) + (tak89 (- z 1) x y))))) + (define (tak17 x y z) + (cond ((not (< y x)) z) + (else (tak18 (tak66 (- x 1) y z) + (tak98 (- y 1) z x) + (tak6 (- z 1) x y))))) + (define (tak18 x y z) + (cond ((not (< y x)) z) + (else (tak19 (tak3 (- x 1) y z) + (tak9 (- y 1) z x) + (tak23 (- z 1) x y))))) + (define (tak19 x y z) + (cond ((not (< y x)) z) + (else (tak20 (tak40 (- x 1) y z) + (tak20 (- y 1) z x) + (tak40 (- z 1) x y))))) + (define (tak20 x y z) + (cond ((not (< y x)) z) + (else (tak21 (tak77 (- x 1) y z) + (tak31 (- y 1) z x) + (tak57 (- z 1) x y))))) + (define (tak21 x y z) + (cond ((not (< y x)) z) + (else (tak22 (tak14 (- x 1) y z) + (tak42 (- y 1) z x) + (tak74 (- z 1) x y))))) + (define (tak22 x y z) + (cond ((not (< y x)) z) + (else (tak23 (tak51 (- x 1) y z) + (tak53 (- y 1) z x) + (tak91 (- z 1) x y))))) + (define (tak23 x y z) + (cond ((not (< y x)) z) + (else (tak24 (tak88 (- x 1) y z) + (tak64 (- y 1) z x) + (tak8 (- z 1) x y))))) + (define (tak24 x y z) + (cond ((not (< y x)) z) + (else (tak25 (tak25 (- x 1) y z) + (tak75 (- y 1) z x) + (tak25 (- z 1) x y))))) + (define (tak25 x y z) + (cond ((not (< y x)) z) + (else (tak26 (tak62 (- x 1) y z) + (tak86 (- y 1) z x) + (tak42 (- z 1) x y))))) + (define (tak26 x y z) + (cond ((not (< y x)) z) + (else (tak27 (tak99 (- x 1) y z) + (tak97 (- y 1) z x) + (tak59 (- z 1) x y))))) + (define (tak27 x y z) + (cond ((not (< y x)) z) + (else (tak28 (tak36 (- x 1) y z) + (tak8 (- y 1) z x) + (tak76 (- z 1) x y))))) + (define (tak28 x y z) + (cond ((not (< y x)) z) + (else (tak29 (tak73 (- x 1) y z) + (tak19 (- y 1) z x) + (tak93 (- z 1) x y))))) + (define (tak29 x y z) + (cond ((not (< y x)) z) + (else (tak30 (tak10 (- x 1) y z) + (tak30 (- y 1) z x) + (tak10 (- z 1) x y))))) + (define (tak30 x y z) + (cond ((not (< y x)) z) + (else (tak31 (tak47 (- x 1) y z) + (tak41 (- y 1) z x) + (tak27 (- z 1) x y))))) + (define (tak31 x y z) + (cond ((not (< y x)) z) + (else (tak32 (tak84 (- x 1) y z) + (tak52 (- y 1) z x) + (tak44 (- z 1) x y))))) + (define (tak32 x y z) + (cond ((not (< y x)) z) + (else (tak33 (tak21 (- x 1) y z) + (tak63 (- y 1) z x) + (tak61 (- z 1) x y))))) + (define (tak33 x y z) + (cond ((not (< y x)) z) + (else (tak34 (tak58 (- x 1) y z) + (tak74 (- y 1) z x) + (tak78 (- z 1) x y))))) + (define (tak34 x y z) + (cond ((not (< y x)) z) + (else (tak35 (tak95 (- x 1) y z) + (tak85 (- y 1) z x) + (tak95 (- z 1) x y))))) + (define (tak35 x y z) + (cond ((not (< y x)) z) + (else (tak36 (tak32 (- x 1) y z) + (tak96 (- y 1) z x) + (tak12 (- z 1) x y))))) + (define (tak36 x y z) + (cond ((not (< y x)) z) + (else (tak37 (tak69 (- x 1) y z) + (tak7 (- y 1) z x) + (tak29 (- z 1) x y))))) + (define (tak37 x y z) + (cond ((not (< y x)) z) + (else (tak38 (tak6 (- x 1) y z) + (tak18 (- y 1) z x) + (tak46 (- z 1) x y))))) + (define (tak38 x y z) + (cond ((not (< y x)) z) + (else (tak39 (tak43 (- x 1) y z) + (tak29 (- y 1) z x) + (tak63 (- z 1) x y))))) + (define (tak39 x y z) + (cond ((not (< y x)) z) + (else (tak40 (tak80 (- x 1) y z) + (tak40 (- y 1) z x) + (tak80 (- z 1) x y))))) + (define (tak40 x y z) + (cond ((not (< y x)) z) + (else (tak41 (tak17 (- x 1) y z) + (tak51 (- y 1) z x) + (tak97 (- z 1) x y))))) + (define (tak41 x y z) + (cond ((not (< y x)) z) + (else (tak42 (tak54 (- x 1) y z) + (tak62 (- y 1) z x) + (tak14 (- z 1) x y))))) + (define (tak42 x y z) + (cond ((not (< y x)) z) + (else (tak43 (tak91 (- x 1) y z) + (tak73 (- y 1) z x) + (tak31 (- z 1) x y))))) + (define (tak43 x y z) + (cond ((not (< y x)) z) + (else (tak44 (tak28 (- x 1) y z) + (tak84 (- y 1) z x) + (tak48 (- z 1) x y))))) + (define (tak44 x y z) + (cond ((not (< y x)) z) + (else (tak45 (tak65 (- x 1) y z) + (tak95 (- y 1) z x) + (tak65 (- z 1) x y))))) + (define (tak45 x y z) + (cond ((not (< y x)) z) + (else (tak46 (tak2 (- x 1) y z) + (tak6 (- y 1) z x) + (tak82 (- z 1) x y))))) + (define (tak46 x y z) + (cond ((not (< y x)) z) + (else (tak47 (tak39 (- x 1) y z) + (tak17 (- y 1) z x) + (tak99 (- z 1) x y))))) + (define (tak47 x y z) + (cond ((not (< y x)) z) + (else (tak48 (tak76 (- x 1) y z) + (tak28 (- y 1) z x) + (tak16 (- z 1) x y))))) + (define (tak48 x y z) + (cond ((not (< y x)) z) + (else (tak49 (tak13 (- x 1) y z) + (tak39 (- y 1) z x) + (tak33 (- z 1) x y))))) + (define (tak49 x y z) + (cond ((not (< y x)) z) + (else (tak50 (tak50 (- x 1) y z) + (tak50 (- y 1) z x) + (tak50 (- z 1) x y))))) + (define (tak50 x y z) + (cond ((not (< y x)) z) + (else (tak51 (tak87 (- x 1) y z) + (tak61 (- y 1) z x) + (tak67 (- z 1) x y))))) + (define (tak51 x y z) + (cond ((not (< y x)) z) + (else (tak52 (tak24 (- x 1) y z) + (tak72 (- y 1) z x) + (tak84 (- z 1) x y))))) + (define (tak52 x y z) + (cond ((not (< y x)) z) + (else (tak53 (tak61 (- x 1) y z) + (tak83 (- y 1) z x) + (tak1 (- z 1) x y))))) + (define (tak53 x y z) + (cond ((not (< y x)) z) + (else (tak54 (tak98 (- x 1) y z) + (tak94 (- y 1) z x) + (tak18 (- z 1) x y))))) + (define (tak54 x y z) + (cond ((not (< y x)) z) + (else (tak55 (tak35 (- x 1) y z) + (tak5 (- y 1) z x) + (tak35 (- z 1) x y))))) + (define (tak55 x y z) + (cond ((not (< y x)) z) + (else (tak56 (tak72 (- x 1) y z) + (tak16 (- y 1) z x) + (tak52 (- z 1) x y))))) + (define (tak56 x y z) + (cond ((not (< y x)) z) + (else (tak57 (tak9 (- x 1) y z) + (tak27 (- y 1) z x) + (tak69 (- z 1) x y))))) + (define (tak57 x y z) + (cond ((not (< y x)) z) + (else (tak58 (tak46 (- x 1) y z) + (tak38 (- y 1) z x) + (tak86 (- z 1) x y))))) + (define (tak58 x y z) + (cond ((not (< y x)) z) + (else (tak59 (tak83 (- x 1) y z) + (tak49 (- y 1) z x) + (tak3 (- z 1) x y))))) + (define (tak59 x y z) + (cond ((not (< y x)) z) + (else (tak60 (tak20 (- x 1) y z) + (tak60 (- y 1) z x) + (tak20 (- z 1) x y))))) + (define (tak60 x y z) + (cond ((not (< y x)) z) + (else (tak61 (tak57 (- x 1) y z) + (tak71 (- y 1) z x) + (tak37 (- z 1) x y))))) + (define (tak61 x y z) + (cond ((not (< y x)) z) + (else (tak62 (tak94 (- x 1) y z) + (tak82 (- y 1) z x) + (tak54 (- z 1) x y))))) + (define (tak62 x y z) + (cond ((not (< y x)) z) + (else (tak63 (tak31 (- x 1) y z) + (tak93 (- y 1) z x) + (tak71 (- z 1) x y))))) + (define (tak63 x y z) + (cond ((not (< y x)) z) + (else (tak64 (tak68 (- x 1) y z) + (tak4 (- y 1) z x) + (tak88 (- z 1) x y))))) + (define (tak64 x y z) + (cond ((not (< y x)) z) + (else (tak65 (tak5 (- x 1) y z) + (tak15 (- y 1) z x) + (tak5 (- z 1) x y))))) + (define (tak65 x y z) + (cond ((not (< y x)) z) + (else (tak66 (tak42 (- x 1) y z) + (tak26 (- y 1) z x) + (tak22 (- z 1) x y))))) + (define (tak66 x y z) + (cond ((not (< y x)) z) + (else (tak67 (tak79 (- x 1) y z) + (tak37 (- y 1) z x) + (tak39 (- z 1) x y))))) + (define (tak67 x y z) + (cond ((not (< y x)) z) + (else (tak68 (tak16 (- x 1) y z) + (tak48 (- y 1) z x) + (tak56 (- z 1) x y))))) + (define (tak68 x y z) + (cond ((not (< y x)) z) + (else (tak69 (tak53 (- x 1) y z) + (tak59 (- y 1) z x) + (tak73 (- z 1) x y))))) + (define (tak69 x y z) + (cond ((not (< y x)) z) + (else (tak70 (tak90 (- x 1) y z) + (tak70 (- y 1) z x) + (tak90 (- z 1) x y))))) + (define (tak70 x y z) + (cond ((not (< y x)) z) + (else (tak71 (tak27 (- x 1) y z) + (tak81 (- y 1) z x) + (tak7 (- z 1) x y))))) + (define (tak71 x y z) + (cond ((not (< y x)) z) + (else (tak72 (tak64 (- x 1) y z) + (tak92 (- y 1) z x) + (tak24 (- z 1) x y))))) + (define (tak72 x y z) + (cond ((not (< y x)) z) + (else (tak73 (tak1 (- x 1) y z) + (tak3 (- y 1) z x) + (tak41 (- z 1) x y))))) + (define (tak73 x y z) + (cond ((not (< y x)) z) + (else (tak74 (tak38 (- x 1) y z) + (tak14 (- y 1) z x) + (tak58 (- z 1) x y))))) + (define (tak74 x y z) + (cond ((not (< y x)) z) + (else (tak75 (tak75 (- x 1) y z) + (tak25 (- y 1) z x) + (tak75 (- z 1) x y))))) + (define (tak75 x y z) + (cond ((not (< y x)) z) + (else (tak76 (tak12 (- x 1) y z) + (tak36 (- y 1) z x) + (tak92 (- z 1) x y))))) + (define (tak76 x y z) + (cond ((not (< y x)) z) + (else (tak77 (tak49 (- x 1) y z) + (tak47 (- y 1) z x) + (tak9 (- z 1) x y))))) + (define (tak77 x y z) + (cond ((not (< y x)) z) + (else (tak78 (tak86 (- x 1) y z) + (tak58 (- y 1) z x) + (tak26 (- z 1) x y))))) + (define (tak78 x y z) + (cond ((not (< y x)) z) + (else (tak79 (tak23 (- x 1) y z) + (tak69 (- y 1) z x) + (tak43 (- z 1) x y))))) + (define (tak79 x y z) + (cond ((not (< y x)) z) + (else (tak80 (tak60 (- x 1) y z) + (tak80 (- y 1) z x) + (tak60 (- z 1) x y))))) + (define (tak80 x y z) + (cond ((not (< y x)) z) + (else (tak81 (tak97 (- x 1) y z) + (tak91 (- y 1) z x) + (tak77 (- z 1) x y))))) + (define (tak81 x y z) + (cond ((not (< y x)) z) + (else (tak82 (tak34 (- x 1) y z) + (tak2 (- y 1) z x) + (tak94 (- z 1) x y))))) + (define (tak82 x y z) + (cond ((not (< y x)) z) + (else (tak83 (tak71 (- x 1) y z) + (tak13 (- y 1) z x) + (tak11 (- z 1) x y))))) + (define (tak83 x y z) + (cond ((not (< y x)) z) + (else (tak84 (tak8 (- x 1) y z) + (tak24 (- y 1) z x) + (tak28 (- z 1) x y))))) + (define (tak84 x y z) + (cond ((not (< y x)) z) + (else (tak85 (tak45 (- x 1) y z) + (tak35 (- y 1) z x) + (tak45 (- z 1) x y))))) + (define (tak85 x y z) + (cond ((not (< y x)) z) + (else (tak86 (tak82 (- x 1) y z) + (tak46 (- y 1) z x) + (tak62 (- z 1) x y))))) + (define (tak86 x y z) + (cond ((not (< y x)) z) + (else (tak87 (tak19 (- x 1) y z) + (tak57 (- y 1) z x) + (tak79 (- z 1) x y))))) + (define (tak87 x y z) + (cond ((not (< y x)) z) + (else (tak88 (tak56 (- x 1) y z) + (tak68 (- y 1) z x) + (tak96 (- z 1) x y))))) + (define (tak88 x y z) + (cond ((not (< y x)) z) + (else (tak89 (tak93 (- x 1) y z) + (tak79 (- y 1) z x) + (tak13 (- z 1) x y))))) + (define (tak89 x y z) + (cond ((not (< y x)) z) + (else (tak90 (tak30 (- x 1) y z) + (tak90 (- y 1) z x) + (tak30 (- z 1) x y))))) + (define (tak90 x y z) + (cond ((not (< y x)) z) + (else (tak91 (tak67 (- x 1) y z) + (tak1 (- y 1) z x) + (tak47 (- z 1) x y))))) + (define (tak91 x y z) + (cond ((not (< y x)) z) + (else (tak92 (tak4 (- x 1) y z) + (tak12 (- y 1) z x) + (tak64 (- z 1) x y))))) + (define (tak92 x y z) + (cond ((not (< y x)) z) + (else (tak93 (tak41 (- x 1) y z) + (tak23 (- y 1) z x) + (tak81 (- z 1) x y))))) + (define (tak93 x y z) + (cond ((not (< y x)) z) + (else (tak94 (tak78 (- x 1) y z) + (tak34 (- y 1) z x) + (tak98 (- z 1) x y))))) + (define (tak94 x y z) + (cond ((not (< y x)) z) + (else (tak95 (tak15 (- x 1) y z) + (tak45 (- y 1) z x) + (tak15 (- z 1) x y))))) + (define (tak95 x y z) + (cond ((not (< y x)) z) + (else (tak96 (tak52 (- x 1) y z) + (tak56 (- y 1) z x) + (tak32 (- z 1) x y))))) + (define (tak96 x y z) + (cond ((not (< y x)) z) + (else (tak97 (tak89 (- x 1) y z) + (tak67 (- y 1) z x) + (tak49 (- z 1) x y))))) + (define (tak97 x y z) + (cond ((not (< y x)) z) + (else (tak98 (tak26 (- x 1) y z) + (tak78 (- y 1) z x) + (tak66 (- z 1) x y))))) + (define (tak98 x y z) + (cond ((not (< y x)) z) + (else (tak99 (tak63 (- x 1) y z) + (tak89 (- y 1) z x) + (tak83 (- z 1) x y))))) + (define (tak99 x y z) + (cond ((not (< y x)) z) + (else (tak0 (tak0 (- x 1) y z) + (tak0 (- y 1) z x) + (tak0 (- z 1) x y))))) + + (tak0 x y z)) + +;;; call: (tak0 18 12 6) + +(let ((input (with-input-from-file "input.txt" read))) + (time + (let loop ((n 500) (v 0)) + (if (zero? n) + v + (loop (- n 1) (tak 18 12 (if input 6 0))))))) diff --git a/benchmarks/gabriel/triangle.sch b/benchmarks/gabriel/triangle.sch new file mode 100644 index 00000000..baeddd27 --- /dev/null +++ b/benchmarks/gabriel/triangle.sch @@ -0,0 +1,85 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: triangle.sch +; Description: TRIANGLE benchmark +; Author: Richard Gabriel +; Created: 12-Apr-85 +; Modified: 12-Apr-85 10:30:32 (Bob Shaw) +; 11-Aug-87 (Will Clinger) +; 22-Jan-88 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; TRIANG -- Board game benchmark. + +(define *board* (make-vector 16 1)) +(define *sequence* (make-vector 14 0)) +(define *a* (make-vector 37)) +(define *b* (make-vector 37)) +(define *c* (make-vector 37)) +(define *answer* '()) +(define *final* '()) + +(define (last-position) + (do ((i 1 (+ i 1))) + ((or (= i 16) (= 1 (vector-ref *board* i))) + (if (= i 16) 0 i)))) + +(define (ttry i depth) + (cond ((= depth 14) + (let ((lp (last-position))) + (if (not (member lp *final*)) + (set! *final* (cons lp *final*)))) + (set! *answer* + (cons (cdr (vector->list *sequence*)) *answer*)) + #t) + ((and (= 1 (vector-ref *board* (vector-ref *a* i))) + (= 1 (vector-ref *board* (vector-ref *b* i))) + (= 0 (vector-ref *board* (vector-ref *c* i)))) + (vector-set! *board* (vector-ref *a* i) 0) + (vector-set! *board* (vector-ref *b* i) 0) + (vector-set! *board* (vector-ref *c* i) 1) + (vector-set! *sequence* depth i) + (do ((j 0 (+ j 1)) + (depth (+ depth 1))) + ((or (= j 36) (ttry j depth)) #f)) + (vector-set! *board* (vector-ref *a* i) 1) + (vector-set! *board* (vector-ref *b* i) 1) + (vector-set! *board* (vector-ref *c* i) 0) '()) + (else #f))) + +(define (gogogo i) + (let ((*answer* '()) + (*final* '())) + (ttry i 1))) + +(for-each (lambda (i x) (vector-set! *a* i x)) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) + '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 + 13 7 8 4 4 7 11 8 12 13 6 10 + 15 9 14 13 13 14 15 9 10 + 6 6)) +(for-each (lambda (i x) (vector-set! *b* i x)) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) + '(2 4 7 5 8 9 3 6 10 5 9 8 + 12 13 14 8 9 5 2 4 7 5 8 + 9 3 6 10 5 9 8 12 13 14 + 8 9 5 5)) +(for-each (lambda (i x) (vector-set! *c* i x)) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) + '(4 7 11 8 12 13 6 10 15 9 14 13 + 13 14 15 9 10 6 1 2 4 3 5 6 1 + 3 6 2 5 4 11 12 13 7 8 4 4)) +(vector-set! *board* 5 0) + +;;; call: (gogogo 22)) + +(time (let loop ((n 100000)) + (if (zero? n) + 'done + (begin + (gogogo 22) + (loop (- n 1)))))) diff --git a/benchmarks/shootout/binarytrees.chibi b/benchmarks/shootout/binarytrees.chibi new file mode 100755 index 00000000..c0d6b637 --- /dev/null +++ b/benchmarks/shootout/binarytrees.chibi @@ -0,0 +1,46 @@ +#! /usr/bin/env chibi-scheme + +;;; The Computer Language Benchmarks Game +;;; http://shootout.alioth.debian.org/ + +(import (chibi) (srfi 9)) + +(define-record-type node + (make-node value left right) + node? + (value node-value node-value-set!) + (left node-left node-left-set!) + (right node-right node-right-set!)) + +(define (make value depth) + (if (zero? depth) + (make-node value #f #f) + (let ((v (* value 2)) + (d (- depth 1))) + (make-node value (make (- v 1) d) (make v d))))) + +(define (check n) + (if n + (+ (node-value n) (- (check (node-left n)) (check (node-right n)))) + 0)) + +(define (print . args) (for-each display args) (newline)) + +(let* ((args (command-line)) + (n (string->number (cadr args))) + (min-depth 4) + (max-depth (max (+ min-depth 2) n)) + (stretch-depth (+ max-depth 1))) + (print "stretch tree of depth " stretch-depth "\t check: " + (check (make 0 stretch-depth))) + (let ((long-lived-tree (make 0 max-depth))) + (do ((d min-depth (+ d 2))) + ((>= d max-depth)) + (let ((iterations (* 2 (+ (- max-depth d) min-depth)))) + (print (* 2 iterations) "\t trees of depth " d "\t check: " + (do ((i 0 (+ i 1)) + (c 0 (+ c (check (make i d)) (check (make (- i) d))))) + ((>= i iterations) + c))))) + (print "long lived tree of depth " max-depth "\t check: " + (check long-lived-tree)))) diff --git a/benchmarks/shootout/chameneos-redux.chibi b/benchmarks/shootout/chameneos-redux.chibi new file mode 100644 index 00000000..113d2afd --- /dev/null +++ b/benchmarks/shootout/chameneos-redux.chibi @@ -0,0 +1,107 @@ +#! /usr/bin/env chibi-scheme + +;;; The Computer Language Benchmarks Game +;;; http://shootout.alioth.debian.org/ + +;;; based on Racket version by Matthew Flatt + +(import (chibi) + (srfi 18) + (chibi match)) + +(define (print . args) + (for-each display args) + (newline)) + +(define (change c1 c2) + (case c1 + ((red) + (case c2 ((blue) 'yellow) ((yellow) 'blue) (else c1))) + ((yellow) + (case c2 ((blue) 'red) ((red) 'blue) (else c1))) + ((blue) + (case c2 ((yellow) 'red) ((red) 'yellow) (else c1))))) + +(let ((colors '(blue red yellow))) + (for-each + (lambda (a) + (for-each + (lambda (b) + (print a " + " b " -> " (change a b))) + colors)) + colors)) + +(define (place meeting-ch n) + (thread-start! + (make-thread + (lambda () + (let loop ((n n)) + (if (<= n 0) + ;; Fade all: + (let loop () + (let ((c (channel-get meeting-ch))) + (channel-put (car c) #f) + (loop))) + ;; Let two meet: + (match-let (((ch1 . v1) (channel-get meeting-ch)) + ((ch2 . v2) (channel-get meeting-ch))) + (channel-put ch1 v2) + (channel-put ch2 v1) + (loop (- n 1))))))))) + +(define (creature color meeting-ch result-ch) + (thread-start! + (make-thread + (lambda () + (let ((ch (make-channel)) + (name (gensym))) + (let loop ((color color) (met 0) (same 0)) + (channel-put meeting-ch (cons ch (cons color name))) + (match (channel-get ch) + ((other-color . other-name) + ;; Meet: + (sleep) ; avoid imbalance from weak fairness + (loop (change color other-color) + (add1 met) + (+ same (if (eq? name other-name) + 1 + 0)))) + (#f + ;; Done: + (channel-put result-ch (cons met same)))))))))) + +(define (spell n) + (for-each + (lambda (i) + (display " ") + (display (vector-ref digits (- (char->integer i) (char->integer #\0))))) + (string->list (number->string n)))) + +(define digits + '#("zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) + +(define (go n inits) + (let ((result-ch (make-channel)) + (meeting-ch (make-channel))) + (place meeting-ch n) + (newline) + (for-each + (lambda (init) + (print " " init) + (creature init meeting-ch result-ch)) + inits) + (newline) + (let ((results (map (lambda (i) (channel-get result-ch)) inits))) + (for-each + (lambda (r) + (display (car r)) + (spell (cdr r)) + (newline)) + results) + (spell (apply + (map car results))) + (newline)))) + +(let ((n (string->number (cadr (command-line))))) + (go n '(blue red yellow)) + (go n '(blue red yellow red yellow blue red yellow red blue)) + (newline)) diff --git a/benchmarks/shootout/knucleotide-input.txt b/benchmarks/shootout/knucleotide-input.txt new file mode 100644 index 00000000..fd4414b1 --- /dev/null +++ b/benchmarks/shootout/knucleotide-input.txt @@ -0,0 +1,4171 @@ +>ONE Homo sapiens alu +GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGA +TCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACT +AAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAG +GCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCG +CCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGT +GGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCA +GGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAA +TTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAG +AATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCA +GCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGT +AATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACC +AGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTG +GTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACC +CGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAG +AGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTT +TGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACA +TGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCT +GTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGG +TTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGT +CTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGG +CGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCG +TCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTA +CTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCG +AGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCG +GGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC +TGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAA +TACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGA +GGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACT +GCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTC +ACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGT +TCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGC +CGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCG +CTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTG +GGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCC +CAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCT +GGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGC +GCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGA +GGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGA +GACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGA +GGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTG +AAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAAT +CCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCA +GTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAA +AAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGC +GGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCT +ACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGG +GAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATC +GCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGC +GGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG +TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAA +AAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAG +GAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACT +CCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCC +TGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAG +ACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGC +GTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGA +ACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGA +CAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCA +CTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCA +ACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCG +CCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGG +AGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTC +CGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCG +AGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACC +CCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAG +CTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAG +CCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGG +CCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATC +ACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAA +AAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGC +TGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCC +ACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGG +CTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGG +AGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATT +AGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAA +TCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGC +CTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAA +TCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAG +CCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGT +GGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCG +GGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAG +CGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTG +GGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATG +GTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGT +AATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTT +GCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCT +CAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCG +GGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTC +TCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACT +CGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAG +ATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGG +CGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTG +AGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATA +CAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGG +CAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGC +ACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCAC +GCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTC +GAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCG +GGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCT +TGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGG +CGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCA +GCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGG +CCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGC +GCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGG +CGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGA +CTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGG +CCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAA +ACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCC +CAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGT +GAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAA +AGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGG +ATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTAC +TAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGA +GGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGC +GCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGG +TGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTC +AGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAA +ATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGA +GAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC +AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTG +TAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGAC +CAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGT +GGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAAC +CCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACA +GAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACT +TTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAAC +ATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCC +TGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAG +GTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCG +TCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAG +GCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCC +GTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCT +ACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCC +GAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCC +GGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCAC +CTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAA +ATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTG +AGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCAC +TGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCT +CACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAG +TTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAG +CCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATC +GCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCT +GGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATC +CCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCC +TGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGG +CGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG +AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCG +AGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGG +AGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGT +GAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAA +TCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGC +AGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCA +AAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGG +CGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTC +TACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCG +GGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGAT +CGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCG +CGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAG +GTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACA +AAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCA +GGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCAC +TCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGC +CTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGA +GACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG +CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTG +AACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCG +ACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGC +ACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCC +AACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGC +GCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCG +GAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACT +CCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCC +GAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAAC +CCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA +GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGA +GCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAG +GCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGAT +CACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTA +AAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGG +CTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGC +CACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTG +GCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAG +GAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAAT +TAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGA +ATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAG +CCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTA +ATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCA +GCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGG +TGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCC +GGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGA +GCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTT +GGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACAT +GGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTG +TAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGT +TGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTC +TCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGC +GGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGT +CTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTAC +TCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGA +GATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGG +GCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCT +GAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT +ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAG +GCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTG +CACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCA +CGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTT +CGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCC +GGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGC +TTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGG +GCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCC +AGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTG +GCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCG +CGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAG +GCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAG +ACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAG +GCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGA +AACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATC +CCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAG +TGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAA +AAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCG +GATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTA +CTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGG +AGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCG +CGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCG +GTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGT +CAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAA +AATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGG +AGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTC +CAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCT +GTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA +CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCG +TGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAA +CCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGAC +AGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCAC +TTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAA +CATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGC +CTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGA +GGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCC +GTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGA +GGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCC +CGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGC +TACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGC +CGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGC +CGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCA +CCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAA +AATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCT +GAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCA +CTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGC +TCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGA +GTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTA +GCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAAT +CGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCC +TGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAAT +CCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGC +CTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTG +GCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGG +GAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGC +GAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG +GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGG +TGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTA +ATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTG +CAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTC +AAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGG +GCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCT +CTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTC +GGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGA +TCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGC +GCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGA +GGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATAC +AAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGC +AGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCA +CTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACG +CCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCG +AGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGG +GCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTT +GAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGC +GACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAG +CACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGC +CAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCG +CGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC +GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGAC +TCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGC +CGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAA +CCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCC +AGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTG +AGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA +GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGA +TCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACT +AAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAG +GCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCG +CCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGT +GGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCA +GGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAA +TTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAG +AATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCA +GCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGT +AATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACC +AGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTG +GTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACC +CGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAG +AGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTT +TGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACA +TGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCT +GTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGG +TTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGT +CTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGG +CGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCG +TCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTA +CTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCG +AGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCG +GGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC +TGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAA +TACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGA +GGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACT +GCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTC +ACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGT +TCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGC +CGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCG +CTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTG +GGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCC +CAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCT +GGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGC +GCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGA +GGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGA +GACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGA +GGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTG +AAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAAT +CCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCA +GTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAA +AAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGC +GGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCT +ACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGG +GAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATC +GCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGC +GGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG +TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAA +AAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAG +GAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACT +CCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCC +TGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAG +ACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGC +GTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGA +ACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGA +CAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCA +CTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCA +ACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCG +CCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGG +AGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTC +CGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCG +AGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACC +CCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAG +CTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAG +CCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGG +CCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATC +ACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAA +AAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGC +TGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCC +ACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGG +CTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGG +AGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATT +AGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAA +TCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGC +CTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAA +TCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAG +CCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGT +GGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCG +GGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAG +CGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTG +GGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATG +GTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGT +AATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTT +GCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCT +CAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCG +GGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTC +TCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACT +CGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAG +ATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGG +CGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTG +AGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATA +CAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGG +CAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGC +ACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCAC +GCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTC +GAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCG +GGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCT +TGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGG +CGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCA +GCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGG +CCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGC +GCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGG +CGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGA +CTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGG +CCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAA +ACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCC +CAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGT +GAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAA +AGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGG +ATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTAC +TAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGA +GGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGC +GCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGG +TGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTC +AGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAA +ATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGA +GAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC +AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTG +TAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGAC +CAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGT +GGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAAC +CCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACA +GAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACT +TTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAAC +ATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCC +TGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAG +GTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCG +TCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAG +GCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCC +GTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCT +ACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCC +GAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCC +GGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCAC +CTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAA +ATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTG +AGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCAC +TGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCT +CACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAG +TTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAG +CCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATC +GCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCT +GGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATC +CCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCC +TGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGG +CGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG +AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCG +AGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGG +AGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGT +GAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAA +TCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGC +AGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCA +AAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGG +CGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTC +TACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCG +GGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGAT +CGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCG +CGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAG +GTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACA +AAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCA +GGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCAC +TCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGC +CTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGA +GACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG +CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTG +AACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCG +ACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGC +ACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCC +AACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGC +GCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCG +GAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACT +CCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCC +GAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAAC +CCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA +GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGA +GCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAG +GCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGAT +CACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTA +AAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGG +CTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGC +CACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTG +GCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAG +GAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAAT +TAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGA +ATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAG +CCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTA +ATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCA +GCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGG +TGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCC +GGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGA +GCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTT +GGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACAT +GGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTG +TAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGT +TGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTC +TCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGC +GGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGT +CTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTAC +TCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGA +GATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGG +GCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCT +GAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT +ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAG +GCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTG +CACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCA +CGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTT +CGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCC +GGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGC +TTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGG +GCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCC +AGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTG +GCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCG +CGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAG +GCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAG +ACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAG +GCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGA +AACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATC +CCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAG +TGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAA +AAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCG +GATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTA +CTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGG +AGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCG +CGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCG +GTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGT +CAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAA +AATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGG +AGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTC +CAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCT +GTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA +CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCG +TGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAA +CCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGAC +AGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCAC +TTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAA +CATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGC +CTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGA +GGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCC +GTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGA +GGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCC +CGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGC +TACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGC +CGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGC +CGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCA +CCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAA +AATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCT +GAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCA +CTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGC +TCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGA +GTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTA +GCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAAT +CGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCC +TGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAAT +CCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGC +CTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTG +GCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGG +GAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGC +GAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG +GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGG +TGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTA +ATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTG +CAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTC +AAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGG +GCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCT +CTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTC +GGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGA +TCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGC +GCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGA +GGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATAC +AAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGC +AGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCA +CTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACG +CCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCG +AGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGG +GCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTT +GAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGC +GACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAG +CACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGC +CAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCG +CGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC +GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGAC +TCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGC +CGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAA +CCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCC +AGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTG +AGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA +GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGA +TCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACT +AAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAG +GCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCG +CCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGT +GGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCA +GGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAA +TTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAG +AATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCA +GCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGT +AATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACC +AGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTG +GTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACC +CGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAG +AGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTT +TGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACA +TGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCT +GTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGG +TTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGT +CTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGG +CGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCG +TCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTA +CTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCG +AGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCG +GGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC +TGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAA +TACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGA +GGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACT +GCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTC +ACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGT +TCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGC +CGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCG +CTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTG +GGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCC +CAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCT +GGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGC +GCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGA +GGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGA +GACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGA +GGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTG +AAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAAT +CCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCA +GTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAA +AAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGC +GGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCT +ACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGG +GAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATC +GCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGC +GGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG +TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAA +AAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAG +GAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACT +CCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCC +TGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAG +ACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGC +GTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGA +ACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGA +CAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCA +CTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCA +ACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCG +CCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGG +AGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTC +CGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCG +AGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACC +CCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAG +CTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAG +CCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGG +CCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATC +ACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAA +AAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGC +TGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCC +ACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGG +CTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGG +AGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATT +AGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAA +TCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGC +CTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAA +TCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAG +CCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGT +GGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCG +GGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAG +CGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTG +GGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATG +GTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGT +AATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTT +GCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCT +CAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCG +GGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTC +TCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACT +CGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAG +ATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGG +CGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTG +AGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATA +CAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGG +CAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGC +ACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCAC +GCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTC +GAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCG +GGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCT +TGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGG +CGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCA +GCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGG +CCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGC +GCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGG +CGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGA +CTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGG +CCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAA +ACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCC +CAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGT +GAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAA +AGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGG +ATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTAC +TAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGA +GGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGC +GCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGG +TGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTC +AGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAA +ATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGA +GAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC +AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTG +TAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGAC +CAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGT +GGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAAC +CCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACA +GAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACT +TTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAAC +ATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCC +TGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAG +GTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCG +TCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAG +GCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCC +GTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCT +ACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCC +GAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCC +GGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCAC +CTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAA +ATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTG +AGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCAC +TGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCT +CACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAG +TTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAG +CCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATC +GCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCT +GGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATC +CCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCC +TGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGG +CGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG +AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCG +AGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGG +AGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGT +GAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAA +TCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGC +AGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCA +AAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGG +CGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTC +TACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCG +GGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGAT +CGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCG +CGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAG +GTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACA +AAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCA +GGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCAC +TCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGC +CTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGA +GACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG +CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTG +AACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCG +ACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGC +ACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCC +AACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGC +GCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCG +GAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACT +CCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCC +GAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAAC +CCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA +GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGA +GCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAG +GCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGAT +CACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTA +AAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGG +CTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGC +CACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTG +GCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAG +GAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAAT +TAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGA +ATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAG +CCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTA +ATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCA +GCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGG +TGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCC +GGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGA +GCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTT +GGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACAT +GGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTG +TAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGT +TGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTC +TCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGC +GGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGT +CTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTAC +TCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGA +GATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGG +GCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCT +GAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT +ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAG +GCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTG +CACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCA +CGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTT +CGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCC +GGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGC +TTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGG +GCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCC +AGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTG +GCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCG +CGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAG +GCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAG +ACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAG +GCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGA +AACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATC +CCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAG +TGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAA +AAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCG +GATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTA +CTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGG +AGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCG +CGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCG +GTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGT +CAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAA +AATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGG +AGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTC +CAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCT +GTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA +CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCG +TGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAA +CCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGAC +AGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCAC +TTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAA +CATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGC +CTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGA +GGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCC +GTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGA +GGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCC +CGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGC +TACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGC +CGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGC +CGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCA +CCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAA +AATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCT +GAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCA +CTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGC +TCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGA +GTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTA +GCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAAT +CGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCC +TGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAAT +CCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGC +CTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTG +GCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGG +GAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGC +GAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG +GAGGCCGAGGCGGGCGGATC +>TWO IUB ambiguity codes +cttBtatcatatgctaKggNcataaaSatgtaaaDcDRtBggDtctttataattcBgtcg +tactDtDagcctatttSVHtHttKtgtHMaSattgWaHKHttttagacatWatgtRgaaa +NtactMcSMtYtcMgRtacttctWBacgaaatatagScDtttgaagacacatagtVgYgt +cattHWtMMWcStgttaggKtSgaYaaccWStcgBttgcgaMttBYatcWtgacaYcaga +gtaBDtRacttttcWatMttDBcatWtatcttactaBgaYtcttgttttttttYaaScYa +HgtgttNtSatcMtcVaaaStccRcctDaataataStcYtRDSaMtDttgttSagtRRca +tttHatSttMtWgtcgtatSSagactYaaattcaMtWatttaSgYttaRgKaRtccactt +tattRggaMcDaWaWagttttgacatgttctacaaaRaatataataaMttcgDacgaSSt +acaStYRctVaNMtMgtaggcKatcttttattaaaaagVWaHKYagtttttatttaacct +tacgtVtcVaattVMBcttaMtttaStgacttagattWWacVtgWYagWVRctDattBYt +gtttaagaagattattgacVatMaacattVctgtBSgaVtgWWggaKHaatKWcBScSWa +accRVacacaaactaccScattRatatKVtactatatttHttaagtttSKtRtacaaagt +RDttcaaaaWgcacatWaDgtDKacgaacaattacaRNWaatHtttStgttattaaMtgt +tgDcgtMgcatBtgcttcgcgaDWgagctgcgaggggVtaaScNatttacttaatgacag +cccccacatYScaMgtaggtYaNgttctgaMaacNaMRaacaaacaKctacatagYWctg +ttWaaataaaataRattagHacacaagcgKatacBttRttaagtatttccgatctHSaat +actcNttMaagtattMtgRtgaMgcataatHcMtaBSaRattagttgatHtMttaaKagg +YtaaBataSaVatactWtataVWgKgttaaaacagtgcgRatatacatVtHRtVYataSa +KtWaStVcNKHKttactatccctcatgWHatWaRcttactaggatctataDtDHBttata +aaaHgtacVtagaYttYaKcctattcttcttaataNDaaggaaaDYgcggctaaWSctBa +aNtgctggMBaKctaMVKagBaactaWaDaMaccYVtNtaHtVWtKgRtcaaNtYaNacg +gtttNattgVtttctgtBaWgtaattcaagtcaVWtactNggattctttaYtaaagccgc +tcttagHVggaYtgtNcDaVagctctctKgacgtatagYcctRYHDtgBattDaaDgccK +tcHaaStttMcctagtattgcRgWBaVatHaaaataYtgtttagMDMRtaataaggatMt +ttctWgtNtgtgaaaaMaatatRtttMtDgHHtgtcattttcWattRSHcVagaagtacg +ggtaKVattKYagactNaatgtttgKMMgYNtcccgSKttctaStatatNVataYHgtNa +BKRgNacaactgatttcctttaNcgatttctctataScaHtataRagtcRVttacDSDtt +aRtSatacHgtSKacYagttMHtWataggatgactNtatSaNctataVtttRNKtgRacc +tttYtatgttactttttcctttaaacatacaHactMacacggtWataMtBVacRaSaatc +cgtaBVttccagccBcttaRKtgtgcctttttRtgtcagcRttKtaaacKtaaatctcac +aattgcaNtSBaaccgggttattaaBcKatDagttactcttcattVtttHaaggctKKga +tacatcBggScagtVcacattttgaHaDSgHatRMaHWggtatatRgccDttcgtatcga +aacaHtaagttaRatgaVacttagattVKtaaYttaaatcaNatccRttRRaMScNaaaD +gttVHWgtcHaaHgacVaWtgttScactaagSgttatcttagggDtaccagWattWtRtg +ttHWHacgattBtgVcaYatcggttgagKcWtKKcaVtgaYgWctgYggVctgtHgaNcV +taBtWaaYatcDRaaRtSctgaHaYRttagatMatgcatttNattaDttaattgttctaa +ccctcccctagaWBtttHtBccttagaVaatMcBHagaVcWcagBVttcBtaYMccagat +gaaaaHctctaacgttagNWRtcggattNatcRaNHttcagtKttttgWatWttcSaNgg +gaWtactKKMaacatKatacNattgctWtatctaVgagctatgtRaHtYcWcttagccaa +tYttWttaWSSttaHcaaaaagVacVgtaVaRMgattaVcDactttcHHggHRtgNcctt +tYatcatKgctcctctatVcaaaaKaaaagtatatctgMtWtaaaacaStttMtcgactt +taSatcgDataaactaaacaagtaaVctaggaSccaatMVtaaSKNVattttgHccatca +cBVctgcaVatVttRtactgtVcaattHgtaaattaaattttYtatattaaRSgYtgBag +aHSBDgtagcacRHtYcBgtcacttacactaYcgctWtattgSHtSatcataaatataHt +cgtYaaMNgBaatttaRgaMaatatttBtttaaaHHKaatctgatWatYaacttMctctt +ttVctagctDaaagtaVaKaKRtaacBgtatccaaccactHHaagaagaaggaNaaatBW +attccgStaMSaMatBttgcatgRSacgttVVtaaDMtcSgVatWcaSatcttttVatag +ttactttacgatcaccNtaDVgSRcgVcgtgaacgaNtaNatatagtHtMgtHcMtagaa +attBgtataRaaaacaYKgtRccYtatgaagtaataKgtaaMttgaaRVatgcagaKStc +tHNaaatctBBtcttaYaBWHgtVtgacagcaRcataWctcaBcYacYgatDgtDHccta +aagacYRcaggattHaYgtKtaatgcVcaataMYacccatatcacgWDBtgaatcBaata +cKcttRaRtgatgaBDacggtaattaaYtataStgVHDtDctgactcaaatKtacaatgc +gYatBtRaDatHaactgtttatatDttttaaaKVccYcaaccNcBcgHaaVcattHctcg +attaaatBtatgcaaaaatYMctSactHatacgaWacattacMBgHttcgaatVaaaaca +BatatVtctgaaaaWtctRacgBMaatSgRgtgtcgactatcRtattaScctaStagKga +DcWgtYtDDWKRgRtHatRtggtcgaHgggcgtattaMgtcagccaBggWVcWctVaaat +tcgNaatcKWagcNaHtgaaaSaaagctcYctttRVtaaaatNtataaccKtaRgtttaM +tgtKaBtRtNaggaSattHatatWactcagtgtactaKctatttgRYYatKatgtccgtR +tttttatttaatatVgKtttgtatgtNtataRatWYNgtRtHggtaaKaYtKSDcatcKg +taaYatcSRctaVtSMWtVtRWHatttagataDtVggacagVcgKWagBgatBtaaagNc +aRtagcataBggactaacacRctKgttaatcctHgDgttKHHagttgttaatgHBtatHc +DaagtVaBaRccctVgtgDtacRHSctaagagcggWYaBtSaKtHBtaaactYacgNKBa +VYgtaacttagtVttcttaatgtBtatMtMtttaattaatBWccatRtttcatagVgMMt +agctStKctaMactacDNYgKYHgaWcgaHgagattacVgtttgtRaSttaWaVgataat +gtgtYtaStattattMtNgWtgttKaccaatagNYttattcgtatHcWtctaaaNVYKKt +tWtggcDtcgaagtNcagatacgcattaagaccWctgcagcttggNSgaNcHggatgtVt +catNtRaaBNcHVagagaaBtaaSggDaatWaatRccaVgggStctDaacataKttKatt +tggacYtattcSatcttagcaatgaVBMcttDattctYaaRgatgcattttNgVHtKcYR +aatRKctgtaaacRatVSagctgtWacBtKVatctgttttKcgtctaaDcaagtatcSat +aWVgcKKataWaYttcccSaatgaaaacccWgcRctWatNcWtBRttYaattataaNgac +acaatagtttVNtataNaYtaatRaVWKtBatKagtaatataDaNaaaaataMtaagaaS +tccBcaatNgaataWtHaNactgtcDtRcYaaVaaaaaDgtttRatctatgHtgttKtga +aNSgatactttcgagWaaatctKaaDaRttgtggKKagcDgataaattgSaacWaVtaNM +acKtcaDaaatttctRaaVcagNacaScRBatatctRatcctaNatWgRtcDcSaWSgtt +RtKaRtMtKaatgttBHcYaaBtgatSgaSWaScMgatNtctcctatttctYtatMatMt +RRtSaattaMtagaaaaStcgVgRttSVaScagtgDtttatcatcatacRcatatDctta +tcatVRtttataaHtattcYtcaaaatactttgVctagtaaYttagatagtSYacKaaac +gaaKtaaatagataatSatatgaaatSgKtaatVtttatcctgKHaatHattagaaccgt +YaaHactRcggSBNgtgctaaBagBttgtRttaaattYtVRaaaattgtaatVatttctc +ttcatgBcVgtgKgaHaaatattYatagWacNctgaaMcgaattStagWaSgtaaKagtt +ttaagaDgatKcctgtaHtcatggKttVDatcaaggtYcgccagNgtgcVttttagagat +gctaccacggggtNttttaSHaNtatNcctcatSaaVgtactgBHtagcaYggYVKNgta +KBcRttgaWatgaatVtagtcgattYgatgtaatttacDacSctgctaaaStttaWMagD +aaatcaVYctccgggcgaVtaaWtStaKMgDtttcaaMtVgBaatccagNaaatcYRMBg +gttWtaaScKttMWtYataRaDBMaDataatHBcacDaaKDactaMgagttDattaHatH +taYatDtattDcRNStgaatattSDttggtattaaNSYacttcDMgYgBatWtaMagact +VWttctttgYMaYaacRgHWaattgRtaagcattctMKVStatactacHVtatgatcBtV +NataaBttYtSttacKgggWgYDtgaVtYgatDaacattYgatggtRDaVDttNactaSa +MtgNttaacaaSaBStcDctaccacagacgcaHatMataWKYtaYattMcaMtgSttDag +cHacgatcaHttYaKHggagttccgatYcaatgatRaVRcaagatcagtatggScctata +ttaNtagcgacgtgKaaWaactSgagtMYtcttccaKtStaacggMtaagNttattatcg +tctaRcactctctDtaacWYtgaYaSaagaWtNtatttRacatgNaatgttattgWDDcN +aHcctgaaHacSgaataaRaataMHttatMtgaSDSKatatHHaNtacagtccaYatWtc +actaactatKDacSaStcggataHgYatagKtaatKagStaNgtatactatggRHacttg +tattatgtDVagDVaRctacMYattDgtttYgtctatggtKaRSttRccRtaaccttaga +gRatagSaaMaacgcaNtatgaaatcaRaagataatagatactcHaaYKBctccaagaRa +BaStNagataggcgaatgaMtagaatgtcaKttaaatgtaWcaBttaatRcggtgNcaca +aKtttScRtWtgcatagtttWYaagBttDKgcctttatMggNttattBtctagVtacata +aaYttacacaaRttcYtWttgHcaYYtaMgBaBatctNgcDtNttacgacDcgataaSat +YaSttWtcctatKaatgcagHaVaacgctgcatDtgttaSataaaaYSNttatagtaNYt +aDaaaNtggggacttaBggcHgcgtNtaaMcctggtVtaKcgNacNtatVaSWctWtgaW +cggNaBagctctgaYataMgaagatBSttctatacttgtgtKtaattttRagtDtacata +tatatgatNHVgBMtKtaKaNttDHaagatactHaccHtcatttaaagttVaMcNgHata +tKtaNtgYMccttatcaaNagctggacStttcNtggcaVtattactHaSttatgNMVatt +MMDtMactattattgWMSgtHBttStStgatatRaDaagattttctatMtaaaaaggtac +taaVttaSacNaatactgMttgacHaHRttgMacaaaatagttaatatWKRgacDgaRta +tatttattatcYttaWtgtBRtWatgHaaattHataagtVaDtWaVaWtgStcgtMSgaS +RgMKtaaataVacataatgtaSaatttagtcgaaHtaKaatgcacatcggRaggSKctDc +agtcSttcccStYtccRtctctYtcaaKcgagtaMttttcRaYDttgttatctaatcata +NctctgctatcaMatactataggDaHaaSttMtaDtcNatataattctMcStaaBYtaNa +gatgtaatHagagSttgWHVcttatKaYgDctcttggtgttMcRaVgSgggtagacaata +aDtaattSaDaNaHaBctattgNtaccaaRgaVtKNtaaYggHtaKKgHcatctWtctDt +ttctttggSDtNtaStagttataaacaattgcaBaBWggHgcaaaBtYgctaatgaaatW +cDcttHtcMtWWattBHatcatcaaatctKMagtDNatttWaBtHaaaNgMttaaStagt +tctctaatDtcRVaYttgttMtRtgtcaSaaYVgSWDRtaatagctcagDgcWWaaaBaa +RaBctgVgggNgDWStNaNBKcBctaaKtttDcttBaaggBttgaccatgaaaNgttttt +tttatctatgttataccaaDRaaSagtaVtDtcaWatBtacattaWacttaSgtattggD +gKaaatScaattacgWcagKHaaccaYcRcaRttaDttRtttHgaHVggcttBaRgtccc +tDatKaVtKtcRgYtaKttacgtatBtStaagcaattaagaRgBagSaattccSWYttta +ttVaataNctgHgttaaNBgcVYgtRtcccagWNaaaacaDNaBcaaaaRVtcWMgBagM +tttattacgDacttBtactatcattggaaatVccggttRttcatagttVYcatYaSHaHc +ttaaagcNWaHataaaRWtctVtRYtagHtaaaYMataHYtNBctNtKaatattStgaMc +BtRgctaKtgcScSttDgYatcVtggaaKtaagatWccHccgKYctaNNctacaWctttt +gcRtgtVcgaKttcMRHgctaHtVaataaDtatgKDcttatBtDttggNtacttttMtga +acRattaaNagaactcaaaBBVtcDtcgaStaDctgaaaSgttMaDtcgttcaccaaaag +gWtcKcgSMtcDtatgtttStaaBtatagDcatYatWtaaaBacaKgcaDatgRggaaYc +taRtccagattDaWtttggacBaVcHtHtaacDacYgtaatataMagaatgHMatcttat +acgtatttttatattacHactgttataMgStYaattYaccaattgagtcaaattaYtgta +tcatgMcaDcgggtcttDtKgcatgWRtataatatRacacNRBttcHtBgcRttgtgcgt +catacMtttBctatctBaatcattMttMYgattaaVYatgDaatVagtattDacaacDMa +tcMtHcccataagatgBggaccattVWtRtSacatgctcaaggggYtttDtaaNgNtaaB +atggaatgtctRtaBgBtcNYatatNRtagaacMgagSaSDDSaDcctRagtVWSHtVSR +ggaacaBVaccgtttaStagaacaMtactccagtttVctaaRaaHttNcttagcaattta +ttaatRtaaaatctaacDaBttggSagagctacHtaaRWgattcaaBtctRtSHaNtgta +cattVcaHaNaagtataccacaWtaRtaaVKgMYaWgttaKggKMtKcgWatcaDatYtK +SttgtacgaccNctSaattcDcatcttcaaaDKttacHtggttHggRRaRcaWacaMtBW +VHSHgaaMcKattgtaRWttScNattBBatYtaNRgcggaagacHSaattRtttcYgacc +BRccMacccKgatgaacttcgDgHcaaaaaRtatatDtatYVtttttHgSHaSaatagct +NYtaHYaVYttattNtttgaaaYtaKttWtctaNtgagaaaNctNDctaaHgttagDcRt +tatagccBaacgcaRBtRctRtggtaMYYttWtgataatcgaataattattataVaaaaa +ttacNRVYcaaMacNatRttcKatMctgaagactaattataaYgcKcaSYaatMNctcaa +cgtgatttttBacNtgatDccaattattKWWcattttatatatgatBcDtaaaagttgaa +VtaHtaHHtBtataRBgtgDtaataMttRtDgDcttattNtggtctatctaaBcatctaR +atgNacWtaatgaagtcMNaacNgHttatactaWgcNtaStaRgttaaHacccgaYStac +aaaatWggaYaWgaattattcMaactcBKaaaRVNcaNRDcYcgaBctKaacaaaaaSgc +tccYBBHYaVagaatagaaaacagYtctVccaMtcgtttVatcaatttDRtgWctagtac +RttMctgtDctttcKtWttttataaatgVttgBKtgtKWDaWagMtaaagaaattDVtag +gttacatcatttatgtcgMHaVcttaBtVRtcgtaYgBRHatttHgaBcKaYWaatcNSc +tagtaaaaatttacaatcactSWacgtaatgKttWattagttttNaggtctcaagtcact +attcttctaagKggaataMgtttcataagataaaaatagattatDgcBVHWgaBKttDgc +atRHaagcaYcRaattattatgtMatatattgHDtcaDtcaaaHctStattaatHaccga +cNattgatatattttgtgtDtRatagSacaMtcRtcattcccgacacSattgttKaWatt +NHcaacttccgtttSRtgtctgDcgctcaaMagVtBctBMcMcWtgtaacgactctcttR +ggRKSttgYtYatDccagttDgaKccacgVatWcataVaaagaataMgtgataaKYaaat +cHDaacgataYctRtcYatcgcaMgtNttaBttttgatttaRtStgcaacaaaataccVg +aaDgtVgDcStctatatttattaaaaRKDatagaaagaKaaYYcaYSgKStctccSttac +agtcNactttDVttagaaagMHttRaNcSaRaMgBttattggtttaRMggatggcKDgWR +tNaataataWKKacttcKWaaagNaBttaBatMHtccattaacttccccYtcBcYRtaga +ttaagctaaYBDttaNtgaaaccHcaRMtKtaaHMcNBttaNaNcVcgVttWNtDaBatg +ataaVtcWKcttRggWatcattgaRagHgaattNtatttctctattaattaatgaDaaMa +tacgttgggcHaYVaaNaDDttHtcaaHtcVVDgBVagcMacgtgttaaBRNtatRtcag +taagaggtttaagacaVaaggttaWatctccgtVtaDtcDatttccVatgtacNtttccg +tHttatKgScBatgtVgHtYcWagcaKtaMYaaHgtaattaSaHcgcagtWNaatNccNN +YcacgVaagaRacttctcattcccRtgtgtaattagcSttaaStWaMtctNNcSMacatt +ataaactaDgtatWgtagtttaagaaaattgtagtNagtcaataaatttgatMMYactaa +tatcggBWDtVcYttcDHtVttatacYaRgaMaacaStaatcRttttVtagaDtcacWat +ttWtgaaaagaaagNRacDtttStVatBaDNtaactatatcBSMcccaSttccggaMatg +attaaWatKMaBaBatttgataNctgttKtVaagtcagScgaaaDggaWgtgttttKtWt +atttHaatgtagttcactaaKMagttSYBtKtaYgaactcagagRtatagtVtatcaaaW +YagcgNtaDagtacNSaaYDgatBgtcgataacYDtaaactacagWDcYKaagtttatta +gcatcgagttKcatDaattgattatDtcagRtWSKtcgNtMaaaaacaMttKcaWcaaSV +MaaaccagMVtaMaDtMaHaBgaacataBBVtaatVYaNSWcSgNtDNaaKacacBttta +tKtgtttcaaHaMctcagtaacgtcgYtactDcgcctaNgagagcYgatattttaaattt +ccattttacatttDaaRctattttWctttacgtDatYtttcagacgcaaVttagtaaKaa +aRtgVtccataBggacttatttgtttaWNtgttVWtaWNVDaattgtatttBaagcBtaa +BttaaVatcHcaVgacattccNggtcgacKttaaaRtagRtctWagaYggtgMtataatM +tgaaRttattttgWcttNtDRRgMDKacagaaaaggaaaRStcccagtYccVattaNaaK +StNWtgacaVtagaagcttSaaDtcacaacgDYacWDYtgtttKatcVtgcMaDaSKStV +cgtagaaWaKaagtttcHaHgMgMtctataagBtKaaaKKcactggagRRttaagaBaaN +atVVcgRcKSttDaactagtSttSattgttgaaRYatggttVttaataaHttccaagDtg +atNWtaagHtgcYtaactRgcaatgMgtgtRaatRaNaacHKtagactactggaatttcg +ccataacgMctRgatgttaccctaHgtgWaYcactcacYaattcttaBtgacttaaacct +gYgaWatgBttcttVttcgttWttMcNYgtaaaatctYgMgaaattacNgaHgaacDVVM +tttggtHtctaaRgtacagacgHtVtaBMNBgattagcttaRcttacaHcRctgttcaaD +BggttKaacatgKtttYataVaNattccgMcgcgtagtRaVVaattaKaatggttRgaMc +agtatcWBttNtHagctaatctagaaNaaacaYBctatcgcVctBtgcaaagDgttVtga +HtactSNYtaaNccatgtgDacgaVtDcgKaRtacDcttgctaagggcagMDagggtBWR +tttSgccttttttaacgtcHctaVtVDtagatcaNMaVtcVacatHctDWNaataRgcgt +aVHaggtaaaaSgtttMtattDgBtctgatSgtRagagYtctSaKWaataMgattRKtaa +catttYcgtaacacattRWtBtcggtaaatMtaaacBatttctKagtcDtttgcBtKYYB +aKttctVttgttaDtgattttcttccacttgSaaacggaaaNDaattcYNNaWcgaaYat +tttMgcBtcatRtgtaaagatgaWtgaccaYBHgaatagataVVtHtttVgYBtMctaMt +cctgaDcYttgtccaaaRNtacagcMctKaaaggatttacatgtttaaWSaYaKttBtag +DacactagctMtttNaKtctttcNcSattNacttggaacaatDagtattRtgSHaataat +gccVgacccgatactatccctgtRctttgagaSgatcatatcgDcagWaaHSgctYYWta +tHttggttctttatVattatcgactaagtgtagcatVgtgHMtttgtttcgttaKattcM +atttgtttWcaaStNatgtHcaaaDtaagBaKBtRgaBgDtSagtatMtaacYaatYtVc +KatgtgcaacVaaaatactKcRgtaYtgtNgBBNcKtcttaccttKgaRaYcaNKtactt +tgagSBtgtRagaNgcaaaNcacagtVtttHWatgttaNatBgtttaatNgVtctgaata +tcaRtattcttttttttRaaKcRStctcggDgKagattaMaaaKtcaHacttaataataK +taRgDtKVBttttcgtKaggHHcatgttagHggttNctcgtatKKagVagRaaaggaaBt +NatttVKcRttaHctaHtcaaatgtaggHccaBataNaNaggttgcWaatctgatYcaaa +HaatWtaVgaaBttagtaagaKKtaaaKtRHatMaDBtBctagcatWtatttgWttVaaa +ScMNattRactttgtYtttaaaagtaagtMtaMaSttMBtatgaBtttaKtgaatgagYg +tNNacMtcNRacMMHcttWtgtRtctttaacaacattattcYaMagBaacYttMatcttK +cRMtgMNccattaRttNatHaHNaSaaHMacacaVaatacaKaSttHatattMtVatWga +ttttttaYctttKttHgScWaacgHtttcaVaaMgaacagNatcgttaacaaaaagtaca +HBNaattgttKtcttVttaaBtctgctacgBgcWtttcaggacacatMgacatcccagcg +gMgaVKaBattgacttaatgacacacaaaaaatRKaaBctacgtRaDcgtagcVBaacDS +BHaaaaSacatatacagacRNatcttNaaVtaaaataHattagtaaaaSWccgtatWatg +gDttaactattgcccatcttHaSgYataBttBaactattBtcHtgatcaataSttaBtat +KSHYttWggtcYtttBttaataccRgVatStaHaKagaatNtagRMNgtcttYaaSaact +cagDSgagaaYtMttDtMRVgWKWtgMaKtKaDttttgactatacataatcNtatNaHat +tVagacgYgatatatttttgtStWaaatctWaMgagaRttRatacgStgattcttaagaD +taWccaaatRcagcagaaNKagtaaDggcgccBtYtagSBMtactaaataMataBSacRM +gDgattMMgtcHtcaYDtRaDaacggttDaggcMtttatgttaNctaattaVacgaaMMt +aatDccSgtattgaRtWWaccaccgagtactMcgVNgctDctaMScatagcgtcaactat +acRacgHRttgctatttaatgaattataYKttgtaagWgtYttgcHgMtaMattWaWVta +RgcttgYgttBHtYataSccStBtgtagMgtDtggcVaaSBaatagDttgBgtctttctc +attttaNagtHKtaMWcYactVcgcgtatMVtttRacVagDaatcttgctBBcRDgcaac +KttgatSKtYtagBMagaRtcgBattHcBWcaactgatttaatttWDccatttatcgagS +KaWttataHactaHMttaatHtggaHtHagaatgtKtaaRactgtttMatacgatcaagD +gatKaDctataMggtHDtggHacctttRtatcttYattttgacttgaaSaataaatYcgB +aaaaccgNatVBttMacHaKaataagtatKgtcaagactcttaHttcggaattgttDtct +aaccHttttWaaatgaaatataaaWattccYDtKtaaaacggtgaggWVtctattagtga +ctattaagtMgtttaagcatttgSgaaatatccHaaggMaaaattttcWtatKctagDtY +tMcctagagHcactttactatacaaacattaacttaHatcVMYattYgVgtMttaaRtga +aataaDatcaHgtHHatKcDYaatcttMtNcgatYatgSaMaNtcttKcWataScKggta +tcttacgcttWaaagNatgMgHtctttNtaacVtgttcMaaRatccggggactcMtttaY +MtcWRgNctgNccKatcttgYDcMgattNYaRagatHaaHgKctcataRDttacatBatc +cattgDWttatttaWgtcggagaaaaatacaatacSNtgggtttccttacSMaagBatta +caMaNcactMttatgaRBacYcYtcaaaWtagctSaacttWgDMHgaggatgBVgcHaDt +ggaactttggtcNatNgtaKaBcccaNtaagttBaacagtatacDYttcctNgWgcgSMc +acatStctHatgRcNcgtacacaatRttMggaNKKggataaaSaYcMVcMgtaMaHtgat +tYMatYcggtcttcctHtcDccgtgRatcattgcgccgatatMaaYaataaYSggatagc +gcBtNtaaaScaKgttBgagVagttaKagagtatVaactaSacWactSaKatWccaKaaa +atBKgaaKtDMattttgtaaatcRctMatcaaMagMttDgVatggMaaWgttcgaWatga +aatttgRtYtattaWHKcRgctacatKttctaccaaHttRatctaYattaaWatVNccat +NgagtcKttKataStRaatatattcctRWatDctVagttYDgSBaatYgttttgtVaatt +taatagcagMatRaacttBctattgtMagagattaaactaMatVtHtaaatctRgaaaaa +aaatttWacaacaYccYDSaattMatgaccKtaBKWBattgtcaagcHKaagttMMtaat +ttcKcMagNaaKagattggMagaggtaatttYacatcWaaDgatMgKHacMacgcVaaca +DtaDatatYggttBcgtatgWgaSatttgtagaHYRVacaRtctHaaRtatgaactaata +tctSSBgggaaHMWtcaagatKgagtDaSatagttgattVRatNtctMtcSaagaSHaat +aNataataRaaRgattctttaataaagWaRHcYgcatgtWRcttgaaggaMcaataBRaa +ccagStaaacNtttcaatataYtaatatgHaDgcStcWttaacctaRgtYaRtataKtgM +ttttatgactaaaatttacYatcccRWtttHRtattaaatgtttatatttgttYaatMca +RcSVaaDatcgtaYMcatgtagacatgaaattgRtcaaYaaYtRBatKacttataccaNa +aattVaBtctggacaagKaaYaaatatWtMtatcYaaVNtcgHaactBaagKcHgtctac +aatWtaDtSgtaHcataHtactgataNctRgttMtDcDttatHtcgtacatcccaggStt +aBgtcacacWtccNMcNatMVaVgtccDYStatMaccDatggYaRKaaagataRatttHK +tSaaatDgataaacttaHgttgVBtcttVttHgDacgaKatgtatatNYataactctSat +atatattgcHRRYttStggaactHgttttYtttaWtatMcttttctatctDtagVHYgMR +BgtHttcctaatYRttKtaagatggaVRataKDctaMtKBNtMtHNtWtttYcVtattMc +gRaacMcctNSctcatttaaagDcaHtYccSgatgcaatYaaaaDcttcgtaWtaattct +cgttttScttggtaatctttYgtctaactKataHacctMctcttacHtKataacacagcN +RatgKatttttSaaatRYcgDttaMRcgaaattactMtgcgtaagcgttatBtttttaat +taagtNacatHgttcRgacKcBBtVgatKttcgaBaatactDRgtRtgaNacWtcacYtt +aaKcgttctHaKttaNaMgWgWaggtctRgaKgWttSttBtDcNtgtttacaaatYcDRt +gVtgcctattcNtctaaaDMNttttNtggctgagaVctDaacVtWccaagtaacacaNct +gaScattccDHcVBatcgatgtMtaatBgHaatDctMYgagaatgYWKcctaatNaStHa +aaKccgHgcgtYaaYtattgtStgtgcaaRtattaKatattagaWVtcaMtBagttatta +gNaWHcVgcaattttDcMtgtaRHVYtHtctgtaaaaHVtMKacatcgNaatttMatatg +ttgttactagWYtaRacgataKagYNKcattataNaRtgaacKaYgcaaYYacaNccHat +MatDcNgtHttRaWttagaaDcaaaaaatagggtKDtStaDaRtaVtHWKNtgtattVct +SVgRgataDaRaWataBgaagaaKtaataaYgDcaStaNgtaDaaggtattHaRaWMYaY +aWtggttHYgagVtgtgcttttcaaDKcagVcgttagacNaaWtagtaataDttctggtt +VcatcataaagtgKaaaNaMtaBBaattaatWaattgctHaVKaSgDaaVKaHtatatat +HatcatSBagNgHtatcHYMHgttDgtaHtBttWatcgtttaRaattgStKgSKNWKatc +agDtctcagatttctRtYtBatBgHHtKaWtgYBgacVVWaKtacKcDttKMaKaVcggt +gttataagaataaHaatattagtataatMHgttYgaRttagtaRtcaaVatacggtcMcg +agtaaRttacWgactKRYataaaagSattYaWgagatYagKagatgSaagKgttaatMgg +tataatgttWYttatgagaaacctNVataatHcccKtDctcctaatactggctHggaSag +gRtKHaWaattcgSatMatttagaggcYtctaMcgctcataSatatgRagacNaaDagga +VBagaYttKtacNaKgtSYtagttggaWcatcWttaatctatgaVtcgtgtMtatcaYcg +tRccaaYgDctgcMgtgtWgacWtgataacacgcgctBtgttaKtYDtatDcatcagKaV +MctaatcttgVcaaRgcRMtDcgattaHttcaNatgaatMtactacVgtRgatggaWttt +actaaKatgagSaaKggtaNtactVaYtaaKRagaacccacaMtaaMtKtatBcttgtaa +WBtMctaataaVcDaaYtcRHBtcgttNtaaHatttBNgRStVDattBatVtaagttaYa +tVattaagaBcacggtSgtVtatttaRattgatgtaHDKgcaatattKtggcctatgaWD +KRYcggattgRctatNgatacaatMNttctgtcRBYRaaaHctNYattcHtaWcaattct +BtMKtVgYataatMgYtcagcttMDataVtggRtKtgaatgccNcRttcaMtRgattaac +attRcagcctHtWMtgtDRagaKaBtgDttYaaaaKatKgatctVaaYaacWcgcatagB +VtaNtRtYRaggBaaBtgKgttacataagagcatgtRattccacttaccatRaaatgWgD +aMHaYVgVtaSctatcgKaatatattaDgacccYagtgtaYNaaatKcagtBRgagtcca +tgKgaaaccBgaagBtgSttWtacgatWHaYatcgatttRaaNRgcaNaKVacaNtDgat +tgHVaatcDaagcgtatgcNttaDataatcSataaKcaataaHWataBtttatBtcaKtK +tatagttaDgSaYctacaRatNtaWctSaatatttYaKaKtaccWtatcRagacttaYtt +VcKgSDcgagaagatccHtaattctSttatggtKYgtMaHagVaBRatttctgtRgtcta +tgggtaHKgtHacHtSYacgtacacHatacKaaBaVaccaDtatcSaataaHaagagaat +ScagactataaRttagcaaVcaHataKgDacatWccccaagcaBgagWatctaYttgaaa +tctVNcYtttWagHcgcgcDcVaaatgttKcHtNtcaatagtgtNRaactttttcaatgg +WgBcgDtgVgtttctacMtaaataaaRggaaacWaHttaRtNtgctaaRRtVBctYtVta +tDcattDtgaccYatagatYRKatNYKttNgcctagtaWtgaactaMVaacctgaStttc +tgaKVtaaVaRKDttVtVctaDNtataaaDtccccaagtWtcgatcactDgYaBcatcct +MtVtacDaaBtYtMaKNatNtcaNacgDatYcatcgcaRatWBgaacWttKttagYtaat +tcggttgSWttttDWctttacYtatatWtcatDtMgtBttgRtVDggttaacYtacgtac +atgaattgaaWcttMStaDgtatattgaDtcRBcattSgaaVBRgagccaaKtttcDgcg +aSMtatgWattaKttWtgDBMaggBBttBaatWttRtgcNtHcgttttHtKtcWtagHSt +aacagttgatatBtaWSaWggtaataaMttaKacDaatactcBttcaatatHttcBaaSa +aatYggtaRtatNtHcaatcaHtagVtgtattataNggaMtcttHtNagctaaaggtaga +YctMattNaMVNtcKtactBKcaHHcBttaSagaKacataYgctaKaYgttYcgacWVtt +WtSagcaacatcccHaccKtcttaacgaKttcacKtNtacHtatatRtaaatacactaBt +ttgaHaRttggttWtatYagcatYDatcggagagcWBataagRtacctataRKgtBgatg +aDatataSttagBaHtaatNtaDWcWtgtaattacagKttcNtMagtattaNgtctcgtc +ctcttBaHaKcKccgtRcaaYagSattaagtKataDatatatagtcDtaacaWHcaKttD +gaaRcgtgYttgtcatatNtatttttatggccHtgDtYHtWgttatYaacaattcaWtat +NgctcaaaSttRgctaatcaaatNatcgtttaBtNNVtgttataagcaaagattBacgtD +atttNatttaaaDcBgtaSKgacgtagataatttcHMVNttgttBtDtgtaWKaaRMcKM +tHtaVtagataWctccNNaSWtVaHatctcMgggDgtNHtDaDttatatVWttgttattt +aacctttcacaaggaSaDcggttttttatatVtctgVtaacaStDVaKactaMtttaSNa +gtgaaattaNacttSKctattcctctaSagKcaVttaagNaVcttaVaaRNaHaaHttat +gtHttgtgatMccaggtaDcgaccgtWgtWMtttaHcRtattgScctatttKtaaccaag +tYagaHgtWcHaatgccKNRtttagtMYSgaDatctgtgaWDtccMNcgHgcaaacNDaa +aRaStDWtcaaaaHKtaNBctagBtgtattaactaattttVctagaatggcWSatMaccc +ttHttaSgSgtgMRcatRVKtatctgaaaccDNatYgaaVHNgatMgHRtacttaaaRta +tStRtDtatDttYatattHggaBcttHgcgattgaKcKtttcRataMtcgaVttWacatN +catacctRataDDatVaWNcggttgaHtgtMacVtttaBHtgagVttMaataattatgtt +cttagtttgtgcDtSatttgBtcaacHattaaBagVWcgcaSYttMgcttacYKtVtatc +aYaKctgBatgcgggcYcaaaaacgNtctagKBtattatctttKtaVttatagtaYtRag +NtaYataaVtgaatatcHgcaaRataHtacacatgtaNtgtcgYatWMatttgaactacR +ctaWtWtatacaatctBatatgYtaagtatgtgtatSttactVatcttYtaBcKgRaSgg +RaaaaatgcagtaaaWgtaRgcgataatcBaataccgtatttttccatcNHtatWYgatH +SaaaDHttgctgtccHtggggcctaataatttttctatattYWtcattBtgBRcVttaVM +RSgctaatMagtYtttaaaaatBRtcBttcaaVtaacagctccSaaSttKNtHtKYcagc +agaaaccccRtttttaaDcDtaStatccaagcgctHtatcttaDRYgatDHtWcaaaBcW +gKWHttHataagHacgMNKttMKHccaYcatMVaacgttaKgYcaVaaBtacgcaacttt +MctaaHaatgtBatgagaSatgtatgSRgHgWaVWgataaatatttccKagVgataattW +aHNcYggaaatgctHtKtaDtctaaagtMaatVDVactWtSaaWaaMtaHtaSKtcBRaN +cttStggtBttacNagcatagRgtKtgcgaacaacBcgKaatgataagatgaaaattgta +ctgcgggtccHHWHaaNacaBttNKtKtcaaBatatgctaHNgtKcDWgtttatNgVDHg +accaacWctKaaggHttgaRgYaatHcaBacaatgagcaaattactgtaVaaYaDtagat +tgagNKggtggtgKtWKaatacagDRtatRaMRtgattDggtcaaYRtatttNtagaDtc +acaaSDctDtataatcgtactaHttatacaatYaacaaHttHatHtgcgatRRttNgcat +SVtacWWgaaggagtatVMaVaaattScDDKNcaYBYaDatHgtctatBagcaacaagaa +tgagaaRcataaKNaRtBDatcaaacgcattttttaaBtcSgtacaRggatgtMNaattg +gatatWtgagtattaaaVctgcaYMtatgatttttYgaHtgtcttaagWBttHttgtctt +attDtcgtatWtataataSgctaHagcDVcNtaatcaagtaBDaWaDgtttagYctaNcc +DtaKtaHcttaataacccaRKtacaVaatNgcWRaMgaattatgaBaaagattVYaHMDc +aDHtcRcgYtcttaaaWaaaVKgatacRtttRRKYgaatacaWVacVcRtatMacaBtac +tggMataaattttHggNagSctacHgtBagcgtcgtgattNtttgatSaaggMttctttc +ttNtYNagBtaaacaaatttMgaccttacataattgYtcgacBtVMctgStgMDtagtaR +ctHtatgttcatatVRNWataDKatWcgaaaaagttaaaagcacgHNacgtaatctttMR +tgacttttDacctataaacgaaatatgattagaactccSYtaBctttaataacWgaaaYa +tagatgWttcatKtNgatttttcaagHtaYgaaRaDaagtaggagcttatVtagtctttc +attaaaatcgKtattaRttacagVaDatgcatVgattgggtctttHVtagKaaRBtaHta +aggccccaaaaKatggtttaMWgtBtaaacttcactttKHtcgatctccctaYaBacMgt +cttBaBaNgcgaaacaatctagtHccHtKttcRtRVttccVctttcatacYagMVtMcag +aMaaacaataBctgYtaatRaaagattaaccatVRatHtaRagcgcaBcgDttStttttc +VtttaDtKgcaaWaaaaatSccMcVatgtKgtaKgcgatatgtagtSaaaDttatacaaa +catYaRRcVRHctKtcgacKttaaVctaDaatgttMggRcWaacttttHaDaKaDaBctg +taggcgtttaHBccatccattcNHtDaYtaataMttacggctNVaacDattgatatttta +cVttSaattacaaRtataNDgacVtgaacataVRttttaDtcaaacataYDBtttaatBa +DtttYDaDaMccMttNBttatatgagaaMgaNtattHccNataattcaHagtgaaggDga +tgtatatatgYatgaStcataaBStWacgtcccataRMaaDattggttaaattcMKtctM +acaBSactcggaatDDgatDgcWctaacaccgggaVcacWKVacggtaNatatacctMta +tgatagtgcaKagggVaDtgtaacttggagtcKatatcgMcttRaMagcattaBRaStct +YSggaHYtacaactMBaagDcaBDRaaacMYacaHaattagcattaaaHgcgctaaggSc +cKtgaaKtNaBtatDDcKBSaVtgatVYaagVtctSgMctacgttaacWaaattctSgtD +actaaStaaattgcagBBRVctaatatacctNttMcRggctttMttagacRaHcaBaacV +KgaataHttttMgYgattcYaNRgttMgcVaaacaVVcDHaatttgKtMYgtatBtVVct +WgVtatHtacaaHttcacgatagcagtaaNattBatatatttcVgaDagcggttMaagtc +ScHagaaatgcYNggcgtttttMtStggtRatctacttaaatVVtBacttHNttttaRca +aatcacagHgagagtMgatcSWaNRacagDtatactaaDKaSRtgattctccatSaaRtt +aaYctacacNtaRtaactggatgaccYtacactttaattaattgattYgttcagDtNKtt +agDttaaaaaaaBtttaaNaYWKMBaaaacVcBMtatWtgBatatgaacVtattMtYatM +NYDKNcKgDttDaVtaaaatgggatttctgtaaatWtctcWgtVVagtcgRgacttcccc +taDcacagcRcagagtgtWSatgtacatgttaaSttgtaaHcgatgggMagtgaacttat +RtttaVcaccaWaMgtactaatSSaHtcMgaaYtatcgaaggYgggcgtgaNDtgttMNg +aNDMtaattcgVttttaacatgVatgtWVMatatcaKgaaattcaBcctccWcttgaaWH +tWgHtcgNWgaRgctcBgSgaattgcaaHtgattgtgNagtDttHHgBttaaWcaaWagc +aSaHHtaaaVctRaaMagtaDaatHtDMtcVaWMtagSagcttHSattaacaaagtRacM +tRtctgttagcMtcaBatVKtKtKacgagaSNatSactgtatatcBctgagVtYactgta +aattaaaggcYgDHgtaacatSRDatMMccHatKgttaacgactKtgKagtcttcaaHRV +tccttKgtSataatttacaactggatDNgaacttcaRtVaagDcaWatcBctctHYatHa +DaaatttagYatSatccaWtttagaaatVaacBatHcatcgtacaatatcgcNYRcaata +YaRaYtgattVttgaatgaVaactcRcaNStgtgtattMtgaggtNttBaDRcgaaaagc +tNgBcWaWgtSaDcVtgVaatMKBtttcgtttctaaHctaaagYactgMtatBDtcStga +ccgtSDattYaataHctgggaYYttcggttaWaatctggtRagWMaDagtaacBccacta +cgHWMKaatgatWatcctgHcaBaSctVtcMtgtDttacctaVgatYcWaDRaaaaRtag +atcgaMagtggaRaWctctgMgcWttaagKBRtaaDaaWtctgtaagYMttactaHtaat +cttcataacggcacBtSgcgttNHtgtHccatgttttaaagtatcgaKtMttVcataYBB +aKtaMVaVgtattNDSataHcagtWMtaggtaSaaKgttgBtVtttgttatcatKcgHac +acRtctHatNVagSBgatgHtgaRaSgttRcctaacaaattDNttgacctaaYtBgaaaa +tagttattactcttttgatgtNNtVtgtatMgtcttRttcatttgatgacacttcHSaaa +ccaWWDtWagtaRDDVNacVaRatgttBccttaatHtgtaaacStcVNtcacaSRttcYa +gacagaMMttttgMcNttBcgWBtactgVtaRttctccaaYHBtaaagaBattaYacgat +ttacatctgtaaMKaRYtttttactaaVatWgctBtttDVttctggcDaHaggDaagtcg +aWcaagtagtWttHtgKtVataStccaMcWcaagataagatcactctHatgtcYgaKcat +cagatactaagNSStHcctRRNtattgtccttagttagMVgtatagactaactctVcaat +MctgtttgtgttgccttatWgtaBVtttctggMcaaKgDWtcgtaaYStgSactatttHg +atctgKagtagBtVacRaagRtMctatgggcaaaKaaaatacttcHctaRtgtDcttDat +taggaaatttcYHaRaaBttaatggcacKtgctHVcaDcaaaVDaaaVcgMttgtNagcg +taDWgtcgttaatDgKgagcSatatcSHtagtagttggtgtHaWtaHKtatagctgtVga +ttaBVaatgaataagtaatVatSttaHctttKtttgtagttaccttaatcgtagtcctgB +cgactatttVcMacHaaaggaatgDatggKtaHtgStatattaaSagctWcctccRtata +BaDYcgttgcNaagaggatRaaaYtaWgNtSMcaatttactaacatttaaWttHtatBat +tgtcgacaatNgattgcNgtMaaaKaBDattHacttggtRtttaYaacgVactBtaBaKt +gBttatgVttgtVttcaatcWcNctDBaaBgaDHacBttattNtgtDtatttVSaaacag +gatgcRatSgtaSaNtgBatagttcHBgcBBaaattaHgtDattatDaKaatBaaYaaMa +ataaataKtttYtagtBgMatNcatgtttgaNagtgttgtgKaNaSagtttgaSMaYBca +aaacDStagttVacaaaaactaaWttBaagtctgtgcgtMgtaattctcctacctcaNtt +taaccaaaaVtBcacataacaccccBcWMtatVtggaatgaWtcaaWaaaaaaaaWtDta +atatRcctDWtcctaccMtVVatKttaWaaKaaatataaagScHBagaggBaSMtaWaVt +atattactSaaaKNaactatNatccttgaYctattcaaaVgatttYHcRagattttaSat +aggttattcVtaaagaKgtattattKtRttNcggcRgtgtgtWYtaacHgKatKgatYta +cYagDtWcHBDctctgRaYKaYagcactKcacSaRtBttttBHKcMtNtcBatttatttt +tgSatVgaaagaWtcDtagDatatgMacaacRgatatatgtttgtKtNRaatatNatgYc +aHtgHataacKtgagtagtaacYttaNccaaatHcacaacaVDtagtaYtccagcattNt +acKtBtactaaagaBatVtKaaHBctgStgtBgtatgaSNtgDataaccctgtagcaBgt +gatcttaDataStgaMaccaSBBgWagtacKcgattgaDgNNaaaacacagtSatBacKD +gcgtataBKcatacactaSaatYtYcDaactHttcatRtttaatcaattataRtttgtaa +gMcgNttcatcBtYBagtNWNMtSHcattcRctttttRWgaKacKttgggagBcgttcgc +MaWHtaatactgtctctatttataVgtttaBScttttaBMaNaatMacactYtBMggtHa +cMagtaRtctgcatttaHtcaaaatttgagKtgNtactBacaHtcgtatttctMaSRagc +agttaatgtNtaaattgagagWcKtaNttagVtacgatttgaatttcgRtgtWcVatcgt +taaDVctgtttBWgaccagaaagtcSgtVtatagaBccttttcctaaattgHtatcggRa +ttttcaaggcYSKaagWaWtRactaaaacccBatMtttBaatYtaagaactSttcgaaSc +aatagtattgaccaagtgttttctaacatgtttNVaatcaaagagaaaNattaaRtttta +VaaaccgcaggNMtatattVctcaagaggaacgBgtttaacaagttcKcYaatatactaa +ccBaaaSggttcNtattctagttRtBacgScVctcaatttaatYtaaaaaaatgSaatga +tagaMBRatgRcMcgttgaWHtcaVYgaatYtaatctttYttatRaWtctgBtDcgatNa +tcKaBaDgatgtaNatWKctccgatattaacattNaaacDatgBgttctgtDtaaaMggt +gaBaSHataacgccSctaBtttaRBtcNHcDatcDcctagagtcRtaBgWttDRVHagat +tYatgtatcWtaHtttYcattWtaaagtctNgtStggRNcgcggagSSaaagaaaatYcH +DtcgctttaatgYcKBVSgtattRaYBaDaaatBgtatgaHtaaRaRgcaSWNtagatHa +acttNctBtcaccatctMcatattccaSatttgcgaDagDgtatYtaaaVDtaagtttWV +aagtagYatRttaagDcNgacKBcScagHtattatcDaDactaaaaaYgHttBcgaDttg +gataaaKSRcBMaBcgaBSttcWtgNBatRaccgattcatttataacggHVtaattcaca +agagVttaaRaatVVRKcgWtVgacctgDgYaaHaWtctttcacMagggatVgactagMa +aataKaaNWagKatagNaaWtaaaatttgaattttatttgctaaVgaHatBatcaaBWcB +gttcMatcgBaaNgttcgSNaggSaRtttgHtRtattaNttcDcatSaVttttcgaaaaa +ttgHatctaRaggSaNatMDaaatDcacgattttagaHgHaWtYgattaatHNSttatMS +gggNtcKtYatRggtttgtMWVtttaYtagcagBagHaYagttatatggtBacYcattaR +SataBatMtttaaatctHcaaaSaaaagttNSaaWcWRccRtKaagtBWtcaaattSttM +tattggaaaccttaacgttBtWatttatatWcDaatagattcctScacctaagggRaaYt +aNaatgVtBcttaaBaacaMVaaattatStYgRcctgtactatcMcVKatttcgSgatRH +MaaaHtagtaaHtVgcaaataatatcgKKtgccaatBNgaaWcVttgagttaKatagttc +aggKDatDtattgaKaVcaKtaataDataataHSaHcattagttaatRVYcNaHtaRcaa +ggtNHcgtcaaccaBaaagYtHWaaaRcKgaYaaDttgcWYtataRgaatatgtYtgcKt +aNttWacatYHctRaDtYtattcBttttatcSataYaYgttWaRagcacHMgtttHtYtt +YaatcggtatStttcgtRSattaaDaKMaatatactaNBaWgctacacYtgaYVgtgHta +aaRaaRgHtagtWattataaaSDaaWtgMattatcgaaaagtaYRSaWtSgNtBgagcRY +aMDtactaacttaWgtatctagacaagNtattHggataatYttYatcataDcgHgttBtt +ctttVttgccgaaWtaaaacgKgtatctaaaaaNtccDtaDatBMaMggaatNKtatBaa +atVtccRaHtaSacataHattgtttKVYattcataVaattWtcgtgMttcttKtgtctaa +cVtatctatatBRataactcgKatStatattcatHHRttKtccaacgtgggtgRgtgaMt +attattggctatcgtgacMtRcBDtcttgtactaatRHttttaagatcgVMDStattatY +BtttDttgtBtNttgRcMtYtgBacHaWaBaatDKctaagtgaaactaatgRaaKgatcc +aagNaaaatattaggWNtaagtatacttttKcgtcggSYtcttgRctataYcttatataa +agtatattaatttataVaacacaDHatctatttttKYVatHRactttaBHccaWagtact +BtcacgaVgcgttRtttttttSVgtSagtBaaattctgaHgactcttgMcattttagVta +agaattHctHtcaDaaNtaacRggWatagttcgtSttgaDatcNgNagctagDgatcNtt +KgttgtaDtctttRaaYStRatDtgMggactSttaDtagSaVtBDttgtDgccatcacaM +attaaaMtNacaVcgSWcVaaDatcaHaatgaattaMtatccVtctBtaattgtWattat +BRcWcaatgNNtactWYtDaKttaaatcactcagtRaaRgatggtKgcgccaaHgaggat +StattYcaNMtcaBttacttatgagDaNtaMgaaWtgtttcttctaHtMNgttatctaWW +atMtBtaaatagDVatgtBYtatcggcttaagacMRtaHScgatatYgRDtcattatSDa +HggaaataNgaWSRRaaaBaatagBattaDctttgHWNttacaataaaaaaatacggttt +gHgVtaHtWMttNtBtctagtMcgKMgHgYtataHaNagWtcaacYattaataYRgtaWK +gaBctataaccgatttaHaNBRaRaMtccggtNgacMtctcatttgcaattcWgMactta +caaDaaNtactWatVtttagccttMaatcagVaagtctVaaDaBtattaattaYtNaYtg +gattaKtaKctYaMtattYgatattataatKtVgDcttatatNBtcgttgtStttttMag +aggttaHYSttcKgtcKtDNtataagttataagSgttatDtRttattgttttSNggRtca +aKMNatgaatattgtBWtaMacctgggYgaSgaagYataagattacgagaatBtggtRcV +HtgYggaDgaYaKagWagctatagacgaaHgtWaNgacttHRatVaWacKYtgRVNgVcS +gRWctacatcKSactctgWYtBggtataagcttNRttVtgRcaWaaatDMatYattaact +ttcgaagRatSctgccttgcRKaccHtttSNVagtagHagBagttagaccaRtataBcca +taatSHatRtcHagacBWatagcaMtacaRtgtgaaBatctKRtScttccaNaatcNgta +atatWtcaMgactctBtWtaaNactHaaaaRctcgcatggctMcaaNtcagaaaaacaca +gtggggWttRttagtaagaVctVMtcgaatcttcMaaaHcaHBttcgattatgtcaDagc +YRtBtYcgacMgtDcagcgaNgttaataatagcagKYYtcgtaBtYctMaRtaRtDagaa +aacacatgYaBttgattattcgaaNttBctSataaMataWRgaHtttccgtDgaYtatgg +tDgHKgMtatttVtMtVagttaRatMattRagataaccctKctMtSttgaHagtcStcta +tttccSagatgttccacgaggYNttHRacgattcDatatDcataaaatBBttatcgaHtN +HaaatatDNaggctgaNcaaggagttBttMgRagVatBcRtaWgatgBtSgaKtcgHttt +gaatcaaDaHttcSBgHcagtVaaSttDcagccgttNBtgttHagYtattctttRWaaVt +SttcatatKaaRaaaNacaVtVctMtSDtDtRHRcgtaatgctcttaaatSacacaatcg +HattcaWcttaaaatHaaatcNctWttaNMcMtaKctVtcctaagYgatgatcYaaaRac +tctaRDaYagtaacgtDgaggaaatctcaaacatcaScttcKttNtaccatNtaNataca +tttHaaDHgcaDatMWaaBttcRggctMaagctVYcacgatcaDttatYtaatcKatWat +caatVYtNagatttgattgaYttttYgacttVtcKaRagaaaHVgDtaMatKYagagttN +atWttaccNtYtcDWgSatgaRgtMatgKtcgacaagWtacttaagtcgKtgatccttNc +ttatagMatHVggtagcgHctatagccctYttggtaattKNaacgaaYatatVctaataM +aaaYtgVtcKaYtaataacagaatHcacVagatYWHttagaaSMaatWtYtgtaaagNaa +acaVgaWtcacNWgataNttcaSagctMDaRttgNactaccgataMaaatgtttattDtc +aagacgctDHYYatggttcaagccNctccttcMctttagacBtaaWtaWVHggaaaaNat +ttaDtDtgctaaHHtMtatNtMtagtcatttgcaaaRatacagRHtatDNtgtDgaatVg +tVNtcaaatYBMaaaagcaKgtgatgatMgWWMaHttttMgMagatDtataaattaacca +actMtacataaattgRataatacgBtKtaataattRgtatDagDtcRDacctatRcagag +cSHatNtcaScNtttggacNtaaggaccgtgKNttgttNcttgaaRgYgRtNtcagttBc +ttttcHtKtgcttYaaNgYagtaaatgaatggWaMattBHtatctatSgtcYtgcHtaat +tHgaaMtHcagaaSatggtatgccaHBtYtcNattWtgtNgctttaggtttgtWatNtgH +tgcDttactttttttgcNtactKtWRaVcttcatagtgSNKaNccgaataaBttataata +YtSagctttaaatSttggctaaKSaatRccgWHgagDttaaatcatgagMtcgagtVtaD +ggaBtatttgDacataaacgtagYRagBWtgDStKDgatgaagttcattatttaKWcata +aatWRgatataRgttRacaaNKttNtKagaaYaStaactScattattaacgatttaaatg +DtaattagatHgaYataaactatggggatVHtgccgtNgatNYcaStRtagaccacWcaM +tatRagHgVactYtWHtcttcatgatWgagaKggagtatgaWtDtVtNaNtcgYYgtaaa +ctttaDtBactagtaDctatagtaatatttatatataacgHaaaRagKattSagttYtSt +atatatagtcttaaaaMtcatgttcaaDactgRttctaagagDtatttttagcgacttgt +gRtgNctgSgRaaaaatgcaMtYtDcatcaaYKttHcatSWgaaaatDataggttatgBD +MtgttataacaaYSgagttacgttatgtDStttaaatctcgWKtcSacgagagaSgttat +BMDgtcggtgtgcgaNtaSHBatBtttVMgVcagaNatcaDDaKMtMYtatagaBccctc +tDtgtatttatatKNtgggtatgtRaacttgaWaaYgcaHatccctggtttStatMtcgc +MtaaaWKttMVtWctVtgttaKDWctgWaVttaDVatgKtagagtcatctaKWgtaaMtt +SacBaMattaKaaHDataattgWtgttttgtcatBacacgtStacaaagtNctNtgtgat +cHtWttcKaagagttttaaaaWacgRacatctNatVStgaatDHgttWcgtRKcatatat +ctcaNttaaBDcctgaaaaaDtaYaHaKttNtaYVaVtttaDtctacttctWttaactaa +ttttMagWcaatcccNKYtBaacatgttgaKgKcgcBHaatDMttatatcSWacatDatR +cWaMtDgatBctHgScttaaaHtSgKtDtttattgtRStWgttccatatttcacWttcat +attgtaHVgaBtacaMtgMaaagDaataactDatattagMaNBagcttcattcgtaaKtg +tatttcacMtgBaVtaattStcttagtYgtgtcgccttKatgggtgaWaataggaatacM +MagaSKRttBgatgacRtgMtagaSRataggtatcaccgaNaaaWSWacDgatacttgat +tagcttgtgVMttatYctaRgHVcDtVRRtSaMtcaVtVtatcaYaHatattaaVaatct +aBtgtacRatNtatttgaYatSaHctaNgNtYtYaYagattVgatcRtaacgYggtgtat +KttaatMagatgRtatatgHaKccHaaaaYtgaacgaWaNgtYHgacagaYtctaVtacc +cgatttttaaagcDttatNRgattKaaattttcatctaatgccgcaataataattgttat +YtagtRNtaagttggtHaKttWMtDKgatSagBYcgRggtWaVaattHtatgtaaaMgSa +aagataaKaaKgttDttttRaagaacaWRcaacDgtgttaatattaKtatcaWacacatt +tVtctgatHRcagtttNcaaatcNctNttttataactWacBBttgBttaaaRaWtBKaaa +cgtatcRcaMaatgYacaaaagtgBataStWYtggtatgacaKWtctSgcKHgtcNaMNc +ataSatattgactacMcataattNVtDaRccaaatcagttttYttagYaacgtaatMtMV +atNgKaaMaaBgattaKttatDaBcttKtccttttacDagaYtacHgttggacaaaVaat +agtYatcataSgatcaaWVttcgaatgaccctccttNtaSBWaatttDttttcaatatYg +gctatDcttatNctttagDcMttcaacWaaNattSYgctttcaHcRaattaataaaatcV +ccRaattactctaMaVRattacagtgRcDtcgtgctcttNtWVtacagtHtatHaBDtcW +ggtgctcaaRHtatgtDgacStgcaaaVKtagttataatactaatatgtagScaatRSac +aattgtattgcagatHHtgBcaatKKtaaMMcaRcgactatKBaMaYatgKatttDaaNt +RatattgtatWttagcaaaaacaWgcacaaHcataYtDaHgttataaSacgcagggggtY +atgcKctaaaHgcVgctBDaVttccStagNgcSgtatgVYaMatcaWRBtVtgYttgtgR +cYttcgctgaacNttgtgtctattWttttcctagMtagaWtaKgatStScatMaBtaSta +SactattYNatctgtacRatYDaatgatgatatgaatYaaaaSHttaaYMaWtDcaNHaB +caYtgVgcatVaacattMRatBtaatttaDacRtagtaaaNYVSMtcagaaDtttDHtRc +YatacSNKaaMcHgatBaaVttactggBYgaYatttttgcDacHctWatcgtagagtact +cattDggtcatKaSgctttatttagtDtRBacttaWYaaaattttgaccttaaWtaatgc +RgccacttMtaggKtcBtgacgaHctttatcgtcStatMHDNagattatNagVaaaWcgg +aaaYcaVactDYactaStattgBHtcYctgggtacatataaYcgaYagaggaggacaVat +acHRtYtctgtaVgaYcNgaaaNatacVgcNgtaatttDcatttttcaacttSNcaaDat +VYctSgcaccttagMgacgcttgaSttaaaatagttaggRHttaaacMatagcaWgMgag +tcgctagtgtKgactaaHttattaWgcaaaaaaSatatgcgttaBNggttaYVatgaact +ttttgccatataaataRatSaBctagttataBccgaaacaagatacttaattttgaHgHM +gtaaKctttaYtaaRacBMtBaYgaBaaacaYtVtagcRgWatHaWagattWSacStMHa +tttaDagacaatcgtgtKtttggaMtgtWtgtgcaaNaaaaWtKaaBcMWtcttctatga +cVgagcgaggHaYYtttWgSaaYYaWtRYHHaMDtctttacaatggaaMctataagcttB +cgHcNWaatttgtatatYtStatctagcactgtVttccagaaattaDtttaRtVataBtt +WagcatDMVactYtgcatWtttgaaMggKaatgaaaaHtataDtgYcMggVaaatSMHtt +tgVttaYaWaataRttgttaYttattttRtWtataaBgtDtttatatcVgaaBcaDtatg +tcaDagaWtgaYtWctcVagctcagctatatagcRVtcaKtaataatHgNaccgaaaatV +HBaatattcgttaVYttatttctBYaatKaagaccVStttcattgaMagSaaaaccccWK +caaNtMYacctaDStagaaatttatcatVgtcaatacccKattgtaaagtggWgtatatV +tagBcttDaBacaattWtDYKtatRKggStRtaaaWatBtaagtaattDaaaaBRacWta +agtacaSttaaatccgctaaccKaattgVWttDattatttattKaMtcYtMRWagMtcgK +gBagacgggVaaNaaatgctKcgtaataaKtaaagtccWcttHMatSYgataaatDttBa +HccattgBttSgaaHYtaataaaMtgaagatgtttBgRcattaRaDHcttBgaMaWaaVM +MattaatttgtgBRctattgKMagNcMtatttaaaWttgaaacatWgcScgYYDYgttYt +VtattgcKcWtagcggtgBaSctaKatacaaVtcaRDccccgtgttBgKgggtHagcgaa +ttaaagMMttScggtDttttaHcSaagaacactcacactBcVgaKNaDHacacttatSag +aattSKHtcagtataaatKaaHtgaaRagaaVcBtaHtaaatcgatcWcaRtaaaattta +WttaagtcaggRctgaWcttDttgactttaVSaaaatggtaWDaRMtBtaaaaaKatBga +tMtctatatcaVaMgatttgNagtDRttDatcttttaMtYaaatcggagttctctaYatN +tagaNcgMMactacHcaagtaaaatStaSaacaHcacSgggtNKatggaaagcggaaKgg +gtaYtacSgccgBaggcRacgtVgDtggaMcYaaaMatggacgYStKKatgaBcaaRtSt +ccSagcRccgccgcSDtgcggBDgaDtBtSSggacMttttaWcatcMatgtNMBWgataa +tcaaVtgaataataaNatgcaaNttNctgacDMcaHccgatgKgWVttccaStggattct +cDacttttttctttaaNcWaMWccWKWttgaaaMctDaaBactRtVattttBtcMaNttW +cKacagttKSttaYaWSactHSaBtHgatgttacatgcatatMtttgtaacScWHBatHa +ctggatatatctgagMgRSatctaaSttaVagcaRcttggaYaatKHtagBBactattcg +taaagaagttgtVcgatgaVatHMtcaggtcgKSgWattgaaaVctccVgtDcaaatgaa +HgMYactcaMatatatattNVttWtWaatttacRagKataaaNtttacaaWgMVactatt +aSgaggVaaagVtaccDRHaaataRaHaRgcattMttcaatcaKaaataDcaDKtctcga +ggBggacctDtttatHacWVaWgatDctaNaNcgKatcMtcMaatBtttggacgtgataa +tagaaacRactcBtattttaKtgSaaggKtaggRaVtatagcccaNRttaccttSMaaga +tcggDacNBatWcgaactacactaactNBtaStgVtNagcatctaVtaKatKgaBtcgtt +tWaagWMgagRaNatHaaaaDtacagacaBagtgcaHaNatctcBccNttaagttDgaat +aaNtcgctaacRBgtaatSttaatatgcataacccaSattKcccttDttggtcaatgggt +tWaacgatacattBtgMaYgaRttatgatKaKgtattDtKWgataacgNBtaccgaKWat +cttcttKtgtcttagcattcctWcaaHgagtatDMSgKtcagcttgVHaKcttDaataaa +VaatttDgtgaaataaRgtcaVaatacttagtVatatgggcatgtDDtMtgtatBggatt +HtgcVtgtgatcaaSattatKYVaacSNNttNWcgaHttKDaaMYHatcgttaattaStt +gctWaacHtaKBtaaaaKHttcRWgaaWcRtBtttggBcDtgtacNttaagcKtaHgtag +aaaaRttgaaacatagtWRaacYggtaaatcgctYaBtWDRtgttgSctaaKatNcattg +tgtMttatccatatagctSacgccSNaaactacgNtgtgcttMatSKtcaaBaNaaacat +aacagaaatagtagctcNcatcVgaagStaataVcDKKttcagDHDtattctaatgaggg +RgBMctatacaagYactctMaaagtcgctttctcgtgaattatNcgatMtttaggcBaaa +tctNtactaaRKtgKactattgtcatatgtacgagttMaaHSSgHgBatatcgcaSaata +aaWgaagtatagaHgcttctttatgaccWaatttaRtaDaatttaatcgaaattgattMc +atcaWaMtaWaKactttctBacactatNgtccttaWgtctgaccKatStaKtgagtacgg +gcgcgtYNtatttagacctctKcatgatKWStcaataactaWgMSgHtgatctttttgtc +gacgtSacttaYgcctWctcctctacaagVtttMaBactWVaccaYtgtSgcgttattcK +tatStgaaKaccgNaataaHtatWtYtRacggcaDaScagcagHaYWRtRNcDtHtcVWt +ggaataaaYttgVaNtgttagtYttgtagSaaatDgaggccDcgBRYStattatttaagg +ccgHgggYRaaccMaagttatSttctttagcMtgcgMtgaSagaNaDagttSatgattWa +tttagtDgcttgagtgMKaYWaYccagcaHatKctaKaDgctagacttattgattaaYtt +atcttattattStaattWaRaYBWagYaatatgttRgScttgBagDaWgcgtgcVDaggc +ttgtctaDRKacttgcaKBWRtaaVaSctKtacttMaaSVaWWcgSaNtttSWgtcggtc +acttggVVtgagaataaataaDttgaaccaaaaMttaaaagaaaaaaaatcNBtatMgcc +WagcaNgaVaNaaaaaaYaMgttaWtatHaagtNtacgacaBtMMattttWNaRtaaata +gYaScKattacagctVKBtWNSKgYtYgtWatHaVatDaaatWgDatcctggSRagagta +aaaMgatttRtaHacatggtaKagVcctgatgaMtaaYgatgtattattttHggBaccaD +ctctggNNtYaatctVttgVtRtVcRacttNctttataggHSRtaRacaaattaacHaHg +tgttgtttcBtBtatWtgtattttgcKagMcaaagaMtattagtStagcBacYaaHcagV +gWtgtttcgtgDHaVtagDatcRaRtggtWtaactgcacgaggaaaRttSDaaVaSttaa +aaacSMttactaNtcaacaattDtacttttYatVSacYtWtMttaattatcKtcttctat +caKDtctStSaaacggtYccatgtgagagtWtagWKgcaBaaaaKttgNactaatcgagg +cWtcDDaaaaaacactHattaattcactatYttaagacactaKaagRtRataaattttca +tHggtaataaatgataHtggctaacBacDgtaatattRtYgtDNDBgKtcaggcHatttt +gHNgWtaatttccgactactgacatVNttYYgactcgctctatttagaMcgggatHcgtt +tatBaDSagBaaaagRttBggttaaBactVHgatgaatttattcaaaattgcacttcDga +cttYcVttactVtttatBaKHagaWgtgaatggBtaaSggcagacNcttaDttVgMtWag +attggVatttacHtctNcMatacttSatMagcttgtNcYaaScaYactcKctKtagScSt +cagtttcatWaatggtgagaggHaggggcaacgcRKtaRcMaNtHaatRaRaaactVtBt +gttaatRtWWcaaagKttccaaKaaatacgVttcacaaacgcggtgagaRaatggtgDMW +atcWVScacaaaDaggaaHtgttSMaaaaaccYccDBtatYgtMagcSagaccaVcctcg +gtVWaaagttatcNaagataataSaataaaKccgtaDtYttatYcttHttaagKcMctaa +atggaatRgaaaVaaVtcKYaggatWcaBtDaggDatccttcYNtgcSMRgaRtNgaatc +gttRttatDVMtagctttacatDVtatatatcagctaDagMtataccYgaggYaaatgDa +aaatSgctctgatgtttVaaBcctgataKtagaaaccaKatatgttaDtgaDtatagata +atacagtaDtatcNtgtDMtYcattRVtctataNtWttggNaSgtMgaaYctctDggHtg +gHDccaccacKKaaacaaaatRatttccctttaagcRattMHctattHaRtataVattgg +atcSttaaHaHgaaHNDtacattSaaggDatttcaaaYgctBcatattaaaKagtgccca +tSctcgatRtaaaMtgWactttNMaWctYgRatDggaactcDcaattaKaactgagtatc +tataagYaaaSRctggtacWtttccWtaYRtKHattatagWtKttaNgcDtatHacccat +taatttataacgctMgaagtaacaacagMgtaYHYVtKMHtacMgKcaaatctgRYataN +tcgttcaatacggWtMcaatYcBWaagYtVaDNagtatagDaaNtaaaYtttcYWttttS +tgggataaMgatattagaaYtNctcttcBagactaYDcgtacHDWccKaHgttcttHgVg +gVDttatcatKaMttttacWaaSattctatagaHaggKaDagBtaaagtcYccattgtYc +atctaNgRgVtgaagtDKttatBKcggDtattRYgHccgtgcgBNMtttVRgacaYctSc +taRacgtagagccgtacRaagtaHKagStSttttgYSatattaaaWHaaWagttDKaaNa +NHaaHttaYcttMtcaaatgKttBtSgtccaaVaattSaacgttgNattgatatNctaWt +VcagtactKcWacgVagggHaaRgaDaatcMttattaataacaBMaaVtgYtKgRgHact +gtactatcBaMtVggtagKcYtHtBSaattagtaatgMcaVVagYYgWtactttccaaSt +tDgaaMaMttcacttYtRgacttcagcttWtttagtgataMaattaagVtagaatatKat +aagtagttaagHMRaDattaHaaVcctDtagtcVYcaataaYcNttNaaaHctcaRaatt +tcaNRgatSHgVatagctRtcatgaBttMaaagRtcgHVtgRgStgatttgtagaKagaR +WRctgNaHYgaaatBctgtttRttNWagaccgagKgtgcggHKVttaatattaatataat +aDtaNcctacaaRgcaNMctctgaaSHWWHcttagtNagtWgWaaKtYaNgcBattatcc +aaaSctRRHKaNtKcBgtgagaDRWBttactaaattSMctatatagaaYacDgatttccV +taagRtgRataatatagtctttttatgtMgtcaacaaNtaaaaactctWtagaVaaaDta +attatagtBStcgaatDtgattVaatMtcaDattVKWaagatagggttgtMRSgtcYgWM +aatgNtagtcBttagtttctctWaaMtVgctWgSgtHagaSagactagKtagWggcattt +HgttgacaaactcggggHggcWBgVgtatgggagVgagtcVcBtDctttagtctaagVWt +HtgtttaScatacMBtKgattatRtgtttgtctttDggcHaBtRtgtaataNataattta +taWctgaYWataStcHaatcRtaaVagDWaSatagtaccNDgaagtatacgttttacgac +gKRtattgDctatRRattVtStaaactagatgVatttagaMaSaaaattVtatYtgttgt +RMagtHaatttSttaaYNaggWagtgcacgaMcactgHgtgtgggHMgtKacttaaYgtc +gcatcSatattgBaagtttacMtYagSatttatttaVtaaDtaWaHcgNatactgactHt +ggWtataDcDScatactcStcDtgtcgtgtatgaggtHaaNKgDattgcBccaagKgtat +gacKSMtttttgttcaaatcaaYtagtaSatgDaaaMccKNaMaatagaataagcaatta +ttataaMgagtgaSgtctNYttattHaNaYYtcDDtaatNRgtatttaaYtaaatcactH +VaHcStccttcccaaVatcVggatKtatgRaaDBgaYtttacttYggactSDtaBcaaNg +gggtattatattBDcttagagYNMatBgttYaagactMatgttRgatacccgtaacacBH +tatKacWgatRcHttaattYtKtStccaaatVDcaNKHHaaataatagtagtatcttgct +NDggVaVVtaVaRaaagSaccgttctcMtVtgNBgtDtttctYgttactBctcRtStWtW +DScMtcWSaRatgaataRHctaNtcStctYtWacagatgtatYBtHaHWBtacggtDcaa +BtatcaggtcaVattaNctactgaaaatWaDgactNWtMtggagaattBaataYcMWYcg +atMYatWtgattSatgaRtDaRgccagtSttatatRaBtattRcWtagtVgaagttMcta +ttatatDttaggtctKtgtgtBagacgttatRKtgatctatttBtataactgataacKcg +gagtgHgtVttcttgtKDgcDtaYatBDatcaatattgttNtaBacatcgcNcaKcaWcR +ataWcVgtacgScaWgttcggHcMttcRccatgaRStYgNacagatacYacWWtggNaDc +WagttHatMaNaatNtcDMDcMaKgHNatScVgatKWatatgNRgtccgYgaagattDHg +tMtcHaSNaaattBatRagtaaatttacaagHWtKatcaagtccHtYcctgttKDMSgta +ctactVctgacaaaaHgatatacataatKtStHgctScSatNatacaYttaaWHtctgaa +tYtagtHtKaggccWBaStaDctaagagNtaatcaatcgttNgaYDaagtaaaaHataga +atcgcgBaYaBgaacSaaWaaaaactccgcMttHttYgtaagaMctKBtacSagattcBa +aWtaattttacRttatcgaRtacaRHgtgRagaaBcttaVgacVDgggaatVatagaact +RRtacgYttNattVHgaHttacaaaaaaaYtcRWtgtgattatgccaSDtttatKWgaat +atSNDgattttaacgtcSRtatggttcttcBtWtttMtBtMScttaHatBattHacYtaY +acattcgttKgtcStSctcKtatatttcaKSgagcttccaacaccRDtttDaccattata +tSgtcWtVaaagttgtagccattDtYaatattDaccatcVDaaRccagttttgtcHacMa +ttcHgaNcatgttKcVttcctgtgcSataaatattgaKtctaWctMRaKggtaYcaagtt +DttcgttacRtatgatggHNaWMtKttcatattaaDaSaBaaaMtMatBgKtttgHtHac +taatcatcgtWaatKaaWcaWtcctVttaaNaggaaaagtaaagaDctNttaDBaBgata +gMgaataacRcYggatcRaaaHaagatRDtVRactaYagttcaccaaWtctcSSaaatcS +KattctggDgaacagDtaDagacagtgtaattcaStYttNaStgtaHgccttaScatMRc +accWtcatttatRtaagatWtNataaWtMNtDVgWttgcWgtgaRttttRgWcttMtcta +HacaaYtKctgaBagtRagacttDatNttaaaDgRtatNcHatcSDgtBatcttacVcYa +cNgaattaacgagttgYgacttDattatacBattMgctagcctagatVcaactNttccta +atgtDaacgYaNatagMatSWtYBaaaRtgMtatSRgaataYaScaVgtaScMagatNNt +ttacaaHBaWtNtRtctaaacDaaaaWMcaNtcVaDNcagaDtgcWKYgagttaHtgcDY +ataaacataBaWWtcggtatgtgaaScaacctttRNatcgttaaagcaDctaatgcBatt +tacaattVaMgSMMtccYaaaBYtggattttcataWttgBtatDtBgactaatgtccWaa +HataaScHttWttDtcgtcaagMctMDtaaaatRtBaaaacaatgtcagcatBgNNBVtt +ttttcBacWtttWtSWWtgaaaaSacgBtaaataaagtcDStaagaactgttaatYatgD +ctattactgaHtaaatStHaagacaKtagDtaaHaDgttccaaDtaaggacactctDggc +gtDagtcWaHgRcHgDgaSctttattgtcttttccttRYaDgNactaaatcaWggcNSBa +gttttatatStKgtcRtgattaaggtcaSBttaacaaKatgggatcaaattgRgcBagtN +tcgDcatttWcctttgtNagDgctgcatttactttgtgtcaBgSatttNHaMcggcagSc +tcKDtWBaagSagWatggYtVatSRgKagattgaVatKttcgatYatKYSgDaacNtcVg +tttaWataWtgVctgcgSggMgatccatgagttgtWcatYWWcctVcNHagtNtgtKttt +gatcaacttaSttattgatNcatWaVgNHcagStVHcggHacaaDttgDttWcaaRaKga +aatKaattagtaWacattgaaatgtgaatgacagtgaRVtaaYagYtcggcatMttgaag +gDgagDRcaKgHtacacaaaMcaBtagHactgKaatRtNttcttcatcatNgYgStggac +tatgSMttgKtDaDgacRRgtWaVattgatttaagYctatatagactaagaggtatWtat +aaactaYaHRctStgKWcgtRtKtYtYtagacgattRaaYBtaStcttaWataatcHtta +taRcactgagtgggagccaattctcDtgDaggHcDRVaVVggaaBtRttaataaRRttgt +aagKNcaVWWgtatacctgatcttBtcttRgaWcaVRKcagttSacttagcgtKtgtYWa +tatcgNttcKaccacacVKctgattBtggacgtctgacaDtWKttattttgMBgKaacaD +ataattWtBtBRtVtacataaatatttgtWtttatagtDtgcctagctHYaatgcaNaaR +caatVtacctgggggKtagBgagaBgRaaNttttMtMagMtgtgattNctcNaKggWtMa +tcttagWgtaatatatNctaYBggKaataBattYtaattataVtggNtcgtgtctaatta +aacctHtacaaactDctDtctgatatgMtgataacWctgtgYSaaNScgDYaWtatDatM +KgcaatttctgNcgtHtaWtagatatcYBttaattactcaaaVattYRWtatttDtaNMY +MttgattataatgcgNggWaatYagttgBagNcaagaaaDtRgtaaaagctgcatctagc +ttaVgtBttatagcKMSaattYtHcMaBttcagtcttgKatgVSVttKgttttttagtgt +DHgNggtcaVtatttaacNtgaatatgctatMcatgaaaBtgBSaWctaataaattatYt +tagtaDtaccggaatgagtaattggatttaacBtctSMgWYtgKgattacgRctctccaa +tgtaggcctgaNaatScgYataaBBacaKtHtttcatgaaHtgBtagaKHVtacctVtca +accaDaaWNHNaatgataattgatgWcagggtcMBtgSgRataHctMctgMHHtKaBtaa +MtMgataaRWtagYtgaaMaSgctYtgcgaaHatDtatgtcWRatKatatYDcBgNtRaR +acattMcagaHgaaagRccgcgWttggSatBagagcHgYtatctVtcatYaaVRtcaSac +aMYDcgRtcaaWgaRgataMtaaaacaggtgtaaYcattgWgDHcWgttaVatttgcatc +taatccacaaagaagSatgcgtagRgagtHDgaVcgtgcttatggMttttcatKSctNac +HcctMaKRatttgatctaaatgHaaScataataatgtttgtgtHaVcaaaaNHaaaatcg +ctgSVtattVttagaaNWcacagtgKtatgattHcYcttgDaWVataBatBttttWtaac +tNaattttctttaaYHaMtttaaaccgStcHaVBaatcRacaaWactgtagVKtNRtcct +agcWaatNgctKccttctcDaBDcatYHatatgcaataaBaagaatgDMttaHcaaYYtc +actgttRtgacRaacctaWtBtBMagBctaaBaWtgatgVtttattataggttaattgta +atYcaRtVctcttgcacSaaMaatactRSgcataKcagcaVNKttcgSatcaaactaatt +DtaHtNaVtgttttttaWVtatNccagWttcgtatBcgttVctcBttaaaaMSaDattKR +cctttcataHaattaatWaaataKcaHVaggaatataBYKHVtgVcVgtcHcttccgcct +attDtMMgWaacttgWttYtttcMcgtcctaaVHtgWtggtgacKtcaWaYMttacttag +VWtacgSatatcgWcKaaatHKaaaYttgtagtcaacWtttggtcaagttgaaBBaSHac +VcgYgttWBSRWggtattttaYDtHatattcgatNttacaaaaVacaMccaaYStaataR +ttVtcttagaVKaacaWcgccgtRatcatctaaatccMcctttaMggccHgYcDgaKcta +tgMRYBagcaNDtgMtcRttgtgHaRttacatgaWcDtgctgtataggNggtgaatagBg +agYNtatcagKtHcatBatgVKgaHWagattRDatatcgYcHagRtaatgWtcStagcVa +tNaaaaKttgRaRBYNgtaaDtStaVRgcMccatMWaaattBDatttaatttataaHtag +tVVaDRMKBtaacaatttttttDaRSgaaKDtVaBatcagtaaMttaagcctRgaNVggg +ttcataatagNatcctacactacgcatgtcggaYgtaKcatggattgactttHtaattWN +RaaWYggttcaaaggaaNtaatgcHcaaaattBtagcttattcaagVtatttWgcctaKt +atBttDYcattagDacKVaYNccgYaYRaaMaattRaagaHtatgcttgcRagcgctSaa +tagaaRacaRacSccagcacVMataatHgRtagcgaKgYRaDcVWSDVgRaMgcDgtaat +tttaYttggtaaWcttKDaaYtatMRcgKccYcagtYcBgRccattcaKtgaSSRtactg +acgHtgtaaaaBatWgcaMcBcYcgccagactcttcSatYattgatgaNccaaaaWaKat +VgcaggtWtBcgttaRMagcaaagtgttcacatataaagaHWtKatctacttatatcacY +RaaVagataagtaattttgatgtBctaataggtaRtaaHaattgtaRcStYSYaWRgMta +caHcNSttVNScattNKaaKgBtagtgatYcaaaStactggttggggaBggtNtgtcaaW +BaYVSNgtaataBNtagtatatcacMcScccVcgtVRRtttNcKaSRNaNtHRttattta +ttgacaatggSaBagataaccgttcctaDNaattgctVtatNtHtatagSccaagctKtt +aaacaaattattgtSHgMWgStttNaccattBMYatRtccStNgttgaaBcctVagcaaa +atgatattcRaBccMWaagKtttttcMtgaRYNaataDttgttWRttattggHtNtataa +tggttgtStYgaMcYVtcattaggtaatVcaNggaRtNataMWcctcYgcgagagRgcHM +gcWtgaYtVSttgDaacgaaaatMttYWtWttcctgaKNttatttattRaattaagaccM +KtttcWgtcaBagKSaWaaacaNtaYaDtBNaaagWtHgacaaagtgVtcatKcgcaatV +aactatgcgaaactccNctatatMgactatttatSaaVttNttRttagHtccKtHtaaaN +atttYVctaatttaaaatHWaNtSacgaaaHggaaatcacagVYcctaattcMNtgtYtg +agttatttaBtcRgBHNacBtactctagaacgcKaaDWYYgcattactVagaYtgaVVcg +caNctttBagKRcSgaaatttgtatccattgtggHcaatRtaVtaSaBtcYYcatcgtgt +cHaVttaHattctgtcaBSNYaKBBattaatggctgtHatattgtBacDcBgatttaaaN +tggaaaaYtNcaKagRRtRgttRtMtWgggatcNtacacctgtWKagatataaYVMtaaD +taaacctctgtgtgccttScacWaggaYacttttKacgtttgtgataKYagaYaVatcWc +SattaMcatBYttYaaatgStKagWattKtttaWgtagaaSgtRattcSaDagVaMatta +ttYaagccSgcNaaDgaaSaggtaNgtWactaWcgHctgaNatttttcaatgtaMHSWaR +tggtaNtaHBtttWWaaatattcVtBtctStWtaWMaBcatttcDagttDtttatatgtt +WBtNaYatcccSgtgagcgaRYtBtagaDacBtaagaataWactaaaagKtaKaWaataa +cKcccgDtagccaaagcggaatcgctSRtacKgcactacccHaactMgtgccaBaRaaaB +VtcgSacRKtttStgatcaaHgKtaaKaccHaccacccKttgagcttcSttttKKcgacB +gggtYMaatcBStcgDBtMcataWtaWaMtgaataagaaDatccSYDtgBatgactBaVt +aagatctcNMgtcaWKtgcWggcgatacgtgtttatttWaDaNWBNaaNtNttcaaatag +taatScgHtMWttgttgaBaDtgNatSaagtttHttaNaNKaattKatttgatcgtVcat +gaatatBtttctaacKaNttVttSagccatRtatatcactcHHatctWSKttaMacaaDa +ttccaRaYttttagttaatattcctYaacVactgctMcgagcaMYtttgaagctagtKgN +WttgaaaMatcaMcttcSVatcaatgtNactaaBagatagagtDMgtNtNWatttSaHac +tagaaaDggtaaaaNctMaatagtaHgacgMaaacMtacatHtaSagaHatYDccagtBt +gaWatcYtVaagataattgatcgacctgcaacgttttattacNMWNcattataDVDacta +tattatYattttgcgaagtgagYVtagYaWaHaatctgWttttatgcHaacgttaccDaK +tatagaccaDDttaacgtHBaacatccgtYaBtVtNccaaataaaatVactDttSKtcMt +DSgaagctaMtatattgattactgtNaagNBcagHaDattaaaWttacacaaatactcaa +tSDatagctcaDttWactttgaStaaDtagatSaaDtgtaatKtgVataggaagWSaaaa +KatttaaagtttgcgtaaagcccggNWaacatacatgttctaRcaHttVtcattatctag +ttttNcataaacDttWaagVtNYtaggctttggtatgagaWgtactNaVatcactVttBK +cttaaccttcMtatcggtaataYaMaYggttgtcaaagSWHctaRMSatVcggactMata +tccgaatcttttttcgagtccagtttgaMtcgcatcaaKagtattRMaaaKDBttDNcca +tttttaaBNtVtccgtaatgaKgtcagMVSattatttaWaattttaHNcaaMaHttgtgg +ctattctacDtgaagattatcgacaaVRHttcSaSaatactNHWaaNcgtWaWgaccgRS +ttNtHtcttcKatYatatBaagtcgctBtgagccatatScctKaagaaKDaWactWagBg +ctgattBagKtgaaataBaaaaagSacScaaagagtagcgaDaYtaMcaYcKtaataMat +ttttaactttgYgtcgaaggacgcHctBcgYgaaVacRYagagBaaYgtagattgcgagt +caagtStDagatBgtgaccctaSWtctDgactaSHttctWatWttctaWtatctYacact +gBWatKKctgtatYgacaaHSatYSaNgSagtatagatgagtatttatgaccMaatgtaH +tStaWttgYagccaWattcagtBaYtaaNaBtaNatactggcttWcaagatDctacggaN +ctatcacatSgKgattgacgacccccgagtNDtattgagaaatattaatcVttNKtaaWt +YacgSNcBHgttgWtatgtttcgccaactKaattaRgacgNataatctacaacKgttBat +YatNMSaaaNtctKgacttatgcttatKtcaVtVcagDaataattYgNtRtHaagcaata +HcacaVgtaNNHtHDatgttaMNtggWagSVaRttcMVDtcttWgtRttctacKaaVttc +VcgcatcctHRKtattSgttSacgaagtcccRDVaacBWagtgYtKtgattgSgaBtgcc +BtcaKacaDatacttHatcattNatttacgtcagtgaggcBtaRNaRcaSgcatattatS +tatgctYcacgtattcattaaRtgStcttWgtattKtSYttNaHaRtNYcRaYtVtggtD +cKcttctactaMcacggcMtacgcttctatatHtaatggcattMDtaaMaKattgaagtB +aaKMVMNacKaDtttKNcgagctaaagtccMMtgagaagVaataatggcaWaaaaVaBgt +aSaVgaaaSaaaataDttVtBccaNagcSBgaMaDaVaVYYRVBgttYMtagtaactDta +agWaattBtattttMDYHtSaStScRaKatattacacctMttgNBKtcRtRggNagtYMa +ttaaatMctYgaatgcKHagSggaaaaBcaggtHtatWcatcgtStagMcctcatgatta +WRcStcgWtgRgttttcctaacatcgctcgDDtRaatatMgtcMtHtMaDYatgDattta +tagctKDtYHaaaaattaSatatctggtctttattttatMtgtYttgtcatactcaaVcY +BgatgSctKtYcctWaRaataWcMgNgcgggagtcttRMgactataHaHtgctNtVaatc +aaccacgSRaDtgKtaaMSKgtaaaaWaKtttVagSDtaaaaaatgttYattttNagMHa +aRtNgBttWattatatgcttatatcatttatKtKaaaagctRaaatcgcYgacgNtacNt +ccVtSaaatttcDVctaatacWgcaMtcttSaaWaaaWagtagtaattaactagRttaVc +SaaatataacHgHatWaattggaagtgcgSSgaaVtgYgSttccatWVataatcgaatat +gHtRcgtBttcttaaggatatgttgtBcNtaatgtcacVatactgaaatMBttRRcRatc +catagagggacatcgccWttagttgWttatKagtaaaagHtttccttSatVatKtgagca +atttattaaYVattcaaattctgSattRaMtgaatMgttattattacaNcggVagcctta +aKgccYcaaDattWtggMcttMacWttccMVgtgaattctDaBYgacttKYtBacatgct +DcRaaKaaRaatatctttagKcKtaactttaatNaaggctgScacctYgcgcaaaccaHt +tVHcBaDgtaatHaHVaaatMgttggtSatHtNNaaVagtgtacaataaagacgKttcaa +aWVacagctcacWHaatcctgtBNWtaNMKcVcVSWtSgcaattctgKtVVaaacaRaat +tgatRcgBacaKacVccVMactagcgMNaaactgataDaSgagaatVHaatVSVtccgga +tgRgtagRatttgtaactaBataVaggcaagHgaaSMSaKgctRagcStNcatttVgcta +tacttcNDtcaKBDcaHtDcaatagttHttattMBgagctgtaaagtMgatStStcagat +atYcBtataacRcaggRaaaggtaWSatKgatatgagcgtgMYatcagcatVttSgaaaa +aatatatgttYttcattatacataatVcacgattataDggttBtRaagtHMtatagaDgN +ttggDaKctBcaaRcgattcgtgccttacaaaWattYWVcaaWagDattgaaagggaaga +HattBtatVggtaHtWtaMagtccagaKttSatatcaStDtgWaagtKWaggtatttaWa +aRcattaatStgaaVtacggaacatKctacatHtaaaBtcNWatttBBaNatRcDattcg +aactataaattataactcagtSgatataagRaYaKHctggtaaNtttaaNgaRHtttatt +atacNttttaDccttYgtaaacaggaagtgataaacatBgaSgtaaaaaaVcBgtWNtRM +ttBttaaBgtaaaatatcHNStaBtaggtaVatYaccNtBaWagRctNSacRtMatDact +StVctaaDtaYSRgttaRNttttKggccagaaBcatagtYcaYNtDatcgtatVcaatWR +taggaattMcatRtgggatgtcMggMtttataagtaBgtggacNaaKYtgctWgagYtWc +ctWtVcttaaactaRacatggtRcatctSDcHcMgcaactttttagttaccttattHRgt +acggcactDBggtMHcVaaRatKctSHacctacaccactaaHaacgSttagKtKttttgN +HVgagtaYaMtVYNVcggttaSBaBtaatttSRcgtBgaWaatctttttKggacaWKaat +tKSaccttgDRgtcatatDatVMtMaVcgaattaNaagMWccctaaHgataatatgtatt +WataaaatBaaMtgRttcHctaagctaagatatattMcggactaRttttKaSttactWYt +gBcaMMacRRgNtactttaaaSKtttcaYBaBttaVagtRtHcWaggaVccttNgtgagt +catataWttYScMtWgVRgattWtaSggacggWWctBHatattataaKaagttactaMRa +aataSRaDttDaaatataVHaatggaaBDgWgHtcKStVcatHtaatcatggBWaagHta +gtMtgHcHtcatggggWcatacaHNHagcDatRcaaattcgcttgDggDNVcaacgSgtg +gcaccttMttaatattVYtVgaagRttaBcagVaYaHcaRDBagatgaVHtNMtcttact +DaggMgMaattRWDcctVtgagaaaaSKatHHttVDgtctgtcacatHNttgaatSaagt +KBatatagacaaRVctcWtgtacKtaacHtgHataSgVtactaggtttatggBgtcaaaY +aDgaaaaaatcgMtagaKaYatgaattatYcttKtacaatttgWttMaatBgaatSttMt +NaVgVtScgcttctBHKgtaRcNBaatcDtacgattgacgtgctatNaaBtMgagNgKct +tWcWKacactYgttVgNcgaattttcttgaaaaactacccctcgcNtgMctatcccacMc +actcMatttatttagtagaacMNtttcttgYKaWtaaBtttcWttagHtgtttctcttgt +ggctatgDgctaatWDataatttagaNcgcRRNataKtctaataHgaaMYctNaKWtact +aacDtgaVcgagaactggtaccaactHgaggctagagHHagtMgKtaaactacaggMatg +tYgSBaKaaaattMgatRtggggtHBVgttaattgKttaaRDacgMactcaaacStaaag +ctctgtgccttcgtSagtSaRctacaataKatattctaVgtgtaattRacKagttattga +MtaatgaNatacDataaggactttccNtStatatKaagaataKtatggtcctctatgagg +ttaaDtgtattgataaaactggatcactKBtttggcgtcaaagaaaNtagtWKatctaaW +BactDaBaYtacaWtaSgcaattattWgaaBgactgaKctatBRgtagttaBaRRgattt +aagBHctStgtVYRtaaataaagtMWtcHgcattcacaaMWtcMccWttgVgcHaWttca +NtgtVaggNgcVatKttataaWDcccctatgatVttttattacagRBBWttcttRaWgaa +tBVgcgtHgWgaccagtYacaattgSttaaMcVtDatttaVttRgttKtcaYWatKtaaD +tttWaYtaatYctSctatagtcctBtccMaMMtaMYHaSSgKaaacttctcBtMtgDtgt +ttttagRcgtacttataHgKtNtMtKcBtaNKaHStgSagYHtataDtcKtagRtNWaac +VgctVtRtttStNtgaaccttaVatgagaaggtcaKSttaDataagcYaSatNStcaatD +NgttcgacaatttaSgaRaBNNacattRatNtgSttHVtgWHgtSHccaactKttYtatH +YttVtgHcNgactMcaacttBatatgSgattttacgtatttgtggtScaacggYtHtgca +tctatttttWtaSatcagaYatcgcagtgtgtMgtattctttcattaRatttStcaatat +gcttDtStaaagaccDcVtaWNcHYtWMaMcgaacKcaNcttacctaBtgcDacatcaHK +tRcDaaacataaRacNNtccDataNactttatBSDYatDtctBtaBatctDatKaMcatt +MatatcDHctaagRgYVcatgttcgtgataHDYaagttSgHYctaaatgtaaaactNgta +gaaactaattRaatcttttBKcgaatSctMaggVaVaaatgagataaataSgttKgtcat +KaKatDYtaaaRttYaMtgctcSatRtagttttagcaaNtaKgatcgWYcacDgaatcaa +tactgBgaNtaactaaWatatacaatacactaNatcaVaKaaMaaaaaatcaccBtgttg +NctaacaBattttaaKWcaggataWMtaattgtaaHtgVtcgaHtScaHtctcHacVata +gtaMcaaKtcccSagMYtWcaaatHHtaagRttDagtMtcYtttaaWWaaaVaRtcHNtc +tcSttagcacaKttgtagtNgWYtatKDtcatttgaacctcKHtatccttattcttNggt +BgtgtKaggWtYgtStgtVaRtaRaaagtagtgtcgcKtKagatgagYtttaatKcScct +gaaaaaRaaHtttttaaaVgtatagKctaNtKaSVgttcgagacattttRSatagttSac +ataMtaYHccacttttctatactagtatgaBaagctttaMtgaatgtcaKYtaaatatgg +attataNcgBHatcctaRaaactgttgacttYaHtStcatcctDaMBttgtaWgagtaat +WKataaaBgBattcttttctttaatWStaatacgNaagtWaMaaNgactMtgaaDaggaa +aSctaSSgatatDttattatcatagBcaataVcHcRgcStaHaaatWagatHttMHacta +RacttaYaaaaNtataHKVaataKtatgatcgtcVaaWgttYtVcaaYggctRWttaaKt +RttDaKtgtatcaattWKaatBHaaaaNgaatggStHgVVgatMgBYtaRNgBDttMcNt +ggaNgtcaHtgttDcNaggBtatYtacVaNttctcWtactHYcSctgtYtDtgWaatcHg +atDatatcHtcttatattaaKaRYaDgaatgSYcgactgcRgaagttagtStYatYtttc +cgacactacagKcaaagDttaatVatcttaaacRaDatRcBatKNtNtaaaHtcBgatKH +cWStSRaKaSMgtaKaBacWgDDttgYaaYttaNtDgHtatSaSataaaaMBaaDtaMat +DaagWtggaMtRcacttatggctNataaaaatatWNMtacctatgtcaYKaRacagttHD +agccgtaaYcaatataatcatagggaaSatgMYBcKBBtaaRVRatRtccVtgtgaagVN +ttcttagtgtcWataVggtaaNaatVgVaKctttNgtttagtaaagBatBtgaYSagHtt +SYaacaStcgcagaSttcDBtKtttggtctacNttgNgKNNtcaaaaKWactgaaYgaYa +ctatHtaWcaactgttSatNVtgtctSttYctgattVaatKgtaYcaaattSgttaStat +ggtccaatgSWccaaactattgccgttacgcNatcHctctcaKatgtagtctattttaag +gHRatcDaagSaVgaVNccaBKtacgtttStagKgtctaHtcattaYcctaVKtttaYaa +atYtccgataaaVttcDgatWcgBtcctaatttNaattgctDYgtgatcaatttaagggc +tctcatcKattgBtaBagcaYcKctctttNtaacHacNStggRtMatHHgtacatgcaMa +gtgtccatRWttRKctaaaDtcMctttaNVgaNtcMatcacHcctgWtaaStcacgtctN +aagRNNaagMaDtactDgctttttcatcYacttaKttatgcStDaStNaMgDtaacKtMt +acctaaWattggtttNaaVHatgaaattaattacgVNaaWtggaWatctgVatcacYctc +VHMtVaNacNtcccaWtttgcaacctcWctHaatcttWcaaaYaBaattSctYatctaag +DgBttagtaSgaWtBcRcKtccYatatcKBgtctttatgaaHDcgNaMatggatgtWagR +ctStagagaagaacagctWtNtataaaataRatHatKgctNactHgttRgRgVcRacatg +HYaNttaHtattaNStaagatgtagaHcVctcYgggccYcaaaatgatcttctagctctH +MaMMgcaVtgHgtaagaWHHtggtaactBcaMNNctagaacggWtctttgaggHcYNaaM +HtaYcttKaagtSccgttgggNMStatacDttataaaVaYcKtcgcattttcgacctctc +acVttNtttattgtcttctaVcatagaattMttgtHtMgacataaatagttctMtgtWgW +ctttcaagYgcgtNaagcaaDaVHaaStMtaaagccccgtgVgtcacatcHVaDtgttBt +BacBtcggYttDagaDYtccMttagcttacNcgaagatRtDataRtgctaatatatgRtW +VttatWKtgcBgactcgagaSgtaaaaagttaaWaaagtatttctcWtatcBtcataacN +cgctcRKaaDKactRaNtagtatBtgaaatttcgcDactttaNtYgagagaNttgaatta +ataaaSMattRHNtYtgttgaDBRBttgWttagSatgacDggNVagRWcggctacDaYSg +aaattHgtYaaagctccVtatacattaMctttgSgacatBKaattRgtaBRtttaactat +tctagcMKMtttctgtgtgVgtctttcDcgtaaMtaggtaaaDtcaYtatccgattcYtg +aaRttctKaNctaYgYaattYgRttWctWttaaaccaatcactVatgcgYttgaaatgat +KBcNRgctcatgaccHagcgaaaatgtVgccatcaBSatKccRStSattaaatttggtaa +gcVattctgVcattMtacatMgaaaaaataYNDtDaatcatWattcaggNcaccctcBtg +cKcHagYtatBatgBttgtVttaYBgBgataaHNtacRtcaaBaKcagNtcagaatYgtt +WgggaNDagtatagRtctcDtDaHScagttcYcatcSYacHcagagNgtgcHagtacagc +tgRtatatMtaatRaWMHgaaKacaBRtagHtaaaNcVHcatWBgWaaacWccggtaaRc +attgMgttaNgttVMVttgcaagagaatcaaaaaagYScKVtgccgacHgacgttcaMcc +tcattatgcBttttaagtKatDactccgBatHYgttcatcgaaatctSaKaagaatWVtc +gttgtcttaMaaYaSDtaaaataccgcKMtatgKtgScaaDMaaaactgtgagcVtttaR +cttgtaNMatatatttggtMgYVatDaatttgctttaaRtaBgttaYaaagKtataMtWS +tcHaaaaNacgctacMttDDgactacaNaatBcagtcattatatSttaVgRtWgSggcaa +tSataVgSYgctBttataaYRRgaactgtgHtgacHWSactYNgtttBactatWStaNtc +StcMttgattStacctgaattctWatNaaHgMatattcaaaKWaBaataatHKgaWgata +YcaWMBtgtacKagaaaaagaattttWttDaMtggttgtgaNMtVtDcaacNttactatt +acggKctatttaaaaBKatagttHaatggaatatYWgtaVtNaaYgataatMaccWagag +atRttMtgKaMcgatattaacaagatgttBBcNaYattcNgtRttgaBcctaagaSMttc +MtcctcYattcaNaRBttaatgVcMNgaacKagatcgNctaWVgttaaYRtgctSctaaa +aNtttgctaaScttcVattaHtaaMacNgttNtKHMcctattttaRtttVtSgtacatBg +tVaaSSaMVaRBcaSaRHtaWtWHttMtattVcaMtWaaaNaccccgHYtcatagaaRta +aBaatttaBccaatcRctcatagWgcBHRtacaaDttcBgaHggcgctaHtgacagcSNa +ttcctcgagaccBggtcaagWctgVcRDgVtaagtttaattatcMtgatNagYttHtYta +gccRatagDtaatcNtaKtacaMSgDaaaatttgHaHtRDgtaattKtaMHgaBcaWtBN +YaWgtttStttaSttgataatgactMKatHBtttaVcYatgggttttaDKcSatttMata +tcagtYaBtgVacaatHcaDMcccgtaataatagDataatVaaagaagaVtctccgaRgt +RtaatcgagtcacttgttSatgNDHaSNRcggtaSaagcSaBgWSgcatcaaWatgttac +atgattcWacMtagtgNcacgatgatttttRcWttSgtaatMRRBaacNWRHaaBaattD +aagStgatccttcaDacccctKaagScSSHaaYHWcHcaWcaaaMBataattgDtagccW +tcRHataMNKtMgHaBcatcgaagtgtaRgtgggaVMatgttaWRtStBHactaaRaact +NctcHaaaggcatgcVHKHgaatcSccttggSaWatWtNcaaBctaRagaaacacgcttc +KatRattcWtgYDaaaaaaNatWtKgaacgtNttactgWHBaccaWacggttcaaVgaga +aacVtMttatagaagtatWtaaaNHYaMacagWagtaatttgcatcttcgaatacggaHt +aatVattctaDaHtRKRaNHcttacatcDKttMDKaWggDtaatcttYctcWtRaaaaKt +aatcctgccccatgcgDtctaaVMtWRKKDctaatatDgactagWtaaaBcKcacMactM +HHttgDataKHDaDttHttatttagtcaaVatccKWtacWtSVcaggtaatatDSatgcc +tKtatDtttagacKaaaagcgtttaaSaaaYtgattgtKtgBMcKttgDaaaagttBRat +HgcaKgDgtgcWataatMWgcVaVatcYgWttaDatcatNaVgtttgggcttgaHRDaWg +atttctgMHgtVtgccttBtWtaatcgttcgKgRcaBaRMtaattWgctaatMaVBccaH +tDagaBNaataRcacYcYcHcatBgaNtgaNgKHttctYaacaaaYgBttRNtNggaagc +WtDggattgagtHaWttVacaaaBtgttaNctaatactKaMaaaaaDtaRatttDaaagN +ttcYcaaactcMgaYgtacaaatMaaatYtcacVaacgaaDagatWgBgaataggtWtKa +aMtgDttHtgagttaatttgVaaDagttNMataatttaSVattNaDtKVccaaatcgaYV +taaaacKRaataatgaBDtctRtgVcttatttYtgaHgttBWatgaatatacSaacctSa +tNNRccagtactKagaRtgSKMcgaaDattttagtHcKcaaagtggtataaaggctccta +SatHtaMtRKattaNRcWtccgctataKggatWttaggtaatHDRatttattRWgcgatc +ttagSgtcttactatgYgttYaVBtgcaYaaRtDaatacHHtDcttHgBgNcccataDta +aaaatctNtacatatWaRMBgaattaaaacgctctctcaagtKcacNacgVRVcttttta +acttgctcStatRScaRaMataNaKagtatcattRttNaVatcKgtacNatttttgaNcg +acaaKctHWtgaKStacMaBatgWttNSacaaKcaDaatcWaKaccgYBggMScgaMcct +agcaDatgtttcVatgtRBtKNWHtcctWDtatttttNNSaatattcMttgatKgNgaNB +atcSggtctRcttttttatatggtNttDYNYgaaaKctcacacYHRgttacatacttYac +aataNaagaaaagttataNaataSatacagttScacVaScaccSWtccagKHtaatcaaa +tVacatWacgBctccaataHaaYtMtacKacHttttKtcataWWtgtgaatWaataaaaa +catttcaccttaHtttgttccaatcccgRBaWgatKgagtttBaVgaNtaNVBgcaataa +gaatagcaKRttgtatcaattaMtaacatataDBgtaaNttcaNcgagatYactggttat +gtNVtaBNtDaaDtDttaSaWtactaVtHactttNttcttcatWttcDatKaacgtttgg +VDaDtVagttatgtcagactKaatcaYtSgttttataaataDttKttKagacWgHgatat +aaatcttagatNKtttWtWaaatattacSHaRgtttScttaatWttacgRRaaMactcat +BacaccatRtttgaacctacttcDMggcVaSBagaatcttaKMagcaVtctDVataWtSg +atagacttBctDtBNWgtgKatWctYgaaStccgVaaaDattYatagtatcaacBaWYct +gaaatttaKVgYtStNtcaVggtggaNYgaRtMaacataSttcagacVactcaVaagtgg +tattaaDBNDaagtatatMtactatatgatRSgtttgccaacgcacRMtacRYNataaga +tcMgttgatcataaacttVcatatgWtacaaaWttggaaactttaScataactRattMtD +acVYataaaagMaattttKtgaBttKcaacatattVtagtcatgactcgDaacDtaWcta +tRttSSYNtgWaScaaataagaaatKtagacataatggNaatttcSKtVWtgacagKWat +tcgVatttcKWgagcaWgNKaaaatatgtaaacgttcactaaWgacaccBNaacagaaSt +ctgctaHcVtttMtcYttStagYcgtttBcRtaYacttgNaacMtDRtagcatgtgcgag +cScaMgtaatBaKataactMttttattaRcattattatacgtaagSNatVRgcttcgaVa +acHNtctaHBKYgKaccYcttagagcccaVgatttgttagactaaacgtgcaBgccaWga +VataggattDBWaattttgtBacWtttttaatDtMgaactaagcVtctcagBMKatgatt +gaNaVttggatDaSaBatttcgccatatgctaattgYacatgatccacaaMHtttcKYKa +WtYcgDtNaaDccgNaNcacacHKttDtttaggctagRVtYgtaactagctttcacaaat +YtHaattYacaattaMSagMactcctcatgtScttcaaYtataaaaScHYaKcaYacact +VcacataNtaBcaRatgYagVBatttgtaactttgRggacaagcVacctattacRcaaMa +cHRagagtaVNctacagtgagacgaaaggKttacattgggacaataKNtattcaagWKtt +gatNagNtgctaNgagatNacSatctNatttatctatRgaaaatKatNKSBcKactatac +StcagtaggtVtcaaaBYYgctattKtWNttcRacaaaNatgaacttaRtaaDSttVBYt +aatccagtNaaacRttagaaccRBatataWaatKctcattcSacWaacaacactDttVtt +gacYaagagtaSgcMttBttaVNgRVagKDcttcttcNtaggttgcgacYacttaaggVH +caagDagaagataaVaatctgtatRatDtKaaSDgattcaattYtcatgYgtgaVMtMaa +ctaagaatgRgDtHttaaccaatStaaaaMctVDDtgttatcttaBBgccNacKMaHggc +BMttctgNctHggagaataYMgtaMccaataattHttYttKggtKaccaactcccHtMSa +atNactcRtttcatgcKcatgcacttcatSaatatactttVtaYttDattgWcctcactc +YccattaDDaHaaKcaatSttagKtWtcatRcaactattaattYaDggKtagtNcgSgtt +tKRgtDWtVHtDNcHWNtKtccgtctagtatSctaBcacgcaBtaacatgagatVtttaa +ggcaVttBttaStWtattgYaggtSatBMBDactVtggttDagacataaactactBgcac +aacMaagaStccaWNaaSYMYtgtaKaMcYSaHaaaatatttMgtcaaDScaKtcaBVta +MVMRRDMtcttRBgWctaacttgaacNaatgttWgtggBtRttHVKgKcHVtatattSaa +aatBttcBtttcDgHccBagtRBRttaVagBctRcaagcattacKccaWVWtaVcggtta +tNaSgccgKtYcBaagcWgcatgaNHaKtagNgcHcgtgtcataaaatagagacttgHYa +tattctaBgtttatRatctatttagacattttNtWaaSagtaHatRtctcggatttatgt +gatBtctRggggcatWctaSVMaRtcatgKattgRcatMaHaataNcBcDcaggcactat +tHBgaatStatattcatBgMVataaSacVacKHatggttaaBKtgtaSaWMattttMacK +tgaaWaaWgctgRatgtgDacBtSaHtDgtgtMVttagatgattagagaSttgattgtSa +aacagHaaatacaRcaccBtaaDtcaMtKaaStttatKagaataaNcaaBtattKaVNaW +aNactagtYattaaagWgHttaMcKaSagatSactctatMSagtggaYctcacKKgaSMg +cRgKtgccagNMataatccaVgatcttHagttttcttaaccataggggcttaDtYatcga +aaMataagcaaatBttgHHcHagacagagaggcacWtacccMttacgtgNttattYctVa +aactgttaagtKatMagttcacaaagggatgaVNMatgcaSattatcKagtHaBtgaagB +cggagtWttVaaDaccMScactgVatccaRaSatattNtgcBatgBaaNgtcaBMgggaa +tgagtatRgaatgtNttacaggcttaHaataaHSagatagtgVctattaaagggaagDWV +ccatcKaaaatRccccaSVaaatttMtatStgtWagtStMaaatBctgcctKWgttDDaS +KactctaaVRtaSWcVactggaaaaNMaaaccgcacNtaVgaagcttDNgaDBtaMaMKN +tKccaVtgctcttMMYaaaaHaattcWgHcgtacatWaMaaKtaataccgBDaYRaggat +atSKcScYagMtaatKHMtaaccatgHgtagDaggtgtaaatatagaKVgccRYctcRaK +BKWtgatHYcaHgBaYtttMcatataatgaDttcatttaStgtcVSgacggtggVgtBtg +acatgtaaSgtBgatKtKtaYcatVtNattataaaHaSccHaaagctSMKattcatagca +cagtgBRataacaatMttKcWaaaaatagStcggRttaattatWaataatMaYagatgVt +atccttttHaScgtBgagWcatgBtgcctatcgtaaWHacagtactgaattaaaaaNatt +RNMaSSNSctattcaaagccVVcatattttagMcgtattNtVBactacScattgKVtata +aKtttgNaWcttNacctagtgaNaaDcagtaWgKggaaKtacgcaaaYttatacSttgYa +YttcDNagggttVDagHatSgtacYVatataVattataSataacgKgatVtVacHYRWtt +atcctaaDtgtaaDgRDttttattWtaaDttggatcattNgtVaaaVggaaggcYgSWaa +attcWHcgaSaVWaMatctMDtHBgttttaatctaWaagatatDKtVttaccgaMatRaa +aBttaNagHatDHWcDtBVttaatKtMataYttSRHHcgtaHDtggttccaaagRRtaWt +VctRcaNDttatacgatMcaatNHtacgaattBaatHtcccatctctccBtgtataYcta +tgtcgaaDYWtNggatNcacRtMaatNtKcttSYSctaDaaaggctDaStatKtataBgc +VaatttggYcttaaatgatgtHctaaccaactttgggttcMaaDattatKtVacgVcSca +actSataSccHttYctttgtggcDtMcactaNSBtMRBMaggttWKtattaatgtKHact +tcaMVatctgttgtccaaYNtaagttKaacttctHcgcWtYttatMBgBaMacaattaDa +actNaaatSatcVtSSgatctatgNatSYaattRatgcDgtctataagagaagRgatatt +tcccaataHgttttWKtgaagNRtctaaBtWcHHcDgaattgaaaKtgttaaRtatgtaM +aggDttcMaccaMaattDctgYctaWtStaNtgRKaBtNcMHcSttMtaKccYacgNNct +ttatStgVtaYtaagttaagaBHaaStVKHatgttRVWtataMtSatgcaattcMcttat +KgMcagtgaatcYtcctNaYcttactttctcttcatggcgNcatScStBtagctWtHaaW +attaccgtctcgtBMcaaacKctcccaacttBgtWStVttMRgKcVagHttVtaagMaNa +tcaHttacatcYKttDBtatgSattVcgBcBVYttHNtcatKgcYgaaSaKtatttttMt +ctatctaSaattDttcWagHSacgttagYgacWaSaDKatcNgctaatgVSctgctYgaK +gKtaataggtggagcgtcgaaaaRYtgYWYSaatacBgacWtaNStcaattWtRctttta +aSYgttcNgtBWWgtgaatHttttBaMcMtKccagtattttcgaHaDtSVgatgaacatg +cacgtcagagDYattBcagDctcttNcNtaaaatRctgMcDacaagtttagtcaaSSaag +aaacatacaDtctctYgcaaacBcaagaBatgtattgacgagYacBDgttcgtgRtaMga +attttcNtgVcttctgtctagtgtccatatctgatYatNtatVWgttacaDacaHDDagW +tgataWtatcaaBRatDRtMgVcgaaattcSMagYgWacgggtaacaaattcagcatagS +gttactBctgSVWatYcYgcBWgggRcHtataSaattBcagHgcgcctttKcttWaggct +ttaaDtRacBactaaVaaKtaaacctcgcgccattactKactKSDcgacaVtatatagga +taKctcgSatgHSatVcgtagtgaBtSYtgaBataatStaaccaagttcaDtHtatatta +acYatattatcctacgagatcaccgtVSttctYgtcataaVactcgWtaVatttgttgga +ctaaaVcaSaDtYcgNtYtctVaMtaattatWRtWcaNtaKcaaYggatgNgaatcaatc +RtcgagtHcgVgttataHDcatttaagttctHtcgMRHtaaagaVactBMtatgaagtaa +aaaBNtataaNttcKcctaNttaaDtcgMacgDcaMatttgYtaaNtcaccgatgagMtg +ttaggWcacHttNgtcttHYMcaattKcagttcNcaaaacgNaaSattgKttaaBaKtta +tttaMggHcttttaaRNVgttaYttttMVRtYVgRatKcgVtacgaatttccBatBgYBR +tSKKctaaaatgatatgBtcttcgtttgacHagtaattatatctgDtBttatgaDtatKt +cKRcRttagattattagHgDNaaaKgcgMtHtttKtDtgaaaagtaMatcagaaccgaat +KgtatatVaccRaKYtDHtcSagtBgtgccWaaaggtYKcaHatDDaaattDStDtcKgg +tMgcMtgtHtcaaVcgtttNtagtNtgKgctaDcScgBcWSatgtatagcKgWgttgaac +gagtgcgcgtKaaaacgRtttccatatatttttMgaKagcVcVRataccWctctcgBcga +ggcgttaatgaHYtttHtaSWtagcagtttKtYaacaaataMtaNDatRgMBaBacSaat +aSDctgaactattgataaRtaVtttHatWaacWtVaHaaBDtactYtaDactttSgtKtR +attgatttatatattattataattBatagattctaacDcRMaaggttcgtcatattRVYc +ttKgtRcgWaatcgaaWWatDctacaaaagaattHaatctgttttacYatKatBaccMaM +aaVtcacStaaYgYKgtttctcattatattNgSaaHtgRaBtcataKYtHtacttgtaca +aaDtYtgatagNRcYatgaStaaagactgtcWDtYaatVaNStagaaaWtaaaataDYtc +aMatSVBVaaaYagaaaattgtgcDagWSaStattttaatNcacgataNBtaattggaat +gcMgacattHaattctctaaMatactaBaaattacaHWgBNtNaaSattttaacHtgtag +tBtcRtttSaNNaYaMaDtatDtagaKggYgcaaSttgctactDcNRtWgtttaVtggca +aactattgSgaagtattatgDgcgtgtcttagcNtRctKggtMaHgaDaaagtactgtcg +atttagatcagNggtaattaKaatgaaYaaHaattggttVaaMggatactctaBgtYHMc +ttccVcaaWtgttHHRgagttKaaagaBtaRtaaWaggttctatRatSgtatcYtaWcat +gtaBtcaatctaatRgaYYtWtccattataBacttWtcctaHaaaaggttgacgtRattK +gaagcattSBtttctaNcSctSStNtYtWaWtgtagtcttgtctttaagNKgaagacgDa +RgtNaBaVDgaattggaYtaccSVYKctSKKcatagttgSttatcStactcaatSMataH +caKgatWVYtNacagtttBtRagYHaagtaNaaVVDgatattMaagattagcatcctaMa +aMctgNtMcSaRcgctHMttaattDtttYttcgataaagtMtaagttaWaaDcaatccKg +tgMMcatBgtRtaHBcttgtBaBggcaDcgaWttgggtaDaggtgatRtYaMWDttatcN +tVcttRaKagctRgtgcNaatctgattatagattagtatatgaataDNatcYaggKRaca +atcaHcaagttagtKgRatRgttaagaaaatacVctaaaagtgtaagKVgcttSWaaHat +agHctagtDgDtSaVtgatcatttaNKgKHataKBctatatWaNgtttgcRaVNttaDgt +cttagHYKatYaVaBtaatgaBattaYcNtgcaBtHaacttVtccatDagVaaaYgWtND +BgacagVgctcaRtaHaaacttttacaaggaSRaaatagaagaatacccVaHatcBRtct +tttaaDMHWtHgacMtctcaagKDttctgYctctcNagaMgcgaaDWatMcMatatttDc +tttactaVSctagttcaRKWgtttKRaVaaKtacaacaKttatttttggcctataaDgtc +BctBDgcYYaatNactcaaRgaRWcgattgVNcWaatctgKagDMgctatKttRatcatt +MaagtctaRaVaattKctgaKtatccgaaRatcHMaaaaaagattccacgtacgaDStat +atctcataggtacgcgatgtgaaggtHYtatWagKVKgaMDcaatttWccttgKgagtct +agatgaatgVRcctaMttgtaRaaYtRtaacWgaaaMttatcatNcgttactaaggtDaa +ggcagtRctcatcaatggYagccagcgaatatagtgttWtaccaRctagatttDtaaatR +cDKtccHtBWgttctWaagccYBSgtggaaagHNttHtctaaattaBatggaDMgaBgat +atcaatactcMtaaKtcYccgatDaYgHDBaagBattWattgatttttaagaRaaggatg +gYggaKttaKtBVBcttaWcttBtacctYaNYttgctgtBaaMtWtcWaagtaaggWcgM +DaaNtccWMWtatcMVgaSaRctaKtBgKWDacDgaaaaNgttcaaaaataMcttaWtat +gNaVaaRataWtgKctRatataagtgttgacgaKgaNgtaHattaaRagSgattctatgt +YtcaattagBYBatccYtgtNacHagHtacVcVacaacaccgNgBtataYaatWHSttat +tgctDacttgtgHgHcMcHacagctRSDtgattaggaDHtYagatggagWtaMatcRccc +acRaaaYagcagatgatacatatttVBBcaaMtctctaWgaNtttcctaVcttaYBDBct +RgSaagcNgatttcacgtcRDaVBttaRaggtaaggHcacttccgDBKgagaatttataa +aMaRattagcVgtttacaaagagaaaMtgDtttYttggcttataKaStacaVttBttctt +gBcVaataaagagtgagBgcgNcNattgaaacRcactDaaccaatWMtaaHtBgaaacaa +ccctcMctcaaatctMWttggttttacttagcRtttacatRtccBttVcatgaaBacaYg +agHttatWDtcctSatRtYggHtNMttRgNtgcatcacgacagaHgtYaSaactgaaNWV +agtagttagaNgatctgcatWYaDacataHtaWttaatHaDgactYgttcaSVtttacct +aatttaDgRcagacaDtgcYVttaagaSSKBYtgHtDtNtcgtcWttDtgtcNtgacKag +cactccDMacDNcccctWataRKcaaatttctRVaacagcaMtataaattWBctttgKgV +catttaVgtDgtatHtgtaSctagtatagcBtBtgtatgtcgcMcgagttctacgaaBgW +ccgaWatgcaRtWtaagYttaNtcWaHtgattYDatWRgRWagtRcHggNatNttWaaac +aSgcaatMatgacNgggaSatgatttcBHcctaaggWactacagaaaagctMcaaagaYt +HVgtaaHKgKattVaWtttcctaWgaKattatgMaattBgaaagtgaSaaaWtSNBtttY +ataVgNatgaSgcBaaccatattcctctagRtattatctttctMtgaRtctcYgaatDtR +cHgcRVtWtaacDtcacYatRcttNgcgaDtVctWtacHtatatgtatKaaggtaNcata +KRaataacacDctcctWgtSaWcatcDgatatBtaatHSNBtcaataaStHtacttaYaD +aMtaagMtgNaaaaNccccgYWHaatgcBcttaBcgtMBKggccaVgacaWgaaaaaVYc +RKctMgcaccWctcSacttcVtacgaagtYtcctttttaYgttattaataactSttRggt +cVgagWRStatKataYcaatNMtacttcgcttVBaYRaKttaaYatacagctBgagcttc +HcaatBaaaVcgctcacaMgttaHaggctaDtSgatattggggBgRMagtaattggattg +YYHtVtcttSRYaacttataBtNKgatVaWSDWacatVcttgttgaagScaDaSttcact +aattagatKttaMcHtMgKccaYatKataMcKNgattgtYtaaRHHcaWagctgtgcYat +MHaatRDgtgttYctatNKtSDtaKgcBttgagtKtacatgaaggcgMatDaWtcBatag +taaaatNYtSVgVatttcaNgRtaRaaNBttggaatVgaaaaagaaggtgNtttVBgcct +tgtgaBtgMgtaaacBgtactWgtaacctatatggaSYattYtVgtttaagccaRtatRM +cgWMgDVSNgataatBRccNagagStHttBgctaBagatattaacaagaggttttcDaRa +gtcDgtHttcataagaacaKBttaBgactaRatgaaDYHttgVagcMcBDgYactWgSga +cBataMMcttSaRHgcagKcgaaYaDgttcataYKcttcMWttattaaBacDcttDtttB +catVggttVHtgtMgKcgaaVgtcgMaaHHYBMaHtaaKaDttaNgNtttttaggMcWtt +NaaaDaaaaactRgaatagSVHtaataagttStccaatcHataatacMcattHtacaatt +tctgatggacatatgcaaacaKBatgcagacagVcctccgcaacNatcMaHtcMtaSctg +taYgtStcBtcatDacRggttRgagaaHatVcttYWgaDtatgYcaBKgtSWVYtttctW +ttHtctaYttttaBtcataaNgtBRaNcgttKgtgVKgggVtWatcWagttSttttttaM +aRWtccgttttattaHatttBVtataSctRWtgcMacaattaStBcacggaatRatactV +gaagMaaagWacaMgctaacaHctHtaatacacgaYagtcttKagcDttaKBHccgtaHa +acaKVtcMKcaataaaNaggttSaatcatgaNaaBtacggBcaagatcRgttttHaNgtK +ctYatBHHtaaaDNHtaVtVagttVacKtcYgcattcatacaaagtaacKaKKtaaNtNa +taaNaaSaBtagaattctgacacNtaHtataBDttBctataatagYSctgtaHcgccgaM +BaggttaMHtKgttactaaHaacgDatataaagcaWtgaMtttgVatcKaattcgHVNat +NgDaaYtataHacaaacaagagtatatDStgcNgcRtaaWVVaDStNgtcaaacgDttaa +ggNttWcaVNaccctgaaaMcagVYVaMtBgtatacSacgSgNtaaaDtRaBSaWcNacg +YaggtcaYtattagVStaccgatgSStMattctWtattHtHaDtatgYaatattgtttta +NggttVatcttRcgaNtHaVaStgaagactcacaaatcactgataaKBtNHtttctWWta +ttgactacNtaWatataaaBaatBttgggtatYtttYtgttttVttgagtcVaMVgaatN +taaNgKMaacgtaatattKWggcagtgRttgtgacactaaYacactggaaKaWYRgcatg +cgttctBcttggtVaaWgtttHagtcaatctcggaNWtaatBNcaMVKStaNcMtgatat +aatDYMctttcgcatgcYtHtVNgStggagcBtggMgccctgtgNtVatactgcctcHca +taDBtaStgNcagaYttaMtcaYtgtagatDaagaHaaaRcRataattcaDtcaDgttgt +atRaaaaYaRgtttDBgDcgaagcNttgcVttcacttaMgtMWaYaattcggaDcgaVtY +attaBYaaaattaHVttttWaacDttaRaSWactcBgaRctacaVStBaaatRgaacMSa +agaatagYtNctcaatagctNttaVtgctgtttgYcttaatgtgMaStactgDBagVSgg +tSKMYttDatgtMaaSaVtccSRMgaaaactHaatWWtcatttctDgcMcggVtgtRtca +tctttNatcaatatYaKaaaatKWtDDDaaactaagtacRHtcKttacaataggttWctt +ataSaYctgctVtaaVggatcctaHVttgWtgHtWttaDHaNgaccctatatgcWtNtta +cctaYtttDWtttaggHNgccatattacKggattVatatcRcggRWMtgcaVRaaHgtaa +taattttaggtctcDccaatatgSaaaagatDtaaVtYgNaHBtcaYttaaaaacagata +taaagttaaaDWccMHMattggtaaagtccgaKtatDKaVHaBagaBatactataVttDt +tDaMagctctaaDSggtttgaDacacVatcttNtgatKtVaBStatgNtgDKYcaatcat +aWtcNatYccgRtcgBHacaBaatagaVtagcttgaKagcgHtttDNtgaagMttStttt +gDDKRWtagtaBgtgagtgBcaDtWtaHcctatHatttgttWgagcggDtgtRDRcaaat +agcacacRtDgtgVaWtaattRacVataBWacSYWVctgYtWDaVtaKataaacttKaaa +MVHaaaaKNtaaacttgVataaaatMaaatMaagtatcaaRtatSYRtBtaataattgtt +tgaWtaNNtctcaatNaataaaaaaattgaaaattattgtgttaaYatccccHtaNcatt +cacttttaMgVDtaDMtcaWSgYWcSYtSgaatHtgctagaVattaBtaaaYgatattcg +aaBtgaaDacacatRaagcgggagggDMtatDttaatttggaKSNtactRMttactgtBg +gcgtcatNttctattaVacgttccKtVttMacttWtctaYcacgtaVtaaRgKcttggat +SYatattttgttacaaMgtgagagaSatattWcagDttggNtNaaYtaggaaKtYHcttg +KattWagNgtaagHHVatYatcattaaaaaYtHgttcaaaataattatBgcaKWKtagaa +tagtatBagaaMtattMagaMtHcWgYcacgttagtgtDNggctatNatRcYYHtaacMa +SStattRagRcgataaaatWNNatgaaatttVtKcRtKtDtaaMcctccaDRcaHtBSWc +YtaKttcacaaMaataaMaactccgSgtYattDtaWctagatBtaatSgatgatHKgttg +caaaaagaScHtgaaHRDatSagatcBcggcatcatYVaatgMaatStgNgWaaaaMttg +cYaaagttSHaYgaaatHattBgtaaMRagSaSacBaagtttttcatgttaaYcagYtgK +tYctaStcaagcgtaVattaNatWtHgtHKNDtcNaKaVaStSacaaStttagaaataat +gcDSatgtaKtgMMtcaaagtNattacMYgtgctNgVcaaNcDtaaaVtYggtaaaactg +caagaWNcaaacctDSaaSgVaKtctcatataMtggBtaRttKtagRcctgttaHgWRaa +ttgDaaatttHtaccagctcagaccKaaBctaagtatWtaVagBgtttatgaHaaggatt +StaactWacKDVtMHccgtacaMWYctDtagatttRctaccRagtWcWgaaaaMcagttc +tgacSctaaaactgaatcacaNcaMWtWccYgtttNaatttggttaaNtggttSattttc +aacgYVccMtcgaactBtatcYttcYDVMttcgattaKWtatttagcaatatcagWatgc +RVaatgRtacWaVVBttggatRtaNgRagttDYataacDVBcaaactttgtttgaccata +gHMtRctaWcgacagtgcVcaaVgRgtaagtRaaaattSBKacBaatcagaatgtHattc +aVRtatVSSaKatNataWRVaaagMaacataDgataWHatcNYcMtatttggaSatttcH +cgacaYcaKaaatattacHcSaBVatHacactaMDataaaggcacaacaSacctgtaaRg +tcccaaaatWtDtagtcaagNtttgatDacDgcagaDcWgatDaaKagctDWtttatatW +gDcaaaWttStDtKtatSagVgaaKtaacgaccgMgaSaatRRcagYtgttNDggcHSca +aYDWtcaacgtaHgaStKtgMtRtaatccagtDaaacHgtacaaccHtagataNaattat +cVtgaKaaNaaaaaaaagttgMgtcRaNaacagtaKcaBgtttgaMDgDMacttattatg +aDgagcgtcacaaRaagtYaggMtaaactagaacagVaMWataggtatHagtttaaHtca +gtaaatgRgcatgRctgaMttBaaataagWVtcHctgtgtYaaaaVtKtaSaaBatMttt +gttatattattcaaBYctBWtggatBtgaggDagtgcacVataRBctaBaaaataatttt +tNggtccgtVaaaaataaattBHaatBaagaHgttaagcctaatcaaatgaYtKaatYta +aggtMgaRggtWgggNactaacgaRaaattSttWtaataaVtHgtacttNtaagHaSacg +WggaYggNStcctgacgDcgHggtttHggtNtMtttDatNDgtgacgtatacgatKatat +aaacaattSaaagcagatKtttSagcaaMttttgaKtMtagtcRacctKSttBttaatMt +gcgttacaaagaVaataattcaSaaWcBVacYKtacaNBaaKRtRtcgWtWBaRKVtYWW +WgattgBctaaatKaattaYtMtSBMBHDtBtaggDtcNctWYagtgSaaBaVtcttNgt +cgttHtgtMtctatKtatVggKaSaagtttattttatgtactactHtHttSMactatHca +agaattVataaaMKNtaMccgtgatDaHcaacttRataacaNgaatcSBtatgacBcctc +gggtaatWaaWtacacaattctRVgattctatgtgtatHagatagggacVaattttDtNa +WKagtatatHtagacgaggtatgtcagtgagHccccaatNataKMBaHtcWgctagtgHa +atBatSataDatatcacccaagattttcSatKgatWtgaagtcBMataaHaaMaattatg +cttWWtttcgVKYNBattggtacttcaaMaVNcctcHatcgctVcttKatgtctctBMgg +acatcaggacSgaKttgagtctKVYaaagtaaSgaaaHaWactgRattaaBttVaHtgga +ttagRWtaaDaaatgatttSMBWMaDactScgRYtgaVagNctgtSBataKacStHRatc +tVgBKaggccaRctaacttcYKtcaDcttgaaacBBataatacYMgWgctgtacttttat +gaSaaatYcccgattattRStccaaaBagaacaaaVtttgcttatagaaacacScccSaN +taaaaBgtaaggcDgtSttRatMYSWatcgtaacgtStBagttaVaaaScccSggaMDBS +gcaaKaggatatacgtatgcWactccgVctNttMaYtaaatKaaatgKStaaaHaKatat +gBtcctatgtVaBggaatBcgcaatgagtatHcYagctDgtWaaccagtatWWtaRtKag +atagtgKatatgaaaggcaWgtNKaaagataWaatHaaaaaKMaaatttBtatHtctNac +tKtBVVagtatcacgtMgtgttaKtaatcgaaMHtYKNcMaatgcaSaaDBaaaaagaWa +DtWMgaacatttDcatttaBaBtDttaaSMtcagcttttRWWaataattcNctactWaat +NaBaattaagaaacttYRHaccatatKtaKcNVgttYagttBtaaaaVtctcgVctagct +cgSVatatagVtMcaaHRctaHStttNtcattRaatgtaRtgttaatYtaagcattgaat +ttaKtctaKKgaaggtcgMctttcWaagcgWaKcttcYttgtgaRaagMtDatgWgYaat +aKaatSWScatKBtYgtaagagaVcacgctHStaacaSgBtgtaNRYaaWtWcKgaccDt +gaWtgagMaYgVVgBaRacYtcKgatcagttgtaKcgttgagNaStctggaatVtactaS +NtaaagtaatcaattaaVaaDattHDBaHKDHctVggcaaacccKMaatVtgttacBcct +StgBgMtScgaaHcatgctMtStaVttttcDaNagtDVaatYcggaDaYtaactaNgtcc +aattSacaaaaRgtagaaKgtcRSNtgatBacccttMtactatKgtaaRMagataMatgV +tVKagaRagtcagMgMaatRHNttagaagaatgggaatcHtttttSgtNgYatgtgcYta +atgDctMaaaMccVScgcRgKNaaagtaMtacaKaMNaBatagBttttcttttYatataN +aWcagatttgMtgaaacaBYtHaaatgtaDactatttNatttKttSattgBatSRtgKHt +tacgattgcggtaaaaacHHtaNgMcgHaVDtgtagaagatBaaagDttaacSatttaat +ttaccagatataattggVgaRctRtcgccVatRNtDgcagBcVaHtBaatDttatgKRKa +gataaRgcagtaKgagttatatcaMSagttccRcttaaatgatcttataaacaaatttcc +cttaBaWtagtagttMaacMaKaaaagHatYKactttRatgtctcgattBcSagaDKttt +HtBaccttNttVttVVtggttacgtaaBMRgatcgtctacaaNBtaVggttYaaggattc +caNgRgtagBtgtaBacaagtataaatBaaatKRtaMtKHgatcgYggDSgKRaSttHSt +catgtatatWacacRacHcatYtttaacYatatgtgttNtgcSagDHgataYttNattat +cVattcaaYttggtaRHtWtcgaBacgtttaBaccaBaatgtcgcNagaNtKtaDtgDta +tgDaBtcKgtBgatacNaccDDatttYtKggMtYNtaactgVacattaaHgMttatcgtH +MNtataBtKSgccaVttaBcttattcBaagtgaWtaRtcctDVRatgaattgatatgaWg +ccacDaatKaHtttacatNttaWNWgtacaggctacttBaYaaatatacaaaatttcgNH +gMgttHctcKYcttgMtaacBaDVtaatttacagaRttttttagcKagtKactatMRtgt +DtaattccRcaaKSttagttttBtctatagaKaVttttgcNagtKVccttagRgWaNaKW +ttataDgcgaatgMKatgatRcYtctgVagaccgcgVgactagaWaaHNtcRNRKaatac +tcYaNtSDKtcVVggNgDagtttaaKRgttaDcgtNNgtcaYttggtttYtatgtaaagg +attttagatattKMcatgYaaatcaVactcagagtRYtgtaactatagtBaDtVaWatDa +tctataaaSgggtactaYaKKWagaaaaataaattatagRcaaaVataVagatatgtagg +cWagacRWattctgacgcDtaBcYattgtaDggMatgagcgagaggctaaatVtctcagR +agDtSgKNcgtVcStacatttagNtgatSNgatcYVtHattHtBgMacRaattaHBacRc +NaaccctVaaYaattcVccatacKcttSagtctgKMNagRaNcatNgcgHattStSKYRg +gtcagtcaccattttagtMaccctggVattHaatVagaaMaattaVacatacacaaatta +attacgtKtagaaaMgatWgWccatYtagacKatctKatMcggYcgcatgHRtcStVtaa +tHgSaaaVagtgaatgtgYtattaYcRagatgatcataacacSgaYaactMKttatRcga +ataaMSatacNgaMatttcggccacgaYYMcaKattRagDtRtatMVBtaattWtMHgNa +WDgStaaSNggStcBcVYtaYagaHtacagttccMcgtYtYttcattgSWcttagttcgt +HtgVRYgaMacttBtatcaactaaaaVtDgataaDgtatcatYDttaStgccBacctaaB +agttgRtaSBtaaaagWgcacBggttagcMaYatttBgtaggtRBaSagttcacgtaDaY +aaaacDSaKattctgtSatatgtatggVBcctctgtgaaHDKgttaRttttBMHgRMgHa +gtagMgacgaagttaatattgRtHtHttatYaaagcagatgtgattagtggcactactVa +ttagatctctgtttatcattYttgatHcHttagStgatgactctDaaatcagtgttgttt +ttcYaaagtatatcYcaSaacaVttcgWtatKaaaHWtRgtttaKacttctgaaNaYacc +tNtcStatttaaagttKgtgatcctBcaBtctttaaaKagttgDtWctDtgtgctataKa +gtaNHatctagYgatcMgtggYaagactgacacttaRaaccHgttcaYtagWtggtgBcS +tacaMcMHataaaNagatactccaggagttaatcatRttttgaKNgSgcaggtgttRaYc +aaataBtaDtatHgBtatacKaataKtaggaaatatgcataaHgaKttttatMaaaNgMa +tYattgaatNtatVaggtKctttHattcatttatYtattagtataYtttagYcattagaa +ataHtaaccttactcatYttHMRagttctDagNSVgcgVaNNattctVcaaVagaattta +agaggttttacRagtagtaaaBaBaaMtaScKgVaRcNtctgtataagtatVgtDgHaYt +tcHYttaagatRgtgaattctYaaaattRtcWtacDDaRatcaKtaSacaagctaNttRY +agMSDKtWgWaYNgaaaatatNtaatatHMtMWRaRacaaaatgctgctacNKaKtagtt +gVatDaVccatSDtgaSggcgWatccBgaaVtgtaWttagatVaBWtacgWtaYattaaa +tMctDgDaaKatttgaaatgctWctttaHtggHaBBSRVBWtgattgagatccNcaaaHt +>THREE Homo sapiens frequency +gcactagtattgtcgggatcccattaacaggctcaaccacgagctcacgcgaggacatgt +agtccgtatctttaacgaagcgacagcgacagaactcccatggataaccaattataaggc +ccgtaatcctctagacatcgtttaccaataaatccgctttctccgtaatcatgttgaata +ccccagagtagtccagatgataaccgatgaaacacaagtctttctcaatgcacttacggt +gaacttattaccgccaacgtagctcatcaaggttgcgacatctagttgtgtgtttgcgac +gagcccagcgaacttcatcaactttcgtatattcaacgccttgtaattttactttaagac +gcctggtgatgtagattcttagataatcagtttgttatcggctgtactttaccataattt +cacaggtttcaggtcaagaagattatagctgtatatacagttccatgctcggtgcacaga +aacgtgatcggataataatcaatcgcttatgtcgtctttaggcgtatccaatacatgccc +cgataccgcagtgtatttcgacatgtaggtataccgtcgcatttgagctcgagtcaggac +gtcagctagattagattccttaatagaatataccgacctctagtccgaactaaactatag +ataacgccaacttcaggttaattgtctagtcgtctgtttgcagatgggattcttagatga +gtgagtatcggccatattggttcgagcactttagtttttgatgcataggatatgcaatgt +atagctgaaagtactttatctgtttcaaactcacattgattaaaccggtaaacctttaaa +gactacaagaaaatattcagtgagggcaattttgtcaatcacaatcttccagctagagat +acttcacaatttgtcttgaggctacgcaacattagacggattttcgcgttttattgaaat +aatcgaggggcccaagagtatccatagttcattttgtaagatttctttacaggcttatta +cagcttcttcagactcctacatgcttacgagttatatgctagcatgtgaacaatagatta +atatacaggaaaacgtacattgagagagatgaccctacacagcgcaaccgttgagtactt +tcattaaagggtaacgctctcgagacagcatccttaagatggccttattgtcaaatcatt +tgcagaagtacgcaagatccctaaccaacgtagaagaatccctacaaacacatgagacgc +ggtgaaaatagacagggtgttagtattcaatcttcggagtatcaatttcgccaatcttgg +tgagaaagcataccctttcttcagagaaagaagatcaatcataacactatctttaacgag +gtacgcacgcgcatcattacctgcctccatggatctttaggatagcggaaagtattggca +gcgtattgtgatttcgttcctactttatcaatttcacattcatatacatgtcttttatca +aaatcgccaataagataggatgagctatattagatgctagtagagttcgcgccaacatca +tcgataggaatactcaggacagcgtgataggacttttcaatccctaatactctctataat +tataactctctcttaagtttggaggcagtaacgcgctctatataatcagtttgctgcacc +attcttcagcctctgatacatacaaataaattccacagcagtaagagggtttaattgaga +catcttgggaacttaggattttactctaacatcaccgaaacgattattggataccgtacc +taaacgaactttctcaaggcagtaatataggacatccgcaataacacaaatgctgcctcc +ccaggagttatgtcttcctggaggctatatcttacacccactcactataggcaaactaaa +gtttaaatgttgattgtctaaaaaaaagatagataagagttggccggcgtagcacatgcg +aaagtgaatcgtaagctataattctctggacttgaagttctgtcctgttcctctgcaaga +aacaaacttcctttaaagctatttacgacgcacatctcagcaagttataaacatgttgga +agtttctagtcggaattcccaaagaacggatctatctaatgcattcctacatttttcctg +tctgccgatggtgccatcctattcaaagaatttcttaaaagtagattaaatgggactttt +aacaatgagtaaccttacgcctctaagggttcctcgagtgccatacaccagtcaggtccg +agccacatacacggagaacattctaacatagcattctcaactcgatcatttgcaggttac +ttctttcctatcctagtgctaaaaatcatacttgcaatcccatagcacggattaagaacc +taagaaacaattcagtaaaacatgttcgaattcttggtatgggaacatcattgcagctat +ggtctaacgcattaatgtttgggtacatcttccatcatataaacaggaagagtctgacga +cagggagtgcttgcgatcatgtctatcattgtgaaatcaaattgtagctcacatgtcgtc +tatgagagcgtgtatccgataagatttagaaaaatagaagtcgtataagatctcactgaa +cttttgaatgaatgtgaagcatatatgatctgctttaataaaactttatccataggatac +gtttccaaatcaattcaataattattagtcaaaatagataaggatgaacaacctgaaggc +cgatcggacgtagaaagtggtcccatcactttgagttgatattgttgaaccacacgttat +tatggttttcaaacagtctcaggatattgtatatacagataatccgataccagttgtctg +acgcccctcttacgtaccccaccctttgtgacgtttaaagcagttgttcagtattttaaa +ctaggcggcaactaatttggaaagaagcacagtggatatgtctaaattcttgttattcag +gcctgaatttaatacaccgcatagttaacttcgcggtagagttgttcatcatgcctcctc +taagctaccacttctatgatacaccaatagttgttctacggaatctgataattggccaag +tcataaacttccgctgcgttcaacccccttgctcgaatatccaactcgaaaagacagcct +tttggtgtccggaacaaatcagttacttcttttctgatgttaattctctgtggtcagata +cagaccaaaaactccgcggatttaccatcctccaagaacaaatttgcatcaacatagcat +tttggctacatattctaagtctcaatagtttaggttttcaactacattatcccaacatta +ggattggaggaataatagctgggtaagtccccttgcgtctacaatcgactattttttatg +aatatgcttctgccgcacctatggttattaaaaaagtcatgactttgaagaaccctgaaa +agatagatgaatcaggtgtaatggcagcagccaaagagcatataattagcaacactctaa +gaacattatagatatgatgatagcgatcgtcatgatgttatccggtcacaatagtagctt +catcagctaattcgttttgccagtggtgacttgcgctggaagaatcgttatacggtccct +tccctcttgatacggtgggggcttattcaaccgcgtggattgggttgtcatacttgcatt +aaacgatgtaaaccatctagtagtcaactatactaaatcacaaaatagtgatcaatacat +acccgcttcatggttttaaccatttaattgattaaagatattccgctaagaaccattatc +tacctaaactgatcgccgtatcctagtagtttgaaatttgatgtaccgtaatgatcaacg +aagtaaaacgttatattgtatgtagaataataggtcttggagctaaatgatgtgattggt +agtgaagacttacccttacaactttaccggtttctcggaagaatatactagagaatcaat +gcatgggctacataagcactttagtctaatgagataaaaaatacacgagtcttccatcat +gaattttttgtcgaaaaactcgaacctggtaatttaaaccatatatctttatgtcgtcaa +taactctcatatgttttatataacttcccaatcacgacttgtaactgcttgttcgactga +gctgtttgagctatgaggccgggatccggttgagctacatctatttgctacaagaaaaat +gaaagcacatttgttgggagttctggctacactcatagagaaataagtggcccgagtggg +tgcggcctgcctccatattcaagtgtatcttaaaccaagtggttccaacgctcgcgctaa +agaattaaagcctttatttcctccacggagtagcccgtaatccggttcgaaagagaccat +tgaagttaattttcatatccagtgaagtttaggcacaagcatgtgttctgccacatgcct +caaagcgctcttcaaccaagatatgattcatcctaacttcgatgaatgcgtctgtaacat +aaatatagaaggaatgattcggcgagttaattttcgccttctccaacatggcatccctac +gttcgttataaggaccatacatgtaggttttaaaggtttgcggttaatcgatatttacat +catagaaattctatagtcaaatttacaagactctagatactcactcgttgcagccggcta +ggaagcgctttgtaccttacttcccttttcgttgcgtaatatgaatttcatatagtaagt +tcaaggcactcatacctccgtgaagagggtagatagactattaaagttgtttaatagtac +gtattgatggaaatgacccgtaggagatttaccactcaatccacaagattcgctgctgtg +cattatcaaaacagtgcatgtcgaaacatgggttgggtccttcaaacacgaatccaggta +gagatacctttgcaatttttcgatgaaggcgaccgagataaatgagctataacactgtat +gtcttttgattgctataaaacacagaaacggatattaatttaggccgtaaccaacatctg +ttatttgacatagaacagatggtcctttacagcgtattccggccttaatattgaggtcca +gtgtattgtcctcctttaaagaagttgattgtaactgacttaaataagacatgtcaccca +ttcactgggttgcaactgctggccctttttgtccatcgcacgctaatgtgataacagtac +cgccctcacacctgcgtttaaaagacataaatgtcgctatgaaggttattcattaatttt +agctgttttcttagaaaaggtaaatttaaaattgaaaaggctagaaaactaaagttacga +caaatgtgtttgtcaagtaggcgggcatcattgagattgtaagaaataaagccataacca +gccccggaatagaaaatgttaaggaaaggcgatcttctttgaattcttattgtcaagtgc +agtcatacgttcttatcagaggacattgcaataaaatctaacaccctcccttgtgtggtt +gggccatttgtacttcgaagcgtccaccatgtgcagaggataacggaatgtggttccgtc +ccataaacgatcattctcgcccacttagtggcgcggtaaatcgctctcatagaggtaact +ggcctgtaatgtccaatgttaggctaccttctccaactttagtacaacgaataatgtccg +attaacaaggagtcaatttgtcatgaccagttcattcaggtacttgtatctatacggacg +cgttccagagtagtatttgaaattttgaggttctactgataagtttagctatcgctgtat +gtctgaataagaatttaatgtttatcttcgataaataacaattaacaactcctaggtgat +acactgtgaagtctgctgttccccaaattacatatgctattttgttcacataccatgaag +ttaagctaagtgctctataatggcataaacggttatcaaactagctcgaatttcttttat +tacgccggaagcggattaactgctgtagatcaaacacgttaggatagtgtcgttttcata +tatatctaaattcggtctaacatgcattacccatgcttgataacgtagcacttcgcagtc +taattatgtaatgtccgtttaaccaaactttaaaaaagtttatctatcaccagtgatgcc +tcatcgtgactacccggatctttagcctttagggtctaaacagaactaatattactacgt +gtcatactccggagcttaaccaggtgaaacttatttgttaaccaaatttagtgacagggt +agaaatacgtatcaaattaacccagcaatacaataagcatgaaaataattgtaatcgggt +ttgggccggaatcccgcttggcgaaaacttaatgacatagtgtgatgcattttgcactgg +attgagccacaaactcaactagcattatgctcaatatttggccagtgttctacggtttga +aatttataaaggccgcgcaaaagtcttgtagttacaaacgcataaatctcgaacgtaata +ggtttaattagaacatccgtaggatttctgtttatagtagatttatactaaatgttctga +ttagattctgacggccttacccatacaattaataaagacgaatatattagttatagttta +ctatccaaataaattaagcgaatcgaaataaactgtcacgatactgggcagttatcaact +tatcacttatacagttcggacactctatattggtctgtgagtactctatcaaactaactc +ataagttaactgcgcttccattaaatttcaatacgttcttgtgctgtgtacaaacctata +atcgaataaatgacacatatggagatgcataataaaaaaaacggctccatatttctcgtt +aatcgggcattcttaaggaggagcatctcaccaaaaataacgttcctgataagtcttaac +tattagaccgtcttcgggaatgaacgaaacctcaagctagcatggtatagttcttgatag +cgcgtaaattctgataatactgggcggacagctggaaattagttgccagtgcacctacgc +aaatagtttacataaatcaacgggctccgaacgtaaatacaaagggttagttacatcgca +acaagatgaaaagcatgtatgtctaccgtcatccgtccctaacaaacataaaggtggtga +agaatctcgtaggtcaactataactccatccttgaagcaactactccgcgtccgtgtgcg +tagttcgcaacgagaacactactgaaaaaagctaaacaactctcggtacaaatgcggctt +gtgtcgataaagttggtggtagtgcacggaataacataacaaggaatattatttattcaa +attttttgtgactgttatttgttttctgcctagaatgtaaggatgtgttttttgtgacct +gatagttacgcttatttcaggtccacggtgcgtgagagtgtgtcctataacggcagggga +gcgaagtagtgtcctttagactattcaaggtagaattttgataacgctctataaaaggta +gaaaatcatgattgagcaataagaccccaacttatcaaaaaaggagttctcgacagcgcg +tgtacagtccctataacggctgtatttcctgtgtcacaacaccctcccatcgcactcaaa +atgtagatttatgatcagacgctaacttgttcttagagaaaaatacacgggatactctgt +gcaacgatttcattaataaggtgcagcttgggacttttttggccgtaggctttattaaca +ttcacagtaggtagcgagacttcctatgaaccaatcatgccacgcgttttaacgtttcaa +atataagctaggaagcgtttgccaggacttctataatgcaccgttttttttagtacttcc +ttactagccttagtttatgttagagtctttccaattacaaaggattgaatagccaaaatt +tctacaattctcagcgaacgccagcttaatctaaacacgagcttcaaatattctacatat +cggcaggagtcaatatataaatatgaaaatcgtaccatcctcgtacttttagaccaaacg +tcttcggataattaaatcctttttcaattaccacagtacgtgcattagaactactgctat +gaaagtaaaccttgaaatatagtcctcaagagcgtatccaagtacattgcacgtgtatac +agtcgtataaacgagttgatgttctgacgctagagcttaccattcgttaaacagataact +aaaatttaatggctgagtgacttagtgttttcgacaaacgtcgcggatgtagactattgt +ttataagcaatttttaaaaacatatgttcaaaacggtatgggatatgtcgaattccacag +gggtttatgtaccatagaagtatgtataaggtactaaaggtttaaatctgtgatattcgg +ttcggtgaaaatcagactagtcacacttagtgtctgtaaattagattgggtgaaggtaag +cgatcccgaactctacaaggcatgggatgagattctaccgactccggataacactttacg +atcgcgcataactctagctcttagataagtttaacttgtcgatctcataaacagttcaaa +atctgcgatttattgtatcaaatccatcctctatcttctataatcatctgaaccgcgata +cggcactatgagccaagtgaagattgaatccaagaaagctataattggtttattttagtc +catttaaattaagtccggtataagtgctctgtacaatatgcagtctcatgggcatatacg +ttaactaccttttgatacttcgaattggtaaaatatcgactatcgatttgcagtaaaagg +tgtagagtccaattactctttcctgttacatacgatctcttagtttggacaactagccca +tgatggcgctcctctagcgcatgaacctactttataattacatctttatcgatgaatttt +tttagactgcggaggccttgagttttaacagggctgctaaatttcttaagcgattagacg +gtagcgtcgtacgctacttgcttggaacaggcaccgaaaatattgatctactattgcgtc +aactctattctgctaatagcgatggcaaatcacagaagccctcttagtgacaatagttgt +caactatatctaagtcgacctttactgtatcaacgatcacggagagaattaccgaatacg +aaacctcaggactaaaaaacggaaaggatttgtcgacggtaaatataatacttgttaagg +gtagcgacacaggtatactttgggtgtaaacgtggtgcttcccggaacgattttcagacc +agaaaattgttccggtaaccaggaaatctcgtctgcgttaattcgtgttagtaaacttga +tcttcagactccttcttttcgttgcagcgagacttaaattatatctgcgaaatagtgccc +cgtgcatacttcagatggtaggagataccatttggcccattgtgactttacgcgattaat +taaccgacatacatctgttcctgagctatgatcgtctgaataaattacggtctcctcttg +atacctaatggtttctggagacgtttctcatgttcaaatggatagcaggagatcgcttca +tcaagtttagctacgcagagcatcaaaatatgtatgggaaagtcgatttccaaaccagaa +gggataaagagaaataacggacttctccgtagattagcctgatattttgatgggaatcat +ggcggcacatacgtaagagttgcgtgaacgaatattttggacggcgggagacacatatcg +gccattcgttaaggtctctatattggacatcacaagcttagcagtatgagctactaacac +tcaagacattattgattttttcaagatatgtttcattcctctaccgctattcccatacgt +tcgattcgccgggtgagcgaaaccacgggactgaggttaagctaatcaataacaactcgt +tgcgatagagacctatgtatactagagagaattccccaacatttttacaaaaacaaagca +gactaaaatagatacagtccctccatacaattaggaccaacatgttattgccgatcctag +cacacacaccacaaactcagaacttctgtcttacctatgaaagggtctgcacttctgatt +gtacgtgtctaattagcattaatattaaaactaattaggataaactataggtacgagctt +tactataagtcactaggtgttttccgatcgaaaaacgggaccttcaagccttggtaagta +catttaggataaagaaaaaaaggaaggtacgtgactaatctgtctaaactgacaatagag +tagtacctacatgcttcatgtcaagtcttaatacgcaagcgctctcgttatactgctcaa +caaaactcataaagttggactccatcatttagaatcatagggaccaaaacatttatttgc +tactgtcactttgtaggtgttctattctgaattcctcatattgatacatgaatcggaata +cctgtggatcccttaggacgcacgtgctttctttacgtcagaatacatattgtcagaatc +gagaagttccatgcaattaagaattcgcctctttgaaaactcatatccccacatataggg +tccaccgttattcggaaacgatataataattattccagcgttgagcgtcccttaagagcg +cattttcgcttggcctttcttctacgactctacaacgcaagtggctgtgtggagtttacc +acagcgcagcaccccatagaactacctctgagagcgcgagatggtggcagtatgctctgc +agctagcgtttagaacgcgcccgcgcattaaccagtcatattaaaatggactgtcttaat +tgtcggcattaggagcaatattaactgatgagggtatcggtcgcagaagtaatgacggaa +atacgcctctagtccgcagagatacgattacagactcagatcccctaacaagcaaaacga +ttaaatcggaatcactccccctatgacatatttgaaatacacaagaaaccacgcaacatg +tcccgcattctcaaccgcgctttataagatgttgagtctgagaattagatgacctaactg +caagaatcatggcgagtttatctagtaggcaagtctgtaccctagggttcgaacgctgtg +acgtcgtgatcggtctaaggacttagatgataaccaagaactggtttaccgagtactttc +actattaggagtaattacatgcgttcaccgcggaatacgacgaaattttttcatatcttt +atgagcgagatcgtgtcgtctttgcattgcaacagtcgctaccagtaattgctgatcaat +tatagattcattatacagatgcttacttttctctattcaatactgtcatgagttgttttt +aaataagcaccagaattatgtcgcctagtataatcttgcttccacttgaatcaatgcgat +ggacagtattctactgattgcaaagtagtctatttcggcttagcagtacgcatgcctatt +tttttgcaggcacagaataatatgcaactaggattctcggcatccaattaacaggctaaa +acaccaccgaaagacaggtaatctacgaagttgatgtttactacagaaagcgaatgatat +cacttggagaacattttagatgcccccttttaatctagactgagtgtaccaatatatcac +cggtctaccgaatcagcttgaataaaccactctagtactcatgataaccgagcatacaca +tgtatttctcaatgcactgaaggtgaactgtttacaccataccttgcgaatcaacgtggc +gacttatacttctgtctttgagtacagcacaccctaatgaatctaagttagttgttgata +cgaattgtaatttgactggatctcgcctcctcatctagattcttagagaagatgtttctt +atagccggtactgtaactttattgatctggtttatggtaatcaacattttacctctattt +aaacgtccttgcgccgtgcactcaatcctgatcggtttagattcaagcgattatcgagtc +tggaggccgagaaaagaaatgcacagagtaagctctctattgcgacatctacgtagaaac +tcgcatttcagatcgagtaagcaactctcattgtgttgattcagtaatacaagattacct +acgcttctacgaaatatactatagatttagcctacgtcacctttagtgtcgagtcggagc +tttgaagatcggatgcggtgtggactgtgtataggcaattttgctgcgagctcgtgactt +ttggttgatgtcgatatcaatgggatacctcaaacgtctttatctctggataactcacat +tgagtataccggtaaaaatttattctattcatctaaatagtcagtgagggctagggtcgc +aatcacattaggccacatacacatacttaacatgttctattgacccgacccaactttagt +agcattgtagccgtttatgcaaatatgccaggcgccaaacactagccagagggcattttg +ttacatttatttaatcgattattacacagtcggaacacgcctacatgcgttcgacttatt +tgcgacatggtcaacaattcagtaatttaatccaaaacctaaagtcagagacatgacact +aaaatcacattaaggtcagttagtgaaggaatggctaaccagctagagaatgcatcatta +acaggcacttattgtcaaatattttccagatctaagcaacatcacgttaaaaagtacaac +aatcacttaaaacacatcagtccaggtgtaattagaaagccgcttagtaggcaagcgtag +gagtataaatgtagacaatagtcgggacttagcagacactggatgcagtcatagaagatc +ttgcataacacgttagggttagagctacgaacgcccatcattaactgcctaaagcgtgcg +tgagcttagcgctaacttttccaacacgtttgtgatttcgttcataatgtatcaatttca +cagtcatatacagggagtgtagaaaaatcgcaattaacatacgttgacctatttttgttc +agagttcagttagagcctaatgattcgagagcaataatcaggacagcctcataggaagtg +tcaatcacttagaagctatattattataaatcgctctttactgtcgtcgaaggaacgagc +gagagagaatcagttgcctgcaactggcttaacaatatgatacataaaaatattttcatc +accactaagacggtggaattcagacttattggcaacttaggatgggactattaaataacc +cataagatgttgggataaagttacgaaacgaaagggatatagcctgttagataggaaatc +cccaataaaacatagccggcctccacagcagtgatctattccgccacgcgatatctttat +accacgcaatataccaataataaaggttaaatgtggttgcgatttaaaaaagatacatat +cagttgcaccgcgtagcaaatccgtatgtgaagcgtaacctagaattatagcgtctgcaa +gttctctaagcttcctctgcaagatacaatatgactttttagcttttttactaccaaatc +tcagaatcttagaaacaggttggtacgtgctactcggaattcccaaagtaccctgctata +tatgccattccttcattggtccgggctcaccatggggccatcatagtaatagaaggtagt +aaaactagttgatttccgacttttaacaatcactatcctgacccagatatgggttccgac +tggcccttactccagtaagggcagacacacagacaacgagaacttgataactttgaattc +tcaaatcgatcattgcaacgtgacttatttactagcctactcctataattcatacgtcaa +atacatttcaacggaggaagataataagtaaatattcactaaataatggtcgaaggagtc +ctttgccaacataagtccacatatgcgctatagattttttcttggggttcatattcaata +agataaacagcaagagtatcacgtcagcgagtcattgagatcttggctagcattgtgata +gcatattctacctaaatggtagtctagcacagagtggataagatatcagttagatataga +caagtactataacagatctcgcttcgttggattgtatggctagctttgatgatatgattt +tataaaaattgatccagacctgacctggccaattatattcattttttatgagtaaaaata +gataaccatgaaaatactcaagccccttaggacgtacaaagtggtaacataaatttcagg +tgttattctgcaaccacacctgttttgggttttcaaaaaggctaagcagattggttttac +agataatccctgaacactggtatctcccaacgatgtcgttcccaacccttgctgaccttt +taagctctgctgaagttttgtaaactaggcggaaaatatgttcgatagatccactcgcct +gaggtagaaattcgtcttagtaacgcctctttggattacacagaatagtgtactgacacg +tacactgctgcagcagccatacgctaacattaaaattcgttgagtctacatttgttgtta +ttcggattatgttattgggaatagtatttttattcccctgcgtgaaaccacatggataga +ttagcctactcctaaagactcccttttggtctacggttcaattctcttactgagtttatg +ttcgtaattatatcggcgcagtgaatctcctaattatcaccggagttaccagacgccatg +aacttatggccagaaacattgcatgtggcctacataggattagtatcaagagtttacgtt +tgcaacgacatttgaccaacttgaccattcctgcttgtagaccgcgggaactcccctgca +cgcgactatagaagttggtggtggatgtggcttatgccgcaaatatggttttgaaaaaag +taatctattgcttgatacctgaattgagacatgtataagggctattgccagatgaaaaac +tgcatataaggtcaaacaatataagaacattatacataggatcttagcgttcctcaggat +ggtatacgctataaagtctagcttcagcagctaaggagttttgccagtgcggacttccgc +tggaagattaggtttaaccgccctgacatcttcataaggtcgggcctgattcaaacccct +ggagtgccgtctcatacttgaattaatcgatggaaaacttcttctagtctaatattatta +ttaacaaatgacggttcaataaataacaccgtaagggtgggaaactgttaagtgatgaat +cattttaacctatcatccattagctacagataatgataccccgatccgactagggggtaa +gtggttgttccgttaggataaaccatgtaaaacgttagagggtttgtagattaattggta +ttccagataaatgaggtcagggcgagtgatcaattacactgaaaaattgtcagcttgcgc +ggtagttgttaagacagtataaatgaaggggattcagaagcaagtttctcgattgactga +atttataaaccagtcgtcaatcatgatttttgtgtcgattaaagcctaaatggtaattta +aaccattgatatttatcgagtctataaatatctttggttgtatattacttcacaatcacc +aattctaaatgattcttccactgtgcgggtggagatatcaggacgggttaaggttgacct +acatcgttttgatacaacaaaaatcaaagcacatggctggggacttctcgatactatctt +tgagatagtacgggcaagagtgggtgacgcctccctacattttcaagtctatcggataac +ttctcggtaaaacgctcgcgatatagttttaaagcattgatttaatccacgcaggagcaa +gttttaccggtcgaatgagaaaattcaacgtaagtgtcatatccagtcatggttagccaa +aagcatgggttatccaaaaggaataaaacagctcttcaacaaagagatgaggcttcataa +cttcgatgaatgcgtatggttctgatatatagatcgatgcatgaggacactttattttag +ccggcgaattaatggaatccatacgttacttatttggacatgacttctaggtgtttttgc +tgtcccgtttagcgatatttacagattagtatttcgtttctcatagttaattgtatctag +atactaactcgttgaagacgcataccttgccatttgtacaggacttaactgttccgtgcg +taatttgaatttcttataggttcttcaaggcacgaatacctcactcatgaccgttcatac +tctagttaaggtcgggaatactacgtatgcagggaattgtaacctaggagatttacaact +ctttaaacaagagtcgctgaggtccaggatcaaaacactgaatctcctaacttcgggtgc +ctccgtaaatcacctagaaacctactcatacatttgcaattttgagatgtaggcgaaaga +gagaaatctgctttttaacggtatctcttgggattccttttaaaaacacataacgatagt +aatgtaccaagtaaccaaaagctgggatgtgtctgtgtactgatccgccgtgtcagagta +gtccgccatgaatattgacgtcaaggctagtgtcatcaggtattgatgttcattgtaaat +gaaggaatgaactaatgtcaccaagtaaagggggtgaaaatgctccccagggttctacag +acatagagatggtcagaacacgacccccctctcaacgcagtgtatttgaaatatatggac +atatctaccttattctgtaattttagatgtgttctgtgtataccgatattgataagtcaa +taggcttgattacgtatcttaagacaaatctgtttcgcaagtaggaccgcatctttcaga +ttgtttctttttatgccataacctgcccaggaattcaaaaggttatcgatacccgatatg +ctgtgaattattattctaatggccactcattcctgcttatatctggaattggcatgaata +tcttacaacctaaagtctggcgttgcgccagttctacttcgtaccggacaccatctccag +tcgttaaccgaaggtgggtacgtcacataaaagttcattagaccacactttgtgccgacg +tatatagatatattacacgtatagggaatgttttctcctaggtgacccgaccttctacta +aggttgtacatcgtataatggcccattaactacgaggaaagtggtattgacctggtaatg +cacgttcttcgatatataccgacgaggtaaagtctactattgcaaagtttgacgttatac +tgataagtttagatttccctggatcgcgcatgaacaatgtatgcgttatctgccatatat +aacatgttacaaatccttggggatactatcgctactatcatcggaccaaaattaaatagg +ctagtgtcttatcagaacatcatgtttaccgaactgatctattttccaatttaagctgat +attacgtccgcgtatttattttagttccccggatgacgattatctgagctacatcataca +agttagcatactcgccggtgcattgatttcttatttcgctatatcttcaagttcacaggc +ttcatatagttccaattagcagtataattaggttttgtaactttaaccatactttataaa +aggttatattgcacaactgatcaagcatccgctataacccgagctttaccagttagcggc +taataacaaataagatgacttcgtgtcatacgaccgtcatgatcatgctctaacttaggt +gggaaccaaatttaggcaatgggtagtaataagtataaaatgataccacatatactataa +caatgaaattatttgtaatccggtttgccaacgtatcccccttcgcgataaattaatgac +atagggtcatccatgtgccaatcgtgtgtgccaaaatctcaaattcaattatcatcaata +ttggccaagtgttataagcgttgaaagtgatataggccgccaaaaagtagtctacttaaa +aaccaatatttatcgttcgttattgctggtagtacaacatcacgagcatttctcttttga +gttgatttatactatatctgctgatgtgattatgtcccacttacccagaatattaagaaa +gtcctagattgtaggtatacttgactataaatataatttaagactatacaaataatctgg +ctacattatgccatcgtagaaactgataacgtagtaacgtcggacactagattttggtcg +gggagtaatctagcatactaacgaatttgttaaatccgctgaaagtatatgtcattacct +gcttggcctgtcttcaatacgtttagactattaaggactcatttcgagatccagtattaa +ttatacgcatccatatttatactgaagacggattgagttaggacgacaagctaaacaaat +attaagttaaggattagtattatattgtagaaactcgtcgggttggaacgattcatcatc +atagaatgcgttacttattcagagagacttaattcggttatgactggcagctcacctgga +aagtaggtgaaaggcaacagaagaatattgttgactgaattctacgggctacgaacgtaa +ttacaaagcggttcgtaaagagcataaagatcaatacaatggatctctacagtattacgt +aaataacatacataaacctggtgttgattcgactagctcatagattaatcattaattgaa +gctacgaagacgcggaagtctgcggagtgagcaaacagtaatcgactgataaatgcttat +aatatcgcgcttaaatgccgcatggtgtacattaacgtgggggtagtcaaaggaatatat +ttactaggaatattagttatgcaaatgttgtgtcaatgtgatgtgttttatccagacatt +ggatgcatggctgtgggggcacaggatacttaccattagttcacctacaagcggcgtgag +agggtctcagttttagccagcgcagagaagtacgggcctttagacgattaatgctagaat +tgtcataaacctcgtgaaaagctagttaataatcatggtgctagaagaacacaacttttc +tataaaccagttctcgactgacagtcgtaactcactatatcgccgctttgtactgtcgca +aaaaaacctcacatagaaagaaaaatctactgggtgcatcagtagagatcgtgttctgag +agataaatacaccggatacgatctgcatcgagttcatgtattaggtcaagcttgggactg +ttgtgccagtagcattttttaacagtcaaagtagggtgagacacgtcatatcataatata +tgccatcgaggtttaaagtttatatgataagctagcatgcgttgcaatcgtattcttgaa +tgctccgtggtttgtactaattcctttatagactgagtgtatcgtacactcggtacaatt +acaaaggatggaagagcaaataggtcttcaattataacagtaccccaccttaatctaaaa +accagcttcaattagtattaatttcgccaggagtatatatataaatatctaaagactaaa +agactcgtacttttacaacttacgtcgtagcataattaaatcatgggtaaatgtcatcag +taagtgcattagaaatactcctttgtaaggatacagtgaatgtgtctcagcaagtcagta +gaaatggaaattcatactcgattaaggcctataaaactgttgttggtatctacagagtga +ttaaaattagtgaatcagattacgaaaatgttttcccgctcgcacttacgcgtttagaca +aaagtacaggtggtacaattggctgtagtagaattttggtataaaataggtgataaaccg +gatgggtgtgggcgaattcaaaagcggtttttgttccatagaactatgtagttggttata +aaggttgtaatctcggagattaggttagggcttaatcagaatagtaacaatttctctatg +taaagtacagtgggtgatcgtatgagttcacgaactcttaatgccatgcctggacaggat +aaacaatacgcatataacttgacgatcgagcttatatcgacctatttgagaagtttaacg +ggtcgatataatatacaggtcttaatagccgattttttctagaaaagcaatcctatatct +tagttaatcagatcaaccccgtgaacgatatatcagcaaactgaacattgtatacaacat +tcctttttgtccgggtggggactccatttaaagtatctcacctagaactcagcggtaata +gatgcagtctcttgcccagttacggtaactaaatgttgatacttagaattgctaaatttt +agtctagacatttccaggtaaaccggtagacgacaatttctctgtcatctgtcataagat +cgcttagtgtgctcaaattgcaattgagggccctactatagacaatcatcagacttttta +attaaatagttttccatgaatgtgttgtcaaggcggaccccttcacttttatcacggctc +ataaatgtcgtatgactgtagtcggtagcggccttcgagtcttcaggggaaatggaaaag +aaattaggcttctaagatggactataatcgattaggctaattccgttcgcaaatcacaga +agcaatcttactcaaaattgttggaatcgatagcgaacgcgaccgtgaatgtttaaaagt +gctcgcacagaattacccaatacctatcatcacgacttaaatacccaaagcagttgtagt +cgcgtaatagattaagtctgaagcctagagacaaagggatactgggcggggaaacctgct +ccttcacggtaacatggtaacaacagaatttggttaaggttaaaacgaaatatactcgga +gtgaattactgttaggtttcgtcatcggatcaataagtagtttccgtgaagacactctta +tattagatctccgaaattctgacccgtgcattaggcacttggtaggagattccatttgga +acttgctcaatgtaagccagtaatgttccgaaataattcgctgcaggagcgaggagccgc +tgaataaaggaccctcgcatcttgttaccttatggttgagggtcaccgttctctgcgtca +attccagagctggagatacattcatcaacgttacctacgcacagaataaaaagatcgagc +gctaactcgttttcctaaacacaacggatttagacaaattaccgaatgcgccggagagta +gcatcttagtgtcatgcctatcatggcggctcagtacgaagagttcaggcatcgaatatt +gtggtagcccgcactcaaagttccgccattaggtaagctatatattgtggtcagaacttg +aggacaactatgagctactaaaaataaacaattttgtcatttgttctagatatgtggcat +tcatcgaacgcttgtaccagaagttacattcgcagcgtgagcgaataaacccgaatgagc +gtaacattatcaataacatatagttcagatagagaacgaggtattcgacagagaattacc +caacattggttattaatctatgcagaataatttagataatgtcactacataatattagga +ccaaaaggtgattccccagaagacaaaacaataaacaatctcacatattcgctagtacct +atgtatgggtatgatcttctgattggacggggataatttccaggtatattaaaacttatt +accataatctagacctaagagaggttatataagtaaagagctgtgttccgatagaaaaac +ccgaccttaaagacttgcgaagtaaattttgctttaacaaaaaaacctacgtaagggaat +attctgtataaactgaaaagtcaggtgtaactacatgagtcatgtcttcgattaattaca +atgcgatctcgttattctgatcaactaatatcataaactgccactacatcttgtacaatc +attcgcaacaatacttttatgtgctaaggtcacgtgcttcctctgctatgctgatttaat +cagattcataaaggaatacgaataactctggatccattaccacgcaagggatttatttac +ggctgattactttttggctgttgacagaactgccatgaaagtaagatgtcgcatcttgca +taaataatagcacctaatatagccgacaaagtgattccgataacagattttaagttgtcc +agccttgagactccatgaagaccgcttgggagcttccccgtgattagaagaatctaaatc +ccaagtggatggggggagtttaaatctcagcaccaacaaatagtacttcctctcagagcg +cgtcatggtcgaaggagcctatcctgatagaggtttgaaagcgcacgcgcatttaactgt +catattaaattggaatctcgtaagtgtcggcagtacgacaaattttaactgatgtcggta +tacggagaagaaggaagcacgcattgaagcagctacgcagaactgagaagatgacactct +aagatacaattaatacaaaaacgttttaagcccaatctatcaacagatgtaagatgtcta +atacacaagaataaaaccttcatgtcccgatgtataataacagctttatttctgctggtc +gaggtgaagtagtggaaattactccatcttgctgcgcgtctttatagtgttggctactct +gtaaccgacgcgtccatccctctctcctagtgatccgtatatccaattagaggataacca +acatctgcgttaccgacgaatttaaatttttcgactatttaattccgttcaaacccgtat +tcgtagtaagtgtttcatagatttatgaccgacatcgtgtacgagttgcagtgcatatgt +agataccactaattgctgatctaggatacatgctttataaacatgcttacttggctattt +tatttactgtcatgtgggggtttttattttcaacaagtatgtgctaccattggataatct +ggcttcaaattgaagatatgcgttccaaacttgtctactgtttgctaagtaggagttgtc +ccattagaactacgcagcacgtggtttgtgatcgaaaagaataattggcaaatacgaggc +tagccttcaaatttaatgcagattactcctcagaaacacacgtaagcgacgaacgtgatg +tttactacacaatgcgtatcatagaaattcgtgataatttttgttccaacctttgaatct +agactgagtggaaaaagatttcaccgggataccgtttatgctggttttaaaaactcgtcg +aatcatcttataactgcattcaaatggatttctcaatcatctgtacgtcaactgttttaa +caataacgtcagaataaaccggcacaatgagacggcggtctttcactacaccacaccctt +aggattataagtgacgtgtggattcgaattctaaggtgacgggatctacaagcctcagct +acattaggtctgaagatctttcgtatagccgcgtatgttactgtttggatatgggttatg +ctaatcaacagttgacagcgagtgaaacggccttgcgacctgaaatctttacggttacct +tttgattcaagacaggatcgacgatggaccacgtgaaatgaattcaaaactgtaacatcg +cttgtgcctcagcgaccgagtaacgacaagttcacatcctctatgcaactatcattgtgg +tcattaaggtattcaagattaactaagagtcgaccatatattctagagttttacaattag +gaaccgttagtctagactaggagcgtgcaacatcgcaggaggtgtggactgtcttgaccc +aagttgcctgacacatagtgtcttttgcttcatgtccttagcaatgcgatacctcaatcg +tagttttatcgggataaataacatggtgtttaaccctattaatggtttctattaatctaa +attgtaaggcagcccttgggtcgaaagcacattaggccacatacacagtatgaaattgtt +cgagtgtccagaccataattgactaccatggtacacggtgttgctattatgactcccgca +aaactcttgacagagggaattttggtacattgatgtaatcgatgatttaacagtaggaac +tagacgtcatccgttagactgagttccgacatgctcaaattgtcaggatttttatccaat +aactaatggctctcacatgtaaataaaatcacattaacgtcacttagtgatggattcgct +aaacagatagactatcattcatgaactggcactgtttcgattatatttgcaacatcgaac +atacttaaagttaaatacgacatcattcaattaaaaaaattcagtacacctctaatgagt +atcccgctttggaggaaagagtagcactttaaatggacaatttaggccggactttcctgt +aaatggatgaagtcattgtacagcttgaataaatcgttagggttagtccttacatccacc +atatgttaatgaataaagcctgagggaccttagagctaacttgtccaacacgttgctcat +ttacttaataaggttgaaatgtatcagtaagtgacagcgagtgtagattttgaccattta +actgaccttcacagttttgtcttcagacgtcacttacaccataatgatgacagagcttgt +agatgcacacactcattcctagtgtaaatcaagtagtagctagattattataaagagata +ttttctggcgtcgaacgtaacacagagagagtataaggggcatgataatggcttatcaat +atgtgtaagaaaaagtttttaatatcatctaactcggtggaatgcacacttatggccaac +tgaccttgggacgagttaagataccataagaggttgcctgtaagttaagataacaaaggg +atattccatctttgtgtgctaagaacctatttatatttgcagccataaaaacctctgtgc +tatgcagccaccagagttatttatacaaagaaagagaccatttagatacgttaattctgc +ttgcgatttattaaacagacatttcacgtccaaccactacaaaagccctatcgcaagacg +atcattgtattatagcctatgcaacgtagctaagcggccgaggaatcataaaatatgaat +tgttacattgtttactacatatgatcacaatctttgtaaaaggttcgttcgtgatactac +catgtacctaactaacctgagatatatgcaatgacttatggggtcagcgcgcaacatccg +caaagcatagtaatacaaggtaggaaaacttctggatttcccaaggttataatgctctat +actgaccaagagatccgttacgactcgcaatgaatactctaagggcactcacaaagaaaa +ccactaattgataaatttcaatgataatatcctgaattgcatcgtgtatgagttacgaga +agtcgcatttaatgaattagtcatagaaatgtcatagcaggaacataattactatatttt +aacgatttaatcgtagttggagtcctttcccaaattatgtcatcagttccgatttagatg +ttttcgggcccttcttagtaaagaagttaatatccaagactagctcctcacccacgcatg +cacatattcgcgagaagtctgatagaatattcgacagaaatgcgactctagctcacactc +gttaactgatcaggtacttatagacaagtacgttatcagatatcgcttcggggcattgtt +gcgctacctttgtgcatagcagttttgaaaaattgttcaagacctgaacgggaaaatgat +attatttttttaggaggaataatacagtaccatgtaaatactcaaccaccttacgtactt +cttacgccgaacatatatggcacgtgttattcggctaacaaaactgttgtgccttttcta +taaggataagcagattcgttttaaacatatgacctgtaaactgggatctacaaaagaggt +acttaaaataaattgcgcaacggtttagatctgcggatctttggttaaagagcaccatta +gatgtgccatacttcctatcgcctgagcgagaatttagtctgaggaaccactcttgggat +ttaaaacaattcggttaggacacctactcggcggatgaagcaatacgataacattaaaag +tcgttcagtctaattttggtcgtagtacgatgagctgatggccaattgtatttttattaa +cagcactgaaacaaaatggagactttagactaatactaaagtctcaatgttcgtcgaacc +ttaaatgctcggaatgaggggatcttcggaagtatagcgccgaagtgtatctcattatta +taacaccagtgtacagacgacatctaattatggccagaaactgtcattgtgccattaaga +ggattagtagatagtctggaccgtggaatagaattttgaccaaattgaccagtcctgctt +gtagacagcgcgatctaaactgcacgagaatatacaagttggtggtgcttgtggctgagc +acgctaagatgcgtttgtttttacgattctagtgcttcttaacgcaattcagtcttctag +atccgctattccaacatcaatatctcaatttaaggtcaatatatataacaaaattagaca +gagcagctgacacttacgaagcatcgtagaaccgatatagtcgaccttatgatgatatgg +acgtgtccaagtccgcacttccgatgcatcttgacggtgaaccgaaatgaaatcttcatt +agggcccccatgtgtcaaaccactcgagtcccgtctctgaagtcaagtattactgcgaaa +aattcgtctactattagtttattatgaacttatgacgcttaaataaattaaacagtaagc +ctgggaaaatgttaaggcaggaatctttgtaacagttcataatgttgctaaagattatca +gaccccgtgaagacttcgggctttgggcttcgtaccgtagcataatacatctatatagtt +agaggcttgcgtgttgttgtgctattccacatatagcagctctgggcgactcttcaatga +aaatgaaaaatggtaacctggcgacctacttgttaagtcagtttaattcaaggggattaa +gtaccaagggtcgagtttctctgtatttattatactgtaggcaagaagcttttttggcga +gatttaagacttaagcctatggtaaaaatttgatagtgagcgactatagtaagagatttg +ggtggttagtaattaaaattctcctatgctaaatcaggcgtacaatctgagggtgcacat +ttctcgacgcgtgaaccttcaccgaaagcgtgtggattatacaaatttcaaacatattgg +cggggcacttatccataatagatttctgtttgtacgccaaactctgcctcacccctccat +aaattgtattggctagaggttaaattctccgtaaatagagacacatatagttttatacaa +ttgtttgaatcaaagcacgagaaacttttaaccgtacattgacaaatgtcttcggatggg +gcagagcatctcttcgtgacccaaatcaatcgctgagcaataagcaagaaaacacagatt +atacaaagagatctggatgaagatattcgtgcaatcactatcgttatgttagagagttcc +atgcatgaggactcgttttttgaccaggagaattaagccaagaaataactgacgtatttc +caaatgaattctacgtgtttttcctgtcacctttagccagtgttaaagatgactatggag +tttcgaataggttattctatagacattataacgagtggaacacccataccttcacagtgc +taaaggtaggaacgggtacgtcaggtagttcaagggattttaggttcttaatccaacgaa +gaaataacgcatcacccgtcattctattgttttcgtcgggattacttagtaggcagggta +ttctaacctacctgagttacaaatctttaaaaaactggccatgaggtcatggtgataaaa +tctgaatcgcctaaattcgcgtccctaaggaaatatactagaatccgtctcagaaagtgc +aaaggttgacttcttcccctaacacagaattctcagttttatagctatctagtggcattc +ctttttataaaactttacgtttgtaagggtccaactttacaaaagctcggatgtgtatgt +gtaatcttccgccgtgtaagacttggaacccatgtatattgacggcatggcgtggctaag +caggtattgatcttcagtgtaaagcaaggtatgttctaatctaacaatgtaaagccgggg +attagccgccaaaggggtctaatgacatagagatgctctgaaatcgtaccaactataaaa +gcacgggatttgaaatatagcgacagatcttccgtattctgttagttgacatctgtgctg +tctttaccgattgtgatttggctttagcagtcatttagtttcgttactcattgctcgtgc +gatagttccaccgaatatggcacattcgttctttttttccattttactgcaaaccttttc +aaaagctgatcgataccactgatgatggcattgattagtcgattggcaactatgtcctgc +ttatatctccaattgcattgaatatagtaaaaaataaaggctcgccttcccaatgggcta +cggagtacacgaaaaaatcgcaactcgtttaaccaagcgccgtacctaacatataagtga +ttgagacaaatagttctccagacgtattgagatatatgtctcctataggcaagcgtttct +aattgctgaccagaaattagaattaggttgttaatactatattcgaccattttattccac +gaatgtgctattctactggtattgctccgtatgcgatatataaccaacacggaaagtcgt +cgattgcaaagtggctccgtagaatcatttctggtcatttaccgggagcgcgcttgaaca +atggatgcggtatctgccatattgttattgttaaaaagacttccgcttactatcgcttcg +atcatcggaaaaatattaatgaggattgggtcgtataagaaaatcatcttttcagttcgc +agatttttgccaatttaaccggttatttcgtcagacttggtagtgtagttacaagcatca +cgattatatcagctacagaattaaactgtcctgactcgacggggcagtgtgtgagtattg +cgctatatattcaaggtaacaggaggcatataggtcatagtacaaggataatgaggtttg +ctaactttaaaaattattgatttaacggttgattgaaaatctctgcaagatgacgctaga +acacctgatgttcaagtttgccgataataacatataagatgaattactgtctttagaccc +tcatgttaatccgctaacttagggcggaaacaatgttaggctatgcggagtaagtactat +attatgataccacatagaatttaacattcatatgatgtctaatacccgttcccaaccttg +caaccgtcccgattaattaagcaattacggtcatcaatgggccaatcctgtctcaaaaat +tatcatattcaaggttcagctattttggcaatgggtgagtaccgttcttagtgatttacg +aacccataatctaggcgacttaatatacaagatttagagttacgttttccgggtagtaca +tattaacgaccatggatcgggtgaggtgttgtattagttatctgatcttgtcagtagctc +ccaatgtcccagaatattatgtttctactagagtgttcgtatactggaatttaaatatta +tgtaagactagacaaattttatggatacattaggccatcgtagaatatgatatagttgta +acgtccctctatagattttcggagggcaggtatattgcttaataaagatgttcggaaatc +agcggaaaggatttgtaattaactgatgcgcagcgcttaaataagtttagactattaagc +tatatgttcgacagcatgtagttttttttaccagaaagtgttatactgatgacccatgga +ggtagctcctcatgataaaaatattgttacttaagcattactattatagtgttcaaacta +gtaccgttgcatactttaagaatcagacatggcgtttcttatgcagacacacttttttag +ctgttgacgcccacctcacatccatagtaggtcaatcgcataagaacaatattctggact +gttttattacccagaagaaagttttttctttccggttcgttaagacaataaagatcattt +cattcgttctcttaacgatgaactaaagtacttaaagtatccgcctcttgtttcgactag +cgcatagtgtaataattaaggcaagataagaagaacaggaacgcgcacgtcggagataac +tctaatagtctctttattccgtttaatatagcccgtaattgcaccatgcgctacagtaac +ggccgccttcgcaaacctatttatgtaattccaagtttaggtatgcaatggttggggcaa +tgtgaggggttttatcaagactttcgttgcttcgcggggggcgcaaagcagactttacag +tagttaaccgaaaaccgcagggagtcgctctaagtgttaccaacccctcactactacgcg +aaggtactcgattattccttgaatgggctgaaacatcgtgattagcgtcttatgattcag +gctgatagaagaaaacttattttctatattccacgtatacaatcacactcgtaactaaat +agttcccagcgttgtaatgtcgctataataaataaaatacaaagaaaattcgtctgggtg +cataagtacagttagtcgtctgtcacataaataatccgcagtcgatctcattacaggtat +tgttgttggtcaaccttcgcaaggtggtccaagtagcattgttgaacagtaaaactaccg +tcacacaaggaatatcataatagatgccatacacggttttacttgatatgtttacagtcc +ttgagttgcaatcgtagtattgtttcatccggggtgtgtacgaagtaatttagacaaggt +gtgtagcggtcactaggtaaaatgacttaggatggatgagcatttaggtattctatgata +acactaaccatcatgtttctaaaatcctcaggaaatttgtattattttaccaacctgtat +ttatagaaagtgcttttgacttaaagaagccgaagtgttcaaattaaggagtacctgatt +gaaagaatggggaattgtaatctgtaactcaattacaaataagccgttctaaggattaag +gctttgtgtctaagcaactcacgtgaattcgaaattcatactcgattaacgactttaata +ctcttctgcgtatctacagactcatttaaattacggaatatgttttcgtttttggtttcc +agctcgcacgtacgcgtttacaaataaggacacctggtacaattggctggagtacaatgt +tggtttttatttgctgattatcccgatccctgtgggcgttggcataaccgggttttcttc +aagactactttcgtgttgcttatatacctggtaatatcggtgagtagcttagggcttaat +cacaatactaacaagttctctatggattggacagggcggcatccgttgactgaacgatct +attaatccattccctgcactggataaacaagacccatttaaattgaccatagagatgtta +gcgtcatatttctgttcgtgatagggtacatatattataaacggattatgagcagtggtt +ttctagaaaagcattcatagttaggagtgtatcagatcataccactgaaccatagagcac +aattctctactggctatacttcattcctttttgtccgggtggggacgaaatttaaaggtt +ctaacctagaacgcagagcgaattgatcaaggcgctggccaagtgaacggttctaaatgt +tcttaatgagaattgcgtattttgactattgacagggcatcgtaaaccgctactcgactt +ggtatctgtaatctgtatgtagatagagtacgggcctataattcaaattcagccaccgaa +gattcacaatcttcagacgtttgaaggaaagaggtttactggtatgtggtgtcaagcccc +acccattctctgttatatccgagcattaatgtagtttcactgtactacggtcacgccgta +gagtcggcagggcaaatccaaaacaatttaggctgagaagtggcactataatagtttagc +ctaagtcccttcgctaataactcaacaaagatgacgcaaaagtcggcgaatagattgcgt +tcgcgtaagggtatcttgaatactgatagctctcatggtaccaagaactttcataacctc +tttatttaccaaacctgttctactagcgttagtgttttagtctgtagccgacacaaaaac +cgagaatggccggcgtaaccggcgcctgcaagctaacatgggatcaaaactattggctta +acgtttaatcgaatgagactagcactgtattactctttcgtttcggcagcggatcaataa +ggaggtgacggcatcactctcttatagtagatatcacttattctcacaacggaagtagga +tcttccgtcctcattaaatttgcaactggctcaatgtaacactgtaatgttaacaaagta +tgagctgaaggtcagagcagacgatgtagtaaggtccctcgaagctgcttacagtatcct +tgaggctcaacgggctatgcggaaattccagacctcgagttacattatgaaacgtgtcat +tccatctcattaaatagttcgtgccctatcgccttgtaatataaacaaccgtttttgtct +attttcccaaggagaaggagagtagcagcttagtggcttgcctatatggccccctaagta +cgtactcggcacgcttagaagattgggctaccccgcactatatgttcccaaagtaggtaa +cctagatagtgtcgtatgaaattcaggtcatcgatgagagtataaaaatatacaattttg +gcaggggttatacattgcgggcatgaagagtaacattggacatgaacggacattcgaacc +ctgtgagtttaataccctatctccggatcattataaagtaaatatacgtcacttactcta +cgtgcgtttagacagtctttgaaactaaattggttatttttctttcatctagatttgtct +gtatctaactaaattatagttccacataaagctgattcaactgaagacataaatataaac +tttctaacatagtagcgaggaaagagctatgcctagcatcggatcatgcgtccgcgagta +gttcctggtagagttaaaagtttttccagaatctagaccgaacacagggtagtgaacgaa +agtgcgcggtgaacatacataataccgaacgtaaacaattccgttcgtattgttgctgta +tctatatttcctacgtaaggctatttgatctataatatgaaaagtcacgtcgaaataaat +caggaagcgcttcgagtatgtacattcagatctccttagtatcatcaaattatagatttt +acggccacgaattattggtctagatgtcccaaaaataatttgatgtcagtagcgatcgtg +cttcctcggagttgaggttggaagaagagtcattatgctataccaagaactctccatcca +gtacctagaaaggcaggtatgtaccgctcattaattttgcgatcttgacagatctgcatg +caaagtaacttgtaccagatggcttttataatagaaactaagtttcccgaataacggtgt +acgataacagatttttaggtgtacagacgtctgactcaatgaacacacattgggacctgc +cccgggaggagtagtagataattaccttctccagcgcgggtcttttaatatcacaacata +aaaatactaattaatatcacacaccctcatcctcgatggagcctagcatcatacacgttt +gatagacaacgccaattttactgtaatatgatattcgaatctagtatgtggacgctgtac +cacattgtttaaaggagctccctttaccgacatgaacgaagcaagctttgtacaagatac +gaagaactcagtactggtaactataagagacaatttatacataaaagtgttaagaccatt +atataaaaagaggtatgaggtctttgtaactacaataatacattcatcgaacgatggaga +ataacagagttatttctgctgctcgagctctagttctgctaatttctcaatcttgatgcc +actcgtttgagtcttccattcgctcttaacgacgcgtacatccctctctcctactcttac +ctatatcctattactggttaacctacatctccgggaaagacgtaggtaaagtggtccacg +attgtattcacttataacacctagtagtactatgtgttgctgagagtgaggacacactta +ctctacgagttcaagtccatatggacattacactttttcagcatctaggtgtcatgatgt +attaacagccgttaggggctatttgattttatcgattgtcggcgtgtgtattttcaacaa +ctaggtgctacaattcgtgaataggcatgaaaattcaagattgcagttcctatcttgtat +aatctttcctttggacgagttgtaccatttcaactaacctgcaagtggggggtcatccat +atgaagatttgccaaatacctggagaccctgaaaagtttatccagattaataataacaaa +caaacctaagcgaagaacgtcagctttaataaactatcactatcatagaaattcctgtta +attgttcttccaaacgttgaatagactatcacgggtaatagattgaacacggagaacgtt +tatccggcttgtaaaatatcgtcgaatctgctgataactcaattatattcgatggagaat +tcatatctaccgcttagcttttaaaaattaagtcagattattccgccacaatgagaaggc +gcgagtgcactaatcaaatcacttaggattattacggacgtctgcattacaatgctttgg +ggtagggttatacaagcatatgattctttaggtctcttgatcgggcgtttaccaccgtag +cttaatgttggcatatccgtgatcctaatattctgttgtcagcgtgtgtataggaatgca +caacgcaaatctttaagctgacctgttcatgaaagacaggagacacgaggcaccacctca +attctatgcaaaactctaacatagcgtggcactatgagtacgtgtaacgacaaggtctca +tactcgatcctaagataattctcgtctggaaggttttaatctttaactaagagtagaact +tagtttattgacttttacaattaggatacggttcgcgactctaccacagggcatcatacc +tggagctctgctatctcgtgaccaaagtggcagcacacatagggtcgggtcctgcatcta +ctgagcaatccctttaagcattcctagtttgagagccatttagatattgctgtttaaacc +gattaatggtttctattattataaagtgtaacgctcccattcgggacattgaaaattagc +aataagacaatgtatgatattcggcgagtctcaacaacattatggtctaccatgggacaa +ggggttgatatgatgaatccacaaaaaatagtcaaacacccatggttcgttaagtgaggg +tatccaggtgttataaggacgatctagaagtattcaggtacacggtgttcagacatgctc +taattgtcaggttgtttataatttaacgtatcgctctctattctaaataatataaaatta +accgctcgtagggatgctttccagtaaaagatacactatcattaaggttatgcaaatgtg +gcgatttgatttgaatcttagtacattcttaaacttaaatacgtattatttaaagtaaat +atattatctaaaccgcttttgtctatccacatttcgtcgaatcacgacctcgttaatgcg +acaatttacgaccctctttcatctaaagcgatcatctatttcttctgattgatgtaatac +tgacccttactccgtacatacaaatgatggtaagcaagaatgactgacgctcctgtcacc +tttcgtggcaatcaactggcgctggtactgaagtagcttgaaagggatatggatgtgtat +gccaggcttcattttgacaatttttctgtcctgctcagtgttgtctgaagtcgtatcgta +cacaataatgatgactctcattgtagatccaatcacgctttcctacgctaatgaaagttc +tagatagtgtaggtgttagacagaggttagcgcctacatccttacacacacagtgttgaa +cggcaagcataatcgagtatcaatagctgtatgtatttgtttggaatatcatatttctcc +cgcctttgaacaatgatgccaaaatgtcctgccctagagttatgataaaataactgctgc +cctgtaacttaagtttacaaaccgatattcaatcgttgtgtcctatgaaaatatttatat +ttgcaccaagaaaatcatctgtgcgatgaacaaaacacagtgatttataaatacaaagag +tacatttagttaccggattgcggcttgacatttattttacagaattttatcggcaaaaca +cttcatatgaactatcgcttcacgataagtctatgatagactagcattcgtagagaacag +gaagagcaatcattatatatgaagtgttacagtgggtactacatatgagatcattaggtc +tatatccggccttcctcataagaccttggaaatatcttacatcagagatatcaaaggaag +tatgggcgaacccagaaaaagccccaaagaatagtaattcatcggacgtaatagtctggt +tttaactaggggttattgatatttaagctaaaagagttccctgaacactcgaaatgtata +atctatcccaactaaaaaagtatacctctaattcagaaatgtcattgagattagactgat +gtcaatacgctaggaggtaagacaagtagaagtttttgatttaggaattgaaatgtaata +cctccatcttaagttctatattttaaagttttatgcggacttcgagtaagtgcacaaatg +atggcataagtgcccagttacatgtttgcggccccgtatgagtaatgatctgtttatcaa +tctctagctactatcccacgaatgcactgatgccagtcatggcgcttacattagtcgaca +gaaatccgacgatacctatcacgcgtgaactgttctggttcttattcaattcgaagtgat +ctcagatacattacggccatgcttgcccttcatgtctgctgagcagttttgttataggct +gaatctcctctaagcgaaattgataggatttttggtggtcgatttagtctgtacctgctt +attaagattcaaaatgacctacttcttacgccgaaatgatagggatcggctgaggaggat +aaatatacgctggtgcctggtatttatccagaacaagttgcctgtgtatcagatgaactc +taatctccgagataaaaaacaggtacgtaaaataaaggccgcaaagggttacatctcagg +atcgtggcgtatagtccaccattagttctgacttacttaatatagactgaccgagattgt +agtatgtggatccaagcttgccatgtaaaacatgtcggttagcaaaacgtataggagcat +gatcaaagaagagttaattaatagtactgcactataattgtcggcggagtaccatgagct +gttgcccaattcgatgtttattaacagcacgcataaaaaatccagacttttcaattagaa +ttaactataaatggtccgcgaaccttaaatgatcggaaggacgggatctgccgttgtata +gaccccaactctatctaatttttataacacctctgtaatcaacaaatcttattatgccat +cattatgtcattcgccaagtaagtccagttcgagattctctggaccgtgcaatagtattg +tcaaattatggtaatggaatccttcttctaacacccttagaaaagccacgagaattgaca +agttgggcgtgcttgtccaggagcaacataagtgccgtttctttttacgatgatagggat +tcttaaagcttttctctattctagatcccagttgccatcatcaatatctcaattgatgct +cattatatagttcttatttagtatgtccagatgtcactgaagatcctgcctagaaccgat +attctcgacaggatcatcagttcgacggggcaaacgcacctatgcacatccatcttgacc +gtgaaacgaaaggaaagagtcagtaccgacccaatgtggaaaaaaactcctgtccacgat +atgtaggcaagttttactgcctttaattagtagtcgattagtgtagtttgatattatcta +ccttatagaatgtaaacagtaacccggccttaatggtttggcaggattctttgtaaaagt +taataatgttcataaactttatcagaaaacctgaagtagtccgcctttcgcctgcgtaac +gttgcagattaattcgttttacggagtggcttgcgtcttgttgtccgagtacacatattg +ctcctctcccccactcttctaggaaaatcaattatgctaacctgcagaccttcttcttta +ctatctttaatgcatgcccagtatgttcatagggtagacttgctatctattttgtataat +ctacgaatgatgcttggggcgcgacttttaacaattaagccgttgggtataatttgagag +ggtgccacgatagtaagagatttccggcgtgagtaaggaaaatgataataggattaagca +ggcgtaatagctcaccctcctcagttctccaaccctgaaccggctaagtatgactgtgca +gtattaattttgaatacatattgcagcccctaggatacattatagatgtctctttcttac +ccaaactcgcccgcaccaagaaagaatgtggattcgattgaggttaaattagccggaatt +acagacacagattcttgtttacaattgtgggaagaaaaccacctcaaacgttgaaaccta +cattcacaaatggattacgttggggatgagaatcgattccggtcaaaaatcatgcccgga +gcaataaccaagaattcacagaggattaatacacttctccatgaagataggactgcttgc +actatccttatctttgtgtcttccttcaagcaccaatcgtttggggacaaccacaattat +gccaagaaataacggaaggtgttccaaatctatgagtccgcggtttcatcgcaacgtttc +actgtgggtatcatgactttggactttagatttgggtattctagagactgtagaaagact +gcaacaacaagacattcacagggcgaaacctaggaaaggggaccgcacgttgtgctaggg +atgtttccttaggaatccatacatgtaagaaagaatcaaccgtaattatagtgttttcgg +ccccttgaattacgtgcatgcctttgctaaaagacctctgggaaatagattgaatattct +ggacagcagcgaatcctgattatatctcaagcgaatatatgacccgcaagaaggatttat +actagaataagtctaagaaagggcattgggtcacttcttccactaacacacttttatcag +ttttataccttgagagtcccatgcatttttatatatatttaactttcgttgcgtaaaact +ttaaatatgatccgtgctctatctctaatctgaacaacggtatcacgtcgaacaaatcta +gtggctacgaatcgcgtcgctaagaacggtttcttctgctggcgttagctacgtatcttc +tatgctaaaaatgtatagccccgcattagcagcaaaaccgggagaatcaaatacacatcc +gatgaaatcgtaacaaagataaaacaacgcgatttctatgtttgccaaagtgattaagtt +gtatcgtaggggtcagcgctgatgtcttttcagtttgggttttggatttaccagtctttt +agtttcggtactatttgatcgggacattcgtccaaacatgatggctcattcgttcttttt +ttcaattttaatcaaaaccttgtatttacctgatacattaaactgagcatcgcatggagg +tggagattcccatatatgtaatcatttgatatcctattccattctttttagttataaata +aacgctccactgcacaatgggagtaggacttcaccaataattagcatctactgtaaacaa +gcgccgtaacgaaatgattactgattgagaaaaataggtctcaacaacttttgacagata +tgtatccgatacccaagcgttgctaattgcgcaaaagtaagtagaattacggtcgtatta +cttgttgccaaatggttattactccaatgggctattctaatccgatggatacgtaggaga +gagtgtacctacaccgaaactcgtagtgggcttagtggctacgtagaagctgttcgggtc +agttacagcgtgcgaccttgtaaaatcgatcacggtgatgaattattgttattgtttaaa +agaagtcccctgaatagcccttagataatacgaaaatttgttatgtccagtcgctcgtat +atcaaaagattcggttaagttcgcagagttttgccaagtttacaggtgatttactaacac +ttgggagggtacgtacaaccatcacctggttagcagagaatgaattatacggtcatgtcg +cgaagggcaagtgtgtgagtattgaccgagttattaaacgtaaatgcaggcatttacgtc +ataggacatcgagtttgtcctttgcgaaatgttaaatttatggttttttccgttgagtga +taatagctgcaacatgaagatagtaaaactgaggttaaactttcaccatattaaattata +tgttcaattacgcgatgtacaaactaatgttaatcagatttaggagcgcgcttaatatgg +gtccctatcccgactttgtacgagattttgataaaaaatagtattgtaaattcatttgat +ggcgtagaaccgggcaaaaccttgaaaaaggacacatttaggatgctatttccctaagaa +agcggaaaatcctggctcaatatttataatagtaatggttaagattgtggcccaatcgct +gagtacccgtcttacgctttttccaacacataatcgacgagaatgtatttaaatgtttga +gacttacgttttccgcgtacttattattaaagtcattggagagggtgtcgtctgggtgta +gttttctcatctgctcaggagctaaaaatgtaaatctattggttgtttctaattctgtcg +tccgtgtaggctatttaatttttatggtacacttgaatatgtttagccataatgtagcca +atactacaatatcagatacttgtatacgacctatagacttttgccgaccgctcgtagagt +gatttagaaagatgttcggatagcacagcaatcgtttgcgaatgtaagcatgcgaagcga +gtatttaactgttgactattttgctatatgttactctgaatgttgttttttttaccagaa +tgtgttataatgatcaaccatgcacgttcctactaatcatataaattttgttacgtaagc +ttttctatgatagtggtctaaagactacccttgcatactttaagattaagacatgcactt +taggaggaactcacacgttttgagctgttctagcccacctataagccattcgtccgcaat +cccataactacaatagtcggcaatcttttattacccagaactaacgtttttatttcccgg +tacgtatcacattaatcttaatttaatgcgtgagagtaacgatgaacgaaagttatttat +gtttaagccgcttcttgagaatacagattactgttagaatgaaggcatcataactagaac +accaacgcgcacctcgcacattactctaatagtagctttattcagtttaatatagacagt +atttgaaccaggcgctaatgttaaggcccccttcgaaaaccttgttatgttattccatgt +ggtcggaggatttgcggggcgatagcgctgggcggggatcaacaatttcgttcatgcgag +cgcccccataaccagtaggtacagttcggaaaagaaaaccccacgcactcgctagaagtg +ttacaatcacatcacttcgtaccgaagggactactgtattccgtcttggggatgtaacag +actgattacagtcttatgatgaagcctcattcatctaaaattagttgatttattccacgg +atactatcacactcctatagaaagagttaccaccgtgggaagctagatataataaataaa +agacatacaatattagtatggctcatgatctacacttactcggatctctctttttttata +accagtagatcgcattacacgtattgttgttccgcatcaggccctaggggctcaaacttc +catggtggataactaaaacgtccgtcactaaacgaagatattaatagatgaaatacacgg +gtttacttgatttctgttcagtcattcacgggaaatcctaggagtctttcataacggcgg +tcttagtaggaatgtagtcaagctctgtagaggtctcgacggaattggtatttcctggca +tcacaatttacctagtattggagatcacttaaaataatgttgagataataatcaggatat +ttctagtatgtgacaaacctctatttagtgattgtgattttcaattaaacaagacgtagg +ggtcaaattaacgactacatgttggaaagaaggccgaattgtaatatctaactcatgtac +taagaagaagtgctttcgtttaaggctttctgtctaacattctaacgtcaattcctatgt +aatactactgtaaccaagttattactcggctgcgtagataaagtctcatgtaaatgacgg +tttatctgttacttttgggtttcaacctagctaggacgccggtactaattacgacacctg +cgtatagtgcagggtgttcaatgtgcctttttatgtccggattataaccatccctctccc +acttggaatatcaccgggttcttaatgacttagttcgtcttccttattttccgggtaaga +tcgctgtggaccggacccattttgatctagtctaaaaaggtatatagcgtttcgtctggc +ccgcttacgttcactgaaacttagattaatcaatgcactgcactggattaacaagaacat +gttatagtgtactgacacatgttagactaagaggtctgttcgggttagccgacttatatg +tttaaccgattttgacaactgggttgagagataacaatgaagagtgaggactgtagaaga +tcttaaaactgtaccatagtgctcaattcgctaatggcttgaattatttaattgttctaa +ccctggcgtcgaatttttttggttcgaaaatacttagcacagcgtattgttcaacgagat +gcacaactgtaccgttagaaagcggcttaatgacaaggcagtattgtgactattgacagg +gaatcctaaaaagctactcgaattggtatatggaagaggtatgtactgagaggtcgcgcc +tattagtcaaattctgccaaagaagagtcaaaagcttaactagtttgatggtatgaggtt +taatgctaggtggtctataccaccaaaaagtatatgggatatcccagaatttatcgactt +tcaatcgtctaccgtcacgacgtacactaggcagccctaatccaaaacttttgaggatga +gtactgccactattatactgtaccatttgtaacttacattttatatcttcaaagaggtag +atattgtcggccattactgtcacttacactaagggtagcttgattactgatacctctcat +ggtaaaaagtaatttaagaacctatttttttacataacctctgctactaccgttagtgtt +ttagtcggttcaagtcacaaaatccctgtagcgcacccctataagcagaaggaaacctta +atgcggataaaaacttttgccggaaccgttaatcctatgagaataccactcttggaatcg +gtcctttaggctgaggatatagaacgaggggaacgcatcaatctaggttaggtgagagaa +ctttgtatcaaaacgcaagtaccatatgccgtcctcagtaaattgccaaatgcagaaatc +ttacactcttttcttaactaagtatgagagcaacctcactcctgaacagcttgttaccta +acgagaagaggctttaagtagcctggagcctcaaccggatatccggatttgactctcatc +cacttacatgatgattacggtcattacatctcatgattttctgagtgccctatagactgg +gaatttaatctaccctgtttctatttgttaacaaggagaaccactggtcaagatgacgcg +cttccatttatgccaccataagtaagttctcggaacccttacatgattggcctaccaacc +tatatatgtgaccaatgtacggtacatagagtgtggcctatcatattcaggtcatcgagc +tcagtatttaaagattatatggtcgctgggggtattcagtgcgcgatggaagactaacat +tggaaatcaacggaattgacaacacgctcactttaataacctatctcaggataagtttaa +tgtaattagacggaactttctctaactccgtgtactaactctttgaaaataatgtgggta +tttttatttcatctagatttgtctgtatcgaaagaaagtattggtccaaataatcctcag +taaaatcaagtcataaatataaaatttagatcttaggacagaggaaagtgctttcccgag +cataggatctggcctacgccagtagttcatgcttgtgttaaaagttgttactgtttatag +tccgtactcagggtagtgttcgatactcagcggggaactgacatattacactaaggaatc +aaggcccttcgtatgggtcatgtttatatatttaattacttacgctatttgatcgagaat +agctatagtaacgtcgtaagaatgcaggatgcgattcgagtttgtaaattcacagatact +gtgtatcatattattatagatgttaaggcatagaattattggtattgatgtacaaaaaat +tatgggtgggcagtaccgataggcattacgagcagtgcagcttggaagaactggatgtat +cctataactagtaagagccttaaaggtactacatacccagggatgttaccatcattaatt +tggccatcttcaatcttcgcaatgcatactttcttctacaagatgccttttagaagacaa +aataagtgtcaacaataacgctgtaacttaactctgttgtacgtggaatcaagtctcact +aaagcaactaacattccgacatgcaaacgcaggactactagattattaaattcgccagcc +cgcctcgtttaatataacatcataaaaattctaagtaatatctcacacactaatccgcca +tcgtccatagcatcagtcacctgtcttacacaaacacatgtttaatcgatgttgttatgc +caagctagtttcgcgaccatgtaactaattgtggaaagctgctaccttgaacgacatcaa +ccatcctacctttgtacaacagaccaacatctctgtactggtaaatagatctgaaaagtt +ataaatataactgttttcacattgatagaaaaacagctatgtgctatttgtatatactat +aataaattaagcgaaacatggagattaaaacagtgttttctcatcctccacctcttgttc +tgctaatttataattcttgatgccactcgtgtgagtcgtccattcgatcgtaaagaaccc +gacataaatagatacgacgctgaacgagatcctatttctcctgaaaattattagcacggt +aactcctagggatagtggtactagttggtatgaacgtataaaaacttgtactactttctc +gggatgtgagggagcaaactattactcgaccagtgcaacgcattatcgacagtaaaagtt +ttcagctgatacctgtctggatggattatatgcaggtaggcgagagtggattgtagcgat +gctcggcgggggtattttaaaaatctaggtgataaaagtcctgtttagccaggaaaagtc +atcattgcactgcatatcgtcgattagctgtcatttcgtccactggtaccagttcaacgt +acatcaaagtccgggcgcatccatatcaagttttgcaatagtactccagaccatgaaatg +gttatccagattaataataacttaatatactttcactacatactcagcgggtattaaatt +tcactttatgtcaaaggactcttatgtggtcttcaaaaaggtctagagtctatcacgcct +aattgtgtgaaaaccgagtaacttgatcagccttgtaaaatatagtagaatatgatgtta +aatcatttatattccagggagattgaatagcttacgattagctggtataatttaactcac +atgattaagcaaatatctgtaggaccgagggaaagaataaaataaagtaccatgagttcg +gaacgctgcattacatggcgttgggctagcctgatacaagaagatgagtatggagctctc +ttcatcgggacgtgacaaccctagcgtaatcttggcagatcccggagcagatgattatcg +tctaacactgtctttaccaatgcacaacgcatagatttaacctgaactgttctggattca +ctcctgactacagcctacaactcatttctatgcataactcttaaagacagtcgcaatatc +agtacctctatacacatcggatcagactagatcataagataagtctcctctggatccttg +tattctgttaagtacactacaaatttgtttagtgtctgggacaattacgataagggtcgc +gactagaccacagggcatatgacctccaccgctcctagcgagtctccaatctgcaagcac +tcatacgctaggggcatgaatcgactgtcaatgcactgtaagatttacgagggtgagacc +catttagatatgcctcgtttaaccgttttaggcttgataggatgagtttgtcgatccatc +aaattcccgacattcatattgtccaataagtatatctagcttattcggactcgctaaact +aaattatggtataaatgccgtcaaccggtgcatttgttcaatcaacaaattatagtcaat +ctcccatggggccttatggcagcgtatacagctggtataacgaccatatacaactatgaa +cggactagctgtgaactaagcagattattggatccttgtgtataattttaagtttcgatc +tatatgctatagtatagaaaatgttccgatcgtacgcttcctttacagttaaacagtcta +tatcatgaagcttatccaaagctggacatttgatggcaatcttacttaattatgaaactt +aattacctattattgaaagtatttatatgatcgaataagatttgctctataaacaggtcg +tccattcacgacctagtgattgcgtaaattgaccaacctaggtaatctaaagcctgcatc +tatttcttatcattcatgttatactgacccgttctcagtacttaaaaatgatcgtaagca +agaatcactcacgctcatgtcacatttagtcgaaataaactgccgatgggaaggaagttc +cgtcattgcgatatcgatgtctatcccacgcgtcattttcaaattggttatctacggata +actgtgcgatgaactactataggtcaaaattatcttcaatctcattctagatcatataaa +gatgtccttcgcgattgatacgtctacagtgtgttggtgttacacagagggtagcgacta +cttacttactaactctctcttgatccgcaagcataagccaggttaaagtgctctatcttt +ttctgtggattataatagttataccgccttgcatctaggtgcccattaggtaatgcccta +gtgttttcataaatttactcctgccatctaacgttactttaatttcccagattcaatagg +tctctcatttgaaaattgttatatgtcaacaaagaatataatagctgagtggaacaatac +actgtgagggagtaatacatactctaaattttctttacggtttgcgcctgcacagttttt +tttatctatgtgatccgcataaaaagtaatttcaacgttccattcaagttaagtcttggt +gacactagcattaggagagatcaccaagaccattatttatttagctagggtttaagtcgg +ttagaaatatcagataatgaggtctttatccggccttacgcagtagaaattggaaatttc +gtaaagcactgagttcaatggaagtatggccgaacccacataatgcacaaatcaagtcga +tttcttccgtccttttagtctcctgggaactacgggttattcatagttaagctaaatcag +ttaacggaactagacaaatgtataatagttcccaaatatatatctataaatcttatgcag +ttagggaatgcagatttgaatcatggcaatacgctagctcggaactcaactacaagtgtt +ggatgtacgaattcaaaggtattacatccttatgatgttcttttttggatacttttatga +cgacttccacgaagtgaaattatgttcgaatatctgaacagttacttggttgagcccaag +gatgacgaatgttctgtttataattctcgtcataatataaatacaagcatatgaggccag +tcatggagctttcatttggactaacatttccgtagagtcatatcacgcctgtaatctgat +ccgtctttttctattcgaagtgttatcagatacatgacgcccttgcgtgacattcatggc +tcctgacatcgggtcttttaggctgaatctaatctaacccaatttgtttggattgtgggt +cctccattttgtctgttaatgcttattaagattaaaaatgtactacgtatttagacctaa +tgattgcgatacgctgtggaccattaatataagctgcgccaggggatttttccagatcat +ctggcctgtgtatatgttcaaatctaatagccgagagaaattactccgacggaaaataaa +ggcagataagcgtttcagagcaccatcgtggcgtttagtcaacctttagttcggaattta +ttaatatacaatctcactctttggacgagctccttaaaagatgcccttgtatatcatgtc +ccgtacctaaaagtataccagcatcatcaaagaacagttaaggaatacgactgctctata +attgtccgaggagtaccttctcatctgccaatagtcgttgggttggaaaacaacgcatta +atatgccacacttgtcaattagaagtttctataaaggggacgagtaactgatttgagacc +tagcacggcagaggacgttcgtgtgacaacatctctttataagtttgagataaaatcgct +aatctacaatgattatttgccaatcattatcgaatgcgcaaagtatctcctgttcgtgat +tctagcctaaggccattactatggtcaaattatgctaatcgaagcagtcttctaacaccc +ttagaaaagcaaacactattgaatactgccgccgcattcgccagcaccaacataactgca +cgtgcttttttccatgattggcattatgaaagatttgatctatgattcttaccagttgca +atattcaatttagcatgtgttcctaattattgtgttattatggtctatctcatcatgtaa +atgaagatcatgacgtcaacacagattctagtcaggatcatcagttcctcggggaaatcg +cacctaggaacagccttatgcaaccgctaaacaaagcaatgaggatgtaccgacaaaagc +tcgatttaaaagcctcgaaacgagatgtacgaatcgtttactgccttttatgaggagtcg +agtactgttggttcatatttgctacatgattgtatgtaataacgatcccgccctttatcg +gttcgatcctttatggcgataagttatgaatcgtcagtatctttagatcaaaaactcaac +tagtacccagttccccggaggaacggtcatgattaatgcgttttacggtctcccgtccct +cttcttgtcagaggaatcagtttcatccgatcccactcgatgattggtatagctatttgc +cgaaaagccacaacgtattcggtactatcttgtttgattcccctgtatcttaattcgcga +cacttgatatcttttgtgtttaatcgacgaatcatcctgggggcgacacttgttacaatt +atccagttgcgtttaatggctgtgggtcacaagattgttagacaggtcccgcgtgtcgta +ggaaattgataattggagtttgcaggacgaatagctcacccgcctaagtgatccaaccct +catcaggataactatcactgggcagtattatttttgatttcatatgccaccccctaggag +actgtagtcatgtatctttcttacccaatctagcccgaaacaagaaagaatgtcgattcc +agtcaccttttattagaccgatttacacacaaagtgtcttggtttaaaggctggcatgaa +tacatactcaaaagttgaaaacgacttgctctattcgattaccttcgcgatctcaatcga +ttacgctaaattttaatgcccgctgaaatatccaacatttaaaacaggattaattctctg +atccatgaacttaggactcattgcacgtgacttatctttctctcttaattcatgctccaa +tacggtgggctaaaccacttttatcacatgaatgtacgcaacgtgttaataagctatgag +tacgcgggggcagcgaaacgggtcaatctgggtatcttctattgggacggtacatttcgg +ttttatagactatgtagttacacggcatcaacatgtaattaaaacggcgtaacctaggaa +agccgaacgcaccttgggattgccatgtgtccggaggattacatacatctaagaaacatt +ctaaactatgtatagtcgtttacgacccttgtagtacgtgcatcccttggcgaaaagtac +tctgggtattagagtgtatattatcgacagcaccgaatcctcattttatagcttgacaat +ttatgacccgaaagaaccttttataagtctataagtatatctaacgcaattgcggcactg +agtccactaactatctttgagcagtgttatacagtgagacgccatggaaggggtttatat +attttactgtcgttccctaaaaagttaattatcagacctgcgcgatctcgtagatgaaca +acgcgatctagtcgaaaaatgcttgtggctaccattccagtcgagatcaaccgtttctgc +ggatcgcgttacattccttgcttatttgcgataaatcgatacaaccccattaccagaaaa +acccggagaatcaattactctgcagatcttatactaaaaaagagattacaacccctgttc +tatgtgtcccaaagtgagtaacgtggagcgttggggtaagagcggagcgattttaacttt +cgcttttccattttccagtattgtactttacgttatatttgagcggcacattcgtcaaaa +catgatccatatggactgaggtgtttaaatgttaatcaaataattgtattttcagctgac +tttaaaatctgcagccattggaggtggagattccaatagatgtaagcaggtgatatcata +tgcaattcttgtgacttattaagataccagacacggcacaatcgcagtagcacgtaaaca +ataatgacaatcgacggttaaattccgaacgtaagatatgtttacggatgcactaaaata +ggtagcaacaacgtttctctgagatgtataagttaccaaacactggagaattccgctaaa +ctaaggacaatttccgtcgtattaattgttgacaaatggttagtaatacattcgcagtgg +ataatccgttgcatacctagcactgagtgtaaataaaaccaatcgactactggcatttcg +ggctaacgactagatgttagcctatgtgaaagcctcacacatgcttattgccttcacggt +gagcaatgtttcttattcgttattagaagtcacctgtagagacagtagagatgacctaaa +tttggtttgtccagtcccgaggtgatctaatgattaggttaacttagaacagtggtcaat +tggttaaagctgatttacgaacacttccgaggggtcgtaaaacattaaactggtgagaac +agtatgatgtattcggtcatctagacaaccccatcgctgggagtttggacagtgttatga +ttcgtaaatccaccatgtgtccgaattcgaaatcctgttgctccggggagatagggttaa +tttaggcttttttacggtgtggcatattagctcaaacatcaacattcttaaaatcagcgt +aaacggtcaccagttgatatttgttctgctaggaagcgatgtacaaaataagcttaataa +gatttaggtccgaccttaatttcggtccatagcacctctttctaagtgttttgcttaaat +aattgtattgttattgattttctgcgagttgaacacggaaaataagtcaaaaaggacact +tttaggttcatatgtaccgatgaatgcgcaatagaatcgagaaatttttagattagtaat +cgtgatgattgtggccaaatcccgcactaaacggctttcgctgtttccaaaaaattttag +tccactaggtatttaaatgttggacactgaacgtggaagccgtcgtattatgaaactaat +ggcagaggggctcctctgcgtgtactttgagcagatgctatcgtcagaaaaaggtaaatc +ttttggttctttataattctggcgtccgtgtagcctagtgaatgtgtttggttcaagtga +atttgtttagccagaatggaccaattacgtcattagctgttacgtctatacgaaatatag +actgtggacgacccatcgtagagtcatgtagttacatgtgaccttagaacaccaatcgtg +tgcgattgtaagcaggacaacacagtattgtactggtcaattggttcatagatctgacta +tgaatcttcgtttttgtacaacaatctcggtgaagcttcaaaaagcctccttcctaataa +tcagttaatttttcgtaaggttcctgttcgaggttagtcgtataaagacgaaacggcctt +aatgtaacattaactattccactgtaggtggatctaacaaggttggacatgtgctaccaa +taagataagaatttcgtccgcaatacaatatctacttttgtagcctatcttggattaaca +acaacttacgttggtatttcaccggacgtatcaaatgattctgattttaatgactgagag +taaacatcaacgaatcttatgtatctttaagccgctgcttgacaagtcacattactgtta +gaatgaacgcttcattactacaaaacctaccaccaactcccacattaatattatactaga +tgtttgaagtttatttgacaaaggttttcaaaaagcacagaatcgttacgaacacgtaca +ttaaattgttagggtattaattgtggtcggtgcatttccggccccatagcgctccgcggg +gagaaactatggccttcatgacagcccccccataacatctaggtaatggtcggataacta +taaacaaccctctccagagaactgtgaaaataaaatctcttagtacacaagcgtatactg +gtttaagtcttgcccatcttaaagactcttttcactattttcttgatgcctcattcttct +aatattaggtgattttttaatccgagaatataaaaagacgatagaaagtgttaaaacacg +gcgtagcgacatattttaaagaaatgaaatactttttgactatccctcatgatctaaact +tacgcggagctatctttttgtataacatgtacagagaattaatccgatgcttcttccgat +taaggacatagcgccgaaaacgtcatggcggcttatcgatatcgtaacgcactataccaa +gtgattaagtgatcaatgaatacgggtttcgggatttctgttaagtcatgcacggcaaat +acttggagtcttgaataacgccgcgcgtagtacgaaggttctcaagctcgcgtgacgtat +agaccgtattgctatttcctgccttctcaattgtccgaggattgctgataacttaaaata +aggttgagtttttaataacgatttgtcgagtttgggaaaatcctcgtttgtgtgtttgtc +attttcaagttatcaagaactacgggtataatttacgacgtaatgttggtttgatgcccg +attgcgaatatcgtacgaatggtatttgtacaactgctttcctttatcgattgctcgaga +acattataaagtctattactatggattaagactgtatacaagtgtttaagcggagcccgt +gataatctataaggttttggtacctttatctgttacttttgccttgaaacatacatacgt +acacgggaatatttacctaaacgccgtatagtccagcctcgtatttgggccgtgttttgt +cagcattttaaactgaaagcgcccacttgcattataacccggtgcggaatctcttagtga +ctcgtcaggagtttacgcctttgagacctctcgacaggacccattttgatctagtcgtta +taggtagagtgcctttcctatcgcaccattaccttctagcaaacttagagtattcaatga +aatcatatcctgtttatactaaatgttataggctaatgacacagctgacactaagaggtc +tcttcgggttacccgaatgagttgtttatacgatgttgacaactcgggggagtcatttca +atgaagactgaggactcttgatcagattaaaacgcttaatgactgataatttagattatg +ccgtgtattatttaagtgggcgaaccctcccctagaatgggtttcctgagaaaagtctta +gaacacagtattctgaatccagatgcaaatcgctaacgttagtaagcggctgtagctctt +ggcagtttggtcaatagtcaatcgcaatccgtttaaccgtctactattcctagagcgaag +agctatgttctgacacgtccccaatattaggcaaaggctccaaaagaacagtcaattgat +taactacgggcttggtttctccgtgaatccttgcgccgctataccacataaaaggatagc +ggtgataccacaagtttgcgacgttaaagcgtcgaccctcaacaagtacactagcaaccc +cttagcaattaattttgtccatcactactgccaagagttgactggaccagttggaaatga +catttgatatattaatagagctacatattgtaccactttactgtcacttacactaaccct +agcgtgattactcatacatatattcgtaaattctaagttatgatactagttttgtaaatt +taatcggcgaagacacgttctcttgtacgagcttcaactaaatatttcactgtagccaac +cactttaaccagaaggataccttaatgccgatataatattgtccaggaaacgttaatact +ttcacaagacaaagcttggaagaggtactttacgatcacctgatagatcgaccggaacga +ttctatataggtttggtctgagaaatttgtagctaaaaccatgttccataggaactcctc +tgtaatgggcaaaatgcagatagcgttcaatcgttgcttaactatctatcacagcatcct +aactcctcaacagcttctttcctaaagacatcagcaggtaagttgacggcacccgataac +ccagagcacgattggaatctaatactctgtatggatcattacgctaagtaaatataatga +ttttctgactcaaagttacactgcgaattttatattaactggttctatttgttaaatacc +acaacctctcgtcaacaggtcgcgatgcaagtgatccaaaaatatctaacttataccaac +cattacttctggcgcagaaaaacatagatatctgaacaatcgaccgttaagactgtctcg +ccgatcttaggaacctaatactgctcagtagttattgtttatttgggccatccccggatt +atgtcagccatggaacactaaaagtcctaatctaacctatggacaaaaagctcactttta +taaaattgctcaccttatgttgattgttatttgtccgaaatgtctataactcagtgtact +atctattggaaaattatggccggagttttattgaatatacttttgtatgttgagaaagaa +tgttgtcgtaataattatcagctggaaaatcatctaatatatattatattgagatattac +gacagacctaagtgctttcccgtcatgagcagatggactaacactcttggtaatccttct +cgttttagttggtaatgtttagtctaagtaatatcccgactcttacttactcagagcgga +aatgactttttaaactaacgtttaaaggcacttagtatgcgtcagggttatttttttaat +tacgtacccttgtgcagagagtttagctattcgatcctacttagtatgaaccatgagagt +acaggttggtaattcacagagaaggtcgagaagattatttttgatgtttaccaatactat +gaggcgtattcatcgaaataattttatggctgcgcacttcacatacgcaggaagaccact +gcagcttgctagatctggatgtatcattgtacttctaagagcctgaaaggtaatacattc +ccagcgagcgtaacagattgtatggggacatattcaatcttagcaatgcattcgttcttc +gaaatcaggcatttttgatgtcataagttctgtcaactataaccctggaactttaatctg +ttgttcgtcgaatcaaggatcaagaaagcttctaaaaggcccaaagcaaaacccaccact +acttcagttttaaattagaatcacaccctagggtattagataataattaaatgtcttagg +aagagatatcaaaagatgcagacatcctcaagtgaataagtctccggtctttcacaaaca +catggttaagcgatgtggttttgactagagacgttcgccaccatcgtaatatttctggtt +acctgcgaacgtgaaccaaatcttacttcatacattgcttaaacagtacaacttatctct +tatcctatagagatctcaaaagtttgtatttttactggtttcaaattgagagaaaaactg +cgttctccgatttctatattattgtttaaatgatgccaaacatccagtttaaaacacggt +gtgatcagccgactcagattcgtatcctatgttagaatgagtcatcaaactacggtcacg +cgtacattacagagtaaactacacgaatgaaagagataagaagatgaaagagttaatagg +tctcctgttaattatgagaaccctaactactacggattggcctactagtgggttggaacg +gatataaaattcgactaagttcgcggcatgtcaggctcctaaatatgaagagaactcggc +atcgaattatccacagtaatagttggaacatgattcctctatgcatggtgtatatccacg +tacgccagtgtgcagtgtagccatgcgaccacgggcgttgtgaatattcttcctcagaaa +aggactgttgagcaaggaattggattctgtgaacggaatatagtcgagtagatggaattt +cctacactgcgaaaaggtcatagtaaatcaaacgccgcgcgcagacatatcttcttggca +attagtactccactaaatcaattggttataaacttttagaatatctttatataagttcac +tacttacgctgcgggtagtatatttaaagtgatgtcttaggaatcttatggcggcggaat +aaacggcttgactatagataccctaattctggcataaccctgtaacgtgtgaagcatgct +ttaatagacgactagatcagcttatagaatggatatgactgccacattgaagagattaac +attagcgggtataatgttacgaacttgtttaacaaaatagctctaccacacacgcatagt +ataatataaaggtcctggagttcgctacgagcctggaattgcagttcccctaccctgagt +aaacaagatcagtatggacctatcttctgacccacgtgtaaaaactaccgttagcggccc +tgagaacggtgaagttgattatcggctaacactcgctttaccaaggaacaaacaattgat +ggaacaggtaagcggctggattctatcctgaatacagcataataatatttgctttcaata +tatagttatgacactcccaatatcactaactctttacaaatcggatatgaagagtgaatt +agagatggagccgatcgttccttgtattctggtaagtactcgactaatgtgtgtagtcta +ggggtaaaggtccttaaccgtcgagtctagaactcacgcattatgaaatcctccgagcat +agagactctaaattcgccaagcaataagtcccgacgcgaaggatgagaagctcattgaac +tgtaacatttacgtcgggctcaccatgttacatatgcagcgggtaaaagtttttgcctgg +agtggttgagtttcgcgatacataaaaggccccactttcatatggtcaaatatctatatc +gtgctttggacgactcgataaactaaagtagcctagtaatgccctaaaccgctgcatttg +tgcaataaaaaatttagagtatatataacttccggacgtatggctgccttgaatcctcgg +atatcgtccttatacaacgatgaacggtatagctcggaactatgcagattaggcgatcct +tgggttgaatttttagtttccatagatatgagttagttttgatatggttaccatacgtcc +ctgcattgaaacttaatctgtatattgattgatccttagcaatagcggcacatttctggg +caatatgacttaattaggttacggtttttactatgatggatacgttttatatgatagaat +aacagttgctatttaaacaggtactacattcaactaatactgtttcactattgtgtccaa +catagggaatatattgcctgaatagatgtattatcaggcatcttttacgctccaggtaga +actaattaaaaatgatccttagaaactttcaagcaacataagctaaaagttacgccaatt +ataagccacatcggtaggatcttcaggcattcccatatccttctctatcaatcccgtctg +ttgctaattggttatctaagcatatcgcggcgagcatctacgataggtataaagttgctg +ctatctaattcgtcataatatatacatggaattacagattcatacgtcttcagtctcgtg +gtgtttctaagagcggacccaagaattacgtaatatctctctcgtgttacccaagaagtt +gacacgtgattgtcagctatctttttctggcgatgttaatagttataaacaattgcatat +agctgcaaattagctaatcaaatactcgtttcttaaatgttatcagcaaagctttaggtt +ctgtaatttcactgtgtaaagagggcgctaagttcaaaattggtttttggcaacaaacaa +tttaatagcgcagtgcaaaaataatatctcagggtgtaattatttctctaattggtcttt +acggttggaccaggcaatgggttttttatctatgtgataccaattaaaagtaatttcaaa +gtgacattaaacttaagtattgctgtcaagaccattacgacacttcaccaacacatttat +gtattgtgctacgcggtatggcccgtagtaatttctgatattgaccgcgttatcagcaag +tacgctgtacaaatgccaaatttagtaaagctctgtgtgcattccaaggtgcccacatca +cacattatcaacatatcatgtcgttgtattacgtccttttactagcctgggaaataccgg +tgattcagagtgaacataaatctctgaaagctactagacaaagctagtatagttaaaata +tatatttcttttaatattaggatctttgcgattgcacatttcaagcatcgcattaaccta +cctccgtactcttctacaacggttgcatgtacgatttctatgcgatgaaatacttatgtt +cttagtttggggttactttgttcacctagtcctcgaacgcaaattagcttcgaatatctg +aaaagtgtatgcgggcaccaaaacgatctcgattcttaggtttataattatagtcagaag +ataaatacatgcatatctggacactcttccacatgtcatgtcgactaactttgaactaca +gtcatatatagactgttatctgatccgtatgtgtctattactactcttatctgagaaagg +acccaatggagtcacagtaagcgatcatgtcatcggggctttttccctgattataagatt +acactattgctgtgcttggggcctcctactttttctatcttaatcattttgtacattaaa +aagctaagaagtaggtacaacttatctttcccatacgagctggaccattaatttaacagc +cgcaaggcgagttttaatgttaatctggaagggctttatgttctaagcttttagcactga +gaaattaatccgtaggaaattaatcccacataacccggtaagagaaccttacgccccgtt +actaataatgttctgcgcaatgtaggaagtgacaagctcactcttgcgacgagctcctta +atacaggccctgcgttatattcgaccgtacctataactagaccaccatcttaaatgtaca +gttatggttttcgacgcatagagtatgggaccacctcgaaatgctcagctgcaaattgta +ctgggggtggttatcaaacatttaatatgaatctatggtaaagtactagtttatagatag +ccgaacactaaaggtttgcagaccttcctcccctgaggaacttcgtgtcacaaattagat +tgagaaggtggtgataaaatcgcgtatctacaatgatttggtgcaaatatttatcgattg +cccaatcgttctactcgtactctttatagcctaacgccttttcttggcgctaattagcct +aatccaagaaggagtctaacaaaattacttaaccatactcttgtctattcggcccacgca +tgcgcaagctcaaaaagttctcaacgggcgtttttacttgagtcccaggaggtaacattg +gatctatgagtcttaacagtggaaatatgatttttagattgtgttcagatttattgtctt +attttggtctatctcatcagctatagctacataatgacgtcttaactgtttcgactaacc +ttcagatctgactaccccaaatacaacatagcaaaagaatgatgctaacgcttaactatc +ctttcacgatcttaacaaaaaagctccatttaaaagaatcgaaaacagatctaccattcg +tggaatcaatttttggacgagtactggtcgggtcgtgcttatttgctacaggattgtttc +gtataacgttcaagcactttagcggttccatccttgatggcgttaactgatgatgcgtaa +gtttatggtgatctaaaactctactacgaaccaggtcccagcacgaaacgtcatctttaa +tgagtttttaggtctccaggcactaggctgcgaagtggaatatgtgtcatcagagacaaa +tagatgattcctatagctttttgcagttaagccactaagtaggcggttctatagggtttc +attcaaatcgatcgtaattcccgactctgcatagcgtgggtcttgtatagaccattcttc +aggcccgccacaatggtttcaagtttcaacttccgtttattggctgtccctcaatagagt +cgttctcagggcacgactctcgttcgttattcataagtccagtttgatccacgaatacag +aacacgcatatctgataataaaagcttaacgataactttcacgcgcatggtttatttttg +atttattaggcaaccaaataccagaatgtagtcagcgatatgtagtaaaatttagacaaa +cataaaacaaagtatcgccattacagtctcctgttaggagaacctttttatcaatatgtg +taggcgtgtattggcgcccttgatttaataataattacggctaaacgtattgatattttc +caggaactgccccatctcatgagatgaccctaaattttattcacacctcatttttaattc +ttttatatcacgattatttatctgagcaagcatctttgcaagcattcatagtgacggtgc +tgtctctatgaatgcatgctaatatacggtgcgctaaacatattggttcaattcaatgta +agctacctcggaatttgcttgcactaagacggggaagccaaaacggtaaatcgccgtata +tgctagtgccaagggacttgtccgttggagtcactatggagttacaagcattataaatct +aaggaaatcgcagtatcagtccttaccccaaagatacttcgcattccctggggtacggac +catgaaatacttctttcatacatgataaacgatggagactcggttaccaccctggtagtt +actccatcaattggagttaactaagatcgctattacaggctttattagccaatcatcaca +agcctctttttagagattcacaagttagcaaaccaaagttcctttgataagtctttaacg +agatctatcccaattccggctaggagtaaaatttatatatttgagatcggggttaaagtc +acacgcaatgcaaggggtttttatatggtaatgtccttccctaattaggtaattttcaga +cctccgagagagagtagatcaacaacgcgttatactcctaaaatgcttgtcgataacatg +acactacagatcatccctggatgagcatcgactttcattacttgattagttcagttaatt +cgtttcaaaccattttcaacaaaatcccccagtagatatgtatatgcacatcttagacta +aataacagttttcataccctgggatttgtgtcactatctcaggaacgtcgagacgtcccc +tatcaccgcagcgagggtaactggccctgttccattgtaatcgatgggacgggacgttat +attgcagacccaaagtagtaataaattcagccatatggacggagggggggaattgttaag +aatataattcgattttcagctgaatgtaaaagctccagccattcctcctccacttgacat +tagttcgaagaaggtctgagaattggaattgcttgtgacgttttttgtttccagacaagg +aaatagcccagtaccaagtataatattatgacaatagaagcttaaattcacaacgtaaca +tatctgttagcatgctctaatagaccgagaaaataagtgtctatgtgtgcgagaactgtc +aattcacggcagtagtcacctaatctaacgtctagttcccgactatgaagtcttcacaaa +tggttagtaataatttcccagtggagtagaagtggcataacgtgcactctctgttaataa +tacctttagactactcccatttcgccagaacgtcttgatggtaccctatgggaaacactc +acacatgcttattgcctgcaacctcagcaatgtgtcgtatgcggtatttctacgaacagc +tagtgaaaggactgatgacctaattttggtttctcaagtccagacgtgatattttgatga +ccgtatctgacatctctgggcaattcggttaacctctggtacgaaatagtccgtcgcgta +ggtaaaaatgataatgctgtcatcactatcatgttttagctaagctacactaccccatcg +ctcgcacgtggcaaagtgtgaggattccgatatcatccatgtgtacgaattcctaatact +cttgctcagggcacttagggttattgtagcctgtgttaccgtctcgcatattagatcatt +aatcaacagtcttataatcaccgtaatcggtaaacagttgttatttgttctgataggtag +acagctaataaagatgctgttgaacagttacgtcccacctttattgccctacagtgaaac +tagttcttactctgttgctgtaatatgtctagggttattgatttgctgccacttcaaaac +ggaaattaagtcattaacgaaaatggttccttcataggtaaagatcaatccccaattgaa +gccagaaattttgagatgtcgattcctgatcattcgccaaatttacagctcgtaaacgag +ttccatgtgtaaaaaaatgttgagtccactagcttgtttattctggctcaaggtacgtgg +aacacgtagtattttgatactaatgccagacccgctacgatccctgtactgtgagcagag +ccgatcctcagaaatagctaaatcttgtgcttcgttagaagtctcgactacgtgtagcct +agtgtttgtgttgcgttatagtctatttgtggacacagtatggtcaaatgacgtcttttg +atctgacggcgttaacaaagatactctgggcaacacacatacttctctcatgttgtttct +tcggacctttcataacctttcctggcacatggttagctgcacatcacaggattgtaaggg +tctagtggttcagtgagcggaatatcattcgtcggtggtgttaatctatctcggtgtagc +ttataaatgcatccgtaagaatattatgtttatttgtcggtacgttcatggtagtggtgt +cgccgatttagacgtaaaggcatgtatggatcttgatctatgcaaaggtaggtccatcta +tatacgttgcacagcggatacaaataagataagaatttactaacatttaaattttcttat +tgtcgagcatagattggaggaaaaacttatttacttggtatttaaacggaagtttctaat +gtttatgattggatgcacggacagtttactgcttactttcttaggtttcttgaacaacag +gatgcactagtaacatgtctcgttcatgcttccattaagttcttcttaaacttacacaaa +ctacctaatttagagttgacgagatggttgaacgtgttgtgacaaacgtttgcaaaatgc +acagtatcgttaccaaaaagtacatttaagtgtgtgcgtaggaattctgctacgtccatt +gcaggccacattcacatcccacccctgaatatatggactgaatcacacacaccaaatttc +atctaccttatcgtagcataactattaacaaacatatacagacttcgcggtaaataaaat +atattagtacacaaccgtatactggttgaactattgcccagctttaagacgcttttaact +aggtgcttgatcaagaagtattattatatgacggcagtgtgtaatacctgaatagatata +gacgttagattgtctgaaaacacgccgtagagacatttttgttagatatgtatttctttt +tgacgagccagcatcttagtatctgaagacgagctatatgtttgtagaaaatcgactgac +attgtatacgaggcggcgtaagattaaccaaattccccagaattagtaatggcgccttat +cgatttactaacgatatataacttgtgatgttgtctgcaatgtatacccgtgtaggctgt +gctcttatcgaaggaaacgcattgaagtccaggctggatgaaaccaccgcgtacttccat +gcgtctatacatagcgtcaccgatactacgttttgctatgtaatccattctaatgggtaa +gaggattcctcttatagtaaaatatgcttgactttttaagaaccattgggagtggttggc +aaaataatagtgggtgtctttctcagtgtatagttttctacaactacccctattaggtta +caagtaatctggctttcttgccacttggcgatgatagttagattcgtatttctacaacgc +agttactgtatccatggcgcgagataattagatacgatttgaatttggatgtagactcgt +tactactgttgtagaccagcacgtgagtatctagatgggtttgctaccttgttagcggac +ttttgccgggaaaaagacatacgtacaaccgtatattttactataagcagtattggccac +cctcgtattgcggcagggtgtgctcacctggttaaaatgaaagagaaaaattccatttta +aaacccggaggaatctattactgacgaggaaggtgtttaacccgttgagacatctcctaa +cgtaaaaggttcatattctagttattccgagagtcactttcctatccaaacatgaactga +tagcataatgacaggttgaatggaaagcatatcctgtttattctaaatctgtttcgctaa +tcaatatgctgtcacgaactcggagcttacccttacaactatgtgttctgtttaccaggt +gctaatatcccggcactcttttcatgcatgtcgctcctagcgtcatctgatttaatagct +taatgtctcatattttacagtagccagtgtagtatggaaggcggcgaaccagcccctaca +ttgggtttcctgacataagtattacatatcacttgtctgattacacagcaaaatcgctaa +ccttactttgcgcatgtagctattggaactttgggctagtgtctatcccattaagtttaa +cagtagactagtccgtgagcgatcaccgagcttatgtctcgtacccaagttttggatttg +gatcaaaaactactcgatattcatgatctacgggcttcctttctccgggtatcattgcgc +cgagattaaaaataaaacgatagcgctgtgaaaacatgtttgacacgggatagcgtagaa +actaaacaacgaatagaccatccaatttgaattttattgggtccagcacttcgccatagt +gttgaatggtaaagttcgaaaggaaatttgttatattaattctgctacattttcgaccac +ttgtatctcaaggacaatatcccttgaggcttttagcagaaagagatgccgtaattctaa +gggatgataataggttgggaaatttaagagcagtagtaacggtcgcgggttcgaccttaa +actatatatttaaatctagccaaacaagttaacaacaaccataaagttatgaccttatta +tattggcaagcttaacgttttaattgctctagtaatagagtggtagaggtaagggaccat +cacctgattcttcctccgcaaccattatatagacgtgtcgtctgacaaatttcgagataa +aacattcgtccttagcaacgaatatcgaatggcaattagccacattgagttaaatagttg +aggatatttcttgcacagaatcagatctaatctaatgattcgttactaaacacttcacca +ggtatcgtgaaggctcaagattacccagagaacctttgcaatataagaatatgtatgcag +cattaccctaagtaattatattctttttctgactcaaagtgacaagccctagtgtatatt +aaatcggtatatttgggaaattcctcaaactatcctaatcaggtagccatgaaagtgatc +aaaaaagttcgtacttataccatacatgaattctggccaagtaaaaaatagattgcgcaa +aattcgtaccttaagtctctcgccaagatattaggatcctattactcatatcgtgttttt +ctttattgccgccatccccggagtatctcacccatccttctcttaaaggcctaatattac +ctatgcaaataaacatatattgttgaaaattgagaacctgatcgtgattcttatgtgtac +catatgtatagtaatcacgcgactatatagtgctttagtatcgcccgtgggtgagtgaat +attctgggctagcgtgagatagtttcttgtcctaatatttttcagatcgaatagcttcta +tttttgtgtttattgacatatgtcgaaactccttactcagtgaaagtcatgaccagatcc +acgaacaatcttcggaatcagtctcgttttacggcggaatcttgagtctaacttatatcc +cgtcgcttactttctaacaccccttatgtatttttaaaattacgtttattcgaacgtact +tggcggaagcgttattttttgaagtaagttacattgggcagactcttgacattttcgata +cgactttctttcatccatcacaggactcgttcgtattgatatcagaagctcgtgatgatt +agttgtcttctttaccaatactttgaggcctattctgcgaaatttttgttgccctgcgaa +cttcacataccaaggaacacctcgcaacatgccttcatatccatcgttcattgtaattct +tacacaatgaatcctaagtaattacatccctgcgtaaaagatggtaggggcactgaggat +atattaccaagcatttagttatgagtaatcagcaatgtttcttgtattaagttctctaaa +atagttacatcgtaatgttatctcgggttccgcgaataaacgagatagattcattatata +tggccctaagcaaaaacctcctcgtattctgttggtaattagaatcacacaatacgggtt +gagatattaattatttgtagtacgaagagatataaaaagatgaacaattactcaagtcaa +gatgtatacgggatttataataaaaatcgggtagagatctgctttgcaattcagacgtgc +cactaaatcgtaatatgtcgcgttacatcagaaagggtaactattattaattaataaagg +gcttaatcactacatattagatcttatccgatagtcttatctattcgttgtatttttaag +cggttctaattcagtcattatatcagtgctccgagttctttattattgttttaaggatga +caaaatgcctcttgttataacgctgggagaagcagactaagagtcggagcagttggtaga +atgaggctgcaaaagacggtctcgacgaatggacagactttactaaaccaatgaaagaca +gaagtagagcaaagtctgaagtggtatcagcttaattatgacaacccttaatacttccct +ttcgccgaatactggcgtggaaaggttttaaaagtcgaagtagttagaggcatctctcgc +tcataaataggtagactactcgcaatccaatgtgactatgtaatactgggaacatcagtc +cgcgatgcagcgtgtttatcaaccgtccccactcgcctggggagacatgagaccaccccc +gtggggattattagtccgcagtaatcgactcttgacaatccttttcgattatgtcatagc +aatttacgacagttcagcgaagtgactactcggcgaaatggtattactaaagcattcgaa +cccacatgaatgtgattcttggcaatttctaatccactaaagcttttccgttgaatctgg +ttgtagatatttatataagttcactaattaagatcacggtagtatattgatagtgatgtc +tttgcaagaggttggccgaggaatttacggattctctattgatacaatttgtctggctta +taactcttaaggctgaaccaggcgtttttagacgacttgatcagctgttagaatggtttg +gactccctctttcatgtcagtaacatttcagccgttattgttacgatatgcttgaacaat +attgatctaccacacacccatagtatattttataggtcatgctgttacctacgagcatgg +tattccacttcccattcaatgagtattcaacatcactagcctcagagatgatgacccacc +tctaataacgtcacgttgcggccatgtgaaacctgaacttgagtagacgatatcaagcgc +tttaaattgcatataacatttgagggtaaagctaagcggatgctttatataatcaatact +caataataagatttgattgcattttagagttatgacacgacatagttcactaacgagtta +ctattcccagatctagactgaagtactgatcgagacgatccttacgtcgatgatcgttag +ttatcgacttaggtcgggtctctagcggtattggtacttaaccggacactatactaataa +cccatgatcaaagcataacagaatacagacgataatttcgccaacatatatgtacagacc +ccaagcatgagaagctcattgaaagctatcattgaagtcccgctcacaatgtgtcttttc +cagacggtttaactggttcccgggagtcctggagtttcgacttacataaatggaaacaat +gtattttgctaatttatctatagcgtcatttggaccaatacagaatattatgttgcctag +taatccactataacccgcaagtgctgatagaaaatttttagacgatttataaatgcccca +agtatccctcccgtgaatcctccgttatactaattagtattcgttcatacgtataccgcg +catatatgaacatttggcgataaggcgcgtgaattgttacgtgacagagatagcagtttc +ttgtgatatggttaacagacgtacatgaagggaaactttatatctatagtgatgcttccg +tagaaataccgccactggtctgccaatgatgaagtatgtagctttaggtttgtactatga +ggctttcgtttgtttgcagagtataacagttgcgagtgaaaaaccgacgaatttatacta +atacgctttcactattggctacaaaatagggaagagtttcaatcatgagagggagtatat +ggatgctttgtagctaaaggtagaacgtatgtatatgctgccgttcattcttgaaagata +cataagcgataagttacgacaattataagcaacatccctaccttcgtaacgatttcactg +ttactgcgcttgaaatacactatggggctattggcggagagaagcagatcgcgccgagca +tatacgagacctataatgttgatgatagagaaggcgtctgaattgatacatcgaagtaca +ctttctttcgtagtatctctcgtcctctttctatctccggacacaagaattaagttatat +atatagagtcttaccaatcatgttgaatcctgattctcagagttctttggcgggccttgt +gatgactgagaaacaatgcaatattgctccaaatttcctaagcaaattctcggttatgtt +atgttatcagcaaagcgttacgttatgttatttaaatctggaatgacggagcgaagttct +tatgtcggtgtgggaataattcttttgaagacagcactccttaaataatatcgctccgtg +tttgtatttatcgaatgggtctgtaaccttgcacaagcaaatcggtggtgtatatatcgg +ataacaattaatacgatgttcatagtgacagtatactgatcgagtcctctaaagtcaatt +acctcacttaacaatctcattgatgttgtgtcattcccggtatcgcccgtagtatgtgct +ctgattgaccgagtgtgaaccaaggaacatctactaatgcctttgttaggtaagatctct +ctgaattccttcgtgccaacttaaaacattatcaaaatttcttctacttggattaactac +ttttacgagcatggcaaattcccctgtggaagacggttcattattatcggaaaccttata +gaaattgcgtgttgactgaaattagatttttattgtaagagttgcatctttgcgattcct +ctggtctagcttccaatgaacagtcctcccttctattcgacatcgggtccttcgtacatg +tctttgcgatgtaataattaggttcggagtgtggccttaatgggtgcaactaggaataca +acgcaaatttgctgacatgatagcaaatcggtatgccggcaccaaaacgtgctccttgct +tagcttgtgaatgagactcagtagttaaataaatccatatctgcaatcgattccacaggt +attgtccactatctttgaactactctaagagatacaagcttagctgagaccgaggtgtat +atgactacgctgatatctgtaaggtaccaatgcaggcaaagtatgcgagaagctaatacc +ggctgtttccagctttataagattaaaatttggctgtcctggcggcctcagaattgttct +atcgtaatcagttggttcattaattagctaagtacgaggtacaacttatctgtcccagaa +cagctccacaagtttttttacagccgaaacccctgtgtgaatcttaatatccaagcgcgt +tatctgattagagtttacaactcagtattttatcagtacgttttgtttccaacattaccc +ggtatgacaaaatgacgccacgtgtcgaataatggtctgaccaatgtaggaagtgaaaag +ataaatattgcctacacatactgaattcaggcaatgcgttttattcgaaaggtcatataa +ctagaaaacatgatgaattcttatcggatccttttactagcatagtgttggcgaacacct +cgtaatgctcagcggcaaattggactgcgggtccttatcatacattttttttcaatatag +gcgattggtctaggttagtgattccccaacacttaaggtttgctgacattcataccctca +gcaacttcctctcaaaaattagagtgagttggtggtcttataagaccgttgattatttga +ggtggtcaaatgatggtgcgatgcacaaatcgttataatcgtactctgtagacaataacc +cattgtagtgccgattttgtgcataatacaagaaggaggatataaaaatgacttttcaat +aatattggctattagcaacaagaaggagaatcctcattaagttagcaaccgcagggggta +ctgcagtccaaggaggtttcattggagagagcagtatgaaaacggcaattatgattgtga +gattcgctgaagattgtgtctctgattttcctagatagaataagctatagctacttaatc +aactcttaactgtggagactatcctgatgatctgaataccccatttacaaaattccatat +caatgaggctaacgcttaaatttcatttctccatcgtaacaaaaatcagcctttttatac +aagacaaaacactgcttccattacgggtagcaatggttgctcgactactggtagcgtcgt +gatgtggtgataaagctgtcttgcgtttatacttaaacaaattttgacctgacataatgg +agcgacttatcggatgttgccgatctttagggtcatctattaagcttatacgaaaaaggg +acaagcacgttacgtaatctggtaggactgggtacctagaaacgcaagaggaggcgaact +ccaatatctgtaagaacagaaaaatacaggagtccttttcatttttcaagttaacaatat +aagtaggagcttagagaggcttgcatgaaaatcgttaggaattacagaataggcagagag +tggggcgtgtagactacattcttcaggccccacaatatgggttataggttaaactgcact +ttttgcgatctcccgaaatactgtcgttctctgcgaaccacgctcgttccttttgctgta +gtccacgttcatccaactattcagataaacaagatcgcagaattaaagcttaaccatatc +ttgatagcccatcgtgtatggggcatgtatgtgcaaacaaaagacctcaatcttgtctgc +gagagggaggaaaatttagacaaacataattcattctttcgactggacacgctaaggttt +ggacaaactttgtatctatatctggaggcctgtattccagcccttcttttaataagattt +acggcttaaactatggatatttgccaggaaatgacactgctattgacaggaacataattt +tgattcaaacctcattgttaattattttatatctcctgtttttatatcagaatgcttctg +tcctagaaggcatactcaaggtgagggctcgaggaatgaatcataatagaccggccccta +ttaatattggttcaattctttcttacataacgcggaatttgattgcacgaacaccgggaa +cacataaccgtatagcgcccgttatgctagtgcctagcgactgggaccgtggagtctata +tcgtctttctaccattattaatctaaggatataccactttaagtcctttcaactaacata +aggcgcattccatgcgctaaggaccttgaatttattatttcttacatgataaaagatcga +gtcgacgggaacaaaaggctacgtactcaataaagtgcagtttactaagagccctttttc +tggcttgtggagactatcataacatgaagatgttttgacattcaatagtttgcaaaacaa +acttactttgtgtagtattgaacgagatctttccaattgccccatagcaggaatagttat +atattgcagatcgcggtgtaacgcactccaaatccatcgcggtgtgtgagggtaagcgac +ttaaagaattacggtttttgatcaaagcacagtgagagttgagcaaattacagttatacg +acttaattcagtctccataaattgaaacgacacttcttaacgggaggaccagacacgttc +attaagtgaggagtgcactttttgactttaaaaacatggtaatcaatttaaaccacttga +tatgtatatgaacagatttgaagttatttctgttttaatacactgggagttctgtcaata +tcgcaggaaccgcctgacgtcccctatcacacctcagagggtaaagggacaggggaaagg +gtaatcgaggggtagggaacgtagttggcacacccaatggacgaataaatgctgccatat +ccacggagggcgggattgcggttgattttaaggcgatggtaacctgaatgtaatagatca +tcaaatgcctcctccactggaaattactgcgtacatccgctgagaattgcaatggagtgt +ctcggtttttctttaaacaaaaccaaattgacaacttcatagtataatttttgcacatta +caagcgttaattaacaaacttactttgctgttagctgcctatatttgtccgacaatataa +ctggatatctctgcgagaactgtaaattaacggcacttggaacataatagttcctattgg +taacgacgttgtaggcggcaattatccggtggaagaattgacaactgcagttgaactgca +tgaaagtcaaatctctcgtaagtataactttagaagactccaaggtacccagaacctctt +cagcggacacgatcgctatcaatcaataaggattattcactgaaaccgctcatatctgga +ggtggacgtttttcttcgaaaagcttgtcaaaggactcatcaaatttttggccgtgctaa +tcgacacacctgttattttcatgaccggataggacatctcgcggaaattcgggtaacagc +tgggtagatataggacctcccctacgtattaatgataagcctgtcataactagcttggtt +taccgaagagacaataaacattcgagcgctcgtgccaaactcggtgcattacgtttgaat +aaatcggtaacatgtactattactctgcctaacggcacttacccgtttgggtccatgggg +taaccgctcgatgttgacagaattatgctaaagtcgtttaagatcccgattaccgaaaat +ctggttatgtctgagcattcgtacactgcgtattaagatcaggttgaacaggttcctaac +aaattttgtgacctaaagtgaaactaggtcgtactctgggcatgttttatgtcgtggcgt +atgcatgtgctgacacttctaaaaccaaattaaggctttatccaatatgggtccttaagt +gctaaacatcattcacaatttcaagacagattgttggtcttgtcgattccgcatctgtcg +ccaaattgacacatcgtaaaccaggtacatcggtaattatatgttgactaaactaccgtg +tgtattctggctctaggtacggcgaacaagtacgatgtgcttaagaagccctcaccccag +acgagcccgcgtaggtcacatcagcagatcctaagtaattccgttttattgtcctgaggg +agtaggatcgacgaactctacaagtcgctttgtcgtgccttataggctatttcgggtcaa +tgtagcgtcaaatgaactattgtcatctgtacgagttaactaagtgtctatcgccaacta +aaagacgtctcgatggttctttatgcggacctgtcatatcattgactggcacttgcttac +atccaaataacacgtttgttagcggatagtcgttaagtgtgcgcaagatcatgaggcggg +gggggtaatatttcgccctctacatgataaatgaataagtaagaagatgatctttttgtg +gcggtaccttaagcgtactcctgtcgacgagttactactaaaggaatgtagggttctgga +tctatgaaaagcgacctccatatatatacgggcctaagcggagtaaaataagtgatcaat +ggactaacattgaaatgttagtattgtcgaccattgagggctggtaaatcttatttacgg +gcgtgggaaaacgaacgtgatatggtttagcatgggatgcaagcactcgttaatgcttac +tttagttggttgcgggaacaacaggaggctatactaactggtagcgttcttgcttccatt +atgttattattataattaaaaataagacatatggtagagttgtagtcagggtggatcggg +ttgtctataacgttggaataatcaaaactatcgttaacaaaaacgaaatttaagtcggtg +cggtggaatgcgcctacctcatgtgcaccacacattcacagcacacccctcattataggc +aaggaagcaaacaaaaaaaagttaatcgaccgtatccgaccttaaattttaaaataaata +gaaacacttagcggtaatgaaaagataggactaaaattcactagtatcctggaacgaggc +aacagagttatctagatggtaacgaggtgctgcatcaagatgtatgatttttggtccgct +gtgtggaatacctctattgatatacaagtgactttctcggtaataacgcacttcacaatg +tgttgtttcttttctatgtattttgcaagagaaagaagcttagtataggtacacctcaga +gatgtttcgtgtaaatcgtatcacatggtataactgcaggaggaacattatccaaattca +ccacaattactaatccacccttttacttttactaaagatatattaattctcatgttgtct +gaattgtataacccggtaccctgggagcgtatcgaaggataccaattgaagtcctcgagg +catgttacaacacacgacttccttccgtctattcagacactcaacgagactaacttttcc +taggtaatcaatgatattgggtaactcgtggcatcttatagttattgatccggctctttt +gtagatcctgtgcgactcgtgcgctaattaagactggctctcttgcgcaggggatacgtt +tattctacgtacccgatttggttactactaagcggcctttcttcaaacttgcagttgtga +cttacattcctatttcttcaaagcagggaagggttacagggagagacttattgagatacg +attggaatttccatgtacaatcgttaatacgcttgtagaccagcaactcagtatagagat +ccgtttcctaaagggtgagcggtaggggcaaggcaataagaaattactaaaaccctagtt +gttaatataagaacgattcgaaacaataggattgcccaagggggtgcgaacatggtgtaa +atcaaagagaaataggcattgttaaaacccgcacgtttctagtacgcaagaggaacgtcg +gtaaccagttctcaaagatcctaacctaaaaggggcttattctactttttccgacactca +atggacgagacaaacatgaacggatagctttaggtctcgttgaatgcaaagaatagaatc +gttattattaatcggtttccattatctatatgcggtatagatctccgagaggaccctgta +aactagctctgcggtttaactggtgctaatagaccgccactatgttattgcttctagctc +ctagcgtcttatcatgttatacattaatgtcgcatattggacagtagccaggcttggatg +gatcgccgacaaaaagaaaagactttccctgtaaggacttaactattacatataacttgg +atcattaatctgcaaattagagtaacggtctttcaccagcttcatattccaacgtggcgc +tagtcgatatcccatgaagtttaaaactagaattggcagtctcacttcacagtgcgtatc +tatacgacaaaagtggtcgatttgcataaatatcttatcgatattcaggttattaccgat +tccttgctaacgctagaagtcacaccagagtaataataattccagacacctgtgaaataa +tcggtcactacggatagactagtaacgataatacgtatagtccataaaagttgaatttta +ggggctaaagatattagcaatactggtctagcctaatcgtcgatagcaaagggctgtgag +gatttctcctacattttcgaccaattgtatcgataggaatagttacagtcacgcttgtag +atgtaagagatgacgttattcttagggttcttaagtcggggggtaatttaagaccactag +taaaggtagaggcgtacacagtaaacgatattttgaaatcgtcaaaaaaaagtttacaac +atcctttaagttagcaactgattttagtggcaaccttaacggttgaattgatctactaat +acaggcctacaccgaagggtacagataatgattcttactaccctaacatgatagagtcct +gtcctatctcataggtcgacattttaaattcgtaatgagcaacgaagatcgtttcccaat +ttgcaacattcacttatagacttcaggttatttcgtgctaacattaagatagaatataat +cagtcgttaagaaactattatccagctttcgtcaaccataaagattaaaaactgaaactt +ggcaagatatgaatagctatcctgctttaaccgatcgtatgagatgctttgtagcaagaa +aagtgactagcacttgtgtttagtaaagcgggagagtgcggtaattaatattaatatact +attaagctacacagcaaaggctgcaataatgttagtaagtagaacataaaggtattctcc +acaagtaataaatagtgtgagctaattgactaacttaactctcgcgacaagtgatgtgga +taagatgactcatatcgtctttttctgtagtgccgacatcccacctggatcgaacaattc +cttctagttatcgactttgattacctatcctattaaacagatagggttgtaaagtcagaa +aatgatcggcttgcgttggtctaccatagctagagttagaacgcgtagatagaggccttt +tgttgccaacgtgggggtgggatgagtctgggcgagcgtgactttctttcgtgtccgaat +ttgtttaacatccattagattagatgtttgtgttttgggtctgatgtcctaactactttc +tcagtgaaactaatgtcatcatccaagtaaaatagtccgatgaagtctccgttttcggcc +gaagcttgtctataacgtatataaagtcgctgaatttagaacacaccttatctatgttgt +aaagttactttattccaaaggacgtgcacgaagcgtgagtgtgggaaggaacttaaagtc +ggatcactcttgtcagtgtagataagaatttctttcatacttcactggaatccggcgtat +ggatatctctaccgcgtcatctggtggtgtctgcggtaaaaagtcttgctgcacgagtct +gagaaatttttggtgccatcacatcgtaactgtacaacgaacaaatagcatcaggccttc +ttatccagcgtgaagtctaattatttcacaagctttcctaagtatgtaaatccctcactt +aatgatgcttgcgccaatgaggatagaggacattgcatgtacgtaggactattctccaag +gggtcttctattttgttagcgaaaattgttacagcctaatgttagagcggcgtacgactt +tataccagatactttcattagatatgcaaatatccaattaaatcatagtagtatcgtggt +atggacaatcaaaaaagacccgttgtgatatgatgtttttctagttcgttctcatatata +tagatcaacaatgaataatctcatgatctataaccgatgtatatttatattccggttgac +tgctccggtgcaattcactacggacactaatgactaatatggcgcctttcatcagaaacg +ctaaatatgattaatgaattaagggagtattatctaattattagagagtagcagttagtc +tgatattttcggtgtatgtgttagccgttataatgctgtctttttatcagtgagaacagg +gagtgtgtagtgttgtatgcttcactttatgactctggttatatccctcggagaacaaga +ataagagtacgagaagttcggtcattgaggatgaaatagaaccgctagacgaatggactc +acgtttataaaactatgtatcacagtactacagctaactctgaagtccgagaagcttttg +taggacaaaacgttataagtacctttcgcagaatacggccgtgcatacctgttataaggc +gtagtagggacaccatgctatccctcatatagagctacactaataccattacatggtgac +tatcgtttacggccatcatctgtaagcgatcatgcctcgttagcatccgtacaatctcgc +atggcgtcactgcagaaaaaccccgtgcggattttgagtcagaactattcgaagcttctc +aatccttttccattatggcatagcaagtgacgactcgtcagccatgggaataatagcact +aatccgattacttatgaattagaacccacatgaatgtgattctgcgaattgtctaagaat +ctaatgattttccggtgaatatggttgttgttatttattgaacttatattattaacatca +cccttcgttagtgatagtcagctatttccaagaggttccccgagcatttttaccattctc +tagtcatacaagttggagcgcttttaaatctttaggctgatcaaggcgttttgtctagaa +ttctgcagatgttagattcgtgtgcaatccctcttgcatgtcagtaacaggtcacccgtt +tttcgttacatatgctggtaaaatattcatagtaataactacaatacttgatttgttacg +taatgctcgtacataacacaatcgtattccacggaacagtaaagctctattattctgatc +gagcctaagagaggatcacactacgctattaaagtcacgttcacgaaatctcaaacctca +actgctggtgaccagttatagacagtgtaattccatattacatgtcaggcttaagctaac +ccgagcctttatataagctataatcaagaattagattggagtgcattttagacttatcta +tcgaaatagtgatagtaagagtttatatgacctgatctagactgatgttctcttccacaa +cagccttaaggcgtggagcctttcttatactattaggtcgcgtcgagagccctattcgta +atgttaacgacactagactaatatacaatgagctaagaataacacaagtcacaagataat +ttacaaatcatatatctacagtccacaaccatcactagcgattgcaaagcgttattggta +ctaccgctctaaatcggtatgtgcaagacgcgttaactggttcaagcctctcctgctcgt +gagactgaaagaaatcgaaaatatggatgtgcctaattgttcttgtgagtcatgtgcaac +tatacagtttagtttggtcaagactatgcaactattaacagcatgtgcgcattgaatatt +tggtgtcgattgataaatgccccaacgttccatcacgtctataagccgtgttactaatgt +gtattagtgcatacctattcagaccatagttcaactgttggactgaaggcccgtcttggg +gttcgtgaatgagagtgcagtttcttgtcttttccttaactgacctaaatgaaggcaatc +ggtttatctagagtcatgcttaaggtgaatttcagccaatgggctcccattgagctagta +tggtgctttacctttgtaagtggtggctttccttggtgtgctgactttaacacggcagag +tgattatccgaagaatggataataagacgctggcaatattggctaataaagtccgatgag +tttcaatcatgactgcgaggagatccatgcggtgtacctaaacctacatcgtatgtattt +gctgacgttcattcttgatacataaagatccgatatcggtccactttgtttaccaaaagc +cctaccttcgtaacgatggaaatgtgaatgagagtgaaatacacgatggggatattgccg +gtgagtacaagttagaccacacattagaactgacctatattcgtcatcatagagatggag +tatgaattgattctgcgaagtacactggctttacgagtatctagacgccgcggtatatct +cccgtcaatactatgaaggtatatatatagaggctgaaaattcatgttcaatcctctttc +taagagtgagtgggagccccttctgttgtcggagtaaaaaggcattattcctcaaattgt +cagaagcaaagtatacgtgatgtttgcttagaacaaaagagttaccttagggtaggtaaa +tctcgattcaccgagagaagtgattttggcggtgtgcgattaattcttttgatgacagat +ctcattattttatatagctccctctttgtatttagagtttgcgtaggtaacctggcaaaa +ccatatcccggggggagagtgcgctgaacattttatacgatgtgattactcaaaggataa +ggttcgaggcctctatactcatggaactatcttataattataatggatcgtggctcattc +cacctatccaaacttctttgtgatctgatgctacgagtgtgaacaaacgtacatcttcta +aggaatttgggacgtttcatagctcgcatttcattcctgaaaacttaaatatttttaaaa +attgattctactgcgaggaactaaggtgtagacaagcccttagtaaccggtggatgtcgc +ttcagttttatagcaaacattattcaatttcagtcttgactgaaattagtttgttagtgt +tagaggtccatatgtcacatgcatatggtctagatgccattgtacagtaataccttagat +tagtattagcggcatgcgtacttggatttcacttgtaagaatgagcttaggacggtcgcc +tgtagggctgcaaataggaatacttacaatttttgatgacttgttagcatatcgctatca +cccataaaaaacctgatacttgatgagcgggtgattgagactatgtactgatataattca +atagctccaatagatgaaacagctatgcgcctatttatgtcaaataatcgatgtgataca +agcttagagctgaacgagcgcgagtggaattagcggtgatctctatcctaaaaagccacg +aaatcgatcccagaagctaatacccgaggtgtcaagcttgagttcagttaaatttgcatc +tcatgccccacgaagaatgggtagagagtttgaaggtgcttctggattttcctaagtacg +tggtaaaaatttgatgtaaatgaacacctcctaatggttgtgttaaccacaaacccctgg +gtgaatctgattagccaacccagtgatctgatttcagttgtcaaatctcttttttataac +taccttttgtttccataatttaaccggatctcataatgaacaaacgggtagaataatggt +agcacatagcgagcttgtctattcagaaatatggcctactcagaatgtattctccaaatc +agtgttatgcgaaacgtaattttacgtgtaataatgatgatttcttatcggttccttgta +ctacaatactcttgcccaacaaatactaagcataacagcaaaattcgaatccccctcctt +ttaataaatggtttttcaatatagccgattcgtattcgttagtctttcaccaactattaa +cctggcatctaattaataaaatcaccaaaggactctataatatgacagtcacttcggcct +cttttaagacagttgattattgcaggtccgcaattgatggtgacatgcacaattagttag +aatccgactatggagacaattaacaattgtagtgcccatttggtccagttgacttcaacc +acgagttataaaggtattttaatttatagtcgatagtaccaacaacaagcacaatcataa +ttatgttagaaaacccagggggtaatgctctaaatccagctttaaggccagagtgcacta +tgaaatcgccattgatcattgtgtcattcgctgaacttggtgtctaggaggtgccgagtg +agaatatcagataccttatgaagcaacgattatatctggactagatcatgatgatcggaa +taaaacattgaaataagtccttatcaaggagcataaacattttatttaatttatacttcg +taaataaattcagaattttttttcaagacattaatctgagtaaatgacggctagaaaggg +ttcctactcgaatcgtagcctacgcatgtgggcagtaacctggcttgcgtttttactgaa +acaaaggttcaccggaaagaaggctgccacttttagcttcttgacgatctttagcgtcat +atttttagattagtcgaaaaacggaaaacaaacttaacgaagctggttgcacggggtacc +gagaaaccaaagagcaggacaactccttgatcgggaagaactgaaatagacagctgtcat +tttcattggtcaacttatcaatataacgaccaccgtagtgacgcttgcatgaaaatactg +aggatgtaaactatagccagtcaggcccgcgtgttgactaattgatgaagcaaacaaaat +agccggtattcgttaaaaggaacgggttgccagctacagatatactctaggtatatccca +aacaagagacgtcctttggctgttgtaatcggtcataatacttgtcacataaacaagatc +gctgaattaaacattaaacagttagtgatacacaatcgtggttggggctgggatgtgcaa +taaaaagtcatctatcgtctatcacagagcgacgtaaatttagacaaacattattatttc +ttgacaatggaatcgataagcgttcctctaacttggtatatatatctcgaccccgggatt +ccagccattcttgtatgaagatttaaccatttaactatgcatagttgaatggtaaggaaa +atgatattgactgcaacagattttggatgcaaaaatatttgtgaattattggttatatac +tggttgtatagcacaatcattaggtcctagaaggcatactcaacctcagcgagagagcta +gcatgcataattgtaccgcccatattaatattcctgaaatgatttcttacattacgccca +atttcagtcatcgaacacccccatcaatttacccgatagagaacgtgatcatacgcaata +ccctatgcgaacgtccactctatagcgtctgtatacaatgattattcgttccatttacaa +cgttaagtaatttaaacttacataaggacaaggaaatccgcgaacctcctggaatgtatg +agttatttatgcagttaacttcgtctcgaccggaactaaaggcgtcgtacgaatgaaagg +ccacttttagaagagacctttgtatccattgtggagaatatcataaattcaagatggggt +gtcatgctattcggtcctaaacattcttaatggctgttctattgttagtctgatttaaaa +tggaaccatagcacgaatagttagatagggctcatacccctgtaacgatctacaaatcct +tccccgggtgtgtgcgttagcgacggaaagttttacggtttgtgatcaaagaacactcac +acgtcagattattacactgatacgaattatttcagtcgacagtaattgaatagaaactta +ttaacgccagcacctgacacggtaagtaaggcaggtctgaactgtttgactgtaaaaaaa +tggtaatatttttaaaaatcttgatttctatatcaaatgatgtgtagttttttctctgtt +attaaaatcccagtgcgcgaaatttagatcgttacgactcacgtacaagatcacacatca +cacgcgttagcgaaagcggaatggctaatacagccctacgcaacgtagtgggatcaacat +atggacgaatttatgctcaatgagccaacctcccccgcattgcggttcattttaaggcct +gggtaacatctatcgtttagataatcaaaggaatccgactatgcaattgtctgacttcat +ccgctctcaagtccaatgcaggcgctacgtgtttctttaatcaataccatattgaaatcg +taatacgataattgttgctattgactacaggttatgaaaaaacttactttgcgggtacat +gcatatttttgtaccacattattacgcgatatctctcagtgtactctaaattaaaccctc +ttcgaacattttagttcctattcgtaaacacgtgctacgcggcaatttgccggtcgtaga +atggacaactccagttcaactgcatgtaactcatagctcgcgttagtataaattgactag +tagccatgggacaaagtaactagtcagcggaaaagatccctttaaagatatatgcaggtt +gcaagcataaagctcattgctcgaggtgcaccgtggtattccaaaagcgtctctatcgta +tcttctaattttgggccgtgagaatcgaaactactctgatttgctgcacacgttaggtaa +tatcgcccattttcccgtataagctccgtacttatacgaactacacgaccttttaagcat +tagccgctcatatcgtgattcgtgtacagatgagtctattaaaattacagacatactcca +tatctcgctccttgaactttgaataatgcgctaacttgtactatgaataggcagaaccca +actttcccgtttgcgtcaagcggggaaacgatacatgttgtcagatttatgattatctag +ttttagatcacgtttaccgataatcggctgtggtctgagcagtcctacactgagtattta +cttcagcttcatatcggtccgaaaaaaggttgtgaccgaatgtcaaaatacggagtacga +tgggcatcttttttcgagtcgcggttgcagggcagcaaaaggcttaaaccatttttacga +tttttactatagcggtcatgaagtgcgaaactgcttgcaaattttctacacacattgtgg +ctcttgtccttgaagcttatggcgaaaatttgaaacatagtataccagggaaagcgcgaa +ttatttggtgactaatagtccgtgggtttgagccatatacctaacgccataaactacgtg +gtgctttagatgcaatctaaacagaacagaaagcgtagcgctcatcagcacagactaact +ttttcagtttgagtcgccggagggacttcgagacaagaacgcgtcaagtcgcttgcgcgg +cacggattcgattgggcggctcaatcttgcctaatttctactattgtcagctgtacgact +gtactaagtgtatagccccaaataaaagaagtatcgatgcgtctttatgaccaaaggtct +tataattgaagcgcacttccgttcatcaaattaaatcctggcttacccgattctccggaa +gtctgacctagagattgacgacggccgcgtattattgagacctcttcaggattaatcaat +aacgaagtagttgatctgtttggcgacgtaccttaagccgactccgctacacgagtttct +actaaaccaatgtagccttatgcttagatgaataccgtcctaattagatattccggcata +acagcagtaaattatctgttcaatggacgaacattgaattgttagtattctacacaagtc +aggcctcgtaaatattaggtaaggccgtgggataacctacgtgatatgcttgagcttgcg +ttgcaagctctcgttaatcattaatttaggtgcgtgagggttaaacaccagcatattcta +tatgctagacgtcttccttaaaggatcgtagtattataattaataataagaaatatggtt +gacgtctagtcagcgggcatacgctgctctatatactggcattattcaaaacttgacggt +aaaaaaacgaattttaaggcgctcacgtcgaatgagccgaactcatgggaaccaaaatgt +cacagaaaacacctctttattgccaagcatgcaataaaaaaaatgttaatagtacgttta +cgacattttattttataataaagagaaactattacacctattgatatgataggacgtaaa +ttaacgagtagcctgcatagaggcaaatgaggtttctacatggtatagacctgatgctga +aacatcgatgagttttggtcccctcgctcgttgaaatctagtcatttactactgtctttc +gagctattataccacttcactatgtggtgtttctttgctatgtatggggctagtcaaaca +tgatgactatagctacaactcagagagcgggcgtgttaagagtatctcatgctagaactg +cacgacgaacttgatacaaagtaacaacatttacgattccacaaggtgactttgaagaaa +catagtttaattctctgcttcgatcatttctataaaccggtaccatcgcagcggatagat +gcataacatttctactactccaggcatcttaaaacacacgtagtacttcactagattaag +acacgataagtgtataacttggcagtgggaagcaaggagattggcgaactcctggcatct +gttacgttttgttcaggctcggttgttgataatgtccgactcctgccatattgaagactc +gctcgagggagatcgggattcgttgattataagtacacgtgttccgtaatactatgaggc +agtgattcaaaatggcacttctgacttacatgactaggtattattaccacggaagcgtta +aaggcacactcttatggacttaagattgcaagtgccttcttctagcctgaattcgcgggt +tcaacacaaactctctttagacatccgttgcctaaaggctgagacgtaggggcaaccctt +taactatgtactaaaaaactagttggtaatttaacaacgtgtccaatcaagacgatgcac +caacgcggtgcgaaaatcgggttaagcaaacacaaataggaattgtgataaaccccacct +tgagaggtcgcaagaccaacctcgggaacaacggctctaagagaataacctaaatccgga +tgagtagactgtgtaactctctaaagggaagtgaaaaaaagctaagcatacatttaggtc +tcctgcattgcattcaattgaatcgtttgtattatgagctgtacagtagctatatcagct +atagttatcccagaggaacaggtaaactagctctgagcgtgaaatccggatattagaacc +cctagatgggattgattctagctaatacaggcttatctggttttacagttatctagatga +ttggtaaggtgaaacgcttggtgccttccaccacttaaacaaaagtattgcccgggaagc +tattttctaggtattataaagtcgagcattaatatcaatttgacagtaaaggtctttcac +cagcttcatatgccatagggcccatactcgatttaaattgaacggtttaacgagtattgg +aactctcacttataactgagtagctatacgaaaaatctggtccatttccagaaatttatt +atcgatttgctgcttagtacccaggaagtgataacccttgaaggcacaacactgtaataa +gttttcctgtcacatctgtaatattcggtcactacgcattcacgactaaagataattact +atactaattaaaagttcaatgttagggccgaatcatagtagaaattctcgtctagcctaa +tcggacttacctatgggctgtgaggatttatcagtatgtggacaaaaatgctagagatag +gtatagttaaagtcaccatggtacatctatgtgaggaagtttgtagttcgcttctttagt +ccgggcgtttgggatgacaactactatacgtagagccgtactcaggattagatagtgtga +aagagtcaaataaaagggttaatattaatttaacgttgcaaatgtgtttaggccaaacat +taaccgttgtagggatattctaatacaggccttcaccgaaccctaatgataatctgtctt +aataacattaaatgattgtctccgctacgagctcttagggcctcattttaaatgactaat +gtccaaagaagagactttcccaatttcaatctgtcacgtatagacggcaccttagtgagt +catatcattaagatagaagattatcaggagggaagtttctattatcaaccgttacgcaac +cataaacttttaaatctcataatggcattgagatcaagagctttcatgatggtaaagttc +gtatgtgatgctggggagctagatatcggtataccacttcggttgtggtaagcccgagtg +ggccgttagtaatattaatagacgattatccgacaatgcattcgctgaaataatcttact +taggagaaattaatgctatgagccaaaactatttatgtctgtcacattattgactaaagt +atctatcgacaaaactgatgtccataagttgtagcagatagtcggtgtatggtgtcacca +atgaaaacctcgagcgaaaaatgaattatagttatccaatttgagtaaattgcctattat +acagataggcttgtttagtcagataaggttccgcttgaggtgctctaacttagcgagagt +tagaaagcctagtgagaggcattttggtgccaaactccggctcgcatgagtaggccagag +agtcactttctttcgtcgaagaagttggtgaacagccttttgattagttgtttgtcttgt +ggctatgtgctactatataagttagaacgcaaactaatctaatcagcaaagtaaaatagg +accttgaacgagacggggtacgccgttgaggctcgagatagtagataaactagaggaatg +tagataaaacattagctagggggtttagttactggattacataggaagtgcaccatcacg +gtgtgggggttcgtacgtaaagtcgcatcaatattgtcagtggacttaacaagttcgtgc +ataatgaaatcctatacggactttgcatatctctaccgactcatctggtcgtctatgcgg +gtaattgtattgctccaagtggatgactattttggcgtcccagcacatagtaaatgtaaa +tccttataatagcataagcaattattagactgcgtgaagtcttagtagttctcaagcttt +acgttgtatgtaaataactcacgtaatcagccgtccccaaatcaccattgaggtcattga +atgtacggagcactattatcaatgcggtatgcgattttctgagcgattattgttaaagac +ttagcgttgagccccggaacacttgattacagattctttaaggagttatccaaatatcat +tttaaataatagtagtatcgtgctttggacaataaaaaaagacccgttctcttatgttgt +tttgcgacgtacttctctgatatatacttcaactatgaagattctattcatcgataaccc +aggtatatttatatgcccgttcactgcgcagggcaaattatctacggacaataatgacgt +agttggacccggtaagaactaacgcttaatatgattaaggatgtatgccagtattatctt +attatgtcagagtagaagtttctctgagattttccgtcgttgtggtacaccggatttggc +tctctttttagaactgagaactcggagtgtgtagtcttgtttccttcaatttatcaatat +gcttttataccgccctcatcaactataacaggacgacaagttccgtcttgctccatcata +tactaccgatacaccaatcgtatcaagtttagtatacttgctttctctcttctacagctt +actcgcttgtccgagaagcggttggtgctcataaagttagtagtaaatgtacaactagta +gccagtccttacctgtttttacgactactacggacaccatgagatacagaagttagtgct +acaattataccattacatgctcaatatcgttgtcggccataagatcgaagagtgcatcac +gcgtgtgaatacgtaaaatctaccatcccgtcaatgcacaaaaacacactccccttgttg +actaacatcttttacaagaggctaaatcattgtccaggatcgaataccttgtgtacaatc +gtcacccatcggaagaataccacttttccgatgtagtatgatttacaaaaaacatctatg +tgagtaggccaattgtagtagaatatattcatttgaccgtcattagccttcttcttaggt +tgtgtacggatagtaggtacataaaccgtcgtgtggcatacgctgcgatttcatacagct +gccaacaccttttttaccaggctagagtcagaaaagttggagccatgttaaatagttacc +atcataaaccactgttgtctactagtctgatcagctttcatgcctgtgcaagcaatatgg +attctcacgtaatggtaacaactgttgcgttacttaggctggttaatttgtcagagtaat +aaatacatgtcttgttgtgtttcctaatcctcggaaagtacacaagcctaggaataggaa +aagtaaagctcttttattctgatagtgactaactcaggatctaaatacgcgattatacta +accttcaccaaagctcaaaaatcatctgctggtgaccagttatagacagggtaattcaat +atttaatgtctcccttaacatttcaccagcatggattgaagatagtataaagttttacat +ggcagtcattgtgtcacggttctatacaaattctgatagttagacggtatttgaaatgtg +cttctagcatggtatcttacacaactgaatgaacgactggagccgttcgtatactatttg +cgagcctcgagaccccgtttcctaatgttaacgaatatagtataatataaattgtgatat +gaataacacaagtaactacagtttggacaattaattgttctaaactaaaaatcattcact +tcagatggcatagagttatggctactacacatataaagcggtatgtgaaacacccgtttt +agccggaaaccctctactgctcgggacaatgaatgatttccaaaatatggatgtgcagaa +ttgttagtgtgactcaggtccaaatagacactttagtttcgtcaagtcgttgcaaagttt +aaaaccatcgcagcattctttatttggtctacattgagaaatgaaaaaacgtgacagaaa +gtctagaagaactgtgaataatgtctattactgattaactagtaagacattagtgcatct +ggtccactgaagcacccgcttggcgttaggcaatctctgtgaactgtcgtggctgttccg +gtaatgtacgaaagcaagcctataggttgatcgagtcgcttcattaaggtcaatttcaca +atatccgatcacattgtgctaggttcgtcctttaccttgcttagtgctgcatgtacgggg +tgtcatgacttgttatcggcagactctttatcccaagaatggataatatgtacatggaaa +gtgtccataattaagtcccttcactgtaaagaatgactgccacgtgatccatgaggtcta +cagaaaccgacttacttgctttttgatcaacttaattatggattcataaagttcagatat +cggtacaattggtgtacaatatgaaattaatgaggaaacatggaaatctgaatgacagtg +atagaaaagatccccatttgcccggtcagttcatgttacaccactcattagtactgtaag +tgtttcgtcagcattgagatccacgatcatgtgtttatgccttcgaaactggatgtacga +cgatcgagacgaagaggtatatataacctaaatactaggtacgttgttagagagacgatg +aaaattaatcgtcaatacgctggcgaacactgagggggacccaatgctcttctcggtcta +aaaaggaatgtgtcagaaattggtcagttcaaaagtagaccggatctttgcggagaacaa +ttcacggaacgtagcgttgggaaatatcctttctaccacacatcggattttcgccctctc +ccattatttattgtgttctcacatagaattattgtttagacatccctcgttgtatggaga +gttgcccgagcgtaaaggcataatccatataccgccgggtgagtgacctgaaattgtttt +tagttgggatttcgctatggattagcttacacgaagagattctaatggtactataggata +attataatgctgcgtggcgcagtacaccgttacaaacgtcgttcgcatatgtggctaaca +cggtgaaaatacctacatcgtatttgcaatttcggtcgtttcatagagcgcattgaatta +ctcaaaaattatatatgttgattatttgattagactgcgtggaaagaaggggtactcaag +ccatttgtaaaagctgcatctcgcttaagtttgagagcttacattagtctatttcagtct +tctaggaaatgtctgtgtgagtggttgtcgtccataggtcactggcatatgcgattcatg +acatgctaaactaagaaagtagattactattaccggcatgcctaatgcgattgcactgct +atgaaggtgcggacgtcgcgcccatgtagccctgataataccaatacttacatttggtca +gcaattctgacattatacctagcacccataaatttactcagacttgaggacaggctcttg +gagtcgatcttctgtttgtatgcatgtgatcatatagatgaataagcgatgcgactagtt +agggcatagtatagatctgtgtatacagttcagctgaacgtccgcgagtggaagtacagc +tgagatctatcctaaaatgcaaccatatcgttcacacatgatatgaacccagggggaaac +attgagttcagttaaattggcagcgaatcccccaagaagaaggcggagtgacgttgaacg +ggcttatggtttttcagtacttcctccgtataagttgagcgaaatgtaaacagaataatc +gttgtgttaacaacattaaaatcgcggaatatgatgagaatacacagtgtgagcatttca +cttgtaaaatatctttggtagaacttactttgctttaaatatgttaaaccgatctaataa +tctacaaaacggtagattttgcctagcacattgcgtccttctctattcagatagaggcaa +tactcagaaggttttatccaaagcactgtgttgactaacctaagttttagtctaataatc +atgattgattataggtgccgtggactacatgactcgtccacaaataatacttagcagatc +agcaattggccaagcacccgacttttatttaatggttgtgcaatagtccagattcgtatt +cgggactctttcaaataatagtttcctggcatctaagtaagaaaagctcataaggaagcg +atattatgacacgctcttccgccgctgttttgaaacttgagtattgctcgtccgaaattg +agggtcacttcaaaatttactgagaagacgaagatcgactaaagttaaaatgctagtcca +cagttggtcaagttgaattcatccacgagttatatagctattttaatttatagtcgagtg +tacaaaaaacatccacaataagatttatcttagaataacaacccccgtatcatcgaaatc +ctccgttatggcctgactcctcgagcttatagcatttgtgctggcgctcttgccaggaac +ttgctcgcgaggtggtgacgagtgagatgatcagtttcattatgatgatacgattttatc +gcgactagttaatcatcatagcaagtaaaatttgaattatgtcattatcatgctccatta +acaggttatttaattgatactgacgaaattttttcacaatgggttttctagaatttaata +tcagtaattgaagccttcataggggtcctactagtatcctacacgacgcaggtccgcagt +atcctggagggacgtgttactgattaaaagggtcaaaggaatgaaggctcacaatgttac +ctgcttcaccatagtgagccgatgagttttacattagtactaaatcccaaatcatacttt +acgatgaggcttgctagcgctaaagagaatacatacaccaccacatagaattgttagcga +tgatatcaaatagactcctggaagtgtcagggggaaactgttcaatatttcgtccacagg +actgaccaggcatggaaaagactgacgttggaaactataccatctcacgcccgacgcttc +actaattgatgatccaaaaaatatagcccggattcctgattagcaaagggttcacagaga +aagatattatcgacgtatatcccaaaaaacagacgtaatgtgcatcttcgaatcgggatg +aatacttgtatcataaaaatgtgacctctagtatacaggttaatgttagtgatacacaat +actcgtgggccatgggttctcaaataaaatgtaatattgcgtcgatcactcacccacgta +tttggtctaattatgttttatttagtgacaatccaatagataaccggtcctattaagggc +tatatttttagcgaccacgcgtttaaacaaaggattgtatgtagatggtaccagtttaat +tgccagtgggcaatcctaagcaaaatgagattctatcctaaagtttgggcttgatataag +atttcggatgtatgggttttataatcgttggagagctcaatcatgagctaatacatggat +ttcgctacctcaccgagagaccttgcatgaagaattctaaccaaaagtttaataggccgg +attggattgagttaattaagaccttgttcagtcatagtaaaaacccttaaattttaccga +ttgacaaagtgagcagtcgcaataccctatgcgaaacgcctcgatagtgactaggtatac +aaggtttttgagttcctttgaaatagttaactaatttaaaattaattaacgacatggaaa +tcacagaacctaatgctttgtaggagttatttatgctgtttactgcctctacaaccctaa +taaagcagtcctaagaatgaaacgcatcttttagttcagaaagtggtatccagggtggtc +aatttaataaattcaacatcgggtctcaggatattcggtcatataatttattaagggctc +ttcgagtcttactctgagtgaaattggaaacagtcatccttttcgttgtgaggcatctta +caccgctatcgatatacaatgcattccaccgcggtgtcccgtacacaaggaaacttgtta +ccttggggatataagaaaactcacacgtctcattattaaactgagtacaatttttgcacg +agaaagtaatgcaatacaatatgatgaaagccagctaatgaaaagggatggaacgcacct +cggatctgttgcactggattaaaatccgattatttttaaaaatattcagtgctagagcat +atcaggtctacttttttatctggtatgtaaagcccacggagcgatagtgagatccttacg +actcaacgaaaagttataacataactcccgttagccaaagcccaatcccgattactgccc +taccctaacgtctgccatctaaatatcgaacttgttatgatcaatgtgactacctcccac +cctttccccttcatttgttccactggggataagctagcgttttcagaatcaatgcaataa +gaatagccaattgtctcacttcatcagagctcttggcaattccaggcgctacgtggttct +ggaatatattcatttttcaaatagtaatacgtttagtgttgctattgtctacacgtttgg +atattacgttatgtgagcggacatcaatagttgtctaactctttagtaagccagagatag +cactcttagcgaatggataccatcttccataagtttagttaatagtccgaaacaactgct +tcgagcatatttgaacctccttgtaggcaaatagcctcttcaaagcaatcttactaatag +atagagtttgttttaagggactactagaaatgggacaatcttaatagtatgacctaaact +gacatttaaagatatatccaggtggcaagcataaagatcattgcgccacctccaccgtgg +gattacttatcagtcgatatcctatatgctaagtttgcgacggcagaatacaaactaagc +tgagttgatgctaaccttacctatgataccccattggaccggttaacagccctacttatt +ccaaataaaagaacttttatgctgtagaagctattatagtgatgcctggtaacttcagta +tattaaaatgacacacatacgccatatagagctcctggaactttgaataatgagcgaact +tcgaagttgaagagcaagaaaccatatgtcacggttgcctaaagcccggtaaccagacat +gtgctatcattgatcattatcgaggttttcataaccttgacccattatcggctgtgcgcg +gacaagtacttaaatcactagtttcttcacctgcttatcggtaagaaataaggttggcaa +agaatcgcataagacggacgtagagccgcagcgttgtgcgagtccaggtgcatgcgcagc +aataggattttaaattttgttccatttttaatttagccgtaaggatgtccgtaaatgatt +gaaaattggattcaatctttgggcctatgctactggaacctgatcgacaaaatttcaaac +atacgttaactccgaaagaccgtatttttgcggctagaatagtcagtcgcttggagccat +ataccttaccacttaaacgacgtgctcctgtagttgaaatataaacagaacacaaagact +accgatcatatcaactgaagatctttgtaactttgaggcgaagcaccctcttcgagacaa +ctaagagtaaagtaccgggcgccgcaaggagtcgattgggaccctaaatcttgacgaatt +gctaagaggctcagagctaccactgtaatttctctagagcccataataaatgaacgatac +atccgtaggtagcacctaagggattataatggaagccaaatgcagttaataatattatat +actggcgtacacgattcgacggatctctcacatagtgattcacgacccccccctttgatt +gacacagcgtcagcattttgcaagaacgatcttctgcatagggtgcgccaccgtaaggat +gacgtcgaagctacaactgggtataatttaccatgcttccctgatgctgagtgcaataca +ctaagaatgagtttttaccccatatcaccagtatttgttctgttattgcgaagaaatggc +tatgctgagttggcgactaaagtcacccatcctttttattaggtaaccccctcccttaaa +ctaactgatttgctggagctgccctgcatacatatactttatcatttatggacgtccgtg +acgcttattatccaccatagtcgatatgctacacggattcattaatggatcgtaggagtt +taagttatatttactaagatcggtctcggctactatcccgccttacccggcgctatttac +ggccatttttaatatattgacggtaattattcctatggtttcgaccgcacgtccttggac +aagaaagaatggcaaaaaaaatgtaaaagaaaaaaaatattgagtccctaccatcatata +aaaaatatgtgatgagtaacttgacgaaatgttagtggttattaaagactatctattaca +ccttttgttttctgtcgtagtatattaaagtctagaagccttacaggaaaatcagggtta +tacagccgatactccgcagcatgaatcatcgaggaggtgtcctaccatcgcgccttgtaa +tcttgtctgtgtatactgtatttagaccttttatacaaagtaaatatctcggctttatgt +gattgggaggggcctactcaaacatgatgacttgacctaataatcactgtgcgggcgtct +tatgactagctattccttgaaatccaccaccaaatggttaatatgtaaaaactttgacga +tgaaacaaggtgaatgtgtagttactttgtgtaattagctgcgtcgagcattgcttgtaa +aaccgtcaatcgcacacgttacttccataaaatttctacgaatacacccttcttaaaaaa +aacgtaggaattcacgagtttaacaaacgataactgtataaagtggaagtccgaagaaag +cagatgcccgaactactcgaagatgtttcgttttcttaaccataggggcttcttaatggc +ccactacgcacattttgttcaagcccgagagggacatccccattacgggagtattactaa +aactgttccgtaatacgttcagcaagggatgaaaaaggccactgctcaagttattgacgt +gggagtattacatcggaagcctgaatcccacactatgatggtctgtacaggcctagggac +tgcgtctagacggtattaccggcttctaatcatacgatcgtgagtcttaacgggaagtaa +ggctcacacctaccccaaaccatttatctatgtaagtataaaattgtgcgtaagtgttca +aagtggacaataaagacgtggcaaaaacccccgcacataagccgctttagatttcacaaa +taccaatgcggttaaaaacatccttgagtcgtacatacaccatactcgcgttaaacggat +ataacagaagataataaatccggatgtggagtcggtgtaactatagaaagccaagtgaaa +taatgcttaccagtcatttagctatacggctttcatttcatgtcaagagggtggagtttg +acctgtacagttgatatatcaccgatacttagaactcacctaaagctaaaattgctcgca +gcgtgtaatccgcatattacaaacaatagatgggattcattatacataagacacgatgat +ctgctttttcaggttgcgagatgttgcctatcgtcaatcgagtcctgccttacaccactt +aaacaaaagtattgacagggaacctattttcgaggtattatatagtccagcttgaatatc +aatttgacagttaacctagtgaaaatcagtaagaggaaatacgccacattctccagtgaa +attctacgggttatcgtctagtccaactatcaattataactcacgagatataagtaaatt +ctcgtacttggcctgatttttattatactttggatccttagtaaacaggaagggagaaac +cttcaacgaaaaacactggattttgttttactctcaaagctcttatatgacggaaatacc +ctgtcaagtcttaactttattactagactaatgaaatgggcttggggtggccagaatcat +agtacaatttagcggatacactattcggactttcctatcggctgtctggttggataagta +tggggactaataggctagacatacctatacttaaactatacaggcgtcatctatctctgc +aactttggagttccctgatgttctcccgccctttgggttcacatcttctataccgacacc +cctaataacgattagtttgtgggttagagtaaattaatacggttaatattaatgtatcgt +tgaaaagctggtgtcgccaataaggtaaccggctaggcagagtatatgtcacgaagtata +actaccctaatgataagctgtaggaataaaattaatgctgtctctaagcgaagagatatt +tccgactctgttttaatgacgaatctcattacttctgacttgcaaatgttcaatatggca +cggtttcacggcacctttgtgacgcatataatgaacttagaagattataacgacggaact +ttatatgataatccgttacgattaaagaatctgttaaatatcataatggcattcagttct +agaccgtgcatcatggtaaacttactttctctgcatggcgacatacatttcgctattcaa +attcgcgtgtggttacacccactcgcacctttggaatattaagagaagatgatcagaaaa +tccattcgctcaatttttctgacgtacgtctaatttatcctaggagacaaatcgttttat +gtctctcacatttttgaagaaaggttcgagagacaatactcaggtcctgaactgctagaa +gatactcggtggagcgtggcaacaatgaaaaactcgtgacataaatgaatgatacttttc +caagttcagttaagtgaatatgtttaacatacccggcttttcgatcttaagctgacgctg +gacgtgcgagtaatgtcagtctcttacatacactagtgactccaagtttcgtcaaaaacg +ccccctcccttctcgagcccactcacgctatgtattgacgcgaacttgttcgggatcaga +cttttcaggagttcggtcgcgtgtccctatgtgctaatatataagttagatcgcattaga +tgctaatctgaatacttatagacgaccttcaacgagaacgggtaccaccttgaggctaga +gttaggtgtgaaacgacaggtagggacatataaaatttgagtgcggctttagttaagggt +ttaattacctactcaaacatcacgctcgcgcccttcgtacgtaatcgaccatctagaggc +taaggggactgtactaggtagtgattaatgatatcctagacgcacgtgccttagatcttc +agactctgatggtccgcgatcaccgtaattgtagtcctccaactcgatcactttgttggc +gtcaaagaaattacgatatctaaatacttataatacaataaccaaggatgagaatgactc +atcgcgttggagttatattgcttgaagttctatggaatgaaagcacgttatctgccgtcc +caatatctccagtgagctaattcattggacggtccactttgatcaatccccgaggagatg +ttcggacactttagtctgtaacacttagcgttgagaccacgaacaattgattactcagtc +ttgaaggtgttttccaaagttcattttaaataagactacgataggcctttcctattgata +taaactacccggctctgttgttcgtgtgagtcgtacttctctgtgtttttctgattatag +caagattcgattcttagtgtaaacagcgatttttatttgacccgtcaatgagaagcgcat +aggatctaagcaaaattatcaagttgtgccacaaggtaagatctttccagttattgcagg +taggatgtatcccacgttgatagtatgaggtctgacgtcaactgtctaggagagttgacc +gcgtgcgggtacaccggatttgcatcgatgttgagaacgcagaactcccactgtcgtggc +ggcgttcctgatatttagcaagaggcgttgataaagccctcatcatctagatctcgacct +catctgccctcttgctccatcattttctacacagactactttcctatctacgttagtata +attgctttctatcttagtatcatttagagcttctccgtcaacaggttcgtgctattaaag +ttagtacgaaagggacaacttgtagcaacgcatttaatcggttttcgactacttcgcaca +aaatcagataaagaagtttgtcattctattagacattgaattgcgcaattgacttgtacc +acttatgatcgaacactgaatcaagactgtgattaactaaaatagacaagccactatatc +aactaataaaaacgcccctggtggtcgaacatagttgactacaggataattaattggact +ggagccattacattctctacaatcgtatcacttcccaagtagacaactttgaccttgtag +tttcatgtacaaaaaaatgctttcgcaggagcacattggtagttcaatagtttcatggga +acctcttgagccgtcttctgtgggtgtgttcggatagtaggtactgataaagtcgtgtcg +ctttcgatgagagggaattcaccggaaaacaccttggttaacaggatagtctatgtaaac +ttcgagacatgtttaagagttaccagcttaatccacggtgctctactagtatcatcagct +gtcttgcctcgcctagaaatatgcattctatcgttatcctatcaacggttgccgtactga +gcagccttattgtggaagagtaatatataaatgtagtcttgtctttacgaagcagacgta +agtaataatgacttggaataccaaaactaaacatagtggattatcatactcaagaactct +ccagataaataacagtttttacgatacgtcaccaatgagcttaaagattaggatcctcaa +aactgatacaaacgctaattcatttgttattggatccagtatcagttaaactgaatggag +tgaagattgtagaatgttgttctggcctcgcatggggtctaggtgatatacaatttctca +tacttacacggtagtggaaatctgattctagcttcgtagctgactatactcaaggaacca +ctgctcaaggtaggagactagttccgaccctacagtcaaagtggccgaagcttaaactat +agactagttgttaaatgctgatttcaagatatcatctatatacagtttggacaattatgt +gtgcgaaactaaaattcatgctattcagatggatttcacttatgccttagaaacagatat +tgcccgagctcaatcaacagttttagccggaaacaatcgaagcatagggacaatgtatct +tttcctaaattgccatgtgcagatttctgagtgtcacgaagcgcataatagaatcttgtg +ttgcctcaactcgttgaaaagtttaaaacaatcgcagcagtctttttggggtctactgtg +tgtttgcaaaataactgaaagaaacgcttgaacaactctgaagtagctcgagtactcatt +aaagtgtaacacattagtgaatatcggccaatgaaccaaacgcttcccggtacgctatct +ctctcatcgggaggcgatgtgcaggttatctacgaaagcatccctttacgttgagagtgt +cgatgcatgaacctcattgtaacaatagcccagcaaattctcatacgtgcctcagggtcc +gggcgtactcctccatggaagggcgcgcatctagtgttataccaactcgctttttaacta +ctatgctgtagttctacaggcatagtggccagtattttctaacttctctggatagatgct +ctcactcctcatccatcacggcttcagtttacgtcttacttgcttgttcagcaacggatg +gaggcattaagtatcttcactgttccctaaaattgctgttcaatatcaaagtaaggacga +tacagggaaagctcaagcacactcattgaatactgccccagttgcaacctcacttaatct +gacaaaaataatgactactctaagtgttgcggaagcagtctcttccacgagcttgtctgt +atcacttcgtataggcatgtaactcgatagacacgaacaccgagtgagaaactatattct +tgcttccgtgtgtgtgacaccaggtaattgatgcggatataagctggagatcactcacgc +ccacacaaggcgctgctacctctttattccaatgtgtaagaatttgctaacttcatttct +agaccgcagctttgcggtcataatttcacggtacggacccttgggttagagacttgataa +cacacttcgcagtttccaccgcgcacatgttttagtggcttctaacatagaatttttgtt +gtgacataaagagtgcgtgggagacttgcccgaccgttaagccataatcaattgaaagcc +ccgtgagtcacatctaattggttgtactgcgcatttagctatcctttagctgactcgaag +agattcgattcctaatataggttaattagatggctgccgcgcgaagtaaaacgtgaaaaa +cgtagtgcgcagatctgcataactcgcgcttaattacttatgagtagttccaagttcgct +acgttatgagagagattggaattaagcaaatatgttttatggtgattttgggatgagaag +gactgctaagtacggctactaaacaaatttctaaaaccgccatctaccttatcttggaga +catttaagttgtatatgtcactagtctagcttttgtctgtgggacgcgttctcggaatga +gggaaatgcaagagccgattcatcaaatgcttatctaagaaagtagtggactattacacc +aagcacgaatgccagggaactgctttcttgctcaggacctcgcgacaaggtaccccgcat +aagtcctagaattacatttggtcagcaatgctgacatttgaccgtgaaaacataatttta +atcagaaggcagctcacccgcttgctctagatcttatctttgtatgaatgtcagaattta +ctgcaatatccgttccgaatagtgagggcttagtatagttctctgtatacaggtcacatc +aaactccccctgtcctagtacagctctgagctttaattaattgcatacatttccttcaat +catcagatgaaaacaccgcgaatcatgctcttctcgtatagggcaagagaagcaacaaac +aactagcccgactcacgttcatccgccgtatccttgttcagttcttactccgtattaggt +cagcgaaatctaatcagaataatcggtcgcgtatcaaaattaaaatcccgcttgaggttg +acaattaaaacgctgagcagttatcggctattagatagtggggtgaaagtaattggctgg +aattatgttaaaacgtgatattaagctaaaatacgctacttgttgccgacctaattcagt +cattcgatattcagttagagccaagaataacaagcttgtataaattgaacggggtgcact +aaacgatgtgttactctaatattcagcttggagtatacctgaaggcgaattcatgtatcg +gccaataataagacgttgaagatcacaatttggactagcaaaagaaggtgatttatgcgt +ggggattgagtccactgtacgagtacggtctctggaaaattataggttcagggaatataa +ggaagtaaagataattaccaagagatttttggtatcgctatgacccagaggtgttctaac +gtctgttttgatccgcagaatttctgcctcaatgcatatttgacggacttgaactagagc +ctctaaagttaaatggcgacgcaactgttcctaaacttcaattattactactcttttttt +cctagggtattgtagaggccagtggacaaaataaatcaaatttaagatgtttcggacatt +aacatcccccgtagcatagaaatcatcagttatccaatctctcatcgagcttttacaatt +tctgctggcgctatggacagcatatgccgcgagacctccgcaagactcacttgatcactg +taagtatcttcattagaggttagagcctatagttaagctgctgacctagtaaaattggta +ttttctaattttattgctcaagttaaaggttagtgaagggataatgacgttatttttgaa +caatgggttgtattcaattttatatcacgaatggaacccttcattcccggcataatacta +gacgacacgaacaagctccgatctatcagccaggcacgtgttaaggtttaattccggcaa +accaatgaagcatcaaaaggtgacctgatgcaacttagggtcacgatgagtttttcagga +ctacttattacctattaataagttaacatgagccttcataccccgtaagacaatacatac +tccaccaattagaattctgagccatcttatctttttgtatcatcgaagggtatggccgaa +taggttaattagttactcctaacgtctctacaggcatgcatttgacgcaccttcgaaaat +agtcaatctctcgccacacgcgtctagtatgcagcatcaaaaatatagtccacggtttcc +ggattaccaaacgcggcaaagagaaacattgtatcgacggagataacttaatacagaagg +aaggggcatcttcgaatacggatgaataattctatctgtttattctgacatcttgttttc +aggttaatcttacgcattcaaatgacgcctgccccatgcgtgcgcaattattttctaata +ttgacgagagcaatctcactccttttgggtctatttatgttttattgaggcacaagccta +tacagaacaggtactattaaggccgtgagtgtgagactcaaaccgtggaaacaaaggatg +ggttgttcttggtacaagttttagtgcatgtgggcaatccttaccaaaatcagatgctat +ccttaactttgggctgcatttaagatggcggttggaggcctgtgagaatcctgcgtgtca +tctttaatgaccgaattcatccatgtagattcagatcacacactcattccttgatgttgt +ctaaacaaaagttgttgtggacgcattggagggagttaagtaacaacttgggatcgcata +cttataaaaattatatgttaaactttcacaaacgctgaagtccaaagtaactagcccaaa +cgcctcgagagtcactaggtattaatggtgtttgagttcctgtgaaatagtgttcgaagg +taaaatttatgtaccaaatcgaaagaacacttaataaggcttgcttgcacggaggtatga +tgtttactgactctacaaccctaattttccagtacgtacattcattccaataggttagtt +ctcaaagtgctatacaggctcctcaattgatgatatgcttcagccgctctatggatatta +gctcattttatttaggaagcccgcttagaggcttactatgagggaaatgccaaaatgtca +tacttttcggtgtgtcccatatgacaccgctttacatagaatttgaattaaaacgcgctc +tcccgttcactaccatacttggtaccgtgcgcatattacatatagatataggatcatttt +ttaaagctgtactaggtttgatcgacaatcttatgctatactatatgatgtaaccctcat +aatcaataccgatcgtacgatcctagcataggtggcaagcgattttatgccgattattgt +gttaaatagtctgtgagtgtgattatcagggctacgttggtagaggggttgtatagacct +cgcacacattgtgacatacttaacaatatacgaaaactgatataataaatccccttaccc +aaacaccaatcccgttgaatcaactaccataacgtctcccatataaattgcctacttgtt +tgcataaatctgaatacataacaccattgcaccttcttgtgttccaatcccgttaagatt +gccttgtcagatgatatgcaagaacaatagcatttgctagcaattattaacagctcttcg +aattgcctccacataacgcgggagggtatattttaatttggcaaatactaagtactgttg +gcgtcatatgctattaacggttggatattaagttatgtcagccgtaagcaagagtgggcg +aaatattttgttacccagtgagagcactcttagagtttggatacaataggccatatgttg +acttaagaggacgtaactacgccgtacaccattgttcaaccgacttcttggcaaatagaa +tcgtattagcaatcttaagaatagagacacgttcgtgttagggtatactacaaatccgaa +aatcttaagaggatcacctaaactgaaatttatacatatttcaacgtggatagatttaac +ataattcagccacctccaacctgggagtaattttcagtagatttactagatgattagtgg +cccaacgcacttgactatataagatctggggatcctaacctgacctatgagacaaaattg +gaaacgttaacagcccttatgtgtacaaagaaaagtaagttgttgctgttcaacagatga +tagtcatgacgcgtaacttcactatagtaaattgaaacaaatacgcaatttagacagaat +ggtacggtcatgaatgacagtaattcgaagtgctagaccaacttaaaataggtaaacgtg +cccgaaaccccccttaacagaaagctgctatcatggtgcagtatcgacgtgttcagaaac +ttgtaacttttgagcaggtccgagcacatggaagtatatcacgtgtttctgaaccggctt +atccctaagatatatccgtcgcaaactttcgatttagtcccacgtagagcccaagcgttg +tgcgactccacgtgcatgcccagaaatacgagtttaaatttggttacatggttaattttg +accgaagcatcgcactttatgattgataattggattcaatatgtcgccctatgcgaatgc +aacatgatccacaatttggctataagacgtttaatccgtatcacactttgtttgcggcta +gtatagtaacgcccgtgcaccaagagtcagtaacaattataagtactccgcaggtacttc +aaatataaaaactaatcaaacacgacccatatgatcatctgaagatatttggaactttct +cgacaaccaccctcgtactcaatacttacactaatcgacaggcacacgcaacgtgtacag +tcgcaccatattgagtcaagatttgcttagtggcgatgagcgtacacgcttatttctcta +gtcacaattagttatctacgagacatcacgagggagcaaataagcgatgttatggctaca +cataggcacgtatgaatatgatataagccagttaaacagtcgaaccatcgagcaaattct +catgcaccaacccacacgttgaggcacaaagagtaagctgtttgaatgtaacttcttctg +ctgagcgggccccaacgtaaggatcaactagaagagaaaactcggtattagtttaaatgc +gtcacggagcatgagtgcatttcactaagaatgtctgtgtaaccaatataacatctattt +gttatctgattgcctacttatggctttgcggtcgtggcgactaatgtctccaatcctttt +gaggtcggtaccaactccctttaaattacgctgtgcaggctcatgcactgcatacatata +cggtagcaggtagggacctcacgcacccttattataatcaatagtagttatcagtcaacg +aggcaggaatgctgaggtcgaggtgttggtatattttctatgtgccgtctaggcgactat +cacgcattaccaggcgagatttaagccaattttgaatatagtcaacgtaatttttactat +gggttccaccgaaacgccttgcacaactaagaatcccataaaatatcgatatcaaataaa +agattgtgtcaataccttcatatatattttttcggttgactaacgtgaactaaggttagg +ggttttgtatgtctatataggaaacagtttcttttctgtcctactttagtaaagtcttca +agccttactccaaaatcacggtgattaagccgttactcagcagcatgattctgcctgctc +gggtcctaaaatccagccttgtaagagtcgctgtgtattagctagggagacctttgttaa +aaaggatatatcgcggcgggatgtgagtgcgtggcgcatactcaatcttcagctcgtgtc +attataatatctctcccccacgcttttcactagatatgccgtgtaagcaaacaccttatg +cttaatttcgaaaatattggtacttgaaaaaagctgtaggggtacttaatgtctggtagg +agatcaggagagaattgagtgtaaaaccgtaaagccctcacctgacttcatgtaaatggc +ttagaagactccatgatttaataaatactacgaaggaaagactggatctaaagataactc +tagtaaggccaactcccttcaatgctgttgccagttataatccaagagctgtccttttct +gaaccatagcggcttctgaagcgaactagaagcaaagttggttctagccagacagccaca +taccctgtacgggtgtattactaaaactggtccggtattagttcaccaagggaggaatta +ggcaaaggatctaggtatgcaagtcggagtattacatccctaccctgaatccatcaatag +gttcctctgtactggccttcgcaatgagtattcaaggttgtacagccgtataataataag +atagtgactatgaacgggaagtaacccgctcaccttccccaaaacattgttatatctaag +tattaaagtctgccgtagtgttaatactcgaaaataaacaactggcaaattacaccgcac +ttaagccgcttttgatttatatttttccaatgcgcttttaaaaataattcagtcctacat +actaattaagacccttaaacggagatatcacaagttaagttttaaccatctcgactaggt +ggaactatagatacccaactcaatttatcattacctgtaatgttcctagaaggattgcat +ttcatgtcaagacggtggagtttcacagcgaaacttcagtgtgaacagattctgagaaat +cacctaaacctattagtcagagcacccggttagaaccagttgtcaaaaaatagagcggtt +gcatgagacagaagtaacgatgagatccgttgtaacgttgagacatctggcctatcgtca +atacagtcctcccttaaaaatatttttaaatactaggcaaacccaacataggttagtcct +atgtgatacgccacatggtatatcattttgtaacgttacctagggataatcaggaagtgg +aattacgcaaaagtagacagtgaaatgcttagggttatagtctagtccaaagataaagga +taaagcacgtcagagaactatattagccgaatgggaatcattgttaggagactgtggatc +atgtctaaaaagcaacgcagaaacagtcatcgaaaaaatctcgtttttgtttgaatctaa +aagagctttgatgaccgatagtacctgtatactagttactgtattacgtgtctaatgatt +tcggattggggtccccagaatcagacgtcattgtagacgattcaagtttaccaatttaat +ttcccagctctccttggagaactatcgccaataattgcagtcactttccttttctgaaac +gataaagccgtcagagttctctgcaacgttggacttacctgaggttctaacccactttcg +gttctaatagtagttaacgacacaacgaataacctttactgtggggctttcacgatattt +tttcgcttattattaatggttacgtcataagctggtgtccaaattaaggttaccggcttc +gcagagtagttgtatccaagtataacttccctaatcataagatcgaggtagaaaattaat +gctgtctctaaccgaacagatatgtcccactatgtggtatggacgttgctaattacttct +gaagggaaattggtcattatggatacgtgtctaccatcaggtcggacgcagatatggttc +tgtcttcagttgatccaccgttctttataggataataactgacgattaaagattatggta +aatagattaagccaattctcttcttgtcagtgaagcatccttaactgacttgctctgcag +cccctcatacatttagctattcaaagtaccggctcgtttcaaactctcccacctttggaa +gaggttgtcaacttgataagtatatcatttacagcattttttcggacgtacctctaatgt +ttcattgcagaaaattagttttttctatcgcacattttgcaagtaacgttagagacacaa +ttatctgcgaatgaactgctagatctgacgaccgggagcctcgcaaatatcaaaaaagac +tgacatatatcaaggagtcgttgacaagtgctggtaagtcaattggtttatctgtcccgg +cgtttcgatcttaagctgaccatgcacggcagagtaatgtcactctcgttcttacaagtc +tgtctccaagggtcggcaaaaaagacccctccattctcgagcccactcacgatatgtagg +gacgacaacttgtgcggcttatgaattgtctggactgcgggcgagggtccatatctccga +agttagaagggacatacctttagatgataagatcaattcttattgacgaaattcatccac +aacggggaacaacttcaccctagacttacgtctgaaaagacacctagcgtcttataaaag +gtcagtgccccgtttcgtaaggctggaattacctacgcaaacttaaacctcgcgcccttc +cttacgtatcgacaagatagaggctatcgcgaatgtactacggaggcatgaatcatatac +tagaaccaagtgcctgtgatattaacaagatgatccgacgcgagcaccgtaattctaggc +ataaaactccagcaatttgggggccgaaaacaaatgacgttagctaattaattatatgac +atgatcaaaggaggtcaatcacgcatcgagttcgacgtatattcattgaacttcgtgcgt +ttgaaagaaacttttatgaaggcaaaattgatcctgtctcctatttcatgcgtacctcct +agttgataattccccgagcagtggttaggacacttttgtcggtatcaagttccggtctca +aaacgtaaaattctgtaatctgtatggatggtctgtgaattagttaatttttatgaagtc +gtcgagacgcagttcctattgatttattctaaacggagatgtgcttcgtgggactcggaa +gtagatctgtgtttatgattattgctactttagatgctgactgttaactccgtgttgttt +ttcaaccgtatatcacaaccgaattggatagaacctatagtttcaagttctgccacaagg +tatcatatttacagttagtgctggttgcttctttcaaacgtggtgagtttgtgctatcac +gtcaacggtagagctcagtggaccgagtgcgcgttcaaccctgttccagagagggtgtga +tagcacatataccacgctcgtcgaggcgttcatgatagtttgcaagagccggtgttaaac +acatattattattgttatccaactaatcggacctatgcataaagcattgtctaaacagaa +taattgcctatatacggtagttttagtgatttatatcttagtatcagttagagcttcgaa +ctcttcaggttcctcatatttaacgttcttcgaaagcgaaaacttctacaaacgaatgta +agcggttttccaagtagtacctataaatcacagaaagatctgtctcagtatagttgaaat +ggtattcagctagtgacgtgtaccaattatcatagttcactcaagcaagacgctcattaa +cgaatatagacaagacactatatcatataataaaaaagaacatggtgctcgaacatagtt +gaattcaccatattgaaggggaatgctgacatgtaattcgctactagacgatcaattccc +tacttgtcaaagttgaactggtacgttcttggaattaaatatgattgcgctggaccaaat +tgcgacttcttgagtttcagggcaaacgattgagccggaggatgtccgtctcttaccttt +cttgcttatgataaacgacggtccctgtacatcactgggaattctcagcaaaaataattg +ggtaaatcgagactcgatgtattcggccacaaaggtgttagacgttaaagattattcaac +ggggcgataataggatcataaccggtatgcaagcgcattgaaagagccatgagatcctta +tccgataaacgctgcacggtatgtgcagccttattgtcgatcacgaatttataaatgtag +tctgggctgtaagttgaagacctaagttataatgaagtgcaataccaaatcgattcatag +tggattatcagactcaagatatctcctgataaattacagttgttaagatacggataaaat +gagatttaagattagcagcctctaatctgtttcaatcccgttggaatgtggtatgcgatc +aaggttaagttaaaatcaagcctgtcttcagtcttgattcttgttctgccatcgcatgcg +gtctacgtgagttaatatgtagcttacgttctagcttgtgctaatctgagtatagattcg +tagaggaatattatcaagcttccacgcctcaacgtacgtgtattggtcacacaagacact +aaaagtggaagtagcgtaaactatagtctagttgttaaatgctcagttcttgttatattc +gatatactcttggctaatttatgtctgagtatataaaattaatgatattaacttgcattt +cacggatcccttagaaaaagattttgaccgagcgcattataaacggttacaccgaatcaa +tagaagcatacccaatagctttctttgaatttattgcctgcgcaacttggctgactctct +agatccgaataattctatatggtcgtgacgaaactagttcattactgtttaaaatgccaa +catgtcttttgggccgataatggctctttgcaaaattactcaatgatacgattgatcaaa +gcggtagttgctagtggtagcatgtaagtctatcaaatgtctgattatccgaaaatcttc +caaaagagtccacgtaccatatctatctcatagcgacgcgaggggaaccttatctaacta +tcattccatttaccgggtgactctcgatgcaggatccgattgggataaattgcccagaaa +tggctcattcctgactaagggtaaggccgttctcagcaagggaaccccgcgaatctaggc +ttataccatctagattgttaactacttgcctgtagttctacagccatactggacagttgt +ttctaaatgatcgggattcatgctagcactcctctgaatgcaccgcgtaagtttaactat +tacgtccgtgggcagataaggatggaggctgtatgtatcttaactgttacctaatatggc +tggtaattatcaaagtaaggaccttaatgccatagcgctagcaatcgctttgtatactga +ccatgtgccaacctctcttaatctgtaaaatataatgtcttagctaactgtggacgatca +tgtctctgcctagagcttcgctgtatcaattcctatagccagcgtactagtgacacaaca +acaccgtgtgagaaaagatattagtccttacgtctgtctctctacagcttattgatgagg +attgaacatggacatatagctccccctcaaaagcagatgctacctctttattccattctc +gaacatttgccgaacttaatttcgacaaacctgaggtcacgtcttaatttatcggtaacg +tcacgtccctttgagactggataaatatattaccaggggccaacgagcaattgttggagg +cgcttctataatacaaggtgtcttgtcaaagaaagacggcgtgcgtctcgtgcaactcac +ttaaccaatattaatgtgaaacccccctctctcacatcttatgcggtgtactgccctggt +acatttcctgtacaggactccaacagtgtagattcctaagatagctgttggagttgcctc +acgccagatcgaaaaactgaataaactagtgagctgagctgcagaaataccgcttaatta +cttatgactagttcaaagggacctacgtgatgtcagacattgcaaggaagaaattaggtt +tgtgcgtcattttggctggactagcactccttacttcccctactattcaaatgtcgtaaa +cagcatgagacaggatcgtgctgacatttaaggtctattgggaacgaggctacctttggt +cgcgcgctcgcgttctccgaatgaccgaaatgcatgagcacagtatgcaattgcttatag +atctaaggtctggtcgttgaaaccaagcacgtaggcctgggaaatcagttcttcctcagc +aactacacaaaagcgtccaagcattagtacttgtagtaaatgtccgaacctatgcgctca +tttgaaagtcaaaaaatatttttaagcagtaggcacctaacccgattcctctacttagta +gctttctttgattctcagaattgactgcaatatcactgcacaattctgtgccattactag +acttctctgtattaacgtctcatcttactaacactcgcctaggacacatctgagagtgaa +gtatttcaatacatttactgaaatcttcagttctaaaatccccgaataaggctcttatcg +gtttggccaacacaagaaaaaaacttcttgcaccactcaccttcatacgcaggagcctgg +ggaacttagtaataactatttcggcagacaaagcttataacaagttgccggcgcgtataa +tatttaaaagaccccttgagctgctcaattaaaacgctcacctggtataggctattagat +agtgccgtcttagtaaggggcgggaattatcggataaactgatattttgataaaataacc +gacttgttcacgacataagtcactaaggagattttatctttctccaaagtatatcttcct +tggataatttcaaagcgctgcaatttaagttctgttactagtttatgctgctgggaggtg +accggaaggcgtagtaatctagaggcaaattataagaagttcatcatatcattttcgact +acaaaaacaaggtgttgtatgccggcgcattgtgtaaactggacgagtaccctagatgga +aaattatacgttaagccaagatttcgatgtaatgataattacctacacatttttgctatc +cataggaacaagagctgttctataggctcgtggcatacgaacatttgctgccgctatgaa +tattggaagctcttcaactacagactctattcttaattgccgtcgaaaatgggccgaatc +ggctattattaatactcggtttttccgaggggattgttgtcgacagtcgtaattattatt +aatattgatgttggtgaggtcatttaaatacaaccttgcagacaatgaataagggatcca +atctctcatactccttttacaattgctcatgcccctatgcaaaccttatgccgccacacc +tccgcaactctctcttctgaactgtaagtagcttcattactggtttgagactatactgaa +gctgatgacattctaaaatggctattttcgaatgtgattcataatgtttatcgtttggga +tggcagaatcacgttatttttgatatagcccgggtattctattgtatagaacgtatgcta +caagtcattccccgaagaagactagaagtaaacaacatgcgaccatcgttaagccacgca +aggctgtagctttatttcccgataacctatcttccataaatagcggacagcaggatactg +acgctcaacatcagtggttatggtctaatttttaacttttaataaggtaacttcagcagg +catacacagtaactctttaatttataatcaaattagaagtctgacacttcttatattttt +ctatcatccaacgcgatcgcccattagcttattgtgttactaataacgtatctaaaccaa +tccttttcaagctactgcctatattgtcaatatatacaaacaacaggatagtaggctgct +taaaaaatattgtcaaccgtgtacgctttacaatacccggaaatcacaaactttgtagac +aacgagtgaaatttatacactacgaagggccagcgtacaagacccatgaattaggcgata +tgtttattctgacatattggtttatccttaatctgtcgctgtaaaatgaagccgccccca +tccctgcgaattttttttcgaagattcacgactgaaatataaatacgtttggctatattt +atgttggagggaggcaatagcctttactgttaaccgaagatttagccagtgagtgtgaca +ctaaaacactggaataaatgcaggcgttcttctgggtaaaaggtttagtcaatctcgcct +ataagttcatatagctctggatataattatctggcccatgcatttatcatggcgcttggt +gccctgtgtgaagccggcctctcatattgaaggtccgaagtattccatgtacattaagat +cactctctcattcatgcatcttggcttaacaaatctggttgtccaagctttccaggcacg +tatggtacaaattcggatcgaatacttataaaaatgatatgttaaactgtctaaaacgct +catctacaaagtaaagtgcactaaccaatagagtctcaagaccgtgtaatgctggtgcac +tgaatgtgtaatacggttagaagggattagttatgttacaaatccattgaaaacttaaga +agcattgcgtgctcggagggtgcatcttttatcaagagactaacattattttcaacgacg +tacatgctttacaatagggtacttatcaaacgccgagaaacgcgcctatagtgatgttat +gattatgacccgatatccattggaccgaattttatgtaggttcccagcgtactcgcgtaa +tatctcggtattgccataatgtaatacttgtcggtctctcccagatgaaaaagcgttaca +gagtatttcaatgaaaaacagcgcgcaacgtcaatacctttaggggtaacggccgctgat +ttcatatagatatacgataagttggtatagctctactaggtggcatccacaatcgttgca +tttactatagctggttacaatcataatctataccgttccttacatactaccatagcggga +tagcgtttttttgccgttgattgggtttaagaggatgtcagtctcattatatccgattcg +gtgggagagccgttgttttcaaatcgcacactttgtgacataatgtacaagataacaaaa +ctgatataagatataaactgtcaatatcaccttgacacttgaatcaaagtaaattaactc +gcaaatataatttgactaattgggtgcagatttctcaattaataaaaaaatggcaccgga +tgggcttacaagccccttatcattcacttgtatcatgatttccaagaacaatagaatttg +ctagcaagtatgaacagagattcgaattgcatccacagtacgccggagcgtttattttaa +tgtggatatgacgatgtactgttggcggcatttgctagtaaccggtccttatttacgtag +cgcacacgtaagcatgtctgggagaaatatggtggtacaatctcagagaaagattacagt +ttggtttaaataggacttatcgggtcggaagtggaacttaataagcagtacacaattggg +caacagacgtcttgcctattacaataggattacaatgcgttagatttcagacacgttcgt +gtttggctattcgtcaattccctaaatagttagacgatcaactattatcaaagtgattct +ttgttcatcctccattcatgtaacagatggcacactacgcataacgccgaggaattttaa +cgagatttaagagagcagttcgggcacaacccacttgactttataacagctcggcagcat +aaacggtaatatgtgacaaatttccaaacgttataagaacgtatgtgtacttagaaaact +aagtggttcatgttcaacagatgtgacgcagcaagcctaacttatctattggttttgcta +taaaagaacaaagttacacagaatcctaagggcttgtttcacacttatgcctagtgcttc +accatcttaaaatagcgaaaccggcacgaatcaaaccttaaaacaatgcgcagatattgg +tgatggtgactccgggtatgataatggtaactgttgaccagcgcccacctcatcgaagta +tagaaagtggttaggataaggatgagaccgaacttatttccggccataactttagatttt +ctacctagtacacaacatcagggcggacacgaaaccgccatcacatcatataccaggttt +aatttgcttaatgggggaagtgtcaacgaaccttcgaactttagcaggcatatggccatt +atatatggccccagagcagaatgctacagcagacaaaatttggatttatgtagtttaata +cctatcaaacttggtgtgaccatacttgtctaacgacagtgcacaaagtgtaagttacaa +ttattactactcagcagcttctgcaatgataaaatcttatcatacacgtcacatatgata +atatctacttagggggaacgggctccacaacctacatagtactcaatacttacactattc +gacaggcacaccaaacctgtacagtcccaaaagattgagtcaactttgcagtactgcaga +tcacagtaatagcttagttagcgagtcaaaattagttttctacgagactgcacgaccgtg +caaatttccgatgtgttggctacaaatagcaacgtatgaatttgtttgaagccacgtaaa +ctgtacaaccttagagataagtctcaggctactaaaaacacgttgtggcactaacaggat +catggttgattcttacttattcggctgaccggcccaataagtaaccttcaactagaacag +aataatcgggagtagtttaattcagtcaaggtgcaggtctcattgtaactaacaagctct +gtgtaaccaagttaaaatcgttttcttagcggattccctacttatggatttgagctcgtc +cacaatattcgatacaagaagtttgtggtccgtaacaacgaaattttaattacgctgtgc +agcctcatccaaggaattaatagaaggttgatggtaggctccgaacgctccatgattata +atcaagtggactgtgcagtaaacgaggaaggtatcctgacgtcgtggtgttcgtttttgt +tatttgtgccctatacgagtagataaaccatgaacagcacagtgtgaacccatggttgat +tttaggctaccttatttttaatttccgttacacagaaacgaattccacaactaacatgcc +attaatttttcgatatcttataaaagatggtcgaaattcattcatttattttttttcggt +tctcgaaagtcaactaagctgtcgcgttttgtttctctttagaggtaaaagtggctttga +tctcctacgtttggatactagtcaaccattactccatttgatccgtgagtatcacctgtc +taacatccagcattatgactcctcggcgaagaaaagacacacttcttagagtcgatgtgt +attagctagggacacagttgtttaatacgatagtgagcccagggagggcagtgcgtcccc +cagtagatttattcagctagtgtaagtataagatatctcacccacgaggttcaagtgata +tgcagtcttagaataatacttatcctgaatttcgatattatgggtacttcaataatccgc +tagcgctactttatgtctcgttggacagcaggacacatggcagtcttaaacactaaagac +atcacctgaatgaatgtaatgggattacaagaatcaatgaggtattatatacgacgtagg +aaactctggatatatacagtaatctagttacgccatcgcacttcattcctctggaaactt +agaagacatcagctgtacgtggaggaaccagacccccgtatgtagccaaatagaaccaaa +gttgcttatacaaacacacccaatgacaatggaccgctggagttcgtaaactcggaacgt +agtactgcacaaacccagcatttagcaataggagctacgtatgcaactcccacgtggtaa +taccttcaagctatcaatatataggtgcctagctaatcgcattcgcaagcagtattcaag +cttgtaaaccagtataataattacagaggctctatgaaacccaactttccagctaaaagt +cccaattaaatggttatttc diff --git a/benchmarks/shootout/knucleotide-output.txt b/benchmarks/shootout/knucleotide-output.txt new file mode 100644 index 00000000..072e3660 --- /dev/null +++ b/benchmarks/shootout/knucleotide-output.txt @@ -0,0 +1,27 @@ +A 30.279 +T 30.113 +G 19.835 +C 19.773 + +AA 9.161 +AT 9.138 +TA 9.108 +TT 9.060 +CA 6.014 +GA 5.996 +AG 5.993 +AC 5.988 +TG 5.987 +GT 5.967 +TC 5.958 +CT 5.948 +GG 3.944 +GC 3.928 +CG 3.910 +CC 3.899 + +1474 GGT +459 GGTA +49 GGTATT +1 GGTATTTTAATT +1 GGTATTTTAATTTATAGT diff --git a/benchmarks/shootout/knucleotide.chibi b/benchmarks/shootout/knucleotide.chibi new file mode 100644 index 00000000..6aee05bc --- /dev/null +++ b/benchmarks/shootout/knucleotide.chibi @@ -0,0 +1,86 @@ +#! /usr/bin/env chibi-scheme + +;;; The Computer Language Benchmarks Game +;;; http://shootout.alioth.debian.org/ + +;;; based on Racket version by Matthew Flatt + +(import (chibi) + (srfi 69) + (srfi 95) + (chibi io)) + +(define (print . args) + (for-each display args) + (newline)) + +(define (string-copy! dst dstart src start end) + (do ((i dstart (+ i 1)) + (j start (+ j 1))) + ((>= j end)) + (string-set! dst i (string-ref src j)))) + +(define (string-upcase str) + (let* ((len (string-length str)) + (res (make-string len))) + (do ((i 0 (+ i 1))) + ((>= i len) res) + (string-set! res i (char-upcase (string-ref str i)))))) + +(define (all-counts len dna) + (let ((table (make-hash-table eq?)) + (seq (make-string len))) + (do ((s (- (string-length dna) len) ( - s 1))) + ((< s 0) table) + (string-copy! seq 0 dna s (+ s len)) + (let ((key (string->symbol seq))) + (let ((cnt (hash-table-ref/default table key 0))) + (hash-table-set! table key (+ cnt 1))))))) + +(define (write-freqs table) + (let* ((content (hash-table->alist table)) + (total (exact->inexact (apply + (map cdr content))))) + (for-each + (lambda (a) + (print (car a) " " + (/ (round (* 100000.0 (/ (cdr a) total))) 1000.0))) + (sort content > cdr)))) + +(define (write-one-freq table key) + (print (hash-table-ref/default table key 0) "\t" key)) + +(define dna + (let ((in (current-input-port))) + ;; Skip to ">THREE ..." + (let lp () + (let ((line (read-line in))) + (cond ((eof-object? line)) + ((and (>= (string-length line) 6) + (eqv? #\> (string-ref line 0)) + (equal? (substring line 0 6) ">THREE"))) + (else (lp))))) + (let ((out (open-output-string))) + ;; Copy everything but newlines to out: + (let lp () + (let ((line (read-line in))) + (cond ((eof-object? line)) + (else + (display line out) + (lp))))) + ;; Extract the string from out: + (string-upcase (get-output-string out))))) + +;; 1-nucleotide counts: +(write-freqs (all-counts 1 dna)) +(newline) + +;; 2-nucleotide counts: +(write-freqs (all-counts 2 dna)) +(newline) + +;; Specific sequences: +(for-each + (lambda (seq) + (write-one-freq (all-counts (string-length seq) dna) + (string->symbol seq))) + '("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT")) diff --git a/bignum.c b/bignum.c new file mode 100644 index 00000000..8d18e36b --- /dev/null +++ b/bignum.c @@ -0,0 +1,1767 @@ +/* bignum.c -- bignum support */ +/* Copyright (c) 2009-2013 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/sexp.h" + +#if SEXP_USE_BIGNUMS + +#define SEXP_INIT_BIGNUM_SIZE 2 + +static int digit_value (int c) { + return (((c)<='9') ? ((c) - '0') : ((sexp_toupper(c) - 'A') + 10)); +} + +static int hex_digit (int n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + +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); + sexp_bignum_length(dst) = len; + } + if (sexp_bignum_length(a) < len) + len = sexp_bignum_length(a); + + sexp_bignum_sign(dst) = sexp_bignum_sign(a); + memset(sexp_bignum_data(dst), 0, + sexp_bignum_length(dst)*sizeof(sexp_uint_t)); + memmove(sexp_bignum_data(dst), sexp_bignum_data(a), + len*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 data[0])) { + data[0] = b - data[0]; + sexp_bignum_sign(a) = -sexp_bignum_sign(a); + } else { + 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) < len+offset)) + d = sexp_make_bignum(ctx, len+offset); + tmp = d; + data = sexp_bignum_data(d); + for (i=0; i> (sizeof(sexp_uint_t)*8); + } + if (carry) { + if (sexp_bignum_length(d) <= len+offset) + 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_bignum_fxrem (sexp ctx, sexp a, sexp_sint_t b) { + sexp_uint_t len=sexp_bignum_hi(a), *data=sexp_bignum_data(a), q, b0; + int i; + sexp_luint_t n = 0; + if (b > 0) { + q = b - 1; + if ((b & q) == 0) + return sexp_make_fixnum(sexp_bignum_sign(a) * (data[0] & q)); + } + b0 = (b >= 0) ? b : -b; + for (i=len-1; i>=0; i--) { + n = (n << sizeof(sexp_uint_t)*8) + data[i]; + q = n / b0; + n -= (sexp_luint_t)q * b0; + } + return sexp_make_fixnum(sexp_bignum_sign(a) * (sexp_sint_t)n); +} + +sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, + signed 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); sexp_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)); + } +#if SEXP_USE_RATIOS + } else if (c=='/') { + res = sexp_bignum_normalize(res); + res = sexp_make_ratio(ctx, res, SEXP_ONE); + sexp_ratio_denominator(res) = sexp_read_number(ctx, in, 10); + res = sexp_ratio_normalize(ctx, res, in); +#endif +#if SEXP_USE_COMPLEX + } else if (c=='i' || c=='i' || c=='+' || c=='-') { + sexp_push_char(ctx, c, in); + res = sexp_bignum_normalize(res); + res = sexp_read_complex_tail(ctx, in, res); +#endif + } else if ((c!=EOF) && ! sexp_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= 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 (SEXP_UINT_T_MAX - bdata[i] - carry) ? 1 : 0); + } + for ( ; carry && (i= 0 ? a : b); + } + return res; +} + +sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b) { + sexp res; + int sign; + if (sexp_bignum_sign(a) == sexp_bignum_sign(b)) { + sign = (sexp_bignum_compare_abs(a, b) >= 0 ? sexp_bignum_sign(a) + : -sexp_bignum_sign(a)); + res = sexp_bignum_sub_digits(ctx, dst, a, b); + } else { + sign = sexp_bignum_sign(a); + res = sexp_bignum_add_digits(ctx, dst, a, b); + } + sexp_bignum_sign(res) = sign; + return res; +} + +static void sexp_bignum_split (sexp ctx, sexp a, sexp_uint_t k, sexp* lo, sexp* hi) { + sexp_uint_t alen=sexp_bignum_hi(a), i, *adata=sexp_bignum_data(a), + *lodata, *hidata; + *lo = sexp_make_bignum(ctx, k); /* must be gc protected by caller */ + *hi = sexp_make_bignum(ctx, alen-k+1); + lodata = sexp_bignum_data(*lo); + hidata = sexp_bignum_data(*hi); + for (i=0; i 0) { /* a1, b1 at least 2 bigits */ + /* guess divisor x */ + alen = sexp_bignum_hi(a1); + sexp_bignum_data(x)[off] = 0; + if (off > 0) sexp_bignum_data(x)[off-1] = 0; + off = alen - blen + 1; + d = (((sexp_luint_t)sexp_bignum_data(a1)[alen-1] << (sizeof(sexp_uint_t)*8)) + + sexp_bignum_data(a1)[alen-2]) + / (((sexp_luint_t)sexp_bignum_data(b1)[blen-1] << (sizeof(sexp_uint_t)*8)) + + sexp_bignum_data(b1)[blen-2]); + if (d == 0) { + d = ((sexp_luint_t)sexp_bignum_data(a1)[alen-1] << (sizeof(sexp_uint_t)*8)) + (sexp_luint_t)sexp_bignum_data(a1)[alen-2]; + d /= sexp_bignum_data(b1)[blen-1]; + off--; + } + dhi = d >> (sizeof(sexp_uint_t)*8); + dlo = d & (((sexp_luint_t)1<<(sizeof(sexp_uint_t)*8))-1); + sexp_bignum_data(x)[off] = dhi; + if (off > 0) sexp_bignum_data(x)[off-1] = dlo; + /* update quotient q and remainder a1 estimates */ + y = sexp_bignum_mul(ctx, NULL, b1, x); + if (sign < 0) { + a1 = sexp_bignum_add(ctx, NULL, a1, y); + q = sexp_sub(ctx, q, x); + } else { + a1 = sexp_bignum_sub(ctx, NULL, a1, y); + q = sexp_add(ctx, q, x); + } + /* flip the sign if we overshot in our estimate */ + if (sexp_bignum_sign(a1) != sign) { + sexp_bignum_sign(a1) = -sign; + sign *= -1; + } + } + /* adjust signs */ + if (sign < 0) { + q = sexp_sub(ctx, q, SEXP_ONE); + a1 = sexp_add(ctx, a1, b1); + } + *rem = a1; + if (sexp_bignum_sign(a) * sexp_bignum_sign(b) < 0) { + sexp_negate_exact(q); + } + if (sexp_bignum_sign(a) < 0) { + sexp_negate_exact(*rem); + } + sexp_gc_release5(ctx); + return q; +} + +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 sexp_bignum_normalize(res); +} + +#if SEXP_USE_MATH + +/* + * a = x * 2^2n, with 0.1 <= x < 1.0 (base 2) => sqrt(a) ~ 2^n + */ +sexp sexp_bignum_sqrt_estimate (sexp ctx, sexp a) { + sexp_uint_t alen=sexp_bignum_hi(a), adata_hi; + int nbits, i; + sexp_gc_var1(res); + + adata_hi = sexp_bignum_data(a)[alen - 1]; + for (i = sizeof(sexp_uint_t)*8-1; i > 0; i--) + if (adata_hi & (1ul << i)) + break; + nbits = sizeof(sexp_uint_t) * 8 * (alen - 1) + i + 1; + + sexp_gc_preserve1(ctx, res); + res = sexp_fixnum_to_bignum(ctx, SEXP_TWO); + res = sexp_bignum_expt(ctx, res, sexp_make_fixnum(nbits / 2)); + sexp_gc_release1(ctx); + return res; +} + +#define SEXP_MAX_ACCURATE_FLONUM_SQRT 1073741824.0 /* 2^30 */ + +/* Babylonian method */ +sexp sexp_bignum_sqrt (sexp ctx, sexp a, sexp* rem_out) { + sexp_gc_var4(res, rem, tmp, tmpa); + if (! sexp_bignump(a)) return sexp_type_exception(ctx, NULL, SEXP_BIGNUM, a); + sexp_gc_preserve4(ctx, res, rem, tmp, tmpa); + /* initial estimate via flonum, ignoring signs */ + if (sexp_negativep(a)) { + tmpa = sexp_copy_bignum(ctx, NULL, a, 0); + a = tmpa; + sexp_negate(a); + } + res = sexp_make_flonum(ctx, sexp_bignum_to_double(a)); + res = sexp_inexact_sqrt(ctx, NULL, 1, res); + if (sexp_flonump(res) && + sexp_flonum_value(res) > SEXP_MAX_ACCURATE_FLONUM_SQRT) { + if (isinf(sexp_flonum_value(res))) + res = sexp_bignum_sqrt_estimate(ctx, a); + else + res = sexp_double_to_bignum(ctx, sexp_flonum_value(res)); + loop: /* until 0 <= a - res*res < 2*res + 1 */ + rem = sexp_mul(ctx, res, res); + tmp = rem = sexp_sub(ctx, a, rem); + if (!sexp_positivep(tmp)) goto adjust; + tmp = sexp_sub(ctx, tmp, SEXP_ONE); + tmp = sexp_quotient(ctx, tmp, SEXP_TWO); + tmp = sexp_compare(ctx, tmp, res); + if (sexp_positivep(tmp)) { + adjust: + tmp = sexp_quotient(ctx, a, res); + res = sexp_add(ctx, res, tmp); + res = sexp_quotient(ctx, res, SEXP_TWO); + goto loop; + } + /* convert back to inexact if non-zero remainder */ + *rem_out = sexp_bignum_normalize(rem); + } + sexp_gc_release4(ctx); + return sexp_bignum_normalize(res); +} + +#endif /* SEXP_USE_MATH */ + +/************************ ratios ******************************/ + +#if SEXP_USE_RATIOS + +double sexp_ratio_to_double (sexp rat) { + sexp num = sexp_ratio_numerator(rat), den = sexp_ratio_denominator(rat); + return (sexp_bignump(num) ? sexp_bignum_to_double(num) + : sexp_fixnum_to_double(num)) + / (sexp_bignump(den) ? sexp_bignum_to_double(den) + : sexp_fixnum_to_double(den)); +} + +sexp sexp_double_to_ratio (sexp ctx, double f) { + int sign, i; + sexp_gc_var3(res, whole, scale); + if (f == trunc(f)) + return sexp_bignum_normalize(sexp_double_to_bignum(ctx, f)); + sexp_gc_preserve3(ctx, res, whole, scale); + whole = sexp_double_to_bignum(ctx, trunc(f)); + res = sexp_fixnum_to_bignum(ctx, SEXP_ZERO); + scale = SEXP_ONE; + sign = (f < 0 ? -1 : 1); + for (i=0, f=fabs(f-trunc(f)); f != trunc(f) && i < 15; i++) { + res = sexp_bignum_fxmul(ctx, NULL, res, 10, 0); + f = f * 10; + res = sexp_bignum_fxadd(ctx, res, double_10s_digit(f)); + f = f - trunc(f); + scale = sexp_mul(ctx, scale, SEXP_TEN); + } + sexp_bignum_sign(res) = sign; + res = sexp_bignum_normalize(res); + scale = sexp_bignum_normalize(scale); + res = sexp_make_ratio(ctx, res, scale); + res = sexp_ratio_normalize(ctx, res, SEXP_FALSE); + res = sexp_add(ctx, res, whole); + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_ratio_add (sexp ctx, sexp a, sexp b) { + sexp_gc_var3(res, num, den); + sexp_gc_preserve3(ctx, res, num, den); + num = sexp_mul(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(b)); + den = sexp_mul(ctx, sexp_ratio_numerator(b), sexp_ratio_denominator(a)); + num = sexp_add(ctx, num, den); + den = sexp_mul(ctx, sexp_ratio_denominator(a), sexp_ratio_denominator(b)); + res = sexp_make_ratio(ctx, num, den); + res = sexp_ratio_normalize(ctx, res, SEXP_FALSE); + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_ratio_mul (sexp ctx, sexp a, sexp b) { + sexp_gc_var3(res, num, den); + sexp_gc_preserve3(ctx, res, num, den); + num = sexp_mul(ctx, sexp_ratio_numerator(a), sexp_ratio_numerator(b)); + den = sexp_mul(ctx, sexp_ratio_denominator(a), sexp_ratio_denominator(b)); + res = sexp_make_ratio(ctx, num, den); + res = sexp_ratio_normalize(ctx, res, SEXP_FALSE); + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_ratio_div (sexp ctx, sexp a, sexp b) { + sexp_gc_var3(res, num, den); + sexp_gc_preserve3(ctx, res, num, den); + num = sexp_mul(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(b)); + den = sexp_mul(ctx, sexp_ratio_denominator(a), sexp_ratio_numerator(b)); + res = sexp_make_ratio(ctx, num, den); + res = sexp_ratio_normalize(ctx, res, SEXP_FALSE); + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_ratio_compare (sexp ctx, sexp a, sexp b) { + sexp_gc_var2(a2, b2); + sexp_gc_preserve2(ctx, a2, b2); + a2 = sexp_mul(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(b)); + b2 = sexp_mul(ctx, sexp_ratio_numerator(b), sexp_ratio_denominator(a)); + a2 = sexp_compare(ctx, a2, b2); + sexp_gc_release2(ctx); + return a2; +} + +sexp sexp_ratio_round (sexp ctx, sexp a) { + sexp_gc_var2(q, r); + sexp_gc_preserve2(ctx, q, r); + q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a)); + if ((sexp_ratio_denominator(a) == SEXP_TWO) && sexp_oddp(q)) { + q = sexp_add(ctx, q, (sexp_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE)); + } else { + r = sexp_remainder(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a)); + r = sexp_mul(ctx, r, SEXP_TWO); + if (sexp_negativep(r)) {sexp_negate(r);} + if (sexp_unbox_fixnum(sexp_compare(ctx, r, sexp_ratio_denominator(a))) > 0) + q = sexp_add(ctx, q, (sexp_positivep(q) ? SEXP_ONE : SEXP_NEG_ONE)); + } + sexp_gc_release2(ctx); + return q; +} + +sexp sexp_ratio_trunc (sexp ctx, sexp a) { + return sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a)); +} + +sexp sexp_ratio_floor (sexp ctx, sexp a) { + sexp_gc_var1(q); + sexp_gc_preserve1(ctx, q); + q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a)); + if (sexp_negativep(sexp_ratio_numerator(a))) + q = sexp_add(ctx, q, SEXP_NEG_ONE); + sexp_gc_release1(ctx); + return q; +} + +sexp sexp_ratio_ceiling (sexp ctx, sexp a) { + sexp_gc_var1(q); + sexp_gc_preserve1(ctx, q); + q = sexp_quotient(ctx, sexp_ratio_numerator(a), sexp_ratio_denominator(a)); + if (sexp_positivep(sexp_ratio_numerator(a))) + q = sexp_add(ctx, q, SEXP_ONE); + sexp_gc_release1(ctx); + return q; +} + +#endif + +/************************ complex numbers ****************************/ + +#if SEXP_USE_COMPLEX + +static sexp sexp_complex_copy (sexp ctx, sexp a) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_complex(ctx, sexp_complex_real(a), sexp_complex_imag(a)); + if (sexp_flonump(sexp_complex_real(a))) + sexp_complex_real(a) = sexp_make_flonum(ctx, sexp_flonum_value(sexp_complex_real(a))); + else if (sexp_bignump(sexp_complex_real(a))) + sexp_complex_real(a) = sexp_copy_bignum(ctx, NULL, sexp_complex_real(a), 0); + if (sexp_flonump(sexp_complex_imag(a))) + sexp_complex_imag(a) = sexp_make_flonum(ctx, sexp_flonum_value(sexp_complex_imag(a))); + else if (sexp_bignump(sexp_complex_imag(a))) + sexp_complex_imag(a) = sexp_copy_bignum(ctx, NULL, sexp_complex_imag(a), 0); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_complex_add (sexp ctx, sexp a, sexp b) { + sexp_gc_var3(res, real, imag); + sexp_gc_preserve3(ctx, res, real, imag); + real = sexp_add(ctx, sexp_complex_real(a), sexp_complex_real(b)); + imag = sexp_add(ctx, sexp_complex_imag(a), sexp_complex_imag(b)); + res = sexp_make_complex(ctx, real, imag); + sexp_gc_release3(ctx); + return sexp_complex_normalize(res); +} + +sexp sexp_complex_sub (sexp ctx, sexp a, sexp b) { + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + tmp = sexp_complex_copy(ctx, b); + sexp_negate(sexp_complex_real(tmp)); + sexp_negate(sexp_complex_imag(tmp)); + res = sexp_complex_add(ctx, a, tmp); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_complex_mul (sexp ctx, sexp a, sexp b) { + sexp_gc_var3(res, real, imag); + sexp_gc_preserve3(ctx, res, real, imag); + real = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_real(b)); + res = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_imag(b)); + real = sexp_sub(ctx, real, res); + imag = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_imag(b)); + res = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_real(b)); + imag = sexp_add(ctx, imag, res); + res = sexp_make_complex(ctx, real, imag); + sexp_gc_release3(ctx); + return sexp_complex_normalize(res); +} + +/* (a + bi) (ac + bd) (bc - ad) */ +/* -------- = ----------- + ----------- i */ +/* (c + di) (c^2 + d^2) (c^2 + d^2) */ + +sexp sexp_complex_div (sexp ctx, sexp a, sexp b) { + sexp_gc_var4(res, real, imag, denom); + sexp_gc_preserve4(ctx, res, real, imag, denom); + /* c^2 + d^2 */ + denom = sexp_mul(ctx, sexp_complex_real(b), sexp_complex_real(b)); + res = sexp_mul(ctx, sexp_complex_imag(b), sexp_complex_imag(b)); + denom = sexp_add(ctx, denom, res); + /* ac + bd */ + real = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_real(b)); + res = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_imag(b)); + real = sexp_add(ctx, real, res); + real = sexp_div(ctx, real, denom); + /* bc - ad */ + imag = sexp_mul(ctx, sexp_complex_imag(a), sexp_complex_real(b)); + res = sexp_mul(ctx, sexp_complex_real(a), sexp_complex_imag(b)); + imag = sexp_sub(ctx, imag, res); + imag = sexp_div(ctx, imag, denom); + res = sexp_make_complex(ctx, real, imag); + sexp_gc_release4(ctx); + return sexp_complex_normalize(res); +} + +static double sexp_to_double (sexp x) { + if (sexp_flonump(x)) + return sexp_flonum_value(x); + else if (sexp_fixnump(x)) + return sexp_fixnum_to_double(x); + else if (sexp_bignump(x)) + return sexp_bignum_to_double(x); +#if SEXP_USE_RATIOS + else if (sexp_ratiop(x)) + return sexp_ratio_to_double(x); +#endif + else + return 0.0; +} + +static sexp sexp_to_complex (sexp ctx, sexp x) { +#if SEXP_USE_RATIOS + sexp_gc_var1(tmp); +#endif + if (sexp_flonump(x) || sexp_fixnump(x) || sexp_bignump(x)) { + return sexp_make_complex(ctx, x, SEXP_ZERO); +#if SEXP_USE_RATIOS + } else if (sexp_ratiop(x)) { + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO); + sexp_complex_real(tmp) = sexp_make_flonum(ctx, sexp_to_double(x)); + sexp_gc_release1(ctx); + return tmp; +#endif + } else { + return x; + } +} + +sexp sexp_complex_exp (sexp ctx, sexp z) { + double e2x = exp(sexp_to_double(sexp_complex_real(z))), + y = sexp_to_double(sexp_complex_imag(z)); + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO); + sexp_complex_real(res) = sexp_make_flonum(ctx, e2x*cos(y)); + sexp_complex_imag(res) = sexp_make_flonum(ctx, e2x*sin(y)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_complex_log (sexp ctx, sexp z) { + double x = sexp_to_double(sexp_complex_real(z)), + y = sexp_to_double(sexp_complex_imag(z)); + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO); + sexp_complex_real(res) = sexp_make_flonum(ctx, log(sqrt(x*x + y*y))); + sexp_complex_imag(res) = sexp_make_flonum(ctx, atan2(y, x)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_complex_expt (sexp ctx, sexp a, sexp b) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_to_complex(ctx, a); + res = sexp_complex_log(ctx, res); + res = sexp_mul(ctx, b, res); + res = sexp_complex_exp(ctx, res); + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_MATH + +sexp sexp_complex_sqrt (sexp ctx, sexp z) { + double x = sexp_to_double(sexp_complex_real(z)), + y = sexp_to_double(sexp_complex_imag(z)), r; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + r = sqrt(x*x + y*y); + res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO); + sexp_complex_real(res) = sexp_make_flonum(ctx, sqrt((x+r)/2)); + sexp_complex_imag(res) = sexp_make_flonum(ctx, (y<0?-1:1)*sqrt((-x+r)/2)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_complex_sin (sexp ctx, sexp z) { + double x = sexp_to_double(sexp_complex_real(z)), + y = sexp_to_double(sexp_complex_imag(z)); + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO); + sexp_complex_real(res) = sexp_make_flonum(ctx, sin(x)*cosh(y)); + sexp_complex_imag(res) = sexp_make_flonum(ctx, cos(x)*sinh(y)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_complex_cos (sexp ctx, sexp z) { + double x = sexp_to_double(sexp_complex_real(z)), + y = sexp_to_double(sexp_complex_imag(z)); + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO); + sexp_complex_real(res) = sexp_make_flonum(ctx, cos(x)*cosh(y)); + sexp_complex_imag(res) = sexp_make_flonum(ctx, -sin(x)*sinh(y)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_complex_tan (sexp ctx, sexp z) { + sexp res; + sexp_gc_var2(sin, cos); + sexp_gc_preserve2(ctx, sin, cos); + sin = sexp_complex_sin(ctx, z); + cos = sexp_complex_cos(ctx, z); + res = sexp_complex_div(ctx, sin, cos); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_complex_asin (sexp ctx, sexp z) { + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + res = sexp_complex_mul(ctx, z, z); + tmp = sexp_make_complex(ctx, SEXP_ONE, SEXP_ZERO); + res = sexp_complex_sub(ctx, tmp, res); + res = sexp_complex_sqrt(ctx, res); + /* tmp = iz */ + sexp_complex_real(tmp) = sexp_complex_imag(z); + sexp_negate(sexp_complex_real(tmp)); + sexp_complex_imag(tmp) = sexp_complex_real(z); + res = sexp_complex_add(ctx, tmp, res); + tmp = sexp_complex_log(ctx, res); + /* res = -i*tmp */ + res = sexp_complex_copy(ctx, tmp); + sexp_negate(sexp_complex_imag(res)); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_complex_acos (sexp ctx, sexp z) { + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + res = sexp_complex_asin(ctx, z); + tmp = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO); + sexp_complex_real(tmp) = sexp_make_flonum(ctx, acos(-1)/2); + res = sexp_sub(ctx, tmp, res); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_complex_atan (sexp ctx, sexp z) { + sexp_gc_var3(res, tmp1, tmp2); + sexp_gc_preserve3(ctx, res, tmp1, tmp2); + tmp1 = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ONE); + tmp1 = sexp_complex_mul(ctx, z, tmp1); + res = sexp_make_complex(ctx, SEXP_ONE, SEXP_ZERO); + res = sexp_complex_sub(ctx, res, tmp1); + res = sexp_complex_log(ctx, res); + tmp2 = sexp_make_complex(ctx, SEXP_ONE, SEXP_ZERO); + tmp2 = sexp_complex_add(ctx, tmp2, tmp1); + tmp2 = sexp_complex_log(ctx, tmp2); + res = sexp_complex_sub(ctx, res, tmp2); + tmp1 = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ONE); + sexp_complex_imag(tmp1) = sexp_make_flonum(ctx, 0.5); + res = sexp_complex_mul(ctx, res, tmp1); + sexp_gc_release3(ctx); + return res; +} + +#endif +#endif + +/****************** generic arithmetic ************************/ + +enum sexp_number_types { + SEXP_NUM_NOT = 0, + SEXP_NUM_FIX, + SEXP_NUM_FLO, + SEXP_NUM_BIG, +#if SEXP_USE_RATIOS + SEXP_NUM_RAT, +#endif +#if SEXP_USE_COMPLEX + SEXP_NUM_CPX, +#endif +}; + +enum sexp_number_combs { + SEXP_NUM_NOT_NOT = 0, + SEXP_NUM_NOT_FIX, + SEXP_NUM_NOT_FLO, + SEXP_NUM_NOT_BIG, +#if SEXP_USE_RATIOS + SEXP_NUM_NOT_RAT, +#endif +#if SEXP_USE_COMPLEX + SEXP_NUM_NOT_CPX, +#endif + SEXP_NUM_FIX_NOT, + SEXP_NUM_FIX_FIX, + SEXP_NUM_FIX_FLO, + SEXP_NUM_FIX_BIG, +#if SEXP_USE_RATIOS + SEXP_NUM_FIX_RAT, +#endif +#if SEXP_USE_COMPLEX + SEXP_NUM_FIX_CPX, +#endif + SEXP_NUM_FLO_NOT, + SEXP_NUM_FLO_FIX, + SEXP_NUM_FLO_FLO, + SEXP_NUM_FLO_BIG, +#if SEXP_USE_RATIOS + SEXP_NUM_FLO_RAT, +#endif +#if SEXP_USE_COMPLEX + SEXP_NUM_FLO_CPX, +#endif + SEXP_NUM_BIG_NOT, + SEXP_NUM_BIG_FIX, + SEXP_NUM_BIG_FLO, + SEXP_NUM_BIG_BIG, +#if SEXP_USE_RATIOS + SEXP_NUM_BIG_RAT, +#endif +#if SEXP_USE_COMPLEX + SEXP_NUM_BIG_CPX, +#endif +#if SEXP_USE_RATIOS + SEXP_NUM_RAT_NOT, + SEXP_NUM_RAT_FIX, + SEXP_NUM_RAT_FLO, + SEXP_NUM_RAT_BIG, + SEXP_NUM_RAT_RAT, +#if SEXP_USE_COMPLEX + SEXP_NUM_RAT_CPX, +#endif +#endif +#if SEXP_USE_COMPLEX + SEXP_NUM_CPX_NOT, + SEXP_NUM_CPX_FIX, + SEXP_NUM_CPX_FLO, + SEXP_NUM_CPX_BIG, +#if SEXP_USE_RATIOS + SEXP_NUM_CPX_RAT, +#endif + SEXP_NUM_CPX_CPX, +#endif +}; + +static int sexp_number_types[] = +#if SEXP_USE_RATIOS && SEXP_USE_COMPLEX + {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 4, 5, 0, 0}; +#else +#if SEXP_USE_RATIOS || SEXP_USE_COMPLEX + {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 4, 0, 0, 0}; +#else + {0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0}; +#endif +#endif + +#define SEXP_NUM_NUMBER_TYPES (4 + SEXP_USE_RATIOS + SEXP_USE_COMPLEX) + +static int sexp_number_type (sexp a) { + return sexp_pointerp(a) ? + (sexp_pointer_tag(a)<(sizeof(sexp_number_types)/sizeof(sexp_number_types[0])) + ? sexp_number_types[sexp_pointer_tag(a)] : 0) +#if SEXP_USE_IMMEDIATE_FLONUMS + : sexp_flonump(a) ? 2 +#endif + : sexp_fixnump(a); +} + +sexp sexp_add (sexp ctx, sexp a, sexp b) { + sexp_sint_t sum; + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: +#if SEXP_USE_RATIOS + case SEXP_NUM_NOT_RAT: +#endif +#if SEXP_USE_COMPLEX + case SEXP_NUM_NOT_CPX: +#endif + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + sum = sexp_unbox_fixnum(a) + sexp_unbox_fixnum(b); + if ((sum < SEXP_MIN_FIXNUM) || (sum > SEXP_MAX_FIXNUM)) + r = sexp_add(ctx, tmp=sexp_fixnum_to_bignum(ctx, a), b); + else + r = sexp_make_fixnum(sum); + 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; +#if SEXP_USE_RATIOS + case SEXP_NUM_FLO_RAT: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) + sexp_ratio_to_double(b)); + break; + case SEXP_NUM_FIX_RAT: + case SEXP_NUM_BIG_RAT: + a = tmp = sexp_make_ratio(ctx, a, SEXP_ONE); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_RAT_RAT: + r = sexp_ratio_add(ctx, a, b); + break; +#endif +#if SEXP_USE_COMPLEX +#if SEXP_USE_RATIOS + case SEXP_NUM_RAT_CPX: +#endif + case SEXP_NUM_FLO_CPX: + case SEXP_NUM_FIX_CPX: + case SEXP_NUM_BIG_CPX: + a = tmp = sexp_make_complex(ctx, a, SEXP_ZERO); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_CPX_CPX: + r = sexp_complex_add(ctx, a, b); + break; +#endif + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_sub (sexp ctx, sexp a, sexp b) { +#if SEXP_USE_FLONUMS + int negatep=0; +#endif + int at=sexp_number_type(a), bt=sexp_number_type(b); + sexp r=SEXP_VOID; + sexp_gc_var2(tmp1, tmp2); + sexp_gc_preserve2(ctx, tmp1, tmp2); + switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: +#if SEXP_USE_RATIOS + case SEXP_NUM_NOT_RAT: +#endif +#if SEXP_USE_COMPLEX + case SEXP_NUM_NOT_CPX: +#endif + 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: +#if SEXP_USE_RATIOS + case SEXP_NUM_RAT_NOT: +#endif +#if SEXP_USE_COMPLEX + case SEXP_NUM_CPX_NOT: +#endif + 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: + tmp1 = sexp_fixnum_to_bignum(ctx, a); + r = sexp_bignum_sub(ctx, NULL, b, tmp1); + sexp_negate_exact(r); + r = sexp_bignum_normalize(r); + 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_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: + tmp1 = sexp_fixnum_to_bignum(ctx, b); + r = sexp_bignum_normalize(sexp_bignum_sub(ctx, NULL, a, tmp1)); + 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; +#if SEXP_USE_RATIOS + case SEXP_NUM_FLO_RAT: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) - sexp_ratio_to_double(b)); + break; + case SEXP_NUM_RAT_FLO: + r = sexp_make_flonum(ctx, sexp_ratio_to_double(a) - sexp_flonum_value(b)); + break; + case SEXP_NUM_RAT_FIX: + case SEXP_NUM_RAT_BIG: + tmp1 = a; a = b; b = tmp1; + negatep = 1; + /* ... FALLTHROUGH ... */ + case SEXP_NUM_FIX_RAT: + case SEXP_NUM_BIG_RAT: + a = tmp1 = sexp_make_ratio(ctx, a, SEXP_ONE); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_RAT_RAT: + tmp2 = sexp_make_ratio(ctx, sexp_ratio_numerator(b), sexp_ratio_denominator(b)); + if (sexp_bignump(sexp_ratio_numerator(tmp2))) + sexp_ratio_numerator(tmp2) = sexp_copy_bignum(ctx, NULL, sexp_ratio_numerator(tmp2), 0); + sexp_negate_exact(sexp_ratio_numerator(tmp2)); + r = sexp_ratio_add(ctx, a, tmp2); + if (negatep) { + if (sexp_ratiop(r)) { + sexp_negate_exact(sexp_ratio_numerator(r)); + } else { + sexp_negate_exact(r); + } + } + break; +#endif +#if SEXP_USE_COMPLEX +#if SEXP_USE_RATIOS + case SEXP_NUM_RAT_CPX: + a = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(a)); + goto complex_sub; + case SEXP_NUM_CPX_RAT: + b = tmp1 = sexp_make_flonum(ctx, sexp_ratio_to_double(b)); + /* ... FALLTHROUGH ... */ +#endif + case SEXP_NUM_CPX_FLO: + case SEXP_NUM_CPX_FIX: + case SEXP_NUM_CPX_BIG: + tmp1 = a; a = b; b = tmp1; + negatep = 1; + /* ... FALLTHROUGH ... */ + case SEXP_NUM_FLO_CPX: + case SEXP_NUM_FIX_CPX: + case SEXP_NUM_BIG_CPX: + a = tmp1 = sexp_make_complex(ctx, a, SEXP_ZERO); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_CPX_CPX: +#if SEXP_USE_RATIOS + complex_sub: +#endif + r = sexp_complex_sub(ctx, a, b); + if (negatep) { + if (sexp_complexp(r)) { + r = sexp_complex_copy(ctx, r); + sexp_negate(sexp_complex_real(r)); + sexp_negate(sexp_complex_imag(r)); + } else { + sexp_negate(r); + } + } + break; +#endif + } + sexp_gc_release2(ctx); + return r; +} + +sexp sexp_mul (sexp ctx, sexp a, sexp b) { + sexp_lsint_t prod; + int at=sexp_number_type(a), bt=sexp_number_type(b), t; + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + if (at > bt) {r=a; a=b; b=r; t=at; at=bt; bt=t;} + switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: +#if SEXP_USE_RATIOS + case SEXP_NUM_NOT_RAT: +#endif + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, a); + break; + case SEXP_NUM_FIX_FIX: + prod = (sexp_lsint_t)sexp_unbox_fixnum(a) * sexp_unbox_fixnum(b); + if ((prod < SEXP_MIN_FIXNUM) || (prod > SEXP_MAX_FIXNUM)) + r = sexp_mul(ctx, tmp=sexp_fixnum_to_bignum(ctx, a), b); + else + r = sexp_make_fixnum(prod); + break; + case SEXP_NUM_FIX_FLO: + r = (a==SEXP_ZERO ? a : 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); + r = sexp_bignum_normalize(r); + 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_normalize(sexp_bignum_mul(ctx, NULL, a, b)); + break; +#if SEXP_USE_RATIOS + case SEXP_NUM_FLO_RAT: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) * sexp_ratio_to_double(b)); + break; + case SEXP_NUM_FIX_RAT: + case SEXP_NUM_BIG_RAT: + a = tmp = sexp_make_ratio(ctx, a, SEXP_ONE); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_RAT_RAT: + r = sexp_ratio_mul(ctx, a, b); + break; +#endif +#if SEXP_USE_COMPLEX +#if SEXP_USE_RATIOS + case SEXP_NUM_RAT_CPX: +#endif + case SEXP_NUM_FLO_CPX: + case SEXP_NUM_FIX_CPX: + case SEXP_NUM_BIG_CPX: + a = tmp = sexp_make_complex(ctx, a, SEXP_ZERO); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_CPX_CPX: + r = sexp_complex_mul(ctx, a, b); + break; +#endif + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_div (sexp ctx, sexp a, sexp b) { + int at=sexp_number_type(a), bt=sexp_number_type(b); +#if ! SEXP_USE_RATIOS + double f; +#endif + sexp r=SEXP_VOID; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: +#if SEXP_USE_RATIOS + case SEXP_NUM_NOT_RAT: +#endif + 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: +#if SEXP_USE_RATIOS + case SEXP_NUM_RAT_NOT: +#endif + r = sexp_type_exception(ctx, NULL, SEXP_NUMBER, b); + break; + case SEXP_NUM_FIX_FIX: +#if SEXP_USE_RATIOS + tmp = sexp_make_ratio(ctx, a, b); + r = sexp_ratio_normalize(ctx, tmp, SEXP_FALSE); +#else + 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)); +#endif + 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: +#if SEXP_USE_RATIOS + tmp = sexp_make_ratio(ctx, a, b); + r = sexp_ratio_normalize(ctx, tmp, SEXP_FALSE); +#else + r = sexp_make_flonum(ctx, sexp_fixnum_to_double(a)/sexp_bignum_to_double(b)); +#endif + 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: +#if SEXP_USE_RATIOS + tmp = sexp_make_ratio(ctx, a, b); + r = sexp_ratio_normalize(ctx, tmp, SEXP_FALSE); + break; +#else + b = tmp = sexp_fixnum_to_bignum(ctx, b); +#endif + /* ... FALLTHROUGH if ! SEXP_USE_RATIOS ... */ + case SEXP_NUM_BIG_BIG: +#if SEXP_USE_RATIOS + tmp = sexp_make_ratio(ctx, a, b); + r = sexp_ratio_normalize(ctx, tmp, SEXP_FALSE); +#else + r = sexp_bignum_quot_rem(ctx, &tmp, a, b); + if (sexp_bignum_normalize(tmp) != SEXP_ZERO) + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) + / sexp_bignum_to_double(b)); + else + r = sexp_bignum_normalize(r); +#endif + break; + case SEXP_NUM_BIG_FLO: + r = sexp_make_flonum(ctx, sexp_bignum_to_double(a) / sexp_flonum_value(b)); + break; +#if SEXP_USE_RATIOS + case SEXP_NUM_FLO_RAT: + r = sexp_make_flonum(ctx, sexp_flonum_value(a) / sexp_ratio_to_double(b)); + break; + case SEXP_NUM_RAT_FLO: + r = sexp_make_flonum(ctx, sexp_ratio_to_double(a) / sexp_flonum_value(b)); + break; + case SEXP_NUM_RAT_FIX: + case SEXP_NUM_RAT_BIG: + b = tmp = sexp_make_ratio(ctx, b, SEXP_ONE); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_FIX_RAT: + case SEXP_NUM_BIG_RAT: + if (!sexp_ratiop(a)) + a = tmp = sexp_make_ratio(ctx, a, SEXP_ONE); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_RAT_RAT: + r = sexp_ratio_div(ctx, a, b); + break; +#endif +#if SEXP_USE_COMPLEX +#if SEXP_USE_RATIOS + case SEXP_NUM_CPX_RAT: + b = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(b)); + /* ... FALLTHROUGH ... */ +#endif + case SEXP_NUM_CPX_FLO: + case SEXP_NUM_CPX_FIX: + case SEXP_NUM_CPX_BIG: + b = tmp = sexp_make_complex(ctx, b, SEXP_ZERO); + /* ... FALLTHROUGH ... */ +#if SEXP_USE_RATIOS + case SEXP_NUM_RAT_CPX: + if (sexp_ratiop(a)) + a = tmp = sexp_make_flonum(ctx, sexp_ratio_to_double(a)); + /* ... FALLTHROUGH ... */ +#endif + case SEXP_NUM_FLO_CPX: + case SEXP_NUM_FIX_CPX: + case SEXP_NUM_BIG_CPX: + if (!sexp_complexp(a)) + a = tmp = sexp_make_complex(ctx, a, SEXP_ZERO); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_CPX_CPX: + r = sexp_complex_div(ctx, a, b); + break; +#endif + } + sexp_gc_release1(ctx); + return r; +} + +sexp sexp_to_inexact (sexp ctx, sexp a) { + if (sexp_fixnump(a)) return sexp_fixnum_to_flonum(ctx, a); + if (sexp_bignump(a)) return sexp_make_flonum(ctx, sexp_bignum_to_double(a)); + return a; +} + +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); + if (b == SEXP_ONE) return a; + sexp_gc_preserve1(ctx, tmp); + switch ((at * SEXP_NUM_NUMBER_TYPES) + 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: +#if SEXP_USE_RATIOS + case SEXP_NUM_FLO_RAT: +#endif + if (sexp_flonum_value(a) != trunc(sexp_flonum_value(a))) { + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + } else { + tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(a))); + tmp = sexp_quotient(ctx, tmp, b); + r = sexp_to_inexact(ctx, tmp); + } + break; +#if SEXP_USE_RATIOS + case SEXP_NUM_RAT_FIX: case SEXP_NUM_RAT_BIG: case SEXP_NUM_RAT_RAT: +#endif +#if SEXP_USE_COMPLEX + case SEXP_NUM_FLO_CPX: case SEXP_NUM_CPX_FIX: case SEXP_NUM_CPX_FLO: + case SEXP_NUM_CPX_BIG: case SEXP_NUM_CPX_CPX: +#if SEXP_USE_RATIOS + case SEXP_NUM_CPX_RAT: +#endif +#endif + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: +#if SEXP_USE_RATIOS + case SEXP_NUM_RAT_FLO: +#endif + if (sexp_flonum_value(b) != trunc(sexp_flonum_value(b))) { + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + } else { + tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(b))); + tmp = sexp_quotient(ctx, a, tmp); + r = sexp_to_inexact(ctx, tmp); + } + break; +#if SEXP_USE_RATIOS + case SEXP_NUM_FIX_RAT: case SEXP_NUM_BIG_RAT: +#endif +#if SEXP_USE_COMPLEX + case SEXP_NUM_FIX_CPX: case SEXP_NUM_BIG_CPX: +#endif + 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); + if (b == SEXP_ONE) return SEXP_ZERO; + sexp_gc_preserve1(ctx, tmp); + switch ((at * SEXP_NUM_NUMBER_TYPES) + 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: +#if SEXP_USE_RATIOS + case SEXP_NUM_FLO_RAT: +#endif + if (sexp_flonum_value(a) != trunc(sexp_flonum_value(a))) { + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + } else { + tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(a))); + tmp = sexp_remainder(ctx, tmp, b); + r = sexp_to_inexact(ctx, tmp); + } + break; +#if SEXP_USE_RATIOS + case SEXP_NUM_RAT_FIX: case SEXP_NUM_RAT_BIG: case SEXP_NUM_RAT_RAT: +#endif +#if SEXP_USE_COMPLEX + case SEXP_NUM_FLO_CPX: case SEXP_NUM_CPX_FIX: case SEXP_NUM_CPX_FLO: + case SEXP_NUM_CPX_BIG: case SEXP_NUM_CPX_CPX: +#if SEXP_USE_RATIOS + case SEXP_NUM_CPX_RAT: +#endif +#endif + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, a); + break; + case SEXP_NUM_FIX_FLO: case SEXP_NUM_BIG_FLO: +#if SEXP_USE_RATIOS + case SEXP_NUM_RAT_FLO: +#endif + if (sexp_flonum_value(b) != trunc(sexp_flonum_value(b))) { + r = sexp_type_exception(ctx, NULL, SEXP_FIXNUM, b); + } else { + tmp = sexp_bignum_normalize(sexp_double_to_bignum(ctx, sexp_flonum_value(b))); + tmp = sexp_remainder(ctx, a, tmp); + r = sexp_to_inexact(ctx, tmp); + } + break; +#if SEXP_USE_RATIOS + case SEXP_NUM_FIX_RAT: case SEXP_NUM_BIG_RAT: +#endif +#if SEXP_USE_COMPLEX + case SEXP_NUM_FIX_CPX: case SEXP_NUM_BIG_CPX: +#endif + 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: + r = sexp_bignum_fxrem(ctx, a, sexp_unbox_fixnum(b)); + break; + 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, g; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + if (at > bt) { + r = sexp_compare(ctx, b, a); + sexp_negate(r); + } else { + switch ((at * SEXP_NUM_NUMBER_TYPES) + bt) { + case SEXP_NUM_NOT_NOT: case SEXP_NUM_NOT_FIX: + case SEXP_NUM_NOT_FLO: case SEXP_NUM_NOT_BIG: +#if SEXP_USE_COMPLEX + case SEXP_NUM_CPX_CPX: case SEXP_NUM_CPX_FIX: + case SEXP_NUM_CPX_FLO: case SEXP_NUM_CPX_BIG: +#if SEXP_USE_RATIOS + case SEXP_NUM_CPX_RAT: +#endif +#endif + 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); + g = sexp_flonum_value(b); + r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1); + break; + case SEXP_NUM_FIX_BIG: + if ((sexp_bignum_hi(b) > 1) || + (sexp_bignum_data(b)[0] > SEXP_MAX_FIXNUM)) + r = sexp_make_fixnum(sexp_bignum_sign(b) < 0 ? 1 : -1); + else + r = sexp_make_fixnum(sexp_unbox_fixnum(a) - (sexp_sint_t)sexp_bignum_data(b)[0]); + break; + case SEXP_NUM_FLO_FLO: + f = sexp_flonum_value(a); + g = sexp_flonum_value(b); + r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1); + break; + case SEXP_NUM_FLO_BIG: + f = sexp_flonum_value(a); + if (isinf(f)) { + r = f > 0 ? SEXP_ONE : SEXP_NEG_ONE; + break; + } else if (isnan(f)) { + r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a); + break; + } else { + a = tmp = sexp_double_to_bignum(ctx, f); + } + /* ... FALLTHROUGH ... */ + case SEXP_NUM_BIG_BIG: + r = sexp_make_fixnum(sexp_bignum_compare(a, b)); + break; +#if SEXP_USE_RATIOS + case SEXP_NUM_FLO_RAT: + f = sexp_flonum_value(a); + if (isinf(f)) { + r = f > 0 ? SEXP_ONE : SEXP_NEG_ONE; + } else if (isnan(f)) { + r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a); + } else { + g = sexp_ratio_to_double(b); + r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1); + } + break; + case SEXP_NUM_FIX_RAT: + case SEXP_NUM_BIG_RAT: + a = tmp = sexp_make_ratio(ctx, a, SEXP_ONE); + /* ... FALLTHROUGH ... */ + case SEXP_NUM_RAT_RAT: + r = sexp_ratio_compare(ctx, a, b); + break; +#endif + } + } + sexp_gc_release1(ctx); + return r; +} + +#endif diff --git a/build-lib/chibi/char-set/compute.scm b/build-lib/chibi/char-set/compute.scm new file mode 100644 index 00000000..73b7a816 --- /dev/null +++ b/build-lib/chibi/char-set/compute.scm @@ -0,0 +1,20 @@ + +(define char-set:letter+digit + (immutable-char-set (char-set-union char-set:letter char-set:digit))) + +(define char-set:hex-digit + (immutable-char-set + (char-set-union (string->char-set "0123456789abcdefABCDEF")))) + +(define char-set:iso-control + (immutable-char-set + (char-set-union (ucs-range->char-set 0 #x20) + (ucs-range->char-set #x7F #xA0)))) + +(define char-set:graphic + (immutable-char-set + (char-set-union + char-set:letter char-set:digit char-set:punctuation char-set:symbol))) + +(define char-set:printing + (immutable-char-set (char-set-union char-set:whitespace char-set:graphic))) diff --git a/build-lib/chibi/char-set/compute.sld b/build-lib/chibi/char-set/compute.sld new file mode 100644 index 00000000..767c37c4 --- /dev/null +++ b/build-lib/chibi/char-set/compute.sld @@ -0,0 +1,22 @@ + +;; Don't import this - it's temporarily used to compute optimized +;; char-set representations. + +(define-library (chibi char-set compute) + (import (chibi) (chibi iset) (chibi char-set)) + (include "derived.scm" "compute.scm") + (export + char-set:lower-case + char-set:upper-case + char-set:title-case + char-set:letter + char-set:punctuation + char-set:symbol + char-set:blank + char-set:whitespace + char-set:digit + char-set:letter+digit + char-set:hex-digit + char-set:iso-control + char-set:graphic + char-set:printing)) diff --git a/chibi-scheme.vcproj b/chibi-scheme.vcproj new file mode 100644 index 00000000..86bd69e9 --- /dev/null +++ b/chibi-scheme.vcproj @@ -0,0 +1,206 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/contrib/bash_completion b/contrib/bash_completion new file mode 100644 index 00000000..021a4d65 --- /dev/null +++ b/contrib/bash_completion @@ -0,0 +1,69 @@ +# bash -*- shell-script -*- completion for chibi-scheme + +type chibi-scheme >/dev/null 2>/dev/null && { + +_chibi-modules() { + for dir in ./lib/ /usr/local/share/chibi/ "$@" \ + $(echo $CHIBI_MODULE_PATH | tr ':' ' '); do + find "$dir" -name \*.sld 2>/dev/null \ + | sed 's!'"$dir"'/*!!;s!\.sld$!!;s!/!.!g' + done | sort -u +} + +_chibi-scheme() { + local cur prev + # Just some likely sample sizes, you're not limited to these. + local sizes="1M 2M 4M 8M 16M 32M 64M 128M 256M 512M 1G 2G 4G" + + COMPREPLY=() + + # We don't require a space between single-char options and the value. + cur=`_get_cword` + case "$cur" in + -m*) + COMPREPLY=( $( compgen -W "$(_chibi-modules | sed 's!^!-m!')" -- "$cur") ) + return 0;; + -x*) + COMPREPLY=( $( compgen -W "$(_chibi-modules | sed 's!^!-x!')" -- "$cur") ) + return 0;; + -l*) + compopt -o nospace + _filedir + return 0;; + -A*) + compopt -o nospace + COMPREPLY=( $( compgen -d -- "${cur#-A}" | sed 's!^!-A!' ) ) + return 0;; + -I*) + compopt -o nospace + COMPREPLY=( $( compgen -d -- "${cur#-I}" | sed 's!^!-I!' ) ) + return 0;; + -h*) + COMPREPLY=( $( compgen -W "$(echo $sizes | tr ' ' '\n' | sed 's!^!-h!')" -- "${cur}" ) ) + return 0;; + -) + COMPREPLY=( $( compgen -W '-d -e -f -h -i -l -m -p -q -x -A -I -V' \ + -- "$cur") ) + return 0;; + -*) + return 0;; + esac + + # Not connected to the option, check the previous word. + prev=${COMP_WORDS[COMP_CWORD-1]} + case "$prev" in + -[mx]) + COMPREPLY=( $( compgen -W "$(_chibi-modules)" -- "$cur") ) + return 0;; + -[AIl]) + _filedir + return 0;; + -h) + COMPREPLY=( $( compgen -W "$sizes" -- "$cur" ) ) + return 0;; + esac +} + +complete -f -F _chibi-scheme chibi-scheme + +} diff --git a/data/.hgignore b/data/.hgignore new file mode 100644 index 00000000..9acc7fcd --- /dev/null +++ b/data/.hgignore @@ -0,0 +1,2 @@ +syntax: glob +*.txt diff --git a/doc/chibi-doc.1 b/doc/chibi-doc.1 new file mode 100644 index 00000000..1c95de76 --- /dev/null +++ b/doc/chibi-doc.1 @@ -0,0 +1,55 @@ +.TH "chibi-doc" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-doc \- generate docs from Scheme scribble syntax + +.SH SYNOPSIS +.B chibi-doc +[-hst] +[ +.I file +] +.BR + +.B chibi-doc +.I dotted-name.of.module +[ +.I identifier +] +.BR +.SP 0.4 + +.SH DESCRIPTION +.I chibi-doc +is a tool to generate documentation from the Scheme scribble syntax +from Racket. It works like a Unix filter, translating from the +current input or a file to standard output. You can also specify a +module name, with components separated with dots, and it will search +for the module and generate documentation from it automatically from +literate comments in the module or any of its source files. These +comments are any line beginning with the characters +.I ;;> + +The scribble syntax is described in the manual. + +.SH OPTIONS +.TP 5 +.BI -h +Outputs in HTML format (the default). +.TP +.BI -s +Outputs in SXML format. +.TP +.BI -t +Outputs in text format (the default for describing a single variable). + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +The chibi-scheme home-page: +.BR +http://code.google.com/p/chibi-scheme/ diff --git a/doc/chibi-ffi.1 b/doc/chibi-ffi.1 new file mode 100644 index 00000000..00bca31a --- /dev/null +++ b/doc/chibi-ffi.1 @@ -0,0 +1,45 @@ +.TH "chibi-ffi" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-ffi \- generate C from Scheme stub files + +.SH SYNOPSIS +.B chibi-ffi +[-c] +[-f +.I +cflags +] +input.stub +[ +.I output.c +] +.BR +.SP 0.4 + +.SH DESCRIPTION +.I chibi-ffi +reads in the C function FFI definitions from an input file and outputs +the appropriate C wrappers into a file with the same base name and the +".c" extension. You can then compile that C file into a shared +library: + + chibi-ffi file.stub + cc -fPIC -shared file.c -lchibi-scheme + +If the -c option is specified then chibi-ffi attempts to compile the +generated C code for you in one step. In this case, additional flags +for the C compiler may be given with the -f option. + +The FFI syntax is described in the manual. + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +The chibi-scheme home-page: +.BR +http://code.google.com/p/chibi-scheme/ diff --git a/doc/chibi-scheme.1 b/doc/chibi-scheme.1 new file mode 100644 index 00000000..f2eaf5db --- /dev/null +++ b/doc/chibi-scheme.1 @@ -0,0 +1,215 @@ +.TH "chibi-scheme" "1" "" "" +.UC 4 +.SH NAME +.PP +chibi-scheme \- a tiny Scheme interpreter + +.SH SYNOPSIS +.B chibi-scheme +[-qQrRfV] +[-I +.I path +] +[-A +.I path +] +[-m +.I module +] +[-x +.I module +] +[-l +.I file +] +[-e +.I expr +] +[-p +.I expr +] +[-d +.I image-file +] +[-i +.I image-file +] +[--] +[ +.I script argument ... +] +.br +.sp 0.4 + +.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. This +works as expected with shell #! semantics. + +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. For a more +sophisticated REPL with readline support, signal handling, module +management and smarter read/write you may want to use the (chibi repl) +module. For example, +.I chibi-scheme -mchibi.repl -e'(repl)' + +The default language the R7RS +(scheme base) module. To get a mostly R5RS-compatible language, use +.I chibi-scheme -xscheme.r5rs +or to get just the core language used for bootstrapping, use +.I chibi-scheme -xchibi +or its shortcut +.I chibi-scheme -q + +.SH OPTIONS + +Space is optional between options and their arguments. +Options without arguments may not be chained together. + +.TP 5 +.BI -V +Prints the version information and exits. +.TP +.BI -q +"Quick" load, shortcut for +.I chibi-scheme -xchibi +This is a slightly different language from (scheme base), +which may load faster, and is guaranteed not to load any +additional shared libraries. +.TP +.BI -Q +Extra "quick" load, shortcut for +.I chibi-scheme -xchibi.primitive +The resulting environment will only contain the core syntactic +forms and primitives coded in C. This is very fast and guaranteed +not to load any external files, but is also very limited. +.TP +.BI -r [main] +Run the "main" procedure when the script finishes loading as in SRFI-22. +.TP +.BI -R [module] +Loads the given module and runs the "main" procedure it defines (which +need not be exported) with a single argument of the list of command-line +arguments as in SRFI-22. The name "main" can be overridden with the -r +option. +.TP +.BI -s +Strict mode, escalating warnings to fatal errors. +.TP +.BI -f +Change the reader to case-fold symbols as in R5RS. +.TP +.BI -h size[/max_size] +Specifies the initial size of the heap, in bytes, +optionally followed by the maximum size the heap can +grow to. +.I size +can be any integer value, optionally suffixed by +"K", for kilobytes, "M" for megabytes, or "G" for gigabytes. +.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 +.TP +.BI -x 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 +If the +.BI -x +version is used, then +.I module +replaces the current environment instead of being added to it. +.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. +.TP +.BI -d image-file +Dumps the current Scheme heap to +.I image-file +and exits. This feature is still experimental. +.TP +.BI -i image-file +Loads the Scheme heap from +.I image-file +instead of compiling the init file on the fly. +This feature is still experimental. + +.SH ENVIRONMENT +.TP +.B CHIBI_MODULE_PATH +A colon separated list of directories to search for module +files, inserted before the system default load paths. chibi-scheme +searchs for modules in directories in the following order: + +.TP + directories included with the -I path option +.TP + directories included from CHIBI_MODULE_PATH +.TP + system directories +.TP + directories included with -A path option + +If CHIBI_MODULE_PATH is unset, the directoriese "./lib", and "." are +search in order. + +.SH AUTHORS +.PP +Alex Shinn (alexshinn @ gmail . com) + +.SH SEE ALSO +.PP +More detailed information can be found in the manuale included in +doc/chibi.scrbl included in the distribution. + +The chibi-scheme home-page: +.br +http://code.google.com/p/chibi-scheme/ diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl new file mode 100755 index 00000000..27d755db --- /dev/null +++ b/doc/chibi.scrbl @@ -0,0 +1,1228 @@ +\; #lang scribble/manual + +\title{Chibi-Scheme} +\author{Alex Shinn} + +\centered{\smaller{Minimal Scheme Implementation for use as an Extension Language}} +\centered{\url{http://synthcode.com/wiki/chibi-scheme/}} + +\section{Introduction} + +Chibi-Scheme is a very small library intended for use as an extension +and scripting language in C programs. In addition to support for +lightweight VM-based threads, each VM itself runs in an isolated heap +allowing multiple VMs to run simultaneously in different OS threads. + +The default language is the R7RS (scheme base) library, with support +for all libraries from the small language. Support for additional +languages such as JavaScript, Go, Lua and Bash are planned for future +releases. Scheme is chosen as a substrate because its first class +continuations and guaranteed tail-call optimization makes implementing +other languages easy. + +The system is designed in optional layers, beginning with a VM based +on a small set of opcodes, a set of primitives implemented in C, a +default language, a module system implementation, and a set of +standard modules. You can choose whichever layer suits your needs +best and customize the rest. Adding your own primitives or wrappers +around existing C libraries is easy with the C FFI. + +Chibi is known to build and run on 32 and 64-bit Linux, FreeBSD, +DragonFly, OS X, iOS, Windows (under Cygwin) and Plan9. + +\section{Installation} + +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. If your make doesn't support GNU make +conditionals, then you'll need to edit the top of the Makefile to +choose the appropriate settings. On Plan9 just run "mk". You can +test the build with "make test". + +To install run "make install". If you want to try the executable out +without installing, you will probably need to set LD_LIBRARY_PATH, +depending on your platform. If you have an old version installed, +run "make uninstall" first, or manually delete the directory. + +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 + +\command{make CFLAGS=-Os CPPFLAGS=-DSEXP_USE_NO_FEATURES=1} + +to optimize for size, or + +\command{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 (non-moving is +important so you can maintain references from C code). You can link +against the Boehm conservative GC by editing the features.h file, or +directly from make with: + +\command{make SEXP_USE_BOEHM=1} + +To compile a static executable, use + +\command{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: + +\command{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: + +\command{ +make -B chibi-scheme-static SEXP_USE_DL=0 CPPFLAGS=-DSEXP_USE_STATIC_LIBS +} + +\subsection{Compile-Time Options} + +The include file \ccode{"chibi/features.h"} describes a number of +C preprocessor values which can be enabled or disabled by setting to +1 or 0 respectively. For example, the above commands used the +features \ccode{SEXP_USE_BOEHM}, \ccode{SEXP_USE_DL} and +\ccode{SEXP_USE_STATIC_LIBS}. Many features are still experimental +and may be removed from future releases, but the important features +are listed below. + +\itemlist[ +\item{\ccode{SEXP_USE_BOEHM} - link with the Boehm GC instead of the native Chibi GC} +\item{\ccode{SEXP_USE_DL} - allow dynamic linking (enabled by default)} +\item{\ccode{SEXP_USE_STATIC_LIBS} - compile the standard C libs statically} +\item{\ccode{SEXP_USE_MODULES} - use the module system} +\item{\ccode{SEXP_USE_GREEN_THREADS} - use lightweight threads (enabled by default)} +\item{\ccode{SEXP_USE_SIMPLIFY} - use a simplification optimizer pass (enabled by default)} +\item{\ccode{SEXP_USE_BIGNUMS} - use bignums (enabled by default)} +\item{\ccode{SEXP_USE_FLONUMS} - use flonums (enabled by default)} +\item{\ccode{SEXP_USE_RATIOS} - use exact ratios (enabled by default)} +\item{\ccode{SEXP_USE_COMPLEX} - use complex numbers (enabled by default)} +\item{\ccode{SEXP_USE_UTF8_STRINGS} - Unicode support (enabled by default)} +\item{\ccode{SEXP_USE_NO_FEATURES} - disable almost all features} +] + +\subsection{Installed Programs} + +The command-line programs \ccode{chibi-scheme}, \ccode{chibi-doc} and +\ccode{chibi-ffi} are installed by default, along with manpages. +\ccode{chibi-scheme} provides a REPL and way to run scripts. Run -? +for a brief list of options, or see the man page for more details. +\ccode{chibi-doc} is the command-line interface to the literate +documentation system described in +\hyperlink["lib/chibi/scribble.html"]{(chibi scribble)}, and used to +build this manual. \ccode{chibi-ffi} is a tool to build wrappers for +C libraries, described in the FFI section below. + +\section{Default Language} + +\subsection{Scheme Standard} + +The default language is the \scheme{(scheme base)} library from +\hyperlink["http://scheme-reports.org/"]{R7RS}, which is mostly a +superset of +\hyperlink["http://www.schemers.org/Documents/Standards/R5RS/HTML/"]{R5RS}. + +The reader defaults to case-sensitive, like R6RS and R7RS but unlike +R5RS. The default configuration includes the full numeric tower: +fixnums, flonums, bignums, exact rationals and complex numbers, though +this can be customized at compile time. + +Full continuations are supported, but currently continuations don't +take C code into account. This means that you can call from Scheme to +C and then from C to Scheme again, but continuations passing through +this chain may not do what you expect. The only higher-order C +functions (thus potentially running afoul of this) in the standard +environment are \scheme{load} and \scheme{eval}. The result of +invoking a continuation created by a different thread is also +currently unspecified. + +In R7RS (and R6RS) semantics it is impossible to use two macros from +different modules which both use the same auxiliary keywords (like +\scheme{else} in \scheme{cond} forms) without renaming one of the +keywords. By default Chibi considers all top-level bindings +effectively unbound when matching auxiliary keywords, so this case +will "just work". This decision was made because the chance of +different modules using the same keywords seems more likely than user +code unintentionally matching a top-level keyword with a different +binding, however if you want to use R7RS semantics you can compile +with \ccode{SEXP_USE_STRICT_TOPLEVEL_BINDINGS=1}. + +\scheme{load} is extended to accept an optional environment argument, like +\scheme{eval}. You can also \scheme{load} shared libraries in addition to +Scheme source files - in this case the function \cfun{sexp_init_library} is +automatically called with the following signature: + +\ccode{ + sexp_init_library(sexp context, sexp self, sexp_sint_t n, sexp environment, + const char* version, sexp_abi_identifier_t abi); +} + +Note, as R7RS (and earlier reports) states, "in contrast to other +dialects of Lisp, the order of evaluation is unspecified [...]". +Chibi is one of the few implementations which use a right-to-left +evaluation order, which can be surprising to programmers coming from +other languages. + +\subsection{Module System} + +Chibi uses the R7RS module system natively, which is a simple static +module system in the style of the +\hyperlink["http://s48.org/"]{Scheme48} module system. As with most +features this is optional, and can be ignored or completely disabled +at compile time. + +Modules names are hierarchical lists of symbols or numbers. A module +definition uses the following form: + +\schemeblock{ + (define-library (foo bar baz) + ...) +} + +where \var{} can be any of + +\schemeblock{ + (export ...) ;; specify an export list + (import ...) ;; specify one or more imports + (begin ...) ;; inline Scheme code + (include ...) ;; load one or more files + (include-shared ...) ;; dynamic load a library +} + +\var{} can either be a module name or any of + +\schemeblock{ + (only ...) + (except ...) + (rename ( ) ...) + (prefix ) +} + +These forms perform basic selection and renaming of individual +identifiers from the given module. They may be composed to perform +combined selection and renaming. + +Some modules can be statically included in the initial configuration, +and even more may be included in image files, however in general +modules are searched for in a module load path. The definition of the +module \scheme{(foo bar baz)} is searched for in the file +\scheme{"foo/bar/baz.sld"}. The default module path includes the +installed directories, \scheme{"."} and \scheme{"./lib"}. Additional +directories can be specified with the command-line options \ccode{-I} +and \ccode{-A} (see the command-line options below) or with the +\scheme{add-modue-directory} procedure at runtime. You can search for +a module file with \scheme{(find-module-file )}, or load it with +\scheme{(load-module-file )}. + +Within the module definition, files are loaded relative to the .sld +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 \emph{without} the +extension - the correct suffix will be added portably (e.g. .so for Unix and +.dylib for OS X). + +You may also use \scheme{cond-expand} and arbitrary macro expansions in a +module definition to generate \var{}. + +\subsection{Macro System} + +\scheme{syntax-rules} macros are provided by default, with the extensions from +\hyperlink["http://srfi.schemers.org/srfi-46/srfi-46.html"]{SRFI-46}. +In addition, low-level hygienic macros are provided with a +syntactic-closures interface, including \scheme{sc-macro-transformer}, +\scheme{rsc-macro-transformer}, and \scheme{er-macro-transformer}. A good +introduction to syntactic-closures can be found at +\url{http://community.schemewiki.org/?syntactic-closures}. + +\scheme{identifier?}, \scheme{identifier->symbol}, \scheme{identifier=?}, and +\scheme{make-syntactic-closure} and \scheme{strip-syntactic-closures} are +also available. + +\subsection{Types} + +You can define new record types with +\hyperlink["http://srfi.schemers.org/srfi-9/srfi-9.html"]{SRFI-9}, or +inherited record types with +\hyperlink["http://srfi.schemers.org/srfi-99/srfi-99.html"]{SRFI-99}. +These are just syntactic sugar for the following more primitive type +constructors: + +\schemeblock{ +(register-simple-type ) + => + +(make-type-predicate ) + => ; takes 1 arg, returns #t iff that arg is of the type + +(make-constructor ) + => ; takes 0 args, returns a newly allocated instance of type + +(make-getter ) + => ; takes 1 args, retrieves the field located at the index + +(make-setter ) + => ; takes 2 args, sets the field located at the index +} + +\subsection{Unicode} + +Chibi supports Unicode strings, encoding them as utf8. This provides easy +interoperability with many C libraries, but means that \scheme{string-ref} and +\scheme{string-set!} are O(n), so they should be avoided in +performance-sensitive code. + +In general you should use high-level APIs such as \scheme{string-map} +to ensure fast string iteration. String ports also provide a simple +way to efficiently iterate and construct strings, by looping over an +input string or accumulating characters in an output string. + +The \scheme{in-string} and \scheme{in-string-reverse} iterators in the +\scheme{(chibi loop)} module will also iterate over strings +efficiently while hiding the low-level details. + +In the event that you do need a low-level interface, such as when +writing your own iterator protocol, you should use the following +string cursor API instead of indexes. + +\itemlist[ +\item{\scheme{(string-cursor-start str)} +\p{returns a start cursor for the string}} +\item{\scheme{(string-cursor-end str)} +\p{returns a cursor one past the last valid cursor}} +\item{\scheme{(string-cursor-ref str cursor)} +\p{get the char at the given cursor}} +\item{\scheme{(string-cursor-next str cursor)} +\p{increment to the next cursor}} +\item{\scheme{(string-cursor-prev str cursor)} +\p{decrement to the previous cursor}} +\item{\scheme{(substring-cursor str cs1 [cs2])} +\p{take a substring from the given cursors}} +\item{\scheme{(string-cursor? cs1 cs2)} +\p{cs1 is after cs2}} +\item{\scheme{(string-cursor>=? cs1 cs2)} +\p{cs1 is the same or after cs2}} +] + +\section{Embedding in C} + +\subsection{Quick Start} + +To use Chibi-Scheme in a program you need to link against the +"libchibi-scheme" library and include the "eval.h" header file: + +\ccode{#include } + +All definitions begin with a "sexp_" prefix, or "SEXP_" for constants. +In addition to the prototypes and utility macros, this includes the +following type definitions: + +\itemlist[ +\item{\ctype{sexp} - an s-expression, used to represent all Scheme objects} +\item{\ctype{sexp_uint_t} - an unsigned integer using as many bits as sexp} +\item{\ctype{sexp_sint_t} - a signed integer using as many bits as sexp} +] + +A simple program might look like: + +\ccodeblock{ +void dostuff(sexp ctx) { + /* declare and preserve local variables */ + sexp_gc_var2(obj1, obj2); + sexp_gc_preserve2(ctx, obj1, obj2); + + /* load a file containing Scheme code */ + obj1 = sexp_c_string(ctx, "/path/to/source/file.scm", -1); + sexp_load(ctx, obj1, NULL); + + /* eval a C string as Scheme code */ + sexp_eval_string(ctx, "(some scheme expression)", -1, NULL); + + /* construct a Scheme expression to eval */ + obj1 = sexp_intern(ctx, "my-procedure", -1); + obj2 = sexp_cons(ctx, obj1, SEXP_NULL); + sexp_eval(ctx, obj2, NULL); + + /* release the local variables */ + sexp_gc_release2(ctx); +} + +int main(int argc, char** argv) { + sexp ctx; + ctx = sexp_make_eval_context(NULL, NULL, NULL, 0, 0); + sexp_load_standard_env(ctx, NULL, SEXP_SEVEN); + sexp_load_standard_ports(ctx, NULL, stdin, stdout, stderr, 0); + dostuff(ctx); + sexp_destroy_context(ctx); +} +} + +Looking at \cfun{main}, \cfun{sexp_make_eval_context} and +\cfun{sexp_destroy_context} create and destroy a "context", which +manages the heap and VM state. The meaning of the arguments is +explained in detail below, but these values will give reasonable +defaults, in this case constructing an environment with the core +syntactic forms, opcodes, and standard C primitives. + +This is still a fairly bare environment, so we call +\cfun{sexp_load_standard_env} to find and load the default +initialization file. + +The resulting context can then be used to construct objects, call +functions, and most importantly evaluate code, as is done in +\cfun{dostuff}. The default garbage collector for Chibi is precise, +which means we need to declare and preserve references to any +temporary values we may generate, which is what the +\cmacro{sexp_gc_var2}, \cmacro{sexp_gc_preserve2} and +\cmacro{sexp_gc_release2} macros do (there are similar macros for +values 1-6). Precise GCs prevent a class of memory leaks (and +potential attackes based thereon), but if you prefer convenience then +Chibi can be compiled with a conservative GC and you can ignore these. + +The interesting part is then the calls to \cfun{sexp_load}, +\cfun{eval_string} and \cfun{eval} which evaluate code stored in +files, C strings, or represented as s-expressions respectively. + +Destroying a context runs any finalizers for all objects in the heap +and then frees the heap memory (but has no effect on other contexts +you or other users of the library may have created). + +\subsection{Contexts and Evaluation} + +Contexts represent the state needed to perform evaluation. This includes +keeping track of the heap (when using precise GC), a default environment, +execution stack, and any global values. A program being evaluated in one +context may spawn multiple child contexts, such as when you call \scheme{eval}, +and each child will share the same heap and globals. When using multiple +interpreter threads, each thread has its own context. + +You can also create independent contexts with their own separate heaps. These +can run simultaneously in multiple OS threads without any need for +synchronization. + +\itemlist[ + +\item{\ccode{sexp_make_context(sexp ctx, size_t size, size_t max_size)} +\p{ +Creates a new context object. The context has no associated environment, and +so cannot be used for evaluation, but can be used to construct Scheme objects +and call primitive C functions on them. + +If \var{ctx} is non-NULL it becomes the "parent" context. The resulting +context will share the same heap as its parent, and when using a precise GC +preserve any variables preserved by the parent, but the parent will not +preserve the child context by default. Typically you either preserve the child +manually or use it to perform a single sub-task then discard it and return to +using only the parent. + +Otherwise, a new heap is allocated with \var{size} bytes, expandable to a +maximum of \var{max_size} bytes, using the system defaults if either is 0. +}} + +\item{\ccode{sexp_make_eval_context(sexp ctx, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size)} +\p{ +Similar to sexp_make_context, but also associates a stack, environment, and +additional globals necessary to evaluate code. Either or both of \var{stack} +and \var{env} may be NULL, in which case defaults will be generated. The +default environment includes the compiled-in C primitives, as well as the 10 +core forms: \scheme{define}, \scheme{set!}, \scheme{lambda}, \scheme{if}, +\scheme{begin}, \scheme{quote}, \scheme{syntax-quote}, \scheme{define-syntax}, +\scheme{let-syntax}, and \scheme{letrec-syntax}. +}} + +\item{\ccode{sexp_load_standard_env(sexp ctx, sexp env, sexp version)} +\p{ +Loads the standard parameters for \var{env}, constructs the feature list from +pre-compiled defaults, and loads the installed initialization file for +\var{version}, which should be the value \var{SEXP_SEVEN}. +Also creates an \scheme{interaction-environment} parameter +and sets \var{env} itself to that. +}} + +\item{\ccode{sexp_load_standard_ports(sexp ctx, sexp env, FILE* in, FILE* out, FILE* err, int leave_open)} +\p{ +Creates \scheme{current-input-port}, \scheme{current-output-port}, and +\scheme{current-error-port} parameters from \var{in}, \var{out} and +\var{err}, and binds them in \var{env}. If \var{env} is \cvar{NULL} +the default context environment is used. Any of the \ctype{FILE*} may +be \cvar{NULL}, in which case the corresponding port is not set. If +\var{leave_open} is true, then the underlying \ctype{FILE*} is left +open after the Scheme port is closed, otherwise they are both closed +together. +}} + +\item{\ccode{sexp_load(sexp ctx, sexp file, sexp env)} +\p{ +Searches the installation path for the \var{file} and loads it in the +environment \var{env}. \var{file} may be a dynamic library or source code. +}} + +\item{\ccode{sexp_eval(sexp ctx, sexp obj, sexp env)} +\p{ +Evaluates \var{obj} as a source form in the environment \var{env} and +returns the result. +}} + +\item{\ccode{sexp_eval_string(sexp ctx, const char* str, int len, sexp env)} +\p{ +Reads a s-expression from the C string \var{str} (or the first \var{len} bytes +if \var{len} is non-negative), evaluates the resulting form in the environment +\var{env}, and returns the result. +}} + +\item{\ccode{sexp_apply(sexp ctx, sexp proc, sexp args)} +\p{ +Applies the procedure \var{proc} to the arguments in the list \var{args} and +returns the result. +}} + +\item{\ccode{sexp_context_env(sexp ctx)} +\p{ +Returns the current default environment associated with the context \var{ctx}. +}} + +\item{\ccode{sexp_env_define(sexp ctx, sexp env, sexp sym, sexp val)} +\p{ +Adds a new binding for \var{sym} in \var{env} with value \var{val}. +}} + +\item{\ccode{sexp_env_ref(sexp env, sexp sym, sexp dflt)} +\p{ +Returns the current binding of \var{sym} in \var{env}, or \var{dflt} if there +is no binding. +}} + +\item{\ccode{sexp_parameter_ref(sexp ctx, sexp param)} +\p{ +Returns the current dynamic value of the parameter \var{param} in the +given context. +}} + +] + +\subsection{Garbage Collection} + +Chibi uses a precise garbage collector by default, which means when performing +multiple computations on the C side you must explicitly preserve any temporary +values. You can declare variables to be preserved with sexp_gc_var\italic{n}, +for n from 1 to 6.\margin-note{You can declare additional macros for larger +values of n if needed.} + +\ccode{ +sexp_gc_var\italic{n}(obj\subscript{1}, obj\subscript{2}, ..., obj\subscript{n}) +} + +This is equivalent to the declaration + +\ccode{ +sexp obj\subscript{1}, obj\subscript{2}, ..., obj\subscript{n}; +} + +except it makes preservation possible. Because it is a declaration it must +occur at the beginning of your function, and because it includes assignments +(in the macro-expanded form) it should occur after all other declarations. + +To preserve these variables for a given context, you can then use +sexp_gc_preserve\italic{n}: + +\ccode{ +sexp_gc_preserve\italic{n}(ctx, obj\subscript{1}, obj\subscript{2}, ..., obj\subscript{n}) +} + +This can be delayed in your code until you know a potentially memory-allocating +computation will be performed, but once you call sexp_gc_preserve\italic{n} it +\emph{must} be paired with a matching sexp_gc_release\italic{n}: + +\ccode{ +sexp_gc_release\italic{n}(ctx); +} + +Note each of these have different signatures. sexp_gc_var\italic{n} just lists +the variables to be declared. sexp_gc_preserve\italic{n} prefixes these with +the context in which they are to be preserved, and sexp_gc_release\italic{n} +just needs the context. + +A typical usage for these is: + +\ccodeblock{ +sexp foo(sexp ctx, sexp bar, sexp baz) { + /* variable declarations */ + int i, j; + ... + sexp_gc_var3(tmp1, tmp2, res); + + /* asserts or other shortcut returns */ + sexp_assert_type(ctx, sexp_barp, SEXP_BAR, bar); + sexp_assert_type(ctx, sexp_bazp, SEXP_BAZ, baz); + + /* preserve the variables in ctx */ + sexp_gc_preserve3(ctx, tmp1, tmp2, res); + + /* perform your computations */ + tmp1 = ... + tmp2 = ... + res = ... + + /* release before returning */ + sexp_gc_release3(ctx); + + return res; +} +} + +If compiled with the Boehm GC, sexp_gc_var\italic{n} just translates to the +plain declaration, while sexp_gc_preserve\italic{n} and +sexp_gc_release\italic{n} become noops. + +When interacting with a garbage collection system from another +language, or communicating between different Chibi managed heaps, you +may want to manually ensure objects are preserved irrespective of any +references to it from other objects in the same heap. This can be +done with the \ccode{sexp_preserve_object} and +\ccode{sexp_release_object} utilities. + +\ccode{ +sexp_preserve_object(ctx, obj) +} + +Increment the absolute reference count for \var{obj}. So long as the +reference count is above 0, \var{obj} will not be reclaimed even if +there are no references to it from other object in the Chibi managed +heap. + +\ccode{ +sexp_release_object(ctx, obj) +} + +Decrement the absolute reference count for \var{obj}. + +\subsection{API Index} + +The above sections describe most everything you need for embedding in +a typical application, notably creating environments and evaluating +code from sexps, strings or files. The following sections expand on +additional macros and utilities for inspecting, accessing and creating +different Scheme types, and for performing port and string I/O. + +Being able to convert from C string to sexp, evaluate it, and convert +the result back to a C string forms the basis of the C API. Because +Chibi is aimed primarily at minimal size, there are relatively few +other utilities or helpers. It is expected most high-level code will +be written in Scheme, and most low-level code will be written in pure, +Scheme-agnostic C and wrapped via the FFI. + +\subsubsection{Type Predicates} + +The sexp represents different Scheme types with the use of tag bits for +so-called "immediate" values, and a type tag for heap-allocated values. The +following predicates can be used to distinguish these types. Note the +predicates in C all end in "p". For efficiency they are implemented as macros, +and so may evaluate their arguments multiple times. + +Note also that the non-immediate type checks will segfault if passed a +NULL value. At the Scheme level (and the return values of any +exported primitives) NULLs are never exposed, however some unexposed +values in C can in certain cases be NULL. If you're not sure you'll +need to check manually before applying the predicate. + +\itemlist[ +\item{\ccode{sexp_booleanp(obj)} - \var{obj} is \scheme{#t} or \scheme{#f}} +\item{\ccode{sexp_fixnump(obj)} - \var{obj} is an immediate integer} +\item{\ccode{sexp_flonump(obj)} - \var{obj} is an inexact real} +\item{\ccode{sexp_bignump(obj)} - \var{obj} is a heap-allocated integer} +\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer} +\item{\ccode{sexp_numberp(obj)} - \var{obj} is any kind of number} +\item{\ccode{sexp_charp(obj)} - \var{obj} is a character} +\item{\ccode{sexp_stringp(obj)} - \var{obj} is a string} +\item{\ccode{sexp_symbolp(obj)} - \var{obj} is a symbol} +\item{\ccode{sexp_idp(obj)} - \var{obj} is a symbol or hygienic identifier} +\item{\ccode{sexp_nullp(obj)} - \var{obj} is the null value} +\item{\ccode{sexp_pairp(obj)} - \var{obj} is a pair} +\item{\ccode{sexp_vectorp(obj)} - \var{obj} is a vector} +\item{\ccode{sexp_iportp(obj)} - \var{obj} is an input port} +\item{\ccode{sexp_oportp(obj)} - \var{obj} is an output port} +\item{\ccode{sexp_portp(obj)} - \var{obj} is any kind of port} +\item{\ccode{sexp_procedurep(obj)} - \var{obj} is a procedure} +\item{\ccode{sexp_opcodep(obj)} - \var{obj} is a primitive opcode} +\item{\ccode{sexp_applicablep(obj)} - \var{obj} is valid as the first arg to apply} +\item{\ccode{sexp_typep(obj)} - \var{obj} is a type} +\item{\ccode{sexp_exceptionp(obj)} - \var{obj} is an exception} +\item{\ccode{sexp_contextp(obj)} - \var{obj} is a context} +\item{\ccode{sexp_envp(obj)} - \var{obj} is an environment} +\item{\ccode{sexp_corep(obj)} - \var{obj} is a special form} +\item{\ccode{sexp_macrop(obj)} - \var{obj} is a macro} +\item{\ccode{sexp_synclop(obj)} - \var{obj} is a syntactic closure} +\item{\ccode{sexp_bytecodep(obj)} - \var{obj} is compiled bytecode} +\item{\ccode{sexp_cpointerp(obj)} - \var{obj} is an opaque C pointer} +] + +\subsubsection{Constants} + +The following shortcuts for various immediate values are available. + +\itemlist[ +\item{\ccode{SEXP_FALSE} - the false boolean} +\item{\ccode{SEXP_TRUE} - the true boolean} +\item{\ccode{SEXP_NULL} - the empty list} +\item{\ccode{SEXP_EOF} - the end-of-file object} +\item{\ccode{SEXP_VOID} - an undefined value often returned by mutators} +\item{\ccode{SEXP_ZERO} - shortcut for sexp_make_fixnum(0)} +\item{...} +\item{\ccode{SEXP_TEN} - shortcut for sexp_make_fixnum(10)} +\item{\ccode{SEXP_NEG_ONE} - shortcut for sexp_make_fixnum(-1)} +] + +\subsubsection{String Handling} + +Scheme strings are length bounded C strings which can be accessed with +the following macros: + +\itemlist[ +\item{\ccode{char* sexp_string_data(sexp s)} - the raw bytes of the string} +\item{\ccode{sexp_uint_t sexp_string_size(sexp s)} - the number of raw bytes in the string} +\item{\ccode{sexp_uint_t sexp_string_length(sexp s)} - the number of characters encoded in \var{s}} +] + +Currently all Scheme strings also happen to be NULL-terminated, but +you should not rely on this and be sure to use the size as a bounds check. + +By default (unless you compile with -DSEXP_USE_UTF8_STRING=0), strings +are interpreted as utf8 encoded on the Scheme side, as describe in +section Unicode above. In many cases you can ignore this on the C +side and just treat the string as an opaque sequence of bytes. +However, if you need to you can use the following macros to safely +access the contents of the string regardless of the options Chibi was +compiled with: + +\itemlist[ +\item{\ccode{sexp sexp_string_ref(sexp ctx, sexp s, sexp i)} - returns the character at index i} +\item{\ccode{sexp sexp_string_set(sexp ctx, sexp s, sexp i, sexp ch)} - sets the character at index i} +\item{\ccode{sexp sexp_string_cursor_ref(sexp ctx, sexp s, sexp i)} - returns the character at raw offset i (a fixnum)} +\item{\ccode{sexp sexp_string_cursor_set(sexp ctx, sexp s, sexp i, sexp ch)} - sets the character at raw offset i (a fixnum)} +\item{\ccode{sexp sexp_string_cursor_next(sexp s, sexp i)} - returns the next cursor after raw offset \var{i}} +\item{\ccode{sexp sexp_string_cursor_prev(sexp s, sexp i)} - returns the previous cursor before raw offset \var{i}} +\item{\ccode{sexp sexp_substring(sexp ctx, sexp s, sexp i, sexp j)} - returns the substring between indices \var{i} and \var{j}} +\item{\ccode{sexp sexp_substring_cursor(sexp ctx, sexp s, sexp i, sexp j)} - returns the substring between raw offsets \var{i} and \var{j}} +] + +When UTF8 support is not compiled in the cursor and non-cursor +variants are equivalent. + +\subsubsection{Accessors} + +The following macros provide access to the different components of the +Scheme types. They do no type checking, essentially translating +directly to pointer offsets, so you should be sure to use the above +predicates to check types first. They only evaluate their arguments +once. + +\itemlist[ +\item{\ccode{sexp_make_boolean(n)} - \scheme{#f} if \var{n} is 0, \scheme{#t} otherwise} +\item{\ccode{sexp_unbox_boolean(obj)} - 1 if \var{obj} is \scheme{#t}, 0 otherwise} +\item{\ccode{sexp_make_fixnum(n)} - creates a new fixnum representing int \var{n}} +\item{\ccode{sexp_unbox_fixnum(obj)} - converts a fixnum to a C integer} +\item{\ccode{sexp_make_character(ch)} - creates a new character representing char \var{ch}} +\item{\ccode{sexp_unbox_character(obj)} - converts a character to a C char} +\item{\ccode{sexp_car(pair)} - the car of \var{pair}} +\item{\ccode{sexp_cdr(pair)} - the cdr of \var{pair}} +\item{\ccode{sexp_ratio_numerator(q)} - the numerator of the ratio \var{q}} +\item{\ccode{sexp_ratio_denominator(q)} - the denominator of the ratio \var{q}} +\item{\ccode{sexp_complex_real(z)} - the real part of the complex \var{z}} +\item{\ccode{sexp_complex_imag(z)} - the imaginary part of the complex \var{z}} +\item{\ccode{sexp_string_length(str)} - the byte length of \var{str} as an int} +\item{\ccode{sexp_string_ref(str, i)} - the \var{i}'th byte of string \var{str}} +\item{\ccode{sexp_string_set(str, i, ch)} - set the \var{i}'th byte of string \var{str}} +\item{\ccode{sexp_vector_length(vec)} - the length of \var{vec} as an int} +\item{\ccode{sexp_vector_ref(vec, i)} - the \var{i}'th object of vector \var{vec}} +\item{\ccode{sexp_vector_set(vec, i, obj)} - set the \var{i}'th object of vector \var{vec}} +\item{\ccode{sexp_bytes_length(bv)} - the number of bytes in bytevector \var{bv}} +\item{\ccode{sexp_bytes_ref(bv, i)} - the \var{i}'th byte of bytevector \var{bv}} +\item{\ccode{sexp_bytes_set(bv, i, k)} - set the \var{i}'th byte of bytevector \var{bv}} +] + +\subsubsection{Constructors} + +Constructors allocate memory and so must be passed a context argument. +Any of these may fail and return the OOM exception object. + +\itemlist[ +\item{\ccode{sexp_cons(sexp ctx, sexp obj1, sexp obj2)} - create a new pair whose car is \var{obj1} and whose cdr is \var{obj2}} +\item{\ccode{sexp_list1(sexp ctx, sexp obj)} - alias for sexp_cons(ctx, obj, SEXP_NULL)} +\item{\ccode{sexp_list2(sexp ctx, sexp obj1, sexp obj2)} - create a list of two elements} +\item{\ccode{sexp_make_string(sexp ctx, sexp len, sexp ch)} - create a new Scheme string of \var{len} characters, all initialized to \var{ch}} +\item{\ccode{sexp_c_string(sexp ctx, const char* str, int len)} - create a new Scheme string copying the first \var{len} characters of the C string \var{str}. If \var{len} is -1, uses strlen(\var{str}).} +\item{\ccode{sexp_intern(sexp ctx, const char* str, int len)} - interns a symbol from the first \var{len} characters of the C string \var{str}. If \var{len} is -1, uses strlen(\var{str}).} +\item{\ccode{sexp_make_vector(sexp ctx, sexp len, sexp obj)} - create a new vector of \var{len} elements, all initialized to \var{obj}} +\item{\ccode{sexp_make_integer(sexp ctx, sexp_sint_t n)} - create an integer, heap allocating as a bignum if needed} +\item{\ccode{sexp_make_unsigned_integer(sexp ctx, sexp_uint_t n)} - create an unsigned integer, heap allocating as a bignum if needed} +] + +\subsubsection{I/O} + +\itemlist[ +\item{\ccode{sexp_read(sexp ctx, sexp in)} - read a single datum from port \var{in}} +\item{\ccode{sexp_write(sexp ctx, sexp obj, sexp out)} - write \var{obj} to port \var{out}} +\item{\ccode{sexp_write_string(sexp ctx, char* str, sexp out)} - write the characters in \var{str} to port \var{out}} +\item{\ccode{sexp_display(sexp ctx, sexp obj, sexp out)} - display \var{obj} to port \var{out}} +\item{\ccode{sexp_newline(sexp ctx, sexp out)} - write a newline to port \var{out}} +\item{\ccode{sexp_print_exception(sexp ctx, sexp exn, sexp out)} - print an error message for \var{exn} to port \var{out}} +\item{\ccode{sexp_current_input_port(sexp ctx)} - the \scheme{current-input-port}} +\item{\ccode{sexp_current_output_port(sexp ctx)} - the \scheme{current-output-port}} +\item{\ccode{sexp_current_error_port(sexp ctx)} - the \scheme{current-error-port}} +\item{\ccode{sexp_debug(sexp ctx, char* msg, sexp obj)} - write \var{obj} with a debug message prefix to \scheme{current-error-port}} +\item{\ccode{sexp_read_from_string(sexp ctx, char* str, int len)} - read a single datum from \var{str}, using at most \var{len} bytes if \var{len} is non-negative} +\item{\ccode{sexp_write_to_string(sexp ctx, sexp obj)} - return a Scheme string representation of \var{obj}} +\item{\ccode{sexp_open_input_string(sexp ctx, sexp str)} - equivalent to \scheme{open-input-string}} +\item{\ccode{sexp_open_output_string(sexp ctx)} - equivalent to \scheme{open-output-string}} +\item{\ccode{sexp_get_output_string(sexp ctx, sexp port)} - equivalent to \scheme{open-output-string}} +] + +\subsubsection{Utilities} + +\itemlist[ +\item{\ccode{sexp_equalp(sexp ctx, sexp x, sexp y)} - \scheme{equal?}} +\item{\ccode{sexp_length(sexp ctx, sexp ls)} - \scheme{length}} +\item{\ccode{sexp_listp(sexp ctx, sexp x)} - \scheme{list?}} +\item{\ccode{sexp_memq(sexp ctx, sexp x, sexp ls)} - \scheme{memq}} +\item{\ccode{sexp_assq(sexp ctx, sexp x, sexp ls)} - \scheme{assq}} +\item{\ccode{sexp_reverse(sexp ctx, sexp ls)} - \scheme{reverse}} +\item{\ccode{sexp_nreverse(sexp ctx, sexp ls)} - \scheme{reverse!}} +\item{\ccode{sexp_append2(sexp ctx, sexp ls)} - \scheme{append} for two arguments} +\item{\ccode{sexp_copy_list(sexp ctx, sexp ls)} - return a shallow copy of \var{ls}} +\item{\ccode{sexp_list_to_vector(sexp ctx, sexp ls)} - \scheme{list->vector}} +\item{\ccode{sexp_symbol_to_string(sexp ctx, sexp sym)} - \scheme{symbol->string}} +\item{\ccode{sexp_string_to_symbol(sexp ctx, sexp str)} - \scheme{string->symbol}} +\item{\ccode{sexp_string_to_number(sexp ctx, sexp str)} - \scheme{string->number}} +] + +\subsection{Exceptions} + +Exceptions can be created with the following: + +\itemlist[ + +\item{\ccode{sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source)} +\p{Create an exception of the given \var{kind} (a symbol), with the +string \var{message}, and \var{irritants} list. \var{procedure} and +\var{source} provide information about the error location. From a C +function, \var{procedure} should generally be \ccode{self}.}} + +\item{\ccode{sexp sexp_user_exception (sexp ctx, sexp self, const char *msg, sexp x)} +\p{Shortcut for an exception of kind \ccode{user}, with the given message and single irritant.}} + +\item{\ccode{sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x)} +\p{Shortcut for an exception of kind \ccode{type}, where \var{x} was +expected to be of type \var{type_id} but wasn't.}} + +\item{\ccode{sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x)} +\p{Shortcut for an exception of kind \ccode{type}, for more general +domain errors, where \var{x} failed to meet the restrictions in \var{msg}.}} + +] + +Returning an exception from a C function by default \emph{raises} that +exception in the VM. If you want to pass an exception as a first +class value, you have to wrap it first: + +\ccode{sexp sexp_maybe_wrap_error (sexp ctx, sexp obj)} + +\subsection{Customizing} + +You can add your own types and primitives with the following functions. + +\itemlist[ + +\item{\ccode{sexp sexp_define_foreign(sexp ctx, sexp env, const char* name, int num_args, sexp_proc1 func)} +\p{ +Defines a new primitive procedure with the name \var{name} in the +environment \var{env}. The procedure takes \var{num_args} arguments +and passes them to the C function \var{func}. The C function must +take the standard calling convention: + +\ccode{sexp func(sexp ctx, sexp self, sexp n, sexp arg\sub{1}, ..., sexp arg\sub{num_args})} + +where \var{ctx} is the current context, \var{self} is the procedure +itself, and \var{n} is the number of arguments passed. + +\var{func} is responsible for checking its own argument types. +}} + +\item{\ccode{sexp sexp_define_foreign_opt(sexp ctx, sexp env, const char* name, int num_args, sexp_proc1 func, sexp dflt)} +\p{ +Equivalent to \cfun{sexp_define_foreign}, except the final argument is +optional and defaults to the value \var{dflt}. +}} + +\item{\ccode{sexp sexp_define_foreign_param(sexp ctx, sexp env, const char* name, int num_args, sexp_proc1 func, const char* param)} +\p{ +Equivalent to \cfun{sexp_define_foreign_opt}, except instead of a fixed +default argument \var{param} should be the name of a parameter bound in +\var{env}. +}} + +\item{\ccode{sexp sexp_register_simple_type(sexp ctx, sexp name, sexp parent, sexp slots)} +\p{ +Defines a new simple record type having \var{slots} new slots in addition +to any inherited from the parent type \var{parent}. If \var{parent} is false, +inherits from the default \var{object} record type. +}} + +] + +See the C FFI for an easy way to automate adding bindings for C +functions. + +\section{C FFI} + +The "chibi-ffi" script reads in the C function FFI definitions from an +input file and outputs the appropriate C wrappers into a file with the +same base name and the ".c" extension. You can then compile that C +file into a shared library: + +\command{ +chibi-ffi file.stub +cc -fPIC -shared file.c -lchibi-scheme +} + +(or using whatever flags are appropriate to generate shared libs on +your platform) and the generated .so file can be loaded directly with +\scheme{load}, or portably using \scheme{(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. + +\subsection{Includes and Initializations} + +\itemlist[ +\item{\scheme{(c-include header)} - includes the file \var{header}} +\item{\scheme{(c-system-include header)} - includes the system file \var{header}} +\item{\scheme{(c-declare args ...)} - outputs \var{args} directly in the top-level C source} +\item{\scheme{(c-init args ...)} - evaluates \var{args} as C code after all other library initializations have been performed, with \cvar{ctx} and \cvar{env} in scope} +] + +\subsection{Struct Interface} + +C structs can be bound as Scheme types with the +\scheme{define-c-struct} form: + +\schemeblock{ +(define-c-struct struct_name + [predicate: predicate-name] + [constructor: constructor-name] + [finalizer: c_finalizer_name] + (type c_field_name getter-name setter-name) ...) +} + +\var{struct_name} should be the name of a C struct type. If provided, +\var{predicate-name} is bound to a procedure which takes one object +and returns \scheme{#t} iff the object is of type \var{struct_name}. + +If provided, \var{constructor-name} is bound to a procedure of zero +arguments which creates and returns a newly allocated instance of the +type. + +If a finalizer is provided, \var{c_finalizer_name} must be a C +function which takes one argument, a pointer to the struct, and +performs any cleanup or freeing of resources necessary. + +The remaining slots are similar to the +\hyperlink["http://srfi.schemers.org/srfi-9/srfi-9.html"]{SRFI-9} syntax, +except they are prefixed with a C type (described below). The +\var{c_field_name} should be a field name of \var{struct_name}. +\var{getter-name} will then be bound to a procedure of one argument, a +\{struct_name} type, which returns the given field. If provided, +\var{setter-name} will be bound to a procedure of two arguments to +mutate the given field. + +The variants \scheme{define-c-class} and \scheme{define-c-union} take +the same syntax but define types with the \ccode{class} and +\ccode{union} keywords respectively. \scheme{define-c-type} just +defines accessors to an opaque type without any specific struct-like +keyword. + +\schemeblock{ +;; Example: the struct addrinfo returned by getaddrinfo. + +(c-system-include "netdb.h") + +(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)) +} + +\subsection{Function and Constant Interface} + +C functions are defined with: + +\scheme{(define-c return-type name-spec (arg-type ...))} + +where \var{name-space} is either a symbol name, or a list of +\scheme{(scheme-name c_name)}. If just a symbol is used, the C name +is generated automatically by replacing any dashes (-) in the Scheme +name with underscores (_). + +Each \var{arg-type} is a type suitable for input validation and +conversion as discussed below. + +\schemeblock{ +;; Example: define connect(2) in Scheme +(define-c int connect (int sockaddr int)) +} + +Constants can be defined with: + +\scheme{(define-c-const type name-space)} + +where \var{name-space} is the same form as in \scheme{define-c}. This +defines a Scheme variable with the same value as the C constant. + +\schemeblock{ +;; Example: define address family constants in Scheme +(define-c-const int (address-family/unix "AF_UNIX")) +(define-c-const int (address-family/inet "AF_INET")) +} + +\subsection{C Types} + +\subsubsection{Basic Types} + +\itemlist[ +\item{\rawcode{void}} +\item{\rawcode{boolean}} +\item{\rawcode{char}} +\item{\rawcode{sexp} (no conversions)} +] + +\subsubsection{Integer Types} + +\itemlist[ +\item{\rawcode{signed-char}} +\item{\rawcode{short}} +\item{\rawcode{int}} +\item{\rawcode{long}} +\item{\rawcode{unsigned-char}} +\item{\rawcode{unsigned-short}} +\item{\rawcode{unsigned-int}} +\item{\rawcode{unsigned-long}} +\item{\rawcode{size_t}} +\item{\rawcode{pid_t}} +\item{\rawcode{uid_t}} +\item{\rawcode{gid_t}} +\item{\rawcode{time_t} (in seconds, but using the chibi epoch of 2010/01/01)} +\item{\rawcode{errno} (as a return type returns \scheme{#f} on error)} +] + +\subsubsection{Float Types} + +\itemlist[ +\item{\rawcode{float}} +\item{\rawcode{double}} +\item{\rawcode{long-double}} +] + +\subsubsection{String Types} + +\itemlist[ +\item{\rawcode{string} - a null-terminated char*} +\item{\rawcode{env-string} - a \rawcode{VAR=VALUE} string represented as a \scheme{(VAR . VALUE)} pair in Scheme} +\item{\scheme{(array char)} is equivalent to \rawcode{string}} +] + +\subsubsection{Port Types} + +\itemlist[ +\item{\rawcode{input-port}} +\item{\rawcode{output-port}} +] + +\subsubsection{Struct Types} + +Struct types are by default just referred to by the bare +\var{struct_name} from \scheme{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 \scheme{(struct struct-name)}. + +\subsubsection{Type modifiers} + +Any type may also be written as a list of modifiers followed by the +type itself. The supported modifiers are: + +\itemlist[ + +\item{\rawcode{const} +\p{Prepends the "const" C type modifier. +As a return or result parameter, makes non-immediates immutable.}} + +\item{\rawcode{free} +\p{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.}} + +\item{\rawcode{maybe-null} +\p{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.}} + +\item{\rawcode{pointer} +\p{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.}} + +\item{\rawcode{reference} +\p{A stack-allocated pointer to this type. +As a result parameter, passes a stack-allocated pointer to +the value, then returns the dereferenced pointer.}} + +\item{\rawcode{struct} +\p{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.}} + +\item{\rawcode{link} +\p{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.}} + +\item{\rawcode{result} +\p{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.}} + +\item{\scheme{(value )} +\p{Specify a fixed value. +As an input parameter, this parameter is not provided +in the Scheme API but always passed as .}} + +\item{\scheme{(default )} +\p{Specify a default value. +As the final input parameter, makes the Scheme parameter +optional, defaulting to .}} + +\item{\scheme{(array [])} +\p{An array type. +Length must be specified for return and result parameters. +If specified, length can be either an integer, indicating a fixed size, +or the symbol null, indicating a NULL-terminated array.}} + +] + +\section{Standard Modules} + +A number of SRFIs are provided in the default installation. Note that +SRFIs 0, 6, 23, 46 and 62 are built into the default environment so +there's no need to import them. SRFI 22 is available with the "-r" +command-line option. This list includes popular SRFIs or SRFIs used +in standard Chibi modules + +\itemlist[ + +\item{\hyperlink["http://srfi.schemers.org/srfi-0/srfi-0.html"]{(srfi 0) - cond-expand}} +\item{\hyperlink["http://srfi.schemers.org/srfi-1/srfi-1.html"]{(srfi 1) - list library}} +\item{\hyperlink["http://srfi.schemers.org/srfi-2/srfi-2.html"]{(srfi 2) - and-let*}} +\item{\hyperlink["http://srfi.schemers.org/srfi-6/srfi-6.html"]{(srfi 6) - basic string ports}} +\item{\hyperlink["http://srfi.schemers.org/srfi-8/srfi-8.html"]{(srfi 8) - receive}} +\item{\hyperlink["http://srfi.schemers.org/srfi-9/srfi-9.html"]{(srfi 9) - define-record-type}} +\item{\hyperlink["http://srfi.schemers.org/srfi-11/srfi-11.html"]{(srfi 11) - let-values/let*-values}} +\item{\hyperlink["http://srfi.schemers.org/srfi-16/srfi-16.html"]{(srfi 16) - case-lambda}} +\item{\hyperlink["http://srfi.schemers.org/srfi-18/srfi-18.html"]{(srfi 18) - multi-threading support}} +\item{\hyperlink["http://srfi.schemers.org/srfi-22/srfi-22.html"]{(srfi 22) - running scheme scripts on Unix}} +\item{\hyperlink["http://srfi.schemers.org/srfi-23/srfi-23.html"]{(srfi 23) - error reporting mechanism}} +\item{\hyperlink["http://srfi.schemers.org/srfi-26/srfi-26.html"]{(srfi 26) - cut/cute partial application}} +\item{\hyperlink["http://srfi.schemers.org/srfi-27/srfi-27.html"]{(srfi 27) - sources of random bits}} +\item{\hyperlink["http://srfi.schemers.org/srfi-33/srfi-33.html"]{(srfi 33) - bitwise operators}} +\item{\hyperlink["http://srfi.schemers.org/srfi-38/srfi-38.html"]{(srfi 38) - read/write shared structures}} +\item{\hyperlink["http://srfi.schemers.org/srfi-39/srfi-39.html"]{(srfi 39) - parameter objects}} +\item{\hyperlink["http://srfi.schemers.org/srfi-46/srfi-46.html"]{(srfi 46) - basic syntax-rules extensions}} +\item{\hyperlink["http://srfi.schemers.org/srfi-55/srfi-55.html"]{(srfi 55) - require-extension}} +\item{\hyperlink["http://srfi.schemers.org/srfi-62/srfi-62.html"]{(srfi 62) - s-expression comments}} +\item{\hyperlink["http://srfi.schemers.org/srfi-69/srfi-69.html"]{(srfi 69) - basic hash tables}} +\item{\hyperlink["http://srfi.schemers.org/srfi-95/srfi-95.html"]{(srfi 95) - sorting and merging}} +\item{\hyperlink["http://srfi.schemers.org/srfi-98/srfi-98.html"]{(srfi 98) - environment access}} +\item{\hyperlink["http://srfi.schemers.org/srfi-99/srfi-99.html"]{(srfi 99) - ERR5RS records}} + +] + +Additional non-standard modules are put in the \scheme{(chibi)} module +namespace. + +\itemlist[ + +\item{\hyperlink["lib/chibi/ast.html"]{(chibi ast) - Abstract Syntax Tree and other internal data types}} + +\item{\hyperlink["lib/chibi/config.html"]{(chibi config) - General configuration management}} + +\item{\hyperlink["lib/chibi/disasm.html"]{(chibi disasm) - Disassembler for the virtual machine}} + +\item{\hyperlink["lib/chibi/equiv.html"]{(chibi equiv) - A version of \scheme{equal?} which is guaranteed to terminate}} + +\item{\hyperlink["lib/chibi/filesystem.html"]{(chibi filesystem) - Interface to the filesystem and file descriptor objects}} + +\item{\hyperlink["lib/chibi/generic.html"]{(chibi generic) - Generic methods for CLOS-style object oriented programming}} + +\item{\hyperlink["lib/chibi/heap-stats.html"]{(chibi heap-stats) - Utilities for gathering statistics on the heap}} + +\item{\hyperlink["lib/chibi/io.html"]{(chibi io) - Various I/O extensions and custom ports}} + +\item{\hyperlink["lib/chibi/loop.html"]{(chibi loop) - Fast and extensible loop syntax}} + +\item{\hyperlink["lib/chibi/match.html"]{(chibi match) - Intuitive and widely supported pattern matching syntax}} + +\item{\hyperlink["lib/chibi/mime.html"]{(chibi mime) - Parse MIME files into SXML}} + +\item{\hyperlink["lib/chibi/modules.html"]{(chibi modules) - Introspection for the module system itself}} + +\item{\hyperlink["lib/chibi/net.html"]{(chibi net) - Simple networking interface}} + +\item{\hyperlink["lib/chibi/pathname.html"]{(chibi pathname) - Utilities to decompose and manipulate pathnames}} + +\item{\hyperlink["lib/chibi/process.html"]{(chibi process) - Interface to spawn processes and handle signals}} + +\item{\hyperlink["lib/chibi/repl.html"]{(chibi repl) - A full-featured Read/Eval/Print Loop}} + +\item{\hyperlink["lib/chibi/scribble.html"]{(chibi scribble) - A parser for the scribble syntax used to write this manual}} + +\item{\hyperlink["lib/chibi/stty.html"]{(chibi stty) - A high-level interface to ioctl}} + +\item{\hyperlink["lib/chibi/system.html"]{(chibi system) - Access to the host system and current user information}} + +\item{\hyperlink["lib/chibi/test.html"]{(chibi test) - A simple unit testing framework}} + +\item{\hyperlink["lib/chibi/time.html"]{(chibi time) - An interface to the current system time}} + +\item{\hyperlink["lib/chibi/trace.html"]{(chibi trace) - A utility to trace procedure calls}} + +\item{\hyperlink["lib/chibi/type-inference.html"]{(chibi type-inference) - An easy-to-use type inference system}} + +\item{\hyperlink["lib/chibi/uri.html"]{(chibi uri) - Utilities to parse and construct URIs}} + +\item{\hyperlink["lib/chibi/weak.html"]{(chibi weak) - Data structures with weak references}} + +] diff --git a/doc/lib/chibi/README b/doc/lib/chibi/README new file mode 100644 index 00000000..b6e02ce1 --- /dev/null +++ b/doc/lib/chibi/README @@ -0,0 +1 @@ +Auto-generated module documentation with tools/chibi-doc. diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..ea94287b --- /dev/null +++ b/eval.c @@ -0,0 +1,2510 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009-2013 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" + +#if SEXP_USE_DEBUG_VM || SEXP_USE_PROFILE_VM || SEXP_USE_STATIC_LIBS +#include "opt/opcode_names.h" +#endif + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +static sexp analyze (sexp ctx, sexp x, int depth, int defok); + +#if SEXP_USE_MODULES +sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env); +sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file); +sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n); +#endif + +sexp sexp_compile_error (sexp ctx, const char *message, sexp o) { + sexp exn; + sexp_gc_var3(sym, irritants, msg); + sexp_gc_preserve3(ctx, sym, irritants, msg); + irritants = sexp_list1(ctx, o); + msg = sexp_c_string(ctx, message, -1); + exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile", -1), + msg, irritants, SEXP_FALSE, + (sexp_pairp(o)?sexp_pair_source(o):SEXP_FALSE)); + sexp_gc_release3(ctx); + return exn; +} + +void sexp_warn (sexp ctx, const char *msg, sexp x) { + sexp_gc_var1(out); + int strictp = sexp_truep(sexp_global(ctx, SEXP_G_STRICT_P)); + sexp_gc_preserve1(ctx, out); + out = sexp_current_error_port(ctx); + if (sexp_not(out)) { /* generate a throw-away port */ + out = sexp_make_output_port(ctx, stderr, SEXP_FALSE); + sexp_port_no_closep(out) = 1; + } + if (sexp_oportp(out)) { + sexp_write_string(ctx, strictp ? "ERROR: " : "WARNING: ", out); + sexp_write_string(ctx, msg, out); + sexp_write(ctx, x, out); + sexp_write_char(ctx, '\n', out); + if (strictp) sexp_stack_trace(ctx, out); + } + sexp_gc_release1(ctx); + if (strictp) exit(1); +} + +sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res) { + sexp x, ignore = (res && sexp_exceptionp(res)) ? sexp_exception_irritants(res) : SEXP_NULL; + if (sexp_envp(from)) from = sexp_env_bindings(from); + for (x=from; sexp_pairp(x) && x!=to; x=sexp_env_next_cell(x)) + if (sexp_cdr(x) == SEXP_UNDEF && sexp_car(x) != ignore + && sexp_not(sexp_memq(ctx, sexp_car(x), ignore))) + sexp_warn(ctx, "reference to undefined variable: ", sexp_car(x)); + return SEXP_VOID; +} + +sexp sexp_maybe_wrap_error (sexp ctx, sexp obj) { + sexp_gc_var2(tmp, res); + if (sexp_exceptionp(obj)) { + sexp_gc_preserve2(ctx, tmp, res); + tmp = obj; + tmp = sexp_list1(ctx, tmp); + res = sexp_make_trampoline(ctx, SEXP_FALSE, tmp); + sexp_gc_release2(ctx); + return res; + } + return obj; +} + +/********************** environment utilities ***************************/ + +static sexp sexp_env_cell_loc1 (sexp env, sexp key, int localp, sexp *varenv) { + sexp ls; + do { +#if SEXP_USE_RENAME_BINDINGS + for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + if (sexp_car(ls) == key) { + if (varenv) *varenv = env; + return sexp_cdr(ls); + } +#endif + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + if (sexp_car(ls) == key) { + if (varenv) *varenv = env; + return ls; + } + env = (localp ? NULL : sexp_env_parent(env)); + } while (env && sexp_envp(env)); + return NULL; +} + +static sexp sexp_env_cell_loc (sexp ctx, sexp env, sexp key, int localp, sexp *varenv) { + sexp cell = sexp_env_cell_loc1(env, key, localp, varenv); + while (!cell && sexp_synclop(key)) { + if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(key), sexp_context_fv(ctx))) + && sexp_not(sexp_memq(ctx, sexp_synclo_expr(key), sexp_synclo_free_vars(key)))) + env = sexp_synclo_env(key); + key = sexp_synclo_expr(key); + cell = sexp_env_cell_loc1(env, key, 0, varenv); + } + return cell; +} + +sexp sexp_env_cell (sexp ctx, sexp env, sexp key, int localp) { + return sexp_env_cell_loc(ctx, env, key, localp, NULL); +} + +static sexp sexp_env_undefine (sexp ctx, sexp env, sexp key) { + sexp ls1=NULL, ls2; + for (ls2=sexp_env_bindings(env); sexp_pairp(ls2); + ls1=ls2, ls2=sexp_env_next_cell(ls2)) + if (sexp_car(ls2) == key) { + if (ls1) sexp_env_next_cell(ls1) = sexp_env_next_cell(ls2); + else sexp_env_bindings(env) = sexp_env_next_cell(ls2); + return SEXP_TRUE; + } + return SEXP_FALSE; +} + +sexp sexp_env_cell_define (sexp ctx, sexp env, sexp key, + sexp value, sexp *varenv) { + sexp_gc_var2(cell, ls); + while (sexp_env_lambda(env) || sexp_env_syntactic_p(env)) + env = sexp_env_parent(env); + if (varenv) *varenv = env; +#if SEXP_USE_RENAME_BINDINGS + /* remove any existing renamed definition */ + for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + if (sexp_car(ls) == key) { + sexp_car(ls) = SEXP_FALSE; + break; + } +#endif + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + if (sexp_car(ls) == key) { + if (sexp_cdr(ls) == SEXP_UNDEF) + sexp_cdr(ls) = value; + return ls; + } + sexp_gc_preserve2(ctx, cell, ls); + sexp_env_push(ctx, env, cell, key, value); + sexp_gc_release2(ctx); + return cell; +} + +static sexp sexp_env_cell_create (sexp ctx, sexp env, sexp key, + sexp value, sexp *varenv) { + sexp cell = sexp_env_cell_loc(ctx, env, key, 0, varenv); + if (!cell) cell = sexp_env_cell_define(ctx, env, key, value, varenv); + return cell; +} + +sexp sexp_env_ref (sexp ctx, sexp env, sexp key, sexp dflt) { + sexp cell = sexp_env_cell(ctx, env, key, 0); + return (cell ? sexp_cdr(cell) : dflt); +} + +sexp sexp_env_define (sexp ctx, sexp env, sexp key, sexp value) { + sexp cell, tmp, res = SEXP_VOID; + if (sexp_immutablep(env)) + return sexp_user_exception(ctx, NULL, "immutable binding", key); + cell = sexp_env_cell(ctx, env, key, 1); + if (!cell) { + sexp_env_push(ctx, env, tmp, key, value); + } else if (sexp_immutablep(cell)) { + res = sexp_user_exception(ctx, NULL, "immutable binding", key); + } else if (sexp_syntacticp(value) && !sexp_syntacticp(sexp_cdr(cell))) { + sexp_env_undefine(ctx, env, key); + sexp_env_push(ctx, env, tmp, key, value); + } else { + sexp_cdr(cell) = value; + } + return res; +} + +#if SEXP_USE_RENAME_BINDINGS +sexp sexp_env_rename (sexp ctx, sexp env, sexp key, sexp value) { + sexp tmp; + sexp_env_push_rename(ctx, env, tmp, key, value); + return SEXP_VOID; +} +#endif + +sexp sexp_env_exports_op (sexp ctx, sexp self, sexp_sint_t n, sexp env) { + sexp ls; + sexp_gc_var1(res); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; +#if SEXP_USE_RENAME_BINDINGS + for (ls=sexp_env_renames(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_push(ctx, res, sexp_cadr(ls)); +#endif + for (ls=sexp_env_bindings(env); sexp_pairp(ls); ls=sexp_env_next_cell(ls)) + sexp_push(ctx, res, sexp_car(ls)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) { + sexp_gc_var2(e, tmp); + sexp_gc_preserve2(ctx, e, tmp); + e = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_parent(e) = env; + sexp_env_bindings(e) = SEXP_NULL; +#if SEXP_USE_RENAME_BINDINGS + sexp_env_renames(e) = SEXP_NULL; +#endif + for ( ; sexp_pairp(vars); vars = sexp_cdr(vars)) + sexp_env_push(ctx, e, tmp, sexp_car(vars), value); + sexp_gc_release2(ctx); + return e; +} + +sexp sexp_extend_synclo_env (sexp ctx, sexp env) { + sexp e1, e2; + sexp_gc_var1(e); + sexp_gc_preserve1(ctx, e); + e = env; + if (sexp_pairp(sexp_context_fv(ctx))) { + e = sexp_alloc_type(ctx, env, SEXP_ENV); + for (e1=env, e2=NULL; e1; e1=sexp_env_parent(e1)) { + e2 = e2 ? (sexp_env_parent(e2) = sexp_alloc_type(ctx, env, SEXP_ENV)) : e; + sexp_env_bindings(e2) = sexp_env_bindings(e1); + sexp_env_syntactic_p(e2) = 1; +#if SEXP_USE_RENAME_BINDINGS + sexp_env_renames(e2) = sexp_env_renames(e1); +#endif + } + sexp_env_parent(e2) = sexp_context_env(ctx); + } + sexp_gc_release1(ctx); + return e; +} + +static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(ctx, res, sexp_car(ls)); + if (!sexp_nullp(ls)) + res = sexp_cons(ctx, ls, res); + sexp_gc_release1(ctx); + return res; +} + +static sexp sexp_flatten_dot (sexp ctx, sexp ls) { + return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls)); +} + +int sexp_param_index (sexp ctx, sexp lambda, sexp name) { + sexp ls; + int i; + while (1) { + i = 0; + ls = sexp_lambda_params(lambda); + for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + if (sexp_car(ls) == name) + return i; + if (ls == name) + return i; + ls = sexp_lambda_locals(lambda); + for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--) + if (sexp_car(ls) == name) + return i-4; + if (sexp_synclop(name)) + name = sexp_synclo_expr(name); + else + break; + } + sexp_warn(ctx, "can't happen: no argument: ", name); + return -10000; +} + +/************************* bytecode utilities ***************************/ + +void sexp_shrink_bcode (sexp ctx, sexp_uint_t i) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) { + tmp = sexp_alloc_bytecode(ctx, i); + if (!sexp_exceptionp(tmp)) { + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); + sexp_bytecode_length(tmp) = i; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(ctx)); + sexp_bytecode_source(tmp) + = sexp_bytecode_source(sexp_context_bc(ctx)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(ctx)), + i); + sexp_context_bc(ctx) = tmp; + } + } +} + +void sexp_expand_bcode (sexp ctx, sexp_uint_t size) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(ctx)) + < (sexp_unbox_fixnum(sexp_context_pos(ctx)))+size) { + tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2); + if (sexp_exceptionp(tmp)) { + sexp_context_exception(ctx) = tmp; + } else { + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); + sexp_bytecode_length(tmp) + = sexp_bytecode_length(sexp_context_bc(ctx))*2; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(ctx)); + sexp_bytecode_source(tmp) + = sexp_bytecode_source(sexp_context_bc(ctx)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(ctx)), + sexp_bytecode_length(sexp_context_bc(ctx))); + sexp_context_bc(ctx) = tmp; + } + } +} + +void sexp_emit (sexp ctx, unsigned char c) { + sexp_expand_bcode(ctx, 1); + if (sexp_exceptionp(sexp_context_exception(ctx))) + return; + sexp_bytecode_data(sexp_context_bc(ctx))[sexp_unbox_fixnum(sexp_context_pos(ctx))] = c; + sexp_context_pos(ctx) = sexp_fx_add(sexp_context_pos(ctx), SEXP_ONE); +} + +sexp sexp_complete_bytecode (sexp ctx) { + sexp bc; + sexp_emit_return(ctx); + sexp_shrink_bcode(ctx, sexp_unbox_fixnum(sexp_context_pos(ctx))); + bc = sexp_context_bc(ctx); + if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */ + if (sexp_nullp(sexp_cdr(sexp_bytecode_literals(bc)))) + sexp_bytecode_literals(bc) = sexp_car(sexp_bytecode_literals(bc)); + else if (sexp_nullp(sexp_cddr(sexp_bytecode_literals(bc)))) + sexp_cdr(sexp_bytecode_literals(bc)) = sexp_cadr(sexp_bytecode_literals(bc)); + else + sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc)); + if (sexp_exceptionp(sexp_bytecode_literals(bc))) + return sexp_bytecode_literals(bc); + } + sexp_bytecode_max_depth(bc) = sexp_unbox_fixnum(sexp_context_max_depth(ctx)); +#if SEXP_USE_FULL_SOURCE_INFO + if (sexp_bytecode_source(bc) && sexp_pairp(sexp_bytecode_source(bc))) { + sexp_bytecode_source(bc) = sexp_nreverse(ctx, sexp_bytecode_source(bc)); + sexp_bytecode_source(bc) = sexp_list_to_vector(ctx, sexp_bytecode_source(bc)); + } +#endif + sexp_bless_bytecode(ctx, bc); + if (sexp_exceptionp(sexp_context_exception(ctx))) + return sexp_context_exception(ctx); + return bc; +} + +sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, + sexp num_args, sexp bc, sexp vars) { + sexp proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE); + sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags; + sexp_procedure_num_args(proc) = sexp_unbox_fixnum(num_args); + sexp_procedure_code(proc) = bc; + sexp_procedure_vars(proc) = vars; + return proc; +} + +static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) { + sexp mac = sexp_alloc_type(ctx, macro, SEXP_MACRO); + sexp_macro_env(mac) = e; + sexp_macro_proc(mac) = p; + return mac; +} + +sexp sexp_make_synclo_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv, sexp expr) { + sexp res; + if (! (sexp_symbolp(expr) || sexp_pairp(expr) || sexp_synclop(expr))) + return expr; + res = sexp_alloc_type(ctx, synclo, SEXP_SYNCLO); + if (SEXP_USE_FLAT_SYNTACTIC_CLOSURES && sexp_synclop(expr)) { + sexp_synclo_env(res) = sexp_synclo_env(expr); + sexp_synclo_free_vars(res) = sexp_synclo_free_vars(expr); + sexp_synclo_expr(res) = sexp_synclo_expr(expr); + } else { + sexp_synclo_env(res) = env; + sexp_synclo_free_vars(res) = fv; + sexp_synclo_expr(res) = expr; + } + return res; +} + +/* internal AST */ + +sexp sexp_make_lambda (sexp ctx, sexp params) { + sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA); + sexp_lambda_name(res) = SEXP_FALSE; + sexp_lambda_params(res) = params; + sexp_lambda_fv(res) = SEXP_NULL; + sexp_lambda_sv(res) = SEXP_NULL; + sexp_lambda_locals(res) = SEXP_NULL; + sexp_lambda_defs(res) = SEXP_NULL; + sexp_lambda_return_type(res) = SEXP_FALSE; + sexp_lambda_param_types(res) = SEXP_NULL; + return res; +} + +sexp sexp_make_ref (sexp ctx, sexp name, sexp cell) { + sexp res = sexp_alloc_type(ctx, ref, SEXP_REF); + sexp_ref_name(res) = name; + sexp_ref_cell(res) = cell; + return res; +} + +static sexp sexp_make_set (sexp ctx, sexp var, sexp value) { + sexp res = sexp_alloc_type(ctx, set, SEXP_SET); + sexp_set_var(res) = var; + sexp_set_value(res) = value; + return res; +} + +static sexp sexp_make_cnd (sexp ctx, sexp test, sexp pass, sexp fail) { + sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND); + sexp_cnd_test(res) = test; + sexp_cnd_pass(res) = pass; + sexp_cnd_fail(res) = fail; + return res; +} + +sexp sexp_make_lit (sexp ctx, sexp value) { + sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT); + sexp_lit_value(res) = value; + return res; +} + +/****************************** contexts ******************************/ + +#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) + +static void sexp_add_path (sexp ctx, const char *str) { + const char *colon; + if (str && *str) { + colon = strchr(str, ':'); + if (colon) + sexp_add_path(ctx, colon+1); + else + colon = str + strlen(str); + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), SEXP_VOID); + sexp_car(sexp_global(ctx, SEXP_G_MODULE_PATH)) + = sexp_c_string(ctx, str, colon-str); + sexp_immutablep(sexp_global(ctx, SEXP_G_MODULE_PATH)) = 1; + } +} + +#if ! SEXP_USE_NATIVE_X86 +static void sexp_init_eval_context_bytecodes (sexp ctx) { + sexp_gc_var3(tmp, vec, ctx2); + sexp_gc_preserve3(ctx, tmp, vec, ctx2); + sexp_emit(ctx, SEXP_OP_RESUMECC); + sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = sexp_complete_bytecode(ctx); + ctx2 = sexp_make_child_context(ctx, NULL); + sexp_emit(ctx2, SEXP_OP_DONE); + tmp = sexp_complete_bytecode(ctx2); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + sexp_global(ctx, SEXP_G_FINAL_RESUMER) + = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); + sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) + = sexp_intern(ctx, "final-resumer", -1); + sexp_gc_release3(ctx); +} +#endif + +void sexp_init_eval_context_globals (sexp ctx) { + const char* user_path; + ctx = sexp_make_child_context(ctx, NULL); +#if ! SEXP_USE_NATIVE_X86 + sexp_init_eval_context_bytecodes(ctx); +#endif + sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL; + sexp_add_path(ctx, sexp_default_module_path); + user_path = getenv(SEXP_MODULE_PATH_VAR); + if (!user_path) user_path = sexp_default_user_module_path; + sexp_add_path(ctx, user_path); +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR) + = sexp_user_exception(ctx, SEXP_FALSE, "I/O would block", SEXP_NULL); + sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO; + sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = SEXP_FALSE; + sexp_global(ctx, SEXP_G_ATOMIC_P) = SEXP_FALSE; +#endif +} + +sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size) { + sexp_gc_var1(res); + res = sexp_make_context(ctx, size, max_size); + if (!res || sexp_exceptionp(res)) + return res; + if (ctx) sexp_gc_preserve1(ctx, res); + sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_SEVEN)); + sexp_context_specific(res) = sexp_make_vector(res, SEXP_SEVEN, SEXP_ZERO); + sexp_context_lambda(res) = SEXP_FALSE; + sexp_context_fv(res) = SEXP_NULL; + sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE); + if (sexp_exceptionp(sexp_context_env(res))) { + res = sexp_context_env(res); + } else if (sexp_exceptionp(sexp_context_specific(res))) { + res = sexp_context_specific(res); + } else if (sexp_exceptionp(sexp_context_bc(res))) { + res = sexp_context_bc(res); + } else { + sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; + sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE; + sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; + sexp_bytecode_source(sexp_context_bc(res)) = SEXP_NULL; + if ((! stack) || (stack == SEXP_FALSE)) { + stack = sexp_alloc_tagged(res, SEXP_STACK_SIZE, SEXP_STACK); + if (sexp_exceptionp(stack)) { + if (ctx) sexp_gc_release1(ctx); + return stack; + } else { + sexp_stack_length(stack) = SEXP_INIT_STACK_SIZE; + sexp_stack_top(stack) = 0; + } + } + sexp_context_stack(res) = stack; + if (! ctx) sexp_init_eval_context_globals(res); + if (ctx) { + sexp_context_params(res) = sexp_context_params(ctx); + sexp_context_tracep(res) = sexp_context_tracep(ctx); + sexp_context_dk(res) = sexp_context_dk(ctx); + sexp_gc_release1(ctx); + } else { + /* TODO: make the root a global (with friendly error in/out) */ + sexp_context_dk(res) = sexp_make_vector(res, SEXP_FOUR, SEXP_FALSE); + sexp_vector_set(sexp_context_dk(res), SEXP_ZERO, SEXP_ZERO); + } + } + return res; +} + +sexp sexp_make_child_context (sexp ctx, sexp lambda) { + sexp res = sexp_make_eval_context(ctx, + sexp_context_stack(ctx), + sexp_context_env(ctx), + 0, + sexp_context_max_size(ctx)); + if (! sexp_exceptionp(res)) { + sexp_context_lambda(res) = lambda; + sexp_context_top(res) = sexp_context_top(ctx); + sexp_context_fv(res) = sexp_context_fv(ctx); + sexp_context_tracep(res) = sexp_context_tracep(ctx); + } + return res; +} + +/**************************** identifiers *****************************/ + +int sexp_idp (sexp x) { + while (sexp_synclop(x)) x = sexp_synclo_expr(x); + return sexp_symbolp(x); +} + +sexp sexp_identifierp_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) { + return sexp_make_boolean(sexp_idp(x)); +} + +sexp sexp_syntactic_closure_expr_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) { + return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); +} + +sexp sexp_strip_synclos (sexp ctx, sexp self, sexp_sint_t n, sexp x) { + sexp_gc_var3(res, kar, kdr); + sexp_gc_preserve3(ctx, res, kar, kdr); + loop: + if (sexp_synclop(x)) { + x = sexp_synclo_expr(x); + goto loop; + } else if (sexp_pairp(x) && sexp_truep(sexp_length(ctx, x))) { + kar = sexp_strip_synclos(ctx, self, n, sexp_car(x)); + kdr = sexp_strip_synclos(ctx, self, n, sexp_cdr(x)); + res = sexp_cons(ctx, kar, kdr); + sexp_pair_source(res) = sexp_pair_source(x); + sexp_immutablep(res) = 1; + } else { + res = x; + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_identifier_eq_op (sexp ctx, sexp self, sexp_sint_t n, sexp e1, sexp id1, sexp e2, sexp id2) { + sexp cell1, cell2; + cell1 = sexp_env_cell(ctx, e1, id1, 0); + cell2 = sexp_env_cell(ctx, e2, id2, 0); + if (cell1 && (cell1 == cell2)) + return SEXP_TRUE; + else if (!cell1 && !cell2 && (id1 == id2)) + return SEXP_TRUE; + /* If the symbols are the same and the cells are either unbound or + * (optionally) bound to top-level variables, consider them the + * same. Local (non-toplevel) bindings must still match exactly. + */ + while (sexp_synclop(id1)) + id1 = sexp_synclo_expr(id1); + while (sexp_synclop(id2)) + id2 = sexp_synclo_expr(id2); + if ((id1 == id2) + && ((!cell1 && !cell2) +#if !SEXP_USE_STRICT_TOPLEVEL_BINDINGS + || ((cell1 && cell2) + && (!sexp_lambdap(sexp_cdr(cell1)) && !sexp_env_cell_syntactic_p(cell1)) + && (!sexp_lambdap(sexp_cdr(cell2)) && !sexp_env_cell_syntactic_p(cell2))) +#endif + )) + return SEXP_TRUE; + return SEXP_FALSE; +} + +/************************* the compiler ***************************/ + +static sexp analyze_list (sexp ctx, sexp x, int depth, int defok) { + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) { + sexp_push(ctx, res, SEXP_FALSE); + tmp = analyze(ctx, sexp_car(x), depth, defok); + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } else { + sexp_pair_source(res) = sexp_pair_source(x); + sexp_car(res) = tmp; + } + } + if (sexp_pairp(res)) res = sexp_nreverse(ctx, res); + sexp_gc_release2(ctx); + return res; +} + +static sexp analyze_app (sexp ctx, sexp x, int depth) { + sexp p, res, tmp; + res = analyze_list(ctx, x, depth, 0); + if (sexp_lambdap(sexp_car(res))) { /* fill in lambda names */ + p=sexp_lambda_params(sexp_car(res)); + for (tmp=sexp_cdr(res); sexp_pairp(tmp)&&sexp_pairp(p); tmp=sexp_cdr(tmp), p=sexp_cdr(p)) + if (sexp_lambdap(sexp_car(tmp))) + sexp_lambda_name(sexp_car(tmp)) = sexp_car(p); + } + return res; +} + +static sexp analyze_seq (sexp ctx, sexp ls, int depth, int defok) { + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + if (sexp_nullp(ls)) + res = SEXP_VOID; + else if (sexp_nullp(sexp_cdr(ls))) + res = analyze(ctx, sexp_car(ls), depth, defok); + else { + res = sexp_alloc_type(ctx, seq, SEXP_SEQ); + sexp_seq_source(res) = sexp_pair_source(ls); + tmp = analyze_list(ctx, ls, depth, defok); + if (sexp_exceptionp(tmp)) + res = tmp; + else + sexp_seq_ls(res) = tmp; + } + sexp_gc_release2(ctx); + return res; +} + +static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) { + sexp env = sexp_context_env(ctx), res; + sexp_gc_var1(cell); + sexp_gc_preserve1(ctx, cell); + cell = sexp_env_cell_loc(ctx, env, x, 0, varenv); + if (! cell) { + while (sexp_synclop(x)) x = sexp_synclo_expr(x); + cell = sexp_env_cell_create(ctx, env, x, SEXP_UNDEF, varenv); + } + if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) { + res = sexp_compile_error(ctx, "invalid use of syntax as value", x); + } else { + res = sexp_make_ref(ctx, sexp_car(cell), cell); + } + sexp_gc_release1(ctx); + return res; +} + +static sexp analyze_set (sexp ctx, sexp x, int depth) { + sexp res, varenv; + sexp_gc_var2(ref, value); + sexp_gc_preserve2(ctx, ref, value); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)) + && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) { + res = sexp_compile_error(ctx, "bad set! syntax", x); + } else { + ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv); + if (sexp_lambdap(sexp_ref_loc(ref))) + sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); + value = analyze(ctx, sexp_caddr(x), depth, 0); + if (sexp_exceptionp(ref)) { + res = ref; + } else if (sexp_exceptionp(value)) { + res = value; + } else if (sexp_immutablep(sexp_ref_cell(ref)) + || (varenv && sexp_immutablep(varenv))) { + res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x)); + } else { + res = sexp_make_set(ctx, ref, value); + sexp_set_source(res) = sexp_pair_source(x); + } + } + sexp_gc_release2(ctx); + return res; +} + +#define sexp_return(res, val) do {res=val; goto cleanup;} while (0) + +static sexp analyze_lambda (sexp ctx, sexp x, int depth) { + int trailing_non_procs; + sexp name, ls, ctx3; + sexp_gc_var6(res, body, tmp, value, defs, ctx2); + sexp_gc_preserve6(ctx, res, body, tmp, value, defs, ctx2); + /* verify syntax */ + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) + sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x)); + for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_idp(sexp_car(ls))) + sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x)); + else if (sexp_truep(sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)))) + sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x)); + /* build lambda and analyze body */ + res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x))); + if (sexp_exceptionp(res)) sexp_return(res, res); + sexp_lambda_source(res) = sexp_pair_source(x); + if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res)))) + sexp_lambda_source(res) = sexp_pair_source(sexp_cdr(x)); + if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res)))) + sexp_lambda_source(res) = sexp_pair_source(sexp_cddr(x)); + ctx2 = sexp_make_child_context(ctx, res); + if (sexp_exceptionp(ctx2)) sexp_return(res, ctx2); + tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); + sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); + if (sexp_exceptionp(sexp_context_env(ctx2))) sexp_return(res, sexp_context_env(ctx2)); + sexp_env_lambda(sexp_context_env(ctx2)) = res; + body = analyze_seq(ctx2, sexp_cddr(x), depth, 1); + if (sexp_exceptionp(body)) sexp_return(res, body); + /* delayed analyze internal defines */ + trailing_non_procs = 0; + defs = SEXP_NULL; + for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { + tmp = sexp_car(ls); + ctx3 = sexp_cdr(tmp); + if (sexp_pairp(sexp_caar(tmp))) { + name = sexp_caaar(tmp); + tmp = sexp_cons(ctx3, sexp_cdaar(tmp), sexp_cdar(tmp)); + tmp = sexp_cons(ctx3, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(sexp_caar(ls)); + value = analyze_lambda(ctx3, tmp, depth); + } else { + name = sexp_caar(tmp); + value = analyze(ctx3, sexp_cadar(tmp), depth, 0); + } + if (sexp_exceptionp(value)) sexp_return(res, value); + if (sexp_lambdap(value)) sexp_lambda_name(value) = name; + tmp = analyze_var_ref(ctx3, name, NULL); + if (sexp_exceptionp(tmp)) sexp_return(res, tmp); + tmp = sexp_make_set(ctx3, tmp, value); + if (sexp_exceptionp(tmp)) sexp_return(res, tmp); + sexp_push(ctx3, defs, tmp); + if (!sexp_lambdap(value)) trailing_non_procs = 1; + if (trailing_non_procs || !SEXP_USE_UNBOXED_LOCALS) + sexp_insert(ctx3, sexp_lambda_sv(res), name); + } + if (sexp_pairp(defs)) { + if (! sexp_seqp(body)) { + tmp = sexp_alloc_type(ctx2, seq, SEXP_SEQ); + sexp_seq_ls(tmp) = sexp_list1(ctx2, body); + body = tmp; + } + sexp_seq_ls(body) = sexp_append2(ctx2, defs, sexp_seq_ls(body)); + if (sexp_exceptionp(sexp_seq_ls(body))) sexp_return(res, sexp_seq_ls(body)); + } + if (sexp_exceptionp(body)) res = body; + else sexp_lambda_body(res) = body; + cleanup: + sexp_gc_release6(ctx); + return res; +} + +static sexp analyze_if (sexp ctx, sexp x, int depth) { + sexp res, fail_expr; + sexp_gc_var3(test, pass, fail); + sexp_gc_preserve3(ctx, test, pass, fail); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad if syntax", x); + } else { + test = analyze(ctx, sexp_cadr(x), depth, 0); + pass = analyze(ctx, sexp_caddr(x), depth, 0); + fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; + fail = analyze(ctx, fail_expr, depth, 0); + res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass : + sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail)); + if (sexp_cndp(res)) sexp_cnd_source(res) = sexp_pair_source(x); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp analyze_define (sexp ctx, sexp x, int depth) { + sexp name, res, varenv; + sexp_gc_var4(ref, value, tmp, env); + sexp_gc_preserve4(ctx, ref, value, tmp, env); + env = sexp_context_env(ctx); + while (sexp_env_syntactic_p(env) && sexp_env_parent(env)) + env = sexp_env_parent(env); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad define syntax", x); + } else { + name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); + if (! sexp_idp(name)) { + res = sexp_compile_error(ctx, "can't define a non-symbol", x); + } else if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { + sexp_env_push(ctx, env, tmp, name, sexp_context_lambda(ctx)); + sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name); + tmp = sexp_cons(ctx, sexp_cdr(x), ctx); + sexp_pair_source(sexp_cdr(x)) = sexp_pair_source(x); + sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), tmp); + res = SEXP_VOID; + } else { +#if SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS + if (sexp_synclop(name)) name = sexp_synclo_expr(name); +#endif + sexp_env_cell_define(ctx, env, name, SEXP_VOID, &varenv); + if (sexp_pairp(sexp_cadr(x))) { + tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); + tmp = sexp_cons(ctx, SEXP_VOID, tmp); + sexp_pair_source(tmp) = sexp_pair_source(x); + value = analyze_lambda(ctx, tmp, depth); + } else + value = analyze(ctx, sexp_caddr(x), depth, 0); + tmp = sexp_env_cell_loc(ctx, env, name, 0, &varenv); + ref = sexp_make_ref(ctx, name, tmp); + if (sexp_exceptionp(ref)) { + res = ref; + } else if (sexp_exceptionp(value)) { + res = value; + } else if (varenv && sexp_immutablep(varenv)) { + res = sexp_compile_error(ctx, "immutable binding", name); + } else { + if (sexp_lambdap(value)) sexp_lambda_name(value) = name; + res = sexp_make_set(ctx, ref, value); + if (sexp_setp(res)) sexp_set_source(res) = sexp_pair_source(x); + } + } + } + sexp_gc_release4(ctx); + return res; +} + +static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx, int localp) { + sexp res = SEXP_VOID, name; + sexp_gc_var1(mac); + sexp_gc_preserve1(eval_ctx, mac); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls)) + && sexp_idp(sexp_caar(ls)) && sexp_nullp(sexp_cddar(ls)))) { + res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_pairp(ls) ? sexp_car(ls) : ls); + break; + } + if (sexp_idp(sexp_cadar(ls))) + mac = sexp_env_ref(eval_ctx, sexp_context_env(eval_ctx), sexp_cadar(ls), SEXP_FALSE); + else + mac = sexp_eval(eval_ctx, sexp_cadar(ls), NULL); + if (sexp_procedurep(mac)) + mac = sexp_make_macro(eval_ctx, mac, sexp_context_env(eval_ctx)); + if (!(sexp_macrop(mac)||sexp_corep(mac))) { + res = (sexp_exceptionp(mac) ? mac + : sexp_compile_error(eval_ctx, "non-procedure macro", mac)); + break; + } + name = sexp_caar(ls); + if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx))) + name = sexp_synclo_expr(name); + if (sexp_macrop(mac) && sexp_pairp(sexp_cadar(ls))) + sexp_macro_source(mac) = sexp_pair_source(sexp_cadar(ls)); + sexp_env_define(eval_ctx, sexp_context_env(bind_ctx), name, mac); +#if !SEXP_USE_STRICT_TOPLEVEL_BINDINGS + if (localp) + sexp_env_cell_syntactic_p(sexp_env_cell(eval_ctx, sexp_context_env(bind_ctx), name, 0)) = 1; +#endif + } + sexp_gc_release1(eval_ctx); + return res; +} + +static sexp analyze_define_syntax (sexp ctx, sexp x) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_list1(ctx, sexp_cdr(x)); + res = sexp_exceptionp(tmp) ? tmp : analyze_bind_syntax(tmp, ctx, ctx, 0); + sexp_gc_release1(ctx); + return res; +} + +static sexp analyze_let_syntax_aux (sexp ctx, sexp x, int recp, int depth) { + sexp res; + sexp_gc_var3(env, ctx2, tmp); + sexp_gc_preserve3(ctx, env, ctx2, tmp); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad let(rec)-syntax", x); + } else { + env = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_syntactic_p(env) = 1; + sexp_env_parent(env) = sexp_context_env(ctx); + sexp_env_bindings(env) = SEXP_NULL; +#if SEXP_USE_RENAME_BINDINGS + sexp_env_renames(env) = SEXP_NULL; +#endif + ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(ctx2) = env; + tmp = analyze_bind_syntax(sexp_cadr(x), (recp ? ctx2 : ctx), ctx2, 1); + res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x), depth, 1)); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp analyze_let_syntax (sexp ctx, sexp x, int depth) { + return analyze_let_syntax_aux(ctx, x, 0, depth); +} + +static sexp analyze_letrec_syntax (sexp ctx, sexp x, int depth) { + return analyze_let_syntax_aux(ctx, x, 1, depth); +} + +static sexp analyze (sexp ctx, sexp object, int depth, int defok) { + sexp op; + sexp_gc_var4(res, tmp, x, cell); + sexp_gc_preserve4(ctx, res, tmp, x, cell); + x = object; + + if (++depth > SEXP_MAX_ANALYZE_DEPTH) { + res = sexp_compile_error(ctx, "SEXP_MAX_ANALYZE_DEPTH exceeded", x); + goto error; + } + + loop: + if (sexp_pairp(x)) { + if (sexp_not(sexp_listp(ctx, x))) { + res = sexp_compile_error(ctx, "dotted list in source", x); + } else if (sexp_idp(sexp_car(x))) { + cell = sexp_env_cell(ctx, sexp_context_env(ctx), sexp_car(x), 0); + if (! cell) { + res = analyze_app(ctx, x, depth); + if (sexp_exceptionp(res)) + sexp_warn(ctx, "exception inside undefined operator: ", sexp_car(x)); + } else { + op = sexp_cdr(cell); + if (sexp_corep(op)) { + switch (sexp_core_code(op)) { + case SEXP_CORE_DEFINE: + res = defok ? analyze_define(ctx, x, depth) + : sexp_compile_error(ctx, "unexpected define", x); + break; + case SEXP_CORE_SET: + res = analyze_set(ctx, x, depth); break; + case SEXP_CORE_LAMBDA: + res = analyze_lambda(ctx, x, depth); break; + case SEXP_CORE_IF: + res = analyze_if(ctx, x, depth); break; + case SEXP_CORE_BEGIN: + res = analyze_seq(ctx, sexp_cdr(x), depth, defok); break; + case SEXP_CORE_QUOTE: + case SEXP_CORE_SYNTAX_QUOTE: + if (! (sexp_pairp(sexp_cdr(x)) && sexp_nullp(sexp_cddr(x)))) + res = sexp_compile_error(ctx, "bad quote form", x); + else + res = sexp_make_lit(ctx, + (sexp_core_code(op) == SEXP_CORE_QUOTE) ? + tmp=sexp_strip_synclos(ctx , NULL, 1, sexp_cadr(x)) : + sexp_cadr(x)); + break; + case SEXP_CORE_DEFINE_SYNTAX: + res = defok ? analyze_define_syntax(ctx, x) + : sexp_compile_error(ctx, "unexpected define-syntax", x); + break; + case SEXP_CORE_LET_SYNTAX: + res = analyze_let_syntax(ctx, x, depth); break; + case SEXP_CORE_LETREC_SYNTAX: + res = analyze_letrec_syntax(ctx, x, depth); break; + default: + res = sexp_compile_error(ctx, "unknown core form", op); break; + } + } else if (sexp_macrop(op)) { + tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); + tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); + tmp = sexp_cons(ctx, x, tmp); + x = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + if (!sexp_exceptionp(x) && !sexp_exceptionp(sexp_context_exception(ctx))) + x = sexp_apply(x, sexp_macro_proc(op), tmp); + if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x))) + sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp)); + goto loop; + } else if (sexp_opcodep(op)) { + res = sexp_length(ctx, sexp_cdr(x)); + if (sexp_unbox_fixnum(res) < sexp_opcode_num_args(op)) { + sexp_warn(ctx, "not enough args for opcode: ", x); + op = analyze_var_ref(ctx, sexp_car(x), NULL); + } else if ((sexp_unbox_fixnum(res) > sexp_opcode_num_args(op)) + && (! sexp_opcode_variadic_p(op))) { + sexp_warn(ctx, "too many args for opcode: ", x); + op = analyze_var_ref(ctx, sexp_car(x), NULL); + } + res = analyze_list(ctx, sexp_cdr(x), 0, 0); + if (! sexp_exceptionp(res)) { + /* push op, which will be a direct opcode if the call is valid */ + sexp_push(ctx, res, op); + if (sexp_pairp(res)) + sexp_pair_source(res) = sexp_pair_source(x); + } + } else { + res = analyze_app(ctx, x, depth); + } + } + } else { + res = analyze_app(ctx, x, depth); + if (!sexp_exceptionp(res) + && !(sexp_pairp(sexp_car(x)) + || (sexp_synclop(sexp_car(x)) + && sexp_pairp(sexp_synclo_expr(sexp_car(x)))))) + sexp_warn(ctx, "invalid operator in application: ", x); + } + } else if (sexp_idp(x)) { + res = analyze_var_ref(ctx, x, NULL); + } else if (sexp_synclop(x)) { + tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_fv(tmp) = sexp_append2(tmp, + sexp_synclo_free_vars(x), + sexp_context_fv(tmp)); + sexp_context_env(tmp) = sexp_extend_synclo_env(tmp, sexp_synclo_env(x)); + x = sexp_synclo_expr(x); + res = analyze(tmp, x, depth, defok); + } else if (sexp_nullp(x)) { + res = sexp_compile_error(ctx, "empty application in source", x); + } else { + if (sexp_pointerp(x)) /* accept vectors and other literals directly, */ + sexp_immutablep(x) = 1; /* but they must be immutable */ + res = x; + } + +error: + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(res)) + && sexp_pairp(x)) + sexp_exception_source(res) = sexp_pair_source(x); + sexp_gc_release4(ctx); + return res; +} + +sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x, 0, 1);} + +/********************** free varable analysis *************************/ + +static sexp insert_free_var (sexp ctx, sexp x, sexp fv) { + sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; + for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) + if ((name == sexp_ref_name(sexp_car(ls))) + && (loc == sexp_ref_loc(sexp_car(ls)))) + return fv; + return sexp_cons(ctx, x, fv); +} + +static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) { + sexp_gc_var1(res); + if (sexp_nullp(fv2)) + return fv1; + sexp_gc_preserve1(ctx, res); + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release1(ctx); + return res; +} + +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) + if ((sexp_ref_loc(sexp_car(fv)) != lambda) + || (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params) + == SEXP_FALSE)) + sexp_push(ctx, res, sexp_car(fv)); + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) { + sexp_gc_var2(fv1, fv2); + sexp_gc_preserve2(ctx, fv1, fv2); + fv1 = fv; + if (sexp_lambdap(x)) { + fv1 = sexp_free_vars(ctx, sexp_lambda_body(x), SEXP_NULL); + fv2 = sexp_flatten_dot(ctx, sexp_lambda_params(x)); + fv2 = sexp_append2(ctx, sexp_lambda_locals(x), fv2); + fv2 = diff_free_vars(ctx, x, fv1, fv2); + sexp_lambda_fv(x) = fv2; + fv1 = union_free_vars(ctx, fv2, fv); + } else if (sexp_pairp(x)) { + for ( ; sexp_pairp(x); x=sexp_cdr(x)) + fv1 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_cndp(x)) { + fv1 = sexp_free_vars(ctx, sexp_cnd_test(x), fv); + fv1 = sexp_free_vars(ctx, sexp_cnd_pass(x), fv1); + fv1 = sexp_free_vars(ctx, sexp_cnd_fail(x), fv1); + } else if (sexp_seqp(x)) { + for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x)) + fv1 = sexp_free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_setp(x)) { + fv1 = sexp_free_vars(ctx, sexp_set_value(x), fv); + fv1 = sexp_free_vars(ctx, sexp_set_var(x), fv1); + } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { + fv1 = insert_free_var(ctx, x, fv); + } else if (sexp_synclop(x)) { + fv1 = sexp_free_vars(ctx, sexp_synclo_expr(x), fv); + } + sexp_gc_release2(ctx); + return fv1; +} + +/************************ library procedures **************************/ + +sexp sexp_open_input_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp path) { + FILE *in; + int count = 0; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + do { + if (count != 0) sexp_gc(ctx, NULL); + in = fopen(sexp_string_data(path), "r"); + } while (!in && sexp_out_of_file_descriptors() && !count++); + if (!in) + return sexp_file_exception(ctx, self, "couldn't open input file", path); +#if SEXP_USE_GREEN_THREADS + fcntl(fileno(in), F_SETFL, O_NONBLOCK); +#endif + return sexp_make_input_port(ctx, in, path); +} + +sexp sexp_open_output_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp path) { + FILE *out; + int count = 0; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); + do { + if (count != 0) sexp_gc(ctx, NULL); + out = fopen(sexp_string_data(path), "w"); + } while (!out && sexp_out_of_file_descriptors() && !count++); + if (!out) + return sexp_file_exception(ctx, self, "couldn't open output file", path); +#if SEXP_USE_GREEN_THREADS + fcntl(fileno(out), F_SETFL, O_NONBLOCK); +#endif + return sexp_make_output_port(ctx, out, path); +} + +sexp sexp_open_binary_input_file (sexp ctx, sexp self, sexp_sint_t n, sexp path) { + sexp res = sexp_open_input_file_op(ctx, self, n, path); + if (sexp_portp(res)) sexp_port_binaryp(res) = 1; + return res; +} + +sexp sexp_open_binary_output_file (sexp ctx, sexp self, sexp_sint_t n, sexp path) { + sexp res = sexp_open_output_file_op(ctx, self, n, path); + if (sexp_portp(res)) sexp_port_binaryp(res) = 1; + return res; +} + +sexp sexp_close_port_op (sexp ctx, sexp self, sexp_sint_t n, sexp port) { + sexp res = SEXP_VOID; + sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port); + /* we can't run arbitrary scheme code in the finalizer, so we need */ + /* to flush and run the closer here */ + if (sexp_port_customp(port)) { + if (sexp_oportp(port)) res = sexp_flush_output(ctx, port); + if (sexp_exceptionp(res)) return res; + if (sexp_applicablep(sexp_port_closer(port))) + res = sexp_apply1(ctx, sexp_port_closer(port), port); + if (sexp_exceptionp(res)) return res; + } + return sexp_finalize_port(ctx, self, n, port); +} + +sexp sexp_set_port_line_op (sexp ctx, sexp self, sexp_sint_t n, sexp port, sexp line) { + sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, port); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, line); + sexp_port_sourcep(port) = 1; + sexp_port_line(port) = sexp_unbox_fixnum(line); + return SEXP_VOID; +} + +#ifndef PLAN9 +sexp sexp_get_port_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port) { + int fd; + sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port); + fd = sexp_port_fileno(port); + if (fd >= 0) + return sexp_make_fixnum(fd); + return SEXP_FALSE; +} +#endif + +#if SEXP_USE_STATIC_LIBS +#ifndef PLAN9 +#include "clibs.c" +#else +struct sexp_library_entry_t sexp_static_libraries[]; +#endif +static struct sexp_library_entry_t *sexp_find_static_library(const char *file) +{ + size_t base_len; + struct sexp_library_entry_t *entry; + + if (file[0] == '.' && file[1] == '/') + file += 2; + base_len = strlen(file) - strlen(sexp_so_extension); + if (strcmp(file + base_len, sexp_so_extension)) + return NULL; + for (entry = &sexp_static_libraries[0]; entry->name; entry++) + if (! strncmp(file, entry->name, base_len)) + return entry; + return NULL; +} +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + struct sexp_library_entry_t *entry = sexp_find_static_library(sexp_string_data(file)); + if (! entry) + return sexp_compile_error(ctx, "couldn't find builtin library", file); + return entry->init(ctx, NULL, 3, env, sexp_version, SEXP_ABI_IDENTIFIER); +} +#else +#define sexp_find_static_library(path) NULL +#if SEXP_USE_DL +#ifdef __MINGW32__ +#include +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp res; + sexp_init_proc init; + HINSTANCE handle = LoadLibraryA(sexp_string_data(file)); + if(!handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = (sexp_init_proc) GetProcAddress(handle, "sexp_init_library"); + if(!init) { + FreeLibrary(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + res = init(ctx, NULL, 3, env, sexp_version, SEXP_ABI_IDENTIFIER); + if (res == SEXP_ABI_ERROR) res = sexp_global(ctx, SEXP_G_ABI_ERROR); + return res; +} +#else +static sexp sexp_make_dl (sexp ctx, sexp file, void* handle) { + sexp res = sexp_alloc_type(ctx, dl, SEXP_DL); + sexp_dl_file(res) = file; + sexp_dl_handle(res) = handle; + return res; +} +static sexp sexp_load_dl (sexp ctx, sexp file, sexp env) { + sexp_init_proc init; + sexp_gc_var2(res, old_dl); + void *handle = dlopen(sexp_string_data(file), RTLD_LAZY); + if (! handle) + return sexp_compile_error(ctx, "couldn't load dynamic library", file); + init = dlsym(handle, "sexp_init_library"); + if (! init) { + dlclose(handle); + return sexp_compile_error(ctx, "dynamic library has no sexp_init_library", file); + } + sexp_gc_preserve2(ctx, res, old_dl); + old_dl = sexp_context_dl(ctx); + sexp_context_dl(ctx) = sexp_make_dl(ctx, file, handle); + res = init(ctx, NULL, 3, env, sexp_version, SEXP_ABI_IDENTIFIER); + /* If the ABI is incompatible the library may not even be able to + properly reference a global, so it returns a special immediate + which we need to translate. */ + if (res == SEXP_ABI_ERROR) res = sexp_global(ctx, SEXP_G_ABI_ERROR); + sexp_context_dl(ctx) = old_dl; + sexp_gc_release2(ctx); + return res; +} +#endif +#endif +#endif + +sexp sexp_load_op (sexp ctx, sexp self, sexp_sint_t n, sexp source, sexp env) { +#if SEXP_USE_DL || SEXP_USE_STATIC_LIBS + const char *suffix; +#endif + sexp_gc_var5(ctx2, x, in, res, out); + if (!env) env = sexp_context_env(ctx); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); +#if SEXP_USE_DL || SEXP_USE_STATIC_LIBS + suffix = sexp_stringp(source) ? sexp_string_data(source) + + sexp_string_size(source) - strlen(sexp_so_extension) : "..."; + if (strcmp(suffix, sexp_so_extension) == 0) { + res = sexp_load_dl(ctx, source, env); + } else { +#endif + res = SEXP_VOID; + if (sexp_iportp(source)) { + in = source; + } else { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source); + in = sexp_open_input_file(ctx, source); + } + sexp_gc_preserve5(ctx, ctx2, x, in, res, out); + if (sexp_exceptionp(in)) { + out = sexp_current_error_port(ctx); + if (sexp_not(out)) out = sexp_current_error_port(ctx); + if (sexp_oportp(out)) + sexp_print_exception(ctx, in, out); + res = in; + } else { + sexp_port_sourcep(in) = 1; + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0); + sexp_context_parent(ctx2) = ctx; + sexp_context_tailp(ctx2) = 0; + while ((x=sexp_read(ctx2, in)) != (sexp) SEXP_EOF) { + res = sexp_exceptionp(x) ? x : sexp_eval(ctx2, x, env); + if (sexp_exceptionp(res)) + break; + } + sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2); + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); + } + sexp_gc_release5(ctx); +#if SEXP_USE_DL || SEXP_USE_STATIC_LIBS + } +#endif + return res; +} + +sexp sexp_register_optimization (sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp priority) { + sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, f); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, priority); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), SEXP_VOID); + sexp_car(sexp_global(ctx, SEXP_G_OPTIMIZATIONS)) = sexp_cons(ctx, priority, f); + return SEXP_VOID; +} + +#if SEXP_USE_MATH + +#if SEXP_USE_BIGNUMS +#define maybe_convert_bignum(z) \ + else if (sexp_bignump(z)) d = sexp_bignum_to_double(z); +#else +#define maybe_convert_bignum(z) +#endif + +#if SEXP_USE_RATIOS +#define maybe_convert_ratio(z) \ + else if (sexp_ratiop(z)) d = sexp_ratio_to_double(z); +#else +#define maybe_convert_ratio(z) +#endif + +#if SEXP_USE_COMPLEX +#define maybe_convert_complex(z, f) \ + else if (sexp_complexp(z)) return sexp_complex_normalize(f(ctx, z)); +#define sexp_complex_dummy(ctx, z) 0 +#else +#define maybe_convert_complex(z, f) +#endif + +#define define_math_op(name, cname, f) \ + sexp name (sexp ctx, sexp self, sexp_sint_t n, sexp z) { \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_fixnump(z)) \ + d = (double)sexp_unbox_fixnum(z); \ + maybe_convert_ratio(z) \ + maybe_convert_bignum(z) \ + maybe_convert_complex(z, f) \ + else \ + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \ + return sexp_make_flonum(ctx, cname(d)); \ + } + +define_math_op(sexp_exp, exp, sexp_complex_exp) +define_math_op(sexp_sin, sin, sexp_complex_sin) +define_math_op(sexp_cos, cos, sexp_complex_cos) +define_math_op(sexp_tan, tan, sexp_complex_tan) +define_math_op(sexp_asin, asin, sexp_complex_asin) +define_math_op(sexp_acos, acos, sexp_complex_acos) +define_math_op(sexp_atan, atan, sexp_complex_atan) + +#if SEXP_USE_RATIOS +#define maybe_round_ratio(ctx, q, f) \ + if (sexp_ratiop(q)) return f(ctx, q); +#else +#define maybe_round_ratio(ctx, q, f) +#endif + +#define define_math_rounder(name, cname, f) \ + sexp name (sexp ctx, sexp self, sexp_sint_t n, sexp z) { \ + maybe_round_ratio(ctx, z, f) \ + if (sexp_flonump(z)) \ + return sexp_make_flonum(ctx, cname(sexp_flonum_value(z))); \ + else if (sexp_fixnump(z) || sexp_bignump(z)) \ + return z; \ + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); \ + } + +static double even_round (double d) { + double res = round(d); + if (fabs(d - res) == 0.5 && ((long)res & 1)) + res += (res < 0) ? 1 : -1; + return res; +} + +define_math_rounder(sexp_round, even_round, sexp_ratio_round) +define_math_rounder(sexp_trunc, trunc, sexp_ratio_trunc) +define_math_rounder(sexp_floor, floor, sexp_ratio_floor) +define_math_rounder(sexp_ceiling, ceil, sexp_ratio_ceiling) + +sexp sexp_log (sexp ctx, sexp self, sexp_sint_t n, sexp z) { + double d; +#if SEXP_USE_COMPLEX + sexp_gc_var1(tmp); + if (sexp_complexp(z)) + return sexp_complex_log(ctx, z); +#endif + if (sexp_flonump(z)) + d = sexp_flonum_value(z); + else if (sexp_fixnump(z)) + d = (double)sexp_unbox_fixnum(z); + maybe_convert_ratio(z) + maybe_convert_bignum(z) + else + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); +#if SEXP_USE_COMPLEX + if (d < 0) { + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_make_flonum(ctx, d); + tmp = sexp_make_complex(ctx, tmp, SEXP_ZERO); + tmp = sexp_complex_log(ctx, tmp); + sexp_gc_release1(ctx); + return tmp; + } +#endif + return sexp_make_flonum(ctx, log(d)); +} + +sexp sexp_inexact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) { +#if SEXP_USE_COMPLEX + int negativep = 0; +#endif + double d, r; + sexp_gc_var1(res); + if (sexp_flonump(z)) + d = sexp_flonum_value(z); + else if (sexp_fixnump(z)) + d = (double)sexp_unbox_fixnum(z); + maybe_convert_ratio(z) /* XXXX add ratio sqrt */ + maybe_convert_complex(z, sexp_complex_sqrt) + else + return sexp_type_exception(ctx, self, SEXP_NUMBER, z); +#if SEXP_USE_COMPLEX + if (d < 0) { + negativep = 1; + d = -d; + } +#endif + sexp_gc_preserve1(ctx, res); + r = sqrt(d); + if (sexp_fixnump(z) + && (((sexp_uint_t)r*(sexp_uint_t)r)==abs(sexp_unbox_fixnum(z)))) + res = sexp_make_fixnum(round(r)); + else + res = sexp_make_flonum(ctx, r); +#if SEXP_USE_COMPLEX + if (negativep) + res = sexp_make_complex(ctx, SEXP_ZERO, res); +#endif + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_BIGNUMS +sexp sexp_exact_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) { + sexp_gc_var2(res, rem); + sexp_gc_preserve2(ctx, res, rem); + if (sexp_bignump(z)) { + res = sexp_bignum_sqrt(ctx, z, &rem); + res = sexp_cons(ctx, res, rem); + } else { + res = sexp_inexact_sqrt(ctx, self, n, z); + if (sexp_flonump(res)) { + res = sexp_bignum_normalize(sexp_double_to_bignum(ctx, trunc(sexp_flonum_value(res)))); + } + if (!sexp_exceptionp(res)) { + rem = sexp_mul(ctx, res, res); + rem = sexp_sub(ctx, z, rem); + res = sexp_cons(ctx, res, rem); + } + } + sexp_gc_release2(ctx); + return res; +} +#endif + +sexp sexp_sqrt (sexp ctx, sexp self, sexp_sint_t n, sexp z) { +#if SEXP_USE_BIGNUMS + sexp_gc_var2(res, rem); + if (sexp_bignump(z)) { + sexp_gc_preserve2(ctx, res, rem); + res = sexp_bignum_sqrt(ctx, z, &rem); + rem = sexp_bignum_normalize(rem); + if (rem != SEXP_ZERO) + res = sexp_make_flonum(ctx, sexp_fixnump(res) ? sexp_unbox_fixnum(res) : sexp_bignum_to_double(res)); + sexp_gc_release2(ctx); + return res; + } +#endif + return sexp_inexact_sqrt(ctx, self, n, z); +} + +#endif /* SEXP_USE_MATH */ + +#if SEXP_USE_RATIOS || !SEXP_USE_FLONUMS +sexp sexp_generic_expt (sexp ctx, sexp x, sexp_sint_t e) { + sexp_gc_var2(res, tmp); + sexp_gc_preserve2(ctx, res, tmp); + for (res = SEXP_ONE, tmp = x; e > 0; e >>= 1) { + if (e&1) res = sexp_mul(ctx, res, tmp); + tmp = sexp_mul(ctx, tmp, tmp); + } + sexp_gc_release2(ctx); + return res; +} +#endif + +sexp sexp_expt_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) { +#if !SEXP_USE_FLONUMS + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, x); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, e); + return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e)); +#else + long double f, x1, e1; + sexp res; +#if SEXP_USE_BIGNUMS + sexp_gc_var1(tmp); +#endif +#if SEXP_USE_COMPLEX + if (sexp_complexp(x) || sexp_complexp(e)) + return sexp_complex_expt(ctx, x, e); +#endif +#if SEXP_USE_BIGNUMS + if (sexp_bignump(e)) { /* bignum exponent needs special handling */ + if ((x == SEXP_ZERO) || (x == SEXP_NEG_ONE)) + res = sexp_make_flonum(ctx, pow(0, 0)); /* +nan.0 */ + else if (x == SEXP_ONE) + res = SEXP_ONE; /* 1.0 */ + else if (sexp_flonump(x)) + res = sexp_make_flonum(ctx, pow(sexp_flonum_value(x), sexp_bignum_to_double(e))); + else + res = sexp_make_flonum(ctx, pow(10.0, 1e100)); /* +inf.0 */ + } else if (sexp_bignump(x)) { + res = sexp_bignum_expt(ctx, x, e); + } else { +#endif + if (sexp_fixnump(x)) + x1 = sexp_unbox_fixnum(x); + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#if SEXP_USE_RATIOS + else if (sexp_ratiop(x)) { + if (sexp_fixnump(e)) { + return sexp_generic_expt(ctx, x, sexp_unbox_fixnum(e)); + } else { + x1 = sexp_ratio_to_double(x); + } + } +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, x); + if (sexp_fixnump(e)) + e1 = sexp_unbox_fixnum(e); + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#if SEXP_USE_RATIOS + else if (sexp_ratiop(e)) + e1 = sexp_ratio_to_double(e); +#endif + else + return sexp_type_exception(ctx, self, SEXP_FIXNUM, e); + f = pow(x1, e1); + if ((f*1000.0 > SEXP_MAX_FIXNUM) || (f*1000.0 < SEXP_MIN_FIXNUM) + || (! sexp_fixnump(x)) || (! sexp_fixnump(e))) { +#if SEXP_USE_BIGNUMS + if (sexp_fixnump(x) && sexp_fixnump(e)) { + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_fixnum_to_bignum(ctx, x); + res = sexp_bignum_expt(ctx, tmp, e); + sexp_gc_release1(ctx); + } else +#endif + res = sexp_make_flonum(ctx, f); + } else + res = sexp_make_fixnum((sexp_sint_t)round(f)); +#if SEXP_USE_BIGNUMS + } +#endif + return res; +#endif /* !SEXP_USE_FLONUMS */ +} + +#if SEXP_USE_RATIOS +sexp sexp_ratio_numerator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat) { + sexp_assert_type(ctx, sexp_ratiop, SEXP_RATIO, rat); + return sexp_ratio_numerator(rat); +} +sexp sexp_ratio_denominator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat) { + sexp_assert_type(ctx, sexp_ratiop, SEXP_RATIO, rat); + return sexp_ratio_denominator(rat); +} +#endif + +#if SEXP_USE_COMPLEX +sexp sexp_complex_real_op (sexp ctx, sexp self, sexp_sint_t n, sexp cpx) { + sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx); + return sexp_complex_real(cpx); +} +sexp sexp_complex_imag_op (sexp ctx, sexp self, sexp_sint_t n, sexp cpx) { + sexp_assert_type(ctx, sexp_complexp, SEXP_COMPLEX, cpx); + return sexp_complex_imag(cpx); +} +#endif + +sexp sexp_exact_to_inexact (sexp ctx, sexp self, sexp_sint_t n, sexp i) { + sexp_gc_var1(res); + res = i; + if (sexp_fixnump(i)) + res = sexp_fixnum_to_flonum(ctx, i); +#if SEXP_USE_FLONUMS + else if (sexp_flonump(i)) + res = i; +#endif +#if SEXP_USE_BIGNUMS + else if (sexp_bignump(i)) + res = sexp_make_flonum(ctx, sexp_bignum_to_double(i)); +#endif +#if SEXP_USE_RATIOS + else if (sexp_ratiop(i)) + res = sexp_make_flonum(ctx, sexp_ratio_to_double(i)); +#endif +#if SEXP_USE_COMPLEX + else if (sexp_complexp(i)) { + sexp_gc_preserve1(ctx, res); + res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO); + sexp_complex_real(res) = sexp_exact_to_inexact(ctx, self, 1, sexp_complex_real(i)); + sexp_complex_imag(res) = sexp_exact_to_inexact(ctx, self, 1, sexp_complex_imag(i)); + sexp_gc_release1(ctx); + } +#endif + else + res = sexp_type_exception(ctx, self, SEXP_FIXNUM, i); + return res; +} + +sexp sexp_inexact_to_exact (sexp ctx, sexp self, sexp_sint_t n, sexp z) { + sexp_gc_var1(res); + if (sexp_exactp(z)) { + res = z; + } +#if SEXP_USE_FLONUMS + else if (sexp_flonump(z)) { + if (isinf(sexp_flonum_value(z)) || isnan(sexp_flonum_value(z))) { + res = sexp_xtype_exception(ctx, self, "exact: not an finite number", z); + } else if (sexp_flonum_value(z) != trunc(sexp_flonum_value(z))) { +#if SEXP_USE_RATIOS + res = sexp_double_to_ratio(ctx, sexp_flonum_value(z)); +#else + res = sexp_xtype_exception(ctx, self, "exact: not an integer", z); +#endif +#if SEXP_USE_BIGNUMS + } else if ((sexp_flonum_value(z) > SEXP_MAX_FIXNUM) + || sexp_flonum_value(z) < SEXP_MIN_FIXNUM) { + res = sexp_double_to_bignum(ctx, sexp_flonum_value(z)); +#endif + } else { + res = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(z)); + } + } +#endif +#if SEXP_USE_COMPLEX + else if (sexp_complexp(z)) { + sexp_gc_preserve1(ctx, res); + res = sexp_make_complex(ctx, SEXP_ZERO, SEXP_ZERO); + sexp_complex_real(res) = sexp_inexact_to_exact(ctx, self, 1, sexp_complex_real(z)); + sexp_complex_imag(res) = sexp_inexact_to_exact(ctx, self, 1, sexp_complex_imag(z)); + sexp_gc_release1(ctx); + } +#endif + else { + res = sexp_type_exception(ctx, self, SEXP_FLONUM, z); + } + return res; +} + +sexp sexp_string_cmp_op (sexp ctx, sexp self, sexp_sint_t n, sexp str1, sexp str2, sexp ci) { + sexp_sint_t len1, len2, len, diff; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str1); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str2); + len1 = sexp_string_size(str1); + len2 = sexp_string_size(str2); + len = ((len1= sexp_string_size(str)) + return sexp_user_exception(ctx, self, "string-ref: index out of range", i); + return sexp_string_utf8_ref(ctx, str, off); +} + +sexp sexp_read_utf8_char (sexp ctx, sexp port, int i) { + if (i >= 0x80) { + if ((i < 0xC0) || (i > 0xF7)) { + return sexp_user_exception(ctx, NULL, "read-char: invalid utf8 byte", sexp_make_fixnum(i)); + } else if (i < 0xE0) { + i = ((i&0x3F)<<6) + (sexp_read_char(ctx, port)&0x3F); + } else if (i < 0xF0) { + i = ((i&0x1F)<<12) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += sexp_read_char(ctx, port)&0x3F; + } else { + i = ((i&0x0F)<<16) + ((sexp_read_char(ctx, port)&0x3F)<<6); + i += (sexp_read_char(ctx, port)&0x3F)<<6; + i += sexp_read_char(ctx, port)&0x3F; + } + } + return sexp_make_character(i); +} + +#if SEXP_USE_MUTABLE_STRINGS + +void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch) { + sexp b; + unsigned char *p, *q; + int i = sexp_unbox_fixnum(index), c = sexp_unbox_character(ch), + old_len, new_len, len; + p = (unsigned char*)sexp_string_data(str) + i; + old_len = sexp_utf8_initial_byte_count(*p); + new_len = sexp_utf8_char_byte_count(c); + if (old_len != new_len) { /* resize bytes if needed */ + len = sexp_string_size(str)+(new_len-old_len); + b = sexp_make_bytes(ctx, sexp_make_fixnum(len), SEXP_VOID); + if (! sexp_exceptionp(b)) { + q = (unsigned char*)sexp_bytes_data(b); + memcpy(q, sexp_string_data(str), i); + memcpy(q+i+new_len, p+old_len, len-i-new_len+1); + sexp_string_bytes(str) = b; + p = q + i; + } + sexp_string_size(str) += new_len - old_len; + } + sexp_utf8_encode_char(p, new_len, c); +} + +sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch) { + sexp off; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch); + off = sexp_string_index_to_offset(ctx, self, n, str, i); + if (sexp_exceptionp(off)) return off; + if (sexp_unbox_fixnum(off) >= sexp_string_size(str)) + return sexp_user_exception(ctx, self, "string-set!: index out of range", i); + sexp_string_utf8_set(ctx, str, off, ch); + return SEXP_VOID; +} + +#endif +#endif + +#if SEXP_USE_AUTO_FORCE +sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val) { + sexp res = sexp_alloc_type(ctx, promise, SEXP_PROMISE); + sexp_promise_donep(res) = sexp_unbox_boolean(done); + sexp_promise_value(res) = val; + return res; +} +#endif + +/***************************** opcodes ********************************/ + +#if SEXP_USE_TYPE_DEFS + +sexp sexp_type_slot_offset_op (sexp ctx , sexp self, sexp_sint_t n, sexp type, sexp slot) { + sexp cpl, slots, *v; + int i, offset=0, len; + sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, type); + cpl = sexp_type_cpl(type); + if (sexp_vectorp(cpl)) { + v = sexp_vector_data(cpl); + len = sexp_vector_length(cpl); + } else { + v = &sexp_type_slots(type); + len = 1; + } + len = sexp_vectorp(cpl) ? sexp_vector_length(cpl) : 1; + for (i=0; ivalue), core, sizeof(core[0])); + return res; +} + +static sexp sexp_copy_opcode (sexp ctx, struct sexp_opcode_struct *op) { + sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + memcpy(&(res->value), op, sizeof(op[0])); + return res; +} + +sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code, + sexp num_args, sexp flags, sexp arg1t, sexp arg2t, + sexp invp, sexp data, sexp data2, sexp_proc1 func) { + sexp res; + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, num_args); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, flags); + if ((! sexp_fixnump(op_class)) || (sexp_unbox_fixnum(op_class) <= 0) + || (sexp_unbox_fixnum(op_class) >= SEXP_OPC_NUM_OP_CLASSES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode class", op_class); + else if ((! sexp_fixnump(code)) || (sexp_unbox_fixnum(code) <= 0) + || (sexp_unbox_fixnum(code) >= SEXP_OP_NUM_OPCODES)) + res = sexp_xtype_exception(ctx, self, "make-opcode: bad opcode", code); + else { + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = sexp_unbox_fixnum(op_class); + sexp_opcode_code(res) = sexp_unbox_fixnum(code); + sexp_opcode_num_args(res) = sexp_unbox_fixnum(num_args); + sexp_opcode_flags(res) = sexp_unbox_fixnum(flags); + sexp_opcode_arg1_type(res) = arg1t; + sexp_opcode_arg2_type(res) = arg2t; + sexp_opcode_inverse(res) = sexp_unbox_fixnum(invp); + sexp_opcode_data(res) = data; + sexp_opcode_data2(res) = data2; + sexp_opcode_func(res) = func; + sexp_opcode_name(res) = name; +#if SEXP_USE_DL + sexp_opcode_dl(res) = sexp_context_dl(ctx); +#endif + } + return res; +} + +sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); +#if ! SEXP_USE_EXTENDED_FCALL + if (num_args > 4) + return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit", + sexp_make_fixnum(num_args)); +#endif + res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + sexp_opcode_class(res) = SEXP_OPC_FOREIGN; +#if SEXP_USE_EXTENDED_FCALL + if (num_args > 4) + sexp_opcode_code(res) = SEXP_OP_FCALLN; + else +#endif + sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1; + if (flags & 1) num_args--; + sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; + sexp_opcode_name(res) = sexp_c_string(ctx, name, -1); + sexp_opcode_data(res) = data; + sexp_opcode_func(res) = f; +#if SEXP_USE_DL + sexp_opcode_dl(res) = sexp_context_dl(ctx); +#endif + sexp_gc_release1(ctx); + return res; +} + +sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { + sexp_gc_var2(sym, res); + sexp_gc_preserve2(ctx, sym, res); + res = sexp_make_foreign(ctx, name, num_args, flags, f, data); + if (!sexp_exceptionp(res)) + sexp_env_define(ctx, env, sym = sexp_intern(ctx, name, -1), res); + sexp_gc_release2(ctx); + return res; +} + +sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, + int num_args, sexp_proc1 f, const char *param) { + sexp res = SEXP_FALSE; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_intern(ctx, param, -1); + tmp = sexp_env_ref(ctx, env, tmp, SEXP_FALSE); + if (sexp_opcodep(tmp)) + res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); + sexp_gc_release1(ctx); + return res; +} + +/*********************** standard environment *************************/ + +/* The 10 core forms. Note quote can be defined as derived syntax: */ + +/* (define-syntax quote */ +/* (lambda (expr use-env mac-env) */ +/* (list */ +/* (make-syntactic-closure mac-env (list) (syntax-quote syntax-quote)) */ +/* (strip-syntactic-closures (car (cdr expr)))))) */ + +static struct sexp_core_form_struct core_forms[] = { + {SEXP_CORE_DEFINE, (sexp)"define"}, + {SEXP_CORE_SET, (sexp)"set!"}, + {SEXP_CORE_LAMBDA, (sexp)"lambda"}, + {SEXP_CORE_IF, (sexp)"if"}, + {SEXP_CORE_BEGIN, (sexp)"begin"}, + {SEXP_CORE_QUOTE, (sexp)"quote"}, + {SEXP_CORE_SYNTAX_QUOTE, (sexp)"syntax-quote"}, + {SEXP_CORE_DEFINE_SYNTAX, (sexp)"define-syntax"}, + {SEXP_CORE_LET_SYNTAX, (sexp)"let-syntax"}, + {SEXP_CORE_LETREC_SYNTAX, (sexp)"letrec-syntax"}, +}; + +sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) { + sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_lambda(e) = NULL; + sexp_env_parent(e) = NULL; + sexp_env_bindings(e) = SEXP_NULL; +#if SEXP_USE_RENAME_BINDINGS + sexp_env_renames(e) = SEXP_NULL; +#endif + return e; +} + +sexp sexp_make_null_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) { + sexp_uint_t i; + sexp_gc_var2(e, core); + sexp_gc_preserve2(ctx, e, core); + e = sexp_make_env(ctx); + for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) { + core = sexp_copy_core(ctx, &core_forms[i]); + sexp_env_define(ctx, e, sexp_intern(ctx, (char*)sexp_core_name(core), -1), core); + sexp_core_name(core) = sexp_c_string(ctx, (char*)sexp_core_name(core), -1); + } + sexp_gc_release2(ctx); + return e; +} + +sexp sexp_make_primitive_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) { + int i; + sexp_gc_var4(e, op, sym, name); + sexp_gc_preserve4(ctx, e, op, sym, name); + e = sexp_make_null_env(ctx, version); + for (i=0; sexp_primitive_opcodes[i].op_class; i++) { + op = sexp_copy_opcode(ctx, &sexp_primitive_opcodes[i]); + name = sexp_intern(ctx, (char*)sexp_opcode_name(op), -1); + sexp_opcode_name(op) = sexp_c_string(ctx, (char*)sexp_opcode_name(op), -1); + if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1); + sexp_opcode_data(op) = sexp_env_ref(ctx, e, sym, SEXP_FALSE); + } else if (sexp_opcode_class(op) == SEXP_OPC_PARAMETER) { + sexp_opcode_data(op) = sexp_cons(ctx, name, SEXP_FALSE); + } + if (sexp_opcode_class(op) == SEXP_OPC_FOREIGN && sexp_opcode_data2(op)) { + sexp_opcode_data2(op) = sexp_c_string(ctx, (char*)sexp_opcode_data2(op), -1); + } + sexp_env_define(ctx, e, name, op); + } + sexp_gc_release4(ctx); + return e; +} + +sexp sexp_find_module_file (sexp ctx, const char *file) { + sexp res=SEXP_FALSE, ls; + char *dir, *path; + sexp_uint_t slash, dirlen, filelen, len; +#ifdef PLAN9 +#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0) + unsigned char buf[128]; +#else +#define file_exists_p(path, buf) (! stat(path, buf)) + struct stat buf_str; + struct stat *buf = &buf_str; +#endif + + filelen = strlen(file); + + ls = sexp_global(ctx, SEXP_G_MODULE_PATH); + for ( ; sexp_pairp(ls) && sexp_not(res); ls=sexp_cdr(ls)) { + dir = sexp_string_data(sexp_car(ls)); + dirlen = sexp_string_size(sexp_car(ls)); + slash = dir[dirlen-1] == '/'; + len = dirlen+filelen+2-slash; + path = (char*) sexp_malloc(len); + if (! path) return sexp_global(ctx, SEXP_G_OOM_ERROR); + memcpy(path, dir, dirlen); + if (! slash) path[dirlen] = '/'; + memcpy(path+len-filelen-1, file, filelen); + path[len-1] = '\0'; + if (sexp_find_static_library(path) || file_exists_p(path, buf)) + res = sexp_c_string(ctx, path, len-1); + free(path); + } + + return res; +} + +#define sexp_file_not_found "couldn't find file in module path" + +sexp sexp_load_module_file (sexp ctx, const char *file, sexp env) { + sexp res; + sexp_gc_var1(path); + sexp_gc_preserve1(ctx, path); + path = sexp_find_module_file(ctx, file); + if (sexp_stringp(path)) { + res = sexp_load(ctx, path, env); + } else { + path = sexp_c_string(ctx, file, -1); + res = sexp_user_exception(ctx, SEXP_FALSE, sexp_file_not_found, path); + } + sexp_gc_release1(ctx); + return res; +} + +#if SEXP_USE_MODULES +sexp sexp_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x) { + if (sexp_pairp(x) && sexp_stringp(sexp_car(x))) { + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_reverse(ctx, x); + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_reverse(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH)); + } + return sexp_global(ctx, SEXP_G_MODULE_PATH); +} +sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + return sexp_find_module_file(ctx, sexp_string_data(file)); +} +sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, file); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + return sexp_load_module_file(ctx, sexp_string_data(file), env); +} +sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n) { + return sexp_context_env(ctx); +} +sexp sexp_set_current_environment (sexp ctx, sexp self, sexp_sint_t n, sexp env) { + sexp oldenv; + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + oldenv = sexp_context_env(ctx); + sexp_context_env(ctx) = env; + return oldenv; +} +sexp sexp_meta_environment (sexp ctx, sexp self, sexp_sint_t n) { + return sexp_global(ctx, SEXP_G_META_ENV); +} +#endif + +sexp sexp_add_module_directory_op (sexp ctx, sexp self, sexp_sint_t n, sexp dir, sexp appendp) { + sexp ls; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dir); + if (sexp_truep(appendp)) { + if (sexp_pairp(ls=sexp_global(ctx, SEXP_G_MODULE_PATH))) { + for ( ; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) + ; + sexp_cdr(ls) = sexp_list1(ctx, dir); + } else { + sexp_global(ctx, SEXP_G_MODULE_PATH) = sexp_list1(ctx, dir); + } + } else { + sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), dir); + } + return SEXP_VOID; +} + +sexp sexp_parameter_ref (sexp ctx, sexp param) { +#if SEXP_USE_GREEN_THREADS + sexp ls; + for (ls=sexp_context_params(ctx); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (sexp_caar(ls) == param) + return sexp_cdar(ls); +#endif + return sexp_opcodep(param) && sexp_opcode_data(param) && sexp_pairp(sexp_opcode_data(param)) + ? sexp_cdr(sexp_opcode_data(param)) : SEXP_FALSE; +} + +#if SEXP_USE_GREEN_THREADS +sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val) { + if (sexp_not(val)) { + return sexp_context_dk(ctx) ? sexp_context_dk(ctx) : SEXP_FALSE; + } else { + sexp_context_dk(ctx) = val; + return SEXP_VOID; + } +} +#endif + +sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n) { + sexp res = sexp_context_params(ctx); + return res ? res : SEXP_NULL; +} + +sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp new) { + sexp_context_params(ctx) = new; + return SEXP_VOID; +} + +void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value) { + sexp param = sexp_env_ref(ctx, env, name, SEXP_FALSE); + if (sexp_opcodep(param)) { + if (! sexp_pairp(sexp_opcode_data(param))) + sexp_opcode_data(param) = sexp_cons(ctx, name, value); + else + sexp_cdr(sexp_opcode_data(param)) = value; + } else { + sexp_warn(ctx, "can't set non-parameter: ", name); + } +} + +sexp sexp_load_standard_ports (sexp ctx, sexp env, FILE* in, FILE* out, + FILE* err, int no_close) { + sexp_gc_var1(p); + sexp_gc_preserve1(ctx, p); + if (!env) env = sexp_context_env(ctx); + if (in) { + p = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_no_closep(p) = no_close; + sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), p); + } + if (out) { + p = sexp_make_output_port(ctx, out, SEXP_FALSE); + sexp_port_no_closep(p) = no_close; + sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), p); + } + if (err) { + p = sexp_make_output_port(ctx, err, SEXP_FALSE); + sexp_port_no_closep(p) = no_close; + sexp_set_parameter(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), p); + } + sexp_gc_release1(ctx); + return SEXP_VOID; +} + +static const char* sexp_initial_features[] = { + sexp_platform, +#if SEXP_BSD + "bsd", +#endif +#if defined(_WIN32) || defined(__MINGW32__) + "windows", +#endif +#if SEXP_USE_DL + "dynamic-loading", +#endif +#if SEXP_USE_BIDIRECTIONAL_PORTS + "bidir-ports", +#endif +#if SEXP_USE_STRING_STREAMS + "string-streams", +#endif +#if SEXP_USE_MODULES + "modules", +#endif +#if SEXP_USE_BOEHM + "boehm-gc", +#endif +#if SEXP_USE_UTF8_STRINGS + "full-unicode", +#endif +#if SEXP_USE_GREEN_THREADS + "threads", +#endif +#if SEXP_USE_NTP_GETTIME + "ntp", +#endif +#if SEXP_USE_AUTO_FORCE + "auto-force", +#endif +#if SEXP_USE_COMPLEX + "complex", +#endif +#if SEXP_USE_RATIOS + "ratios", +#endif + "r7rs", + "chibi", + NULL, +}; + +sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { + int len; + char init_file[128]; + const char** features; + int endianess_check = 1; + sexp_gc_var3(op, tmp, sym); + sexp_gc_preserve3(ctx, op, tmp, sym); + if (!e) e = sexp_context_env(ctx); + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1), + tmp=sexp_c_string(ctx, sexp_so_extension, -1)); + tmp = SEXP_NULL; + sexp_push(ctx, tmp, sym=sexp_intern(ctx, (*(unsigned char*) &endianess_check) ? "little-endian" : "big-endian", -1)); + for (features=sexp_initial_features; *features; features++) + sexp_push(ctx, tmp, sym=sexp_intern(ctx, *features, -1)); + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*features*", -1), tmp); + sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; +#if SEXP_USE_SIMPLIFY + op = sexp_make_foreign(ctx, "sexp_simplify", 1, 0, + (sexp_proc1)sexp_simplify, SEXP_VOID); + tmp = sexp_cons(ctx, sexp_make_fixnum(500), op); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp); +#endif + sexp_global(ctx, SEXP_G_ERR_HANDLER) + = sexp_env_ref(ctx, e, sym=sexp_intern(ctx, "current-exception-handler", -1), SEXP_FALSE); + /* load init.scm */ + len = strlen(sexp_init_file); + strncpy(init_file, sexp_init_file, len); + init_file[len] = sexp_unbox_fixnum(version) + '0'; + strncpy(init_file + len + 1, sexp_init_file_suffix, strlen(sexp_init_file_suffix)); + init_file[len + 1 + strlen(sexp_init_file_suffix)] = 0; + tmp = sexp_load_module_file(ctx, init_file, e); + sexp_set_parameter(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); + /* load and bind config env */ +#if SEXP_USE_MODULES + if (!sexp_exceptionp(tmp)) { + if (!sexp_envp(tmp=sexp_global(ctx, SEXP_G_META_ENV))) { + tmp = sexp_make_env(ctx); + if (! sexp_exceptionp(tmp)) { + sexp_global(ctx, SEXP_G_META_ENV) = tmp; + sexp_env_parent(tmp) = e; + op = sexp_load_module_file(ctx, sexp_meta_file, tmp); + if (sexp_exceptionp(op)) + sexp_print_exception(ctx, op, sexp_current_error_port(ctx)); + } + } + if (!sexp_exceptionp(tmp)) { + sym = sexp_intern(ctx, "repl-import", -1); + tmp = sexp_env_ref(ctx, tmp, sym, SEXP_VOID); + sym = sexp_intern(ctx, "import", -1); + sexp_env_define(ctx, e, sym, tmp); + } + } +#endif + sexp_gc_release3(ctx); + return sexp_exceptionp(tmp) ? tmp : e; +} + +sexp sexp_make_standard_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp version) { + sexp_gc_var1(env); + sexp_gc_preserve1(ctx, env); + env = sexp_make_primitive_env(ctx, version); + if (! sexp_exceptionp(env)) env = sexp_load_standard_env(ctx, env, SEXP_SEVEN); + sexp_gc_release1(ctx); + return env; +} + +#if SEXP_USE_RENAME_BINDINGS +#define sexp_same_bindingp(x, y) ((x) == (y)) +#else +#define sexp_same_bindingp(x, y) (sexp_env_value(x) == sexp_env_value(y)) +#endif + +/* Rewrite to in place: to => empty->imports->to */ +sexp sexp_env_import_op (sexp ctx, sexp self, sexp_sint_t n, sexp to, sexp from, sexp ls, sexp immutp) { + sexp oldname, newname; + sexp_gc_var3(value, oldcell, tmp); + sexp_gc_preserve3(ctx, value, oldcell, tmp); + if (! sexp_envp(to)) to = sexp_context_env(ctx); + if (! sexp_envp(from)) from = sexp_context_env(ctx); + /* create an empty imports env frame */ + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_parent(to) = value; + sexp_env_lambda(value) = sexp_env_lambda(to); + sexp_env_lambda(to) = NULL; + sexp_env_bindings(value) = sexp_env_bindings(to); + sexp_env_bindings(to) = SEXP_NULL; +#if SEXP_USE_RENAME_BINDINGS + sexp_env_renames(value) = sexp_env_renames(to); + sexp_env_renames(to) = SEXP_NULL; +#endif + sexp_immutablep(value) = sexp_immutablep(to); + sexp_immutablep(to) = sexp_truep(immutp); + /* import the bindings, one at a time or in bulk */ + if (sexp_not(ls)) { + sexp_env_bindings(to) = sexp_env_bindings(from); +#if SEXP_USE_RENAME_BINDINGS + sexp_env_renames(to) = sexp_env_renames(from); +#endif + } else { + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (sexp_pairp(sexp_car(ls))) { + newname = sexp_caar(ls); oldname = sexp_cdar(ls); + } else { + newname = oldname = sexp_car(ls); + } + oldcell = sexp_env_cell(ctx, to, newname, 0); + value = sexp_env_cell(ctx, from, oldname, 0); + if (value) { +#if SEXP_USE_RENAME_BINDINGS + sexp_env_rename(ctx, to, newname, value); +#else + sexp_env_push(ctx, to, tmp, newname, sexp_cdr(value)); +#endif +#if SEXP_USE_WARN_UNDEFS + if (oldcell + && sexp_cdr(oldcell) != SEXP_UNDEF + && !sexp_same_bindingp(oldcell, value)) + sexp_warn(ctx, "importing already defined binding: ", newname); + } else { + sexp_warn(ctx, "importing undefined variable: ", oldname); +#endif + } + } + } + /* create a new empty frame for future defines */ + value = sexp_make_env(ctx); + sexp_env_parent(value) = sexp_env_parent(to); + sexp_env_lambda(value) = sexp_env_lambda(to); + sexp_env_bindings(value) = sexp_env_bindings(to); +#if SEXP_USE_RENAME_BINDINGS + sexp_env_renames(value) = sexp_env_renames(to); + sexp_env_renames(to) = SEXP_NULL; +#endif + sexp_env_parent(to) = value; + sexp_env_bindings(to) = SEXP_NULL; + sexp_immutablep(to) = 0; + sexp_gc_release3(ctx); + return SEXP_VOID; +} + +/************************** eval interface ****************************/ + +sexp sexp_generate_op (sexp ctx, sexp self, sexp_sint_t n, sexp ast, sexp env) { + sexp_gc_var3(ctx2, vec, res); + if (sexp_contextp(env)) { + ctx2 = env; + } else { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0); + } + sexp_gc_preserve3(ctx, ctx2, vec, res); + sexp_free_vars(ctx2, ast, SEXP_NULL); /* should return SEXP_NULL */ + sexp_emit_enter(ctx2); + sexp_generate(ctx2, 0, 0, 0, ast); + res = sexp_complete_bytecode(ctx2); + if (!sexp_exceptionp(res)) { + sexp_context_specific(ctx2) = SEXP_FALSE; + vec = sexp_make_vector(ctx2, 0, SEXP_VOID); + if (sexp_exceptionp(vec)) res = vec; + else res = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, vec); + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_compile_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) { + sexp_gc_var3(ast, tmp, res); + sexp ctx2; + if (! env) env = sexp_context_env(ctx); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_gc_preserve3(ctx, ast, tmp, res); + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0); + if (sexp_exceptionp(ctx2)) { + res = ctx2; + } else { + tmp = sexp_context_child(ctx); + sexp_context_child(ctx) = ctx2; + ast = sexp_analyze(ctx2, obj); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + res = sexp_global(ctx2, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(res) && !sexp_exceptionp(ast); res=sexp_cdr(res)) + ast = sexp_apply1(ctx2, sexp_cdar(res), ast); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + res = sexp_generate_op(ctx2, self, n, ast, ctx2); + } + } + sexp_context_child(ctx) = tmp; + sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2); + } + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_eval_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) { + sexp_sint_t top; + sexp ctx2; + sexp_gc_var3(res, tmp, params); + if (! env) env = sexp_context_env(ctx); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_gc_preserve3(ctx, res, tmp, params); + top = sexp_context_top(ctx); + params = sexp_context_params(ctx); + sexp_context_params(ctx) = SEXP_NULL; + ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0); + tmp = sexp_context_child(ctx); + sexp_context_child(ctx) = ctx2; + res = sexp_exceptionp(ctx2) ? ctx2 : sexp_compile_op(ctx2, self, n, obj, env); + if (! sexp_exceptionp(res)) + res = sexp_apply(ctx2, res, SEXP_NULL); + sexp_context_child(ctx) = tmp; + sexp_context_params(ctx) = params; + sexp_context_top(ctx) = top; + sexp_context_last_fp(ctx) = sexp_context_last_fp(ctx2); + sexp_gc_release3(ctx); + return res; +} + +sexp sexp_eval_string (sexp ctx, const char *str, sexp_sint_t len, sexp env) { + sexp res; + sexp_gc_var1(obj); + sexp_gc_preserve1(ctx, obj); + obj = sexp_read_from_string(ctx, str, len); + res = sexp_eval(ctx, obj, env); + sexp_gc_release1(ctx); + return res; +} + +void sexp_scheme_init (void) { + if (! scheme_initialized_p) { + scheme_initialized_p = 1; + sexp_init(); + } +} diff --git a/examples/echo-server.scm b/examples/echo-server.scm new file mode 100755 index 00000000..eb3c9a6d --- /dev/null +++ b/examples/echo-server.scm @@ -0,0 +1,26 @@ +#!/usr/bin/env chibi-scheme + +;; Simple R7RS echo server, using the run-net-server utility from +;; (chibi net server). + +(import (scheme base) (scheme write) (chibi net) (chibi net server)) + +;; Copy each input line to output. +(define (echo-handler in out sock addr) + (let ((line (read-line in))) + (cond + ((not (or (eof-object? line) (equal? line ""))) + ;; log the request to stdout + (display "read: ") (write line) + (display " from ") + (display (sockaddr-name (address-info-address addr))) + (display ":") (write (sockaddr-port (address-info-address addr))) + (newline) + ;; write and flush the response + (display line out) + (newline out) + (flush-output-port out) + (echo-handler in out sock addr))))) + +;; Start the server on *:5556 dispatching clients to echo-handler. +(run-net-server 5556 echo-handler) diff --git a/fedora.spec b/fedora.spec new file mode 100644 index 00000000..e9beb325 --- /dev/null +++ b/fedora.spec @@ -0,0 +1,59 @@ +Summary: A small-footprint Scheme for use as a C Extension Language +Name: chibi-scheme +Version: 0.4 +Release: 1%{?dist} + + +Source0: http://chibi-scheme.googlecode.com/files/chibi-scheme-0.4.tgz +Patch1: chibi-scheme.Makefile.patch +Group: Development/Tools +License: BSD +URL: http://code.google.com/p/chibi-scheme/ +BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n) +# BuildRequires: + + +%description +Chibi-Scheme is a very small library intended for use as an extension +and scripting language in C programs. In addition to support for +lightweight VM-based threads, each VM itself runs in an isolated heap +allowing multiple VMs to run simultaneously in different OS threads. + +%prep +%setup -q -n %{name}-%{version} +%patch1 + +%build +%{__make} PREFIX=%{_prefix} DESTDIR=%{RPM_BUILD_ROOT} LIBDIR=%{_libdir} SOLIBDIR=%{_libdir} MODDIR=%{_datarootdir}/chibi-scheme doc all + +%install +rm -rf $RPM_BUILD_ROOT + +mkdir -p ${RPM_BUILD_ROOT} +%{__make} PREFIX=%{_prefix} DESTDIR=${RPM_BUILD_ROOT} LIBDIR=%{_libdir} SOLIBDIR=%{_libdir} LDFLAGS="-C ${RPM_BUILD_ROOT}%{_sysconfdir}/ld.so.conf.d" MODDIR=%{_datarootdir}/chibi-scheme install + +%clean +rm -rf $RPM_BUILD_ROOT + +%files +%defattr(-,root,root,-) +%{_bindir}/chibi-scheme +%{_datarootdir}/chibi-scheme +%{_datarootdir}/man +%{_libdir}/libchibi-scheme.so + + +%package devel +Summary: Development files for the %{name} package. +%description devel +This package contains development and include +files for %{name} package. + +%files devel +%defattr(-,root,root,-) +%{_includedir} + +%changelog +* Sat May 28 2011 Alex Shinn - 0.4 +* Wed Apr 22 2011 Rajesh Krishnan - 0.3 +- Initial release diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..0cf491b5 --- /dev/null +++ b/gc.c @@ -0,0 +1,741 @@ +/* gc.c -- simple mark&sweep garbage collector */ +/* Copyright (c) 2009-2012 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC + +#include "chibi/sexp.h" + +#if SEXP_USE_MMAP_GC +#include +#endif + +#ifdef __APPLE__ +#define SEXP_RTLD_DEFAULT RTLD_SELF +#else +#define SEXP_RTLD_DEFAULT RTLD_DEFAULT +#endif + +#define SEXP_BANNER(x) ("**************** GC "x"\n") + +#define SEXP_MINIMUM_OBJECT_SIZE (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 + +#if SEXP_USE_DEBUG_GC +#define sexp_debug_printf(fmt, ...) fprintf(stderr, SEXP_BANNER(fmt),__VA_ARGS__) +#else +#define sexp_debug_printf(fmt, ...) +#endif + +static sexp_heap sexp_heap_last (sexp_heap h) { + while (h->next) h = h->next; + return h; +} + +static size_t sexp_heap_total_size (sexp_heap h) { + size_t total_size = 0; + for (; h; h=h->next) + total_size += h->size; + return total_size; +} + +#if ! SEXP_USE_GLOBAL_HEAP +void sexp_free_heap (sexp_heap heap) { +#if SEXP_USE_MMAP_GC + munmap(heap, sexp_heap_pad_size(heap->size)); +#else + free(heap); +#endif +} +#endif + +#if SEXP_USE_LIMITED_MALLOC +static sexp_sint_t allocated_bytes=0, max_allocated_bytes=-1; +void* sexp_malloc(size_t size) { + char* max_alloc; + void* res; + if (max_allocated_bytes < 0) { + max_alloc = getenv("CHIBI_MAX_ALLOC"); + max_allocated_bytes = max_alloc ? atoi(max_alloc) : 8192000; /* 8MB */ + } + if (max_allocated_bytes > 0 && allocated_bytes + size > max_allocated_bytes) + return NULL; + if (!(res = malloc(size))) return NULL; + allocated_bytes += size; + return res; +} +/* TODO: subtract freed memory from max_allocated_bytes */ +void sexp_free(void* ptr) { + free(ptr); +} +#endif + +void sexp_preserve_object(sexp ctx, sexp x) { + sexp_global(ctx, SEXP_G_PRESERVATIVES) = sexp_cons(ctx, x, sexp_global(ctx, SEXP_G_PRESERVATIVES)); +} + +void sexp_release_object(sexp ctx, sexp x) { + sexp ls1, ls2; + for (ls1=NULL, ls2=sexp_global(ctx, SEXP_G_PRESERVATIVES); sexp_pairp(ls2); + ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_car(ls2) == x) { + if (ls1) sexp_cdr(ls1) = sexp_cdr(ls2); + else sexp_global(ctx, SEXP_G_PRESERVATIVES) = sexp_cdr(ls2); + break; + } +} + +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) + SEXP_GC_PAD; +#if SEXP_USE_DEBUG_GC + if (res == 0) { + fprintf(stderr, SEXP_BANNER("%p zero-size object: %p"), ctx, x); + return 1; + } +#endif + return res; +} + +#if SEXP_USE_SAFE_GC_MARK + +#if SEXP_USE_DEBUG_GC > 2 +int sexp_valid_heap_position(sexp ctx, sexp_heap h, sexp x) { + sexp p = sexp_heap_first_block(h), end = sexp_heap_end(h); + sexp_free_list q = h->free_list, r; + while (p < end) { + for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) + ; + if ((char*)r == (char*)p) { + p = (sexp) (((char*)p) + r->size); + continue; + } + if (p == x) { + return 1; + } else if (p > x) { + fprintf(stderr, SEXP_BANNER("bad heap position: %p free: %p-%p : %p-%p"), + x, q, ((char*)q)+q->size, r, ((char*)r)+r->size); + return 0; + } + p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p))); + } + fprintf(stderr, SEXP_BANNER("bad heap position: %p heap: %p-%p"), x, h, end); + return 0; +} +#else +#define sexp_valid_heap_position(ctx, h, x) 1 +#endif + +int sexp_in_heap_p(sexp ctx, sexp x) { + sexp_heap h; + if ((sexp_uint_t)x & (sexp_heap_align(1)-1)) { + fprintf(stderr, SEXP_BANNER("invalid heap alignment: %p"), x); + return 0; + } + for (h=sexp_context_heap(ctx); h; h=h->next) + if (((sexp)h < x) && (x < (sexp)(h->data + h->size))) + return sexp_valid_heap_position(ctx, h, x); + fprintf(stderr, SEXP_BANNER("invalid object outside heap: %p"), x); + return 0; +} +#endif + +#if SEXP_USE_DEBUG_GC > 1 +int sexp_valid_object_type_p (sexp ctx, sexp x) { + if (sexp_pointer_tag(x)<=0 || sexp_pointer_tag(x)>sexp_context_num_types(ctx)){ + fprintf(stderr, SEXP_BANNER("%p mark: bad object at %p: tag: %d"), + ctx, x, sexp_pointer_tag(x)); + return 0; + } + return 1; +} +#else +#define sexp_valid_object_type_p(ctx, x) 1 +#endif + +#if SEXP_USE_HEADER_MAGIC +int sexp_valid_header_magic_p (sexp ctx, sexp x) { + 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) { + fprintf(stderr, SEXP_BANNER("%p mark: bad magic at %p: %x"), + ctx, x, sexp_pointer_magic(x)); + return 0; + } + return 1; +} +#else +#define sexp_valid_header_magic_p(ctx, x) 1 +#endif + +#if SEXP_DEBUG_GC > 1 || SEXP_USE_SAFE_GC_MARK || SEXP_USE_HEADER_MAGIC +int sexp_valid_object_p (sexp ctx, sexp x) { + return sexp_in_heap_p(ctx, x) && sexp_valid_object_type_p(ctx, x) + && sexp_valid_header_magic_p(ctx, x); +} +#endif + +void sexp_mark (sexp ctx, sexp x) { + sexp_sint_t len; + sexp t, *p, *q; + struct sexp_gc_var_t *saves; + loop: + if (!x || !sexp_pointerp(x) || !sexp_valid_object_p(ctx, x) || sexp_markedp(x)) + return; + sexp_markedp(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); + len = sexp_type_num_slots_of_object(t, x) - 1; + if (len >= 0) { + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + q = p + len; + while (p < q && ! (*q && sexp_pointerp(*q))) + q--; /* skip trailing immediates */ + while (p < q && *q == q[-1]) + q--; /* skip trailing duplicates */ + while (p < q) + sexp_mark(ctx, *p++); + x = *p; + goto loop; + } +} + +#if SEXP_USE_CONSERVATIVE_GC + +int stack_references_pointer_p (sexp ctx, sexp x) { + sexp *p; + for (p=(&x)+1; pbacktrace, SEXP_BACKTRACE_SIZE); + for (i=0; i < SEXP_BACKTRACE_SIZE; i++) + fprintf(stderr, SEXP_BANNER(" : %s"), debug_text[i]); + free(debug_text); +} +#else +#define sexp_print_gc_trace(ctx, p) +#endif + +void sexp_conservative_mark (sexp ctx) { + sexp_heap h = sexp_context_heap(ctx); + sexp p, end; + sexp_free_list q, r; + for ( ; h; h=h->next) { /* just scan the whole heap */ + p = sexp_heap_first_block(h); + q = h->free_list; + end = sexp_heap_end(h); + while (p < end) { + for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) + ; + if ((char*)r == (char*)p) { + p = (sexp) (((char*)p) + r->size); + continue; + } + if (!sexp_markedp(p) && stack_references_pointer_p(ctx, p)) { +#ifdef SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG + if (sexp_pointer_tag(p) == SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG) +#endif + if (1) { +#if SEXP_USE_DEBUG_GC > 3 + if (p && sexp_pointerp(p)) { + fprintf(stderr, SEXP_BANNER("MISS: %p [%d]: %s"), p, + sexp_pointer_tag(p), sexp_pointer_source(p)); + sexp_print_gc_trace(ctx, p); + fflush(stderr); + } +#endif + sexp_mark(ctx, p); + } + } + p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p))); + } + } +} + +#else +#define sexp_conservative_mark(ctx) +#endif + +#if SEXP_USE_WEAK_REFERENCES +void sexp_reset_weak_references(sexp ctx) { + int i, len, all_reset_p; + sexp_heap h = sexp_context_heap(ctx); + sexp p, t, end, *v; + sexp_free_list q, r; + for ( ; h; h=h->next) { /* just scan the whole heap */ + p = sexp_heap_first_block(h); + q = h->free_list; + end = sexp_heap_end(h); + 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; + } + if (sexp_valid_object_p(ctx, p) && sexp_markedp(p)) { + t = sexp_object_type(ctx, p); + if (sexp_type_weak_base(t) > 0) { + all_reset_p = 1; + v = (sexp*) ((char*)p + sexp_type_weak_base(t)); + len = sexp_type_num_weak_slots_of_object(t, p); + for (i=0; inext) { + p = sexp_heap_first_block(h); + q = h->free_list; + end = sexp_heap_end(h); + 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_markedp(p)) { + t = sexp_object_type(ctx, p); + finalizer = sexp_type_finalize(t); + if (finalizer) { + finalize_count++; +#if SEXP_USE_DL + if (sexp_type_tag(t) == SEXP_DL && pass <= 0) + free_dls = 1; + else +#endif + finalizer(ctx, NULL, 1, p); + } + } + p = (sexp) (((char*)p)+size); + } + } +#if SEXP_USE_DL + if (free_dls && pass++ <= 0) goto loop; +#endif + return sexp_make_fixnum(finalize_count); +} + +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; + /* scan over the whole heap */ + for ( ; h; h=h->next) { + p = sexp_heap_first_block(h); + q = h->free_list; + end = sexp_heap_end(h); + 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_USE_DEBUG_GC + if (!sexp_valid_object_p(ctx, p)) + fprintf(stderr, SEXP_BANNER("%p sweep: invalid object at %p"), ctx, p); + if ((char*)q + q->size > (char*)p) + fprintf(stderr, SEXP_BANNER("%p sweep: bad size at %p < %p + %lu"), + ctx, p, q, q->size); + if (r && ((char*)p)+size > (char*)r) + fprintf(stderr, SEXP_BANNER("%p sweep: bad size at %p + %lu > %p"), + ctx, p, size, r); +#endif + if (!sexp_markedp(p)) { + /* free p */ + sum_freed += size; + if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) { + /* merge q with p */ + if (r && r->size && ((((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 && r->size && ((((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_markedp(p) = 0; + p = (sexp) (((char*)p)+size); + } + } + } + if (sum_freed_ptr) *sum_freed_ptr = sum_freed; + return sexp_make_fixnum(max_freed); +} + +#if SEXP_USE_GLOBAL_SYMBOLS +void sexp_mark_global_symbols(sexp ctx) { + int i; + for (i=0; isize = size; + h->max_size = max_size; + h->data = (char*) sexp_heap_align(sizeof(h->data)+(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_free_chunk_size)); + free->size = 0; /* actually sexp_heap_align(sexp_free_chunk_size) */ + free->next = next; + next->size = size - sexp_heap_align(sexp_free_chunk_size); + next->next = NULL; +#if SEXP_USE_DEBUG_GC + fprintf(stderr, SEXP_BANNER("heap: %p-%p data: %p-%p"), + h, ((char*)h)+sexp_heap_pad_size(size), h->data, h->data + size); + fprintf(stderr, SEXP_BANNER("first: %p end: %p"), + sexp_heap_first_block(h), sexp_heap_end(h)); + fprintf(stderr, SEXP_BANNER("free1: %p-%p free2: %p-%p"), + free, ((char*)free)+free->size, next, ((char*)next)+next->size); +#endif + 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, h->max_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 SEXP_USE_DEBUG_GC + ls3 = (sexp_free_list) sexp_heap_end(h); + if (ls2 >= ls3) + fprintf(stderr, "alloced %lu bytes past end of heap: %p (%lu) >= %p" + " next: %p (%lu)\n", size, ls2, ls2->size, ls3, ls2->next, + (ls2->next ? ls2->next->size : 0)); +#endif + 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 = sexp_context_heap(ctx); + size = sexp_heap_align(size) + SEXP_GC_PAD; + res = sexp_try_alloc(ctx, size); + if (! res) { + max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed)); + total_size = sexp_heap_total_size(sexp_context_heap(ctx)); + if (((max_freed < size) + || ((total_size > sum_freed) + && (total_size - sum_freed) > (total_size*SEXP_GROW_HEAP_RATIO))) + && ((!h->max_size) || (total_size < h->max_size))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); + if (! res) { + res = sexp_global(ctx, SEXP_G_OOM_ERROR); + sexp_debug_printf("ran out of memory allocating %lu bytes => %p", size, res); + } + } + return res; +} + +#if ! SEXP_USE_GLOBAL_HEAP + +void sexp_offset_heap_pointers (sexp_heap heap, sexp_heap from_heap, sexp* types, sexp flags) { + sexp_sint_t i, off, len, freep, loadp; + sexp_free_list q; + sexp p, t, end, *v; +#if SEXP_USE_DL + sexp name; +#endif + freep = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_FREEP); + loadp = sexp_unbox_fixnum(flags) & sexp_unbox_fixnum(SEXP_COPY_LOADP); + + off = (sexp_sint_t)((sexp_sint_t)heap - (sexp_sint_t)from_heap); + heap->data += off; + end = (sexp) (heap->data + heap->size); + + /* adjust the free list */ + heap->free_list = (sexp_free_list) ((char*)heap->free_list + off); + for (q=heap->free_list; q->next; q=q->next) + q->next = (sexp_free_list) ((char*)q->next + off); + + /* adjust data by traversing over the new heap */ + p = (sexp) (heap->data + sexp_heap_align(sexp_free_chunk_size)); + q = heap->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)((char*)(types[sexp_pointer_tag(p)]) + + ((char*)types > (char*)p ? off : 0)); + len = sexp_type_num_slots_of_object(t, p); + v = (sexp*) ((char*)p + sexp_type_field_base(t)); + /* offset any pointers in the _destination_ heap */ + for (i=0; idata + sexp_heap_align(sexp_free_chunk_size)); + q = heap->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 { +#if SEXP_USE_DL + if (sexp_opcodep(p) && sexp_opcode_func(p)) { + name = (sexp_opcode_data2(p) && sexp_stringp(sexp_opcode_data2(p))) ? sexp_opcode_data2(p) : sexp_opcode_name(p); + if (sexp_dlp(sexp_opcode_dl(p))) { + if (!sexp_dl_handle(sexp_opcode_dl(p))) + sexp_dl_handle(sexp_opcode_dl(p)) = dlopen(sexp_string_data(sexp_dl_file(sexp_opcode_dl(p))), RTLD_LAZY); + sexp_opcode_func(p) = dlsym(sexp_dl_handle(sexp_opcode_dl(p)), sexp_string_data(name)); + } else { + sexp_opcode_func(p) = dlsym(SEXP_RTLD_DEFAULT, sexp_string_data(name)); + } + } else +#endif + if (sexp_typep(p)) { + if (sexp_type_finalize(p)) { + /* TODO: handle arbitrary finalizers in images */ +#if SEXP_USE_DL + if (sexp_type_tag(p) == SEXP_DL) + sexp_type_finalize(p) = SEXP_FINALIZE_DL; + else +#endif + sexp_type_finalize(p) = SEXP_FINALIZE_PORT; + } + } + t = types[sexp_pointer_tag(p)]; + p = (sexp) (((char*)p)+sexp_heap_align(sexp_type_size_of_object(t, p)+SEXP_GC_PAD)); + } + } + } +} + +sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags) { + sexp_sint_t off; + sexp_heap to, from = sexp_context_heap(ctx); + + /* 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, from->max_size); + if (!to) return sexp_global(ctx, SEXP_G_OOM_ERROR); + 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)); + + /* adjust the pointers */ + sexp_offset_heap_pointers(to, from, sexp_context_types(ctx) + off, flags); + + 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, SEXP_MAXIMUM_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 +} + +#endif diff --git a/include/chibi/bignum.h b/include/chibi/bignum.h new file mode 100644 index 00000000..1c8402c6 --- /dev/null +++ b/include/chibi/bignum.h @@ -0,0 +1,72 @@ +/* bignum.h -- header for bignum utilities */ +/* Copyright (c) 2009-2012 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_BIGNUM_H +#define SEXP_BIGNUM_H + +#include "chibi/eval.h" + +#if (SEXP_64_BIT) && defined(__GNUC__) +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_API sexp_sint_t sexp_bignum_compare (sexp a, sexp b); +SEXP_API sexp sexp_compare (sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_make_bignum (sexp ctx, sexp_uint_t len); +SEXP_API sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len); +SEXP_API sexp sexp_bignum_normalize (sexp a); +SEXP_API sexp_uint_t sexp_bignum_hi (sexp a); +SEXP_API sexp sexp_fixnum_to_bignum (sexp ctx, sexp a); +SEXP_API double sexp_bignum_to_double (sexp a); +SEXP_API sexp sexp_double_to_bignum (sexp ctx, double f); +SEXP_API sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b); +SEXP_API sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset); +SEXP_API sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset); +SEXP_API sexp sexp_bignum_add (sexp ctx, sexp dst, sexp a, sexp b); +SEXP_API sexp sexp_bignum_sub (sexp ctx, sexp dst, sexp a, sexp b); +SEXP_API sexp sexp_bignum_mul (sexp ctx, sexp dst, sexp a, sexp b); +SEXP_API sexp sexp_bignum_div (sexp ctx, sexp dst, sexp a, sexp b); +SEXP_API sexp sexp_bignum_expt (sexp ctx, sexp n, sexp e); +SEXP_API sexp sexp_bignum_sqrt (sexp ctx, sexp a, sexp* rem); +SEXP_API sexp sexp_add (sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_sub (sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_mul (sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_div (sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_quotient (sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_remainder (sexp ctx, sexp a, sexp b); +#if SEXP_USE_RATIOS +SEXP_API sexp sexp_double_to_ratio (sexp ctx, double f); +SEXP_API double sexp_ratio_to_double (sexp rat); +SEXP_API sexp sexp_make_ratio (sexp ctx, sexp num, sexp den); +SEXP_API sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in); +SEXP_API sexp sexp_ratio_round (sexp ctx, sexp a); +SEXP_API sexp sexp_ratio_trunc (sexp ctx, sexp a); +SEXP_API sexp sexp_ratio_floor (sexp ctx, sexp a); +SEXP_API sexp sexp_ratio_ceiling (sexp ctx, sexp a); +SEXP_API sexp sexp_ratio_compare (sexp ctx, sexp a, sexp b); +#endif +#if SEXP_USE_COMPLEX +SEXP_API sexp sexp_make_complex (sexp ctx, sexp real, sexp image); +SEXP_API sexp sexp_complex_normalize (sexp real); +SEXP_API sexp sexp_complex_math_error (sexp ctx, sexp z); +SEXP_API sexp sexp_complex_sqrt (sexp ctx, sexp z); +SEXP_API sexp sexp_complex_exp (sexp ctx, sexp z); +SEXP_API sexp sexp_complex_expt (sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_complex_log (sexp ctx, sexp z); +SEXP_API sexp sexp_complex_sin (sexp ctx, sexp z); +SEXP_API sexp sexp_complex_cos (sexp ctx, sexp z); +SEXP_API sexp sexp_complex_tan (sexp ctx, sexp z); +SEXP_API sexp sexp_complex_asin (sexp ctx, sexp z); +SEXP_API sexp sexp_complex_acos (sexp ctx, sexp z); +SEXP_API sexp sexp_complex_atan (sexp ctx, sexp z); +#endif + +#endif /* ! SEXP_BIGNUM_H */ + diff --git a/include/chibi/eval.h b/include/chibi/eval.h new file mode 100644 index 00000000..72869bcb --- /dev/null +++ b/include/chibi/eval.h @@ -0,0 +1,270 @@ +/* eval.h -- headers for eval library */ +/* Copyright (c) 2009-2011 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_file "init-" +#define sexp_init_file_suffix ".scm" +#define sexp_meta_file "meta.scm" +#define sexp_leap_seconds_file "leap.txt" + +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 +}; + +SEXP_API struct sexp_opcode_struct* sexp_primitive_opcodes; + +#if SEXP_USE_DEBUG_VM || SEXP_USE_PROFILE_VM || SEXP_USE_STATIC_LIBS +SEXP_API const char** sexp_opcode_names; +#endif + +/**************************** prototypes ******************************/ + +SEXP_API void sexp_warn (sexp ctx, const char *msg, sexp x); +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_uint_t max_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_maybe_wrap_error (sexp ctx, sexp obj); +SEXP_API sexp sexp_analyze (sexp context, sexp x); +SEXP_API sexp sexp_simplify (sexp ctx, sexp self, sexp_sint_t n, sexp ast); +SEXP_API sexp sexp_make_lambda (sexp ctx, sexp params); +SEXP_API sexp sexp_make_ref (sexp ctx, sexp name, sexp cell); +SEXP_API void sexp_generate (sexp ctx, sexp name, sexp loc, sexp lam, sexp x); +SEXP_API void sexp_emit (sexp ctx, unsigned char c); +SEXP_API void sexp_emit_return (sexp ctx); +#if SEXP_USE_NATIVE_X86 +SEXP_API void sexp_emit_enter (sexp ctx); +SEXP_API void sexp_bless_bytecode (sexp ctx, sexp bc); +#else +#define sexp_emit_enter(ctx) +#define sexp_bless_bytecode(ctx, bc) +#endif +SEXP_API sexp sexp_complete_bytecode (sexp ctx); +SEXP_API void sexp_shrink_bcode (sexp ctx, sexp_uint_t i); +SEXP_API void sexp_expand_bcode (sexp ctx, sexp_uint_t size); +SEXP_API void sexp_stack_trace (sexp ctx, sexp out); +SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); +SEXP_API int sexp_param_index (sexp ctx, sexp lambda, sexp name); +SEXP_API sexp sexp_compile_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env); +SEXP_API sexp sexp_generate_op (sexp context, sexp self, sexp_sint_t n, sexp obj, sexp env); +SEXP_API sexp sexp_eval_op (sexp context, sexp self, sexp_sint_t 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 self, sexp_sint_t n, sexp expr, sexp env); +SEXP_API sexp sexp_exception_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn); +SEXP_API sexp sexp_make_env_op (sexp context, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_make_null_env_op (sexp context, sexp self, sexp_sint_t n, sexp version); +SEXP_API sexp sexp_env_cell_define (sexp ctx, sexp env, sexp name, sexp value, sexp* varenv); +SEXP_API sexp sexp_make_primitive_env_op (sexp context, sexp self, sexp_sint_t n, sexp version); +SEXP_API sexp sexp_make_standard_env_op (sexp context, sexp self, sexp_sint_t n, sexp version); +SEXP_API void sexp_set_parameter (sexp ctx, sexp env, sexp name, sexp value); +SEXP_API sexp sexp_load_standard_ports (sexp context, sexp env, FILE* in, FILE* out, FILE* err, int no_close); +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_current_module_path_op (sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_find_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file); +SEXP_API sexp sexp_load_module_file_op (sexp ctx, sexp self, sexp_sint_t n, sexp file, sexp env); +SEXP_API sexp sexp_add_module_directory_op (sexp ctx, sexp self, sexp_sint_t n, sexp dir, sexp appendp); +SEXP_API sexp sexp_current_environment (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_set_current_environment (sexp ctx, sexp self, sexp_sint_t n, sexp env); +SEXP_API sexp sexp_meta_environment (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value); +SEXP_API sexp sexp_env_import_op (sexp ctx, sexp self, sexp_sint_t n, sexp to, sexp from, sexp ls, sexp immutp); +SEXP_API sexp sexp_env_exports_op (sexp ctx, sexp self, sexp_sint_t n, sexp env); +SEXP_API sexp sexp_identifierp_op(sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_identifier_eq_op(sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp c, sexp d); +SEXP_API sexp sexp_make_synclo_op(sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv, sexp expr); +SEXP_API sexp sexp_strip_synclos(sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_syntactic_closure_expr_op(sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_open_input_file_op(sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_open_output_file_op(sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_open_binary_input_file(sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_open_binary_output_file(sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_close_port_op(sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_set_port_line_op (sexp ctx, sexp self, sexp_sint_t n, sexp port, sexp line); +SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val); +SEXP_API sexp sexp_env_cell (sexp ctx, sexp env, sexp sym, int localp); +SEXP_API sexp sexp_env_ref (sexp ctx, sexp env, sexp sym, sexp dflt); +SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param); +#if SEXP_USE_RENAME_BINDINGS +SEXP_API sexp sexp_env_rename (sexp ctx, sexp env, sexp key, sexp value); +#endif +SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from, sexp to, sexp res); +SEXP_API sexp sexp_make_lit (sexp ctx, sexp value); +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 self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars); +SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); +SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i); +#if SEXP_USE_AUTO_FORCE +SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val); +#endif +#if SEXP_USE_UTF8_STRINGS +SEXP_API sexp sexp_read_utf8_char (sexp ctx, sexp port, int i); +SEXP_API void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch); +SEXP_API sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i); +SEXP_API sexp sexp_string_utf8_index_set (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i, sexp ch); +#endif +#if SEXP_USE_GREEN_THREADS +SEXP_API sexp sexp_dk (sexp ctx, sexp self, sexp_sint_t n, sexp val); +#endif +SEXP_API sexp sexp_thread_parameters (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_thread_parameters_set (sexp ctx, sexp self, sexp_sint_t n, sexp val); +SEXP_API sexp sexp_string_cmp_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp ci); +#if SEXP_USE_RATIOS +SEXP_API sexp sexp_ratio_numerator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat); +SEXP_API sexp sexp_ratio_denominator_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat); +#endif +#if SEXP_USE_COMPLEX +SEXP_API sexp sexp_complex_real_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat); +SEXP_API sexp sexp_complex_imag_op (sexp ctx, sexp self, sexp_sint_t n, sexp rat); +#endif +#if SEXP_USE_PROFILE_VM +SEXP_API sexp sexp_reset_vm_profile (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_print_vm_profile (sexp ctx, sexp self, sexp_sint_t n); +#endif + +#if SEXP_USE_MATH +SEXP_API sexp sexp_exp(sexp ctx, sexp self, sexp_sint_t n, sexp z); +SEXP_API sexp sexp_log(sexp ctx, sexp self, sexp_sint_t n, sexp z); +SEXP_API sexp sexp_sin(sexp ctx, sexp self, sexp_sint_t n, sexp z); +SEXP_API sexp sexp_cos(sexp ctx, sexp self, sexp_sint_t n, sexp z); +SEXP_API sexp sexp_tan(sexp ctx, sexp self, sexp_sint_t n, sexp z); +SEXP_API sexp sexp_asin(sexp ctx, sexp self, sexp_sint_t n, sexp z); +SEXP_API sexp sexp_acos(sexp ctx, sexp self, sexp_sint_t n, sexp z); +SEXP_API sexp sexp_atan(sexp ctx, sexp self, sexp_sint_t n, sexp z); +SEXP_API sexp sexp_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z); +SEXP_API sexp sexp_exact_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z); +SEXP_API sexp sexp_inexact_sqrt(sexp ctx, sexp self, sexp_sint_t n, sexp z); +SEXP_API sexp sexp_round(sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_trunc(sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_floor(sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_ceiling(sexp ctx, sexp self, sexp_sint_t n, sexp x); +#endif +SEXP_API sexp sexp_expt_op(sexp ctx, sexp self, sexp_sint_t n, sexp z1, sexp z2); +SEXP_API sexp sexp_exact_to_inexact(sexp ctx, sexp self, sexp_sint_t n, sexp i); +SEXP_API sexp sexp_inexact_to_exact(sexp ctx, sexp self, sexp_sint_t n, sexp x); + +#if SEXP_USE_NATIVE_X86 +SEXP_API sexp sexp_write_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp ch, sexp out); +SEXP_API sexp sexp_newline_op(sexp ctx, sexp self, sexp_sint_t n, sexp out); +SEXP_API sexp sexp_read_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp in); +SEXP_API sexp sexp_peek_char_op(sexp ctx, sexp self, sexp_sint_t n, sexp in); +SEXP_API sexp sexp_char_upcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch); +SEXP_API sexp sexp_char_downcase(sexp ctx, sexp self, sexp_sint_t n, sexp ch); +#endif + +#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); + +#define sexp_env_key(x) sexp_car(x) +#define sexp_env_value(x) sexp_cdr(x) +#define sexp_env_next_cell(x) sexp_pair_source(x) +#define sexp_env_push(ctx, env, tmp, name, value) (tmp=sexp_cons(ctx,name,value), sexp_env_next_cell(tmp)=sexp_env_bindings(env), sexp_env_bindings(env)=tmp) +#define sexp_env_push_rename(ctx, env, tmp, name, value) (tmp=sexp_cons(ctx,name,value), sexp_env_next_cell(tmp)=sexp_env_renames(env), sexp_env_renames(env)=tmp) + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_make_type_predicate_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type); +SEXP_API sexp sexp_make_constructor_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type); +SEXP_API sexp sexp_make_getter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index); +SEXP_API sexp sexp_make_setter_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp type, sexp index); +SEXP_API sexp sexp_type_slot_offset_op (sexp ctx, sexp self, sexp_sint_t n, sexp type, sexp index); +#endif + +#ifdef PLAN9 +SEXP_API sexp sexp_rand (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_srand (sexp ctx, sexp self, sexp_sint_t n, sexp seed); +SEXP_API sexp sexp_file_exists_p (sexp ctx, sexp self, sexp_sint_t n, sexp path); +SEXP_API sexp sexp_fdopen (sexp ctx, sexp self, sexp_sint_t n, sexp fd, sexp mode); +SEXP_API sexp sexp_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port); +SEXP_API sexp sexp_fork (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_exec (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp args); +SEXP_API void sexp_exits (sexp ctx, sexp self, sexp_sint_t n, sexp msg); +SEXP_API sexp sexp_dup (sexp ctx, sexp self, sexp_sint_t n, sexp oldfd, sexp newfd); +SEXP_API sexp sexp_pipe (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_sleep (sexp ctx, sexp self, sexp_sint_t n, sexp msecs); +SEXP_API sexp sexp_getenv (sexp ctx, sexp self, sexp_sint_t n, sexp name); +SEXP_API sexp sexp_getwd (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_chdir (sexp ctx, sexp self, sexp_sint_t n, sexp path); +SEXP_API sexp sexp_getuser (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_sysname (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_wait (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_postnote (sexp ctx, sexp self, sexp_sint_t n, sexp pid, sexp note); +SEXP_API sexp sexp_postmountsrv (sexp ctx, sexp self, sexp_sint_t n, sexp ls, sexp name, sexp mtpt, sexp flags); +SEXP_API sexp sexp_9p_req_offset (sexp ctx, sexp self, sexp_sint_t n, sexp req); +SEXP_API sexp sexp_9p_req_count (sexp ctx, sexp self, sexp_sint_t n, sexp req); +SEXP_API sexp sexp_9p_req_fid (sexp ctx, sexp self, sexp_sint_t n, sexp req); +SEXP_API sexp sexp_9p_req_newfid (sexp ctx, sexp self, sexp_sint_t n, sexp req); +SEXP_API sexp sexp_9p_respond (sexp ctx, sexp self, sexp_sint_t n, sexp req, sexp err); +SEXP_API sexp sexp_9p_responderror (sexp ctx, sexp self, sexp_sint_t n, sexp req); +#else +SEXP_API sexp sexp_get_port_fileno (sexp ctx, sexp self, sexp_sint_t n, sexp port); +#endif + +#if SEXP_USE_SIMPLIFY +SEXP_API int sexp_rest_unused_p (sexp lambda); +#else +#define sexp_rest_unused_p(lambda) 0 +#endif + +/* simplify primitive API interface */ +#define sexp_make_synclo(ctx, a, b, c) sexp_make_synclo_op(ctx, NULL, 3, a, b, c) +#define sexp_make_procedure(ctx, f, n, b, v) sexp_make_procedure_op(ctx, NULL, 4, f, n, b, v) +#define sexp_make_env(ctx) sexp_make_env_op(ctx, NULL, 0) +#define sexp_make_null_env(ctx, v) sexp_make_null_env_op(ctx, NULL, 0, v) +#define sexp_make_primitive_env(ctx, v) sexp_make_primitive_env_op(ctx, NULL, 1, v) +#define sexp_make_standard_env(ctx, v) sexp_make_standard_env_op(ctx, NULL, 1, v) +#define sexp_add_module_directory(ctx, d, a) sexp_add_module_directory_op(ctx, NULL, 1, d, a) +#define sexp_eval(ctx, x, e) sexp_eval_op(ctx, NULL, 2, x, e) +#define sexp_load(ctx, f, e) sexp_load_op(ctx, NULL, 2, f, e) +#define sexp_env_import(ctx, a, b, c, d) sexp_env_import_op(ctx, NULL, 4, a, b, c, d) +#define sexp_identifierp(ctx, x) sexp_identifierp_op(ctx, NULL, 1, x) +#define sexp_identifier_to_symbol(ctx, x) sexp_syntactic_closure_expr_op(ctx, NULL, 1, x) +#define sexp_identifier_eq(ctx, a, b, c, d) sexp_identifier_eq_op(ctx, NULL, 4, a, b, c, d) +#define sexp_open_input_file(ctx, x) sexp_open_input_file_op(ctx, NULL, 1, x) +#define sexp_open_output_file(ctx, x) sexp_open_output_file_op(ctx, NULL, 1, x) +#define sexp_close_port(ctx, x) sexp_close_port_op(ctx, NULL, 1, x) +#define sexp_warn_undefs(ctx, from, to, res) sexp_warn_undefs_op(ctx, NULL, 3, from, to, res) +#define sexp_string_cmp(ctx, a, b, c) sexp_string_cmp_op(ctx, NULL, 3, a, b, c) + +#ifdef __cplusplus +} /* extern "C" */ +#endif + +#endif /* ! SEXP_EVAL_H */ diff --git a/include/chibi/features.h b/include/chibi/features.h new file mode 100644 index 00000000..968111b2 --- /dev/null +++ b/include/chibi/features.h @@ -0,0 +1,825 @@ +/* features.h -- general feature configuration */ +/* Copyright (c) 2009-2012 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +/* uncomment this to disable most features */ +/* Most features are enabled by default, but setting this */ +/* option will disable any not explicitly enabled. */ +/* #define SEXP_USE_NO_FEATURES 1 */ + +/* uncomment this to disable interpreter-based threads */ +/* #define SEXP_USE_GREEN_THREADS 0 */ + +/* 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 meta.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 detailed source info for debugging */ +/* By default Chibi will associate source info with every */ +/* bytecode offset. By disabling this only lambda-level source */ +/* info will be recorded (the line of the opening paren for the */ +/* lambda). */ +/* #define SEXP_USE_FULL_SOURCE_INFO 0 */ + +/* uncomment this to disable a simplifying optimization pass */ +/* This performs some simple optimizations such as dead-code */ +/* elimination, constant-folding, and directly propagating */ +/* non-mutated let values bound to constants or non-mutated */ +/* references. More than performance, this is aimed at reducing the */ +/* size of the compiled code, especially as the result of macro */ +/* expansions, so it's a good idea to leave it enabled. */ +/* #define SEXP_USE_SIMPLIFY 0 */ + +/* uncomment this to disable dynamic type definitions */ +/* This enables register-simple-type and related */ +/* opcodes for defining types, needed by the default */ +/* implementation of (srfi 9). */ +/* #define SEXP_USE_TYPE_DEFS 0 */ + +/* uncomment this to use the Boehm conservative GC */ +/* Conservative GCs make it easier to write extensions, */ +/* since you don't have to keep track of intermediate */ +/* variables, but can leak memory. Boehm is also a */ +/* very large library to link in. You may want to */ +/* enable this when debugging your own extensions, or */ +/* if you suspect a bug in the native GC. */ +/* #define SEXP_USE_BOEHM 1 */ + +/* uncomment this to disable weak references */ +/* #define SEXP_USE_WEAK_REFERENCES 0 */ + +/* 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 track what C source line each object is allocated from */ +/* #define SEXP_USE_TRACK_ALLOC_SOURCE 1 */ + +/* uncomment this to take a short backtrace of where each object is */ +/* allocated from */ +/* #define SEXP_USE_TRACK_ALLOC_BACKTRACE 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 enable "safe" field accessors for primitive types */ +/* The sexp union type fields are abstracted away with macros of the */ +/* form sexp__(), however these are just convenience */ +/* macros equivalent to directly accessing the union field, and will */ +/* return incorrect results (or segfault) if isn't of the correct */ +/* . Thus you're required to check the types manually before */ +/* accessing them. However, to detect errors earlier you can enable */ +/* SEXP_USE_SAFE_ACCESSORS, and on invalid accesses chibi will print */ +/* a friendly error message and immediately segfault itself so you */ +/* can see where the invalid access was made. */ +/* Note this is only intended for debugging, and mostly for user code. */ +/* If you want to build chibi itself with this option, compilation */ +/* may be very slow and using CFLAGS=-O0 is recommended. */ +/* #define SEXP_USE_SAFE_ACCESSORS 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 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 to disable foreign function bindings with > 6 args */ +/* #define SEXP_USE_EXTENDED_FCALL 0 */ + +/* 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 want exact ratio support */ +/* Ratios are part of the bignum library and imply bignums. */ +/* #define SEXP_USE_RATIOS 0 */ + +/* uncomment this if you don't want imaginary number support */ +/* #define SEXP_USE_COMPLEX 0 */ + +/* uncomment this if you don't want 1## style approximate digits */ +/* #define SEXP_USE_PLACEHOLDER_DIGITS 0 */ + +/* uncomment this if you don't need extended math operations */ +/* This includes the trigonometric and expt functions. */ +/* Automatically disabled if you've disabled flonums. */ +/* #define SEXP_USE_MATH 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* This is something of a hack, but can be quite useful. */ +/* It's very fast and doesn't involve any separate analysis */ +/* passes. */ +/* #define SEXP_USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* By default (this may change) small symbols are represented */ +/* as immediates using a simple huffman encoding. This keeps */ +/* the symbol table small, and minimizes hashing when doing a */ +/* lot of reading. */ +/* #define SEXP_USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* You can trade off some space in exchange for longer read */ +/* times by disabling hashing and just putting all */ +/* non-immediate symbols in a single list. */ +/* #define SEXP_USE_HASH_SYMS 0 */ + +/* uncomment this to disable extended char names as defined in R7RS */ +/* #define SEXP_USE_EXTENDED_CHAR_NAMES 0 */ + +/* uncomment this to disable UTF-8 string support */ +/* The default settings store strings in memory as UTF-8, */ +/* and assumes strings passed to/from the C FFI are UTF-8. */ +/* #define SEXP_USE_UTF8_STRINGS 0 */ + +/* uncomment this to disable the string-set! opcode */ +/* By default (non-literal) strings are mutable. */ +/* Making them immutable allows for packed UTF-8 strings. */ +/* #define SEXP_USE_MUTABLE_STRINGS 0 */ + +/* uncomment this to base string ports on C streams */ +/* This historic option enables string and custom ports backed */ +/* by FILE* objects using memstreams and funopen/fopencookie. */ +/* #define SEXP_USE_STRING_STREAMS 1 */ + +/* 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 */ + +/* uncomment this to disable growing the stack on overflow */ +/* If enabled, chibi attempts to grow the stack on overflow, */ +/* up to SEXP_MAX_STACK_SIZE, otherwise a failed stack check */ +/* will just raise an error immediately. */ +/* #define SEXP_USE_GROW_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 + +/* the default number of opcodes to run each thread for */ +#ifndef SEXP_DEFAULT_QUANTUM +#define SEXP_DEFAULT_QUANTUM 500 +#endif + +#ifndef SEXP_MAX_ANALYZE_DEPTH +#define SEXP_MAX_ANALYZE_DEPTH 8192 +#endif + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#ifndef SEXP_64_BIT +#if defined(__amd64) || defined(__x86_64) || defined(_WIN64) || defined(_Wp64) || defined(__LP64__) || defined(__PPC64__) +#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 +#if ! defined(_GNU_SOURCE) && ! defined(_WIN32) && ! defined(PLAN9) +#define _GNU_SOURCE +#endif +#endif + +#ifndef SEXP_USE_NO_FEATURES +#define SEXP_USE_NO_FEATURES 0 +#endif + +#ifndef SEXP_USE_PEDANTIC +#define SEXP_USE_PEDANTIC 0 +#endif + +#ifndef SEXP_USE_GREEN_THREADS +#define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_DEBUG_THREADS +#define SEXP_USE_DEBUG_THREADS 0 +#endif + +#ifndef SEXP_USE_AUTO_FORCE +#define SEXP_USE_AUTO_FORCE 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_default_user_module_path +#define sexp_default_user_module_path "./lib:." +#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 +#if defined(PLAN9) || defined(_WIN32) +#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_FULL_SOURCE_INFO +#define SEXP_USE_FULL_SOURCE_INFO ! SEXP_USE_NO_FEATURES +#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_WEAK_REFERENCES +#define SEXP_USE_WEAK_REFERENCES ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MALLOC +#define SEXP_USE_MALLOC 0 +#endif + +#ifndef SEXP_USE_LIMITED_MALLOC +#define SEXP_USE_LIMITED_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 SEXP_USE_DEBUG_GC > 1 +#endif + +#ifndef SEXP_USE_CONSERVATIVE_GC +#define SEXP_USE_CONSERVATIVE_GC 0 +#endif + +#ifndef SEXP_USE_TRACK_ALLOC_SOURCE +#define SEXP_USE_TRACK_ALLOC_SOURCE SEXP_USE_DEBUG_GC > 2 +#endif + +#ifndef SEXP_USE_TRACK_ALLOC_BACKTRACE +#define SEXP_USE_TRACK_ALLOC_BACKTRACE SEXP_USE_TRACK_ALLOC_SOURCE +#endif + +#ifndef SEXP_BACKTRACE_SIZE +#define SEXP_BACKTRACE_SIZE 3 +#endif + +#ifndef SEXP_USE_HEADER_MAGIC +#define SEXP_USE_HEADER_MAGIC 0 +#endif + +#ifndef SEXP_GC_PAD +#define SEXP_GC_PAD 0 +#endif + +#ifndef SEXP_USE_SAFE_ACCESSORS +#define SEXP_USE_SAFE_ACCESSORS 0 +#endif + +#ifndef SEXP_USE_SAFE_VECTOR_ACCESSORS +#define SEXP_USE_SAFE_VECTOR_ACCESSORS 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_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_STRICT_TOPLEVEL_BINDINGS +#define SEXP_USE_STRICT_TOPLEVEL_BINDINGS 0 +#endif + +#if SEXP_USE_STRICT_TOPLEVEL_BINDINGS +#define SEXP_USE_RENAME_BINDINGS 1 +#else +#ifndef SEXP_USE_RENAME_BINDINGS +#define SEXP_USE_RENAME_BINDINGS 0 +#endif +#endif + +#ifndef SEXP_USE_SPLICING_LET_SYNTAX +#define SEXP_USE_SPLICING_LET_SYNTAX 0 +#endif + +#ifndef SEXP_USE_FLAT_SYNTACTIC_CLOSURES +#define SEXP_USE_FLAT_SYNTACTIC_CLOSURES 0 +#endif + +#if SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS +#define SEXP_USE_UNWRAPPED_TOPLEVEL_BINDINGS 0 +#endif + +#ifndef SEXP_USE_EXTENDED_FCALL +#define SEXP_USE_EXTENDED_FCALL (!SEXP_USE_NO_FEATURES) +#endif + +#ifndef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS (!SEXP_USE_NO_FEATURES) +#endif + +#ifndef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS (!SEXP_USE_NO_FEATURES) +#endif + +#ifndef SEXP_USE_RATIOS +#define SEXP_USE_RATIOS SEXP_USE_FLONUMS +#endif + +#ifndef SEXP_USE_COMPLEX +#define SEXP_USE_COMPLEX SEXP_USE_FLONUMS +#endif + +#if (SEXP_USE_RATIOS || SEXP_USE_COMPLEX) +#undef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS 1 +#undef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS 1 +#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_IEEE_EQV +#define SEXP_USE_IEEE_EQV SEXP_USE_FLONUMS +#endif + +#ifndef SEXP_USE_PLACEHOLDER_DIGITS +#define SEXP_USE_PLACEHOLDER_DIGITS 0 +#endif + +#ifndef SEXP_PLACEHOLDER_DIGIT +#define SEXP_PLACEHOLDER_DIGIT '#' +#endif + +#ifndef SEXP_USE_MATH +#define SEXP_USE_MATH SEXP_USE_FLONUMS && ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_ESCAPE_NEWLINE +#define SEXP_USE_ESCAPE_NEWLINE ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_ESCAPE_REQUIRES_TRAILING_SEMI_COLON +#define SEXP_USE_ESCAPE_REQUIRES_TRAILING_SEMI_COLON SEXP_USE_PEDANTIC +#endif + +#ifndef SEXP_USE_OBJECT_BRACE_LITERALS +#define SEXP_USE_OBJECT_BRACE_LITERALS (SEXP_USE_TYPE_DEFS && !SEXP_USE_NO_FEATURES) +#endif + +/* Dangerous without shared object detection. */ +#ifndef SEXP_USE_TYPE_PRINTERS +#define SEXP_USE_TYPE_PRINTERS 0 +#endif + +#ifndef SEXP_USE_BYTEVECTOR_LITERALS +#define SEXP_USE_BYTEVECTOR_LITERALS ! 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_FOLD_CASE_SYMS +#define SEXP_USE_FOLD_CASE_SYMS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_DEFAULT_FOLD_CASE_SYMS +#define SEXP_DEFAULT_FOLD_CASE_SYMS 0 +#endif + +/* experimental optimization to use jumps instead of the TAIL-CALL opcode */ +#ifndef SEXP_USE_TAIL_JUMPS +/* #define SEXP_USE_TAIL_JUMPS ! SEXP_USE_NO_FEATURES */ +#define SEXP_USE_TAIL_JUMPS 0 +#endif + +#ifndef SEXP_USE_RESERVE_OPCODE +#define SEXP_USE_RESERVE_OPCODE SEXP_USE_TAIL_JUMPS +#endif + +/* experimental optimization to avoid boxing locals which aren't set! */ +#ifndef SEXP_USE_UNBOXED_LOCALS +/* #define SEXP_USE_UNBOXED_LOCALS ! SEXP_USE_NO_FEATURES */ +#define SEXP_USE_UNBOXED_LOCALS 0 +#endif + +#ifndef SEXP_USE_DEBUG_VM +#define SEXP_USE_DEBUG_VM 0 +#endif + +#ifndef SEXP_USE_PROFILE_VM +#define SEXP_USE_PROFILE_VM 0 +#endif + +#ifndef SEXP_USE_EXTENDED_CHAR_NAMES +#define SEXP_USE_EXTENDED_CHAR_NAMES ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_UTF8_STRINGS +#define SEXP_USE_UTF8_STRINGS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MUTABLE_STRINGS +#define SEXP_USE_MUTABLE_STRINGS 1 +#endif + +#if (SEXP_USE_UTF8_STRINGS && SEXP_USE_MUTABLE_STRINGS) +#define SEXP_USE_PACKED_STRINGS 0 +#endif +#ifndef SEXP_USE_PACKED_STRINGS +#define SEXP_USE_PACKED_STRINGS 1 +#endif + +#ifndef SEXP_USE_STRING_STREAMS +#define SEXP_USE_STRING_STREAMS 0 +#endif + +#ifndef SEXP_USE_AUTOCLOSE_PORTS +#define SEXP_USE_AUTOCLOSE_PORTS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_GC_FILE_DESCRIPTORS +#define SEXP_USE_GC_FILE_DESCRIPTORS (SEXP_USE_AUTOCLOSE_PORTS &&!SEXP_USE_BOEHM && !defined(PLAN9)) +#endif + +#ifndef SEXP_USE_BIDIRECTIONAL_PORTS +#define SEXP_USE_BIDIRECTIONAL_PORTS 0 +#endif + +#ifndef SEXP_PORT_BUFFER_SIZE +#define SEXP_PORT_BUFFER_SIZE 4096 +#endif + +#ifndef SEXP_USE_NTP_GETTIME +#define SEXP_USE_NTP_GETTIME 0 +#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 + +#ifndef SEXP_USE_GROW_STACK +#define SEXP_USE_GROW_STACK SEXP_USE_CHECK_STACK && ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_LONG_PROCEDURE_ARGS +#define SEXP_USE_LONG_PROCEDURE_ARGS ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_INIT_BCODE_SIZE +#define SEXP_INIT_BCODE_SIZE 128 +#endif +#ifndef SEXP_INIT_STACK_SIZE +#if SEXP_USE_CHECK_STACK +#define SEXP_INIT_STACK_SIZE 1024 +#else +#define SEXP_INIT_STACK_SIZE 8192 +#endif +#endif +#ifndef SEXP_MAX_STACK_SIZE +#define SEXP_MAX_STACK_SIZE SEXP_INIT_STACK_SIZE*1000 +#endif + +#ifndef SEXP_DEFAULT_EQUAL_DEPTH +#define SEXP_DEFAULT_EQUAL_DEPTH 10000 +#endif + +#ifndef SEXP_DEFAULT_EQUAL_BOUND +#define SEXP_DEFAULT_EQUAL_BOUND 100000000 +#endif + +#ifndef SEXP_USE_IMAGE_LOADING +#define SEXP_USE_IMAGE_LOADING SEXP_USE_DL && !SEXP_USE_GLOBAL_HEAP && !SEXP_USE_BOEHM && !SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_UNSAFE_PUSH +#define SEXP_USE_UNSAFE_PUSH 0 +#endif + +#ifndef SEXP_USE_MAIN_HELP +#define SEXP_USE_MAIN_HELP ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_MAIN_ERROR_ADVISE +#define SEXP_USE_MAIN_ERROR_ADVISE ! SEXP_USE_NO_FEATURES +#endif + +#ifndef SEXP_USE_SEND_FILE +#define SEXP_USE_SEND_FILE (__linux || SEXP_BSD) +#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_RATIOS +#define SEXP_USE_RATIOS 0 +#undef SEXP_USE_COMPLEX +#define SEXP_USE_COMPLEX 0 +#undef SEXP_USE_UTF8_STRINGS +#define SEXP_USE_UTF8_STRINGS 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 strcasestr cistrstr +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#define isinf(x) (isInf(x,1) || isInf(x,-1)) +#define isnan(x) isNaN(x) +#elif defined(_WIN32) +#define snprintf(buf, len, fmt, val) sprintf(buf, fmt, val) +#define strcasecmp lstrcmpi +#define strncasecmp(s1, s2, n) lstrcmpi(s1, s2) +#define round(x) floor((x)+0.5) +#define trunc(x) floor((x)+0.5*(((x)<0)?1:0)) +#define isnan(x) (x!=x) +#define isinf(x) (x > DBL_MAX || x < -DBL_MAX) +#endif + +#ifdef _WIN32 +#define sexp_pos_infinity (DBL_MAX*DBL_MAX) +#define sexp_neg_infinity -sexp_pos_infinity +#define sexp_nan log(-2) +#elif PLAN9 +#define sexp_pos_infinity Inf(1) +#define sexp_neg_infinity Inf(-1) +#define sexp_nan NaN() +#else +#define sexp_pos_infinity (1.0/0.0) +#define sexp_neg_infinity -sexp_pos_infinity +#define sexp_nan (0.0/0.0) +#endif + +#ifdef __MINGW32__ +#ifdef BUILDING_DLL +#define SEXP_API __declspec(dllexport) +#else +#define SEXP_API __declspec(dllimport) +#endif +#else +#define SEXP_API extern +#endif + +/************************************************************************/ +/* Feature signature. Used for image files and dynamically loaded */ +/* libraries to verify they are compatible with the compiled options . */ +/************************************************************************/ + +typedef char sexp_abi_identifier_t[8]; + +#if SEXP_USE_BOEHM +#define SEXP_ABI_GC "b" +#elif (SEXP_USE_HEADER_MAGIC && SEXP_USE_TRACK_ALLOC_SOURCE) +#define SEXP_ABI_GC "d" +#elif SEXP_USE_HEADER_MAGIC +#define SEXP_ABI_GC "m" +#elif SEXP_USE_TRACK_ALLOC_SOURCE +#define SEXP_ABI_GC "s" +#else +#define SEXP_ABI_GC "c" +#endif + +#if SEXP_USE_NATIVE_X86 +#define SEXP_ABI_BACKEND "x" +#else +#define SEXP_ABI_BACKEND "v" +#endif + +#if (SEXP_USE_RESERVE_OPCODE && SEXP_USE_AUTO_FORCE) +#define SEXP_ABI_INSTRUCTIONS "*" +#elif SEXP_USE_RESERVE_OPCODE +#define SEXP_ABI_INSTRUCTIONS "r" +#elif SEXP_USE_AUTO_FORCE +#define SEXP_ABI_INSTRUCTIONS "f" +#else +#define SEXP_ABI_INSTRUCTIONS "-" +#endif + +#if SEXP_USE_GREEN_THREADS +#define SEXP_ABI_THREADS "g" +#else +#define SEXP_ABI_THREADS "-" +#endif + +#if SEXP_USE_MODULES +#define SEXP_ABI_MODULES "m" +#else +#define SEXP_ABI_MODULES "-" +#endif + +#if (SEXP_USE_COMPLEX && SEXP_USE_RATIOS) +#define SEXP_ABI_NUMBERS "*" +#elif SEXP_USE_COMPLEX +#define SEXP_ABI_NUMBERS "c" +#elif SEXP_USE_RATIOS +#define SEXP_ABI_NUMBERS "r" +#elif SEXP_USE_BIGNUMS +#define SEXP_ABI_NUMBERS "b" +#elif SEXP_USE_INFINITIES +#define SEXP_ABI_NUMBERS "i" +#elif SEXP_USE_FLONUMS +#define SEXP_ABI_NUMBERS "f" +#else +#define SEXP_ABI_NUMBERS "-" +#endif + +#if SEXP_USE_UTF8_STRINGS +#define SEXP_ABI_STRINGS "u" +#elif SEXP_USE_PACKED_STRINGS +#define SEXP_ABI_STRINGS "p" +#else +#define SEXP_ABI_STRINGS "-" +#endif + +#if SEXP_USE_HUFF_SYMS +#define SEXP_ABI_SYMS "h" +#else +#define SEXP_ABI_SYMS "-" +#endif + +#define SEXP_ABI_IDENTIFIER \ + (SEXP_ABI_GC SEXP_ABI_BACKEND SEXP_ABI_INSTRUCTIONS SEXP_ABI_THREADS \ + SEXP_ABI_MODULES SEXP_ABI_NUMBERS SEXP_ABI_STRINGS SEXP_ABI_SYMS) + +#define sexp_version_compatible(ctx, subver, genver) (strcmp((subver), (genver)) == 0) +#define sexp_abi_compatible(ctx, subabi, genabi) (strncmp((subabi), (genabi), sizeof(sexp_abi_identifier_t)) == 0) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h new file mode 100755 index 00000000..c4e6676f --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,1641 @@ +/* sexp.h -- header for sexp library */ +/* Copyright (c) 2009-2013 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 defined(_WIN32) || defined(__MINGW32__) +#include +#define sexp_isalpha(x) ((isalpha)((int)(x))) +#define sexp_isxdigit(x) ((isxdigit)((int)(x))) +#define sexp_isdigit(x) ((isdigit)((int)(x))) +#define sexp_tolower(x) ((tolower)((int)(x))) +#define sexp_toupper(x) ((toupper)((int)(x))) +#else +#if SEXP_USE_DL +#include +#endif +#ifndef PLAN9 +#include +#include +#endif +#if SEXP_USE_GREEN_THREADS +#include +#include +#include +#endif +#define sexp_isalpha(x) (isalpha(x)) +#define sexp_isxdigit(x) (isxdigit(x)) +#define sexp_isdigit(x) (isdigit(x)) +#define sexp_tolower(x) (tolower(x)) +#define sexp_toupper(x) (toupper(x)) +#endif + +#if SEXP_USE_GC_FILE_DESCRIPTORS +#define sexp_out_of_file_descriptors() (errno == EMFILE) +#else +#define sexp_out_of_file_descriptors() (0) +#endif + +#ifdef __GNUC__ +#define SEXP_NO_WARN_UNUSED __attribute__((unused)) +#else +#define SEXP_NO_WARN_UNUSED +#endif + +#ifdef PLAN9 +#include +#include +#include +#include +#include <9p.h> +typedef unsigned long size_t; +#else +#include +#include +#include +#include +#include +#include +#include +#include +#if SEXP_USE_FLONUMS +#include +#include +#endif +#endif + +#if SEXP_USE_TRACK_ALLOC_BACKTRACE +#include +#endif + +#include +#include + +/* 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_BYTES, + SEXP_STRING, + SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, +#if SEXP_USE_RATIOS + SEXP_RATIO, +#endif +#if SEXP_USE_COMPLEX + SEXP_COMPLEX, +#endif + SEXP_IPORT, + SEXP_OPORT, + SEXP_FILENO, + SEXP_EXCEPTION, + SEXP_PROCEDURE, + SEXP_MACRO, + SEXP_SYNCLO, + SEXP_ENV, + SEXP_BYTECODE, + SEXP_CORE, +#if SEXP_USE_DL + SEXP_DL, +#endif + SEXP_OPCODE, + SEXP_LAMBDA, + SEXP_CND, + SEXP_REF, + SEXP_SET, + SEXP_SEQ, + SEXP_LIT, + SEXP_STACK, + SEXP_CONTEXT, + SEXP_CPOINTER, +#if SEXP_USE_AUTO_FORCE + SEXP_PROMISE, +#endif + SEXP_NUM_CORE_TYPES +}; + +/* procedure flags */ +#define SEXP_PROC_NONE 0uL +#define SEXP_PROC_VARIADIC 1uL +#define SEXP_PROC_UNUSED_REST 2uL + +#ifdef _WIN32 +typedef unsigned short sexp_tag_t; +typedef SIZE_T sexp_uint_t; +typedef SSIZE_T sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#elif SEXP_64_BIT +typedef unsigned int sexp_tag_t; +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#elif defined(__CYGWIN__) +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 5) +#else +typedef unsigned short sexp_tag_t; +typedef unsigned int sexp_uint_t; +typedef int sexp_sint_t; +#define sexp_heap_align(n) sexp_align(n, 4) +#endif + +#if SEXP_USE_LONG_PROCEDURE_ARGS +typedef int sexp_proc_num_args_t; +#else +typedef short sexp_proc_num_args_t; +#endif + +typedef struct sexp_struct *sexp; + +#define sexp_heap_pad_size(s) (sizeof(struct sexp_heap_t) + (s) + sexp_heap_align(1)) +#define sexp_free_chunk_size (sizeof(struct sexp_free_list_t)) +#define sexp_heap_first_block(h) ((sexp)(h->data + sexp_heap_align(sexp_free_chunk_size))) +#define sexp_heap_last_block(h) ((sexp)((char*)h->data + h->size - sexp_heap_align(sexp_free_chunk_size))) +#define sexp_heap_end(h) ((sexp)((char*)h->data + h->size)) + +#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, sexp_sint_t 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, sexp_sint_t); +typedef sexp (*sexp_proc2) (sexp, sexp, sexp_sint_t, sexp); +typedef sexp (*sexp_proc3) (sexp, sexp, sexp_sint_t, sexp, sexp); +typedef sexp (*sexp_proc4) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp); +typedef sexp (*sexp_proc5) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc6) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc7) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_init_proc)(sexp, sexp, sexp_sint_t, sexp, const char*, const sexp_abi_identifier_t); + +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, max_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_DEBUG_GC + char *name; +#endif + struct sexp_gc_var_t *next; +}; + +struct sexp_library_entry_t { /* for static builds */ + const char *name; + sexp_init_proc init; +}; + +struct sexp_type_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; + short weak_base, weak_len_base, weak_len_off, weak_len_scale, weak_len_extra; + short depth; + sexp name, cpl, slots, dl, id, print; + sexp_proc2 finalize; +}; + +struct sexp_opcode_struct { + unsigned char op_class, code, num_args, flags, inverse; + sexp name, data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type, + argn_type, methods, dl; + sexp_proc1 func; +}; + +struct sexp_core_form_struct { + char code; + sexp name; +}; + +struct sexp_struct { + sexp_tag_t tag; + char markedp; + unsigned int immutablep:1; + unsigned int freep:1; + unsigned int brokenp:1; + unsigned int syntacticp:1; +#if SEXP_USE_TRACK_ALLOC_SOURCE + const char* source; + void* backtrace[SEXP_BACKTRACE_SIZE]; +#endif +#if SEXP_USE_HEADER_MAGIC + unsigned int magic; +#endif + union { + /* basic types */ + double flonum; + char flonum_bits[sizeof(double)]; /* for eqv? comparison on flonums */ + struct sexp_type_struct type; + struct { + sexp car, cdr; + sexp source; + } pair; + struct { + sexp_uint_t length; + sexp data[]; + } vector; + struct { + sexp_uint_t length; + char data[]; + } bytes; + struct { +#if SEXP_USE_PACKED_STRINGS + sexp_uint_t length; + char data[]; +#else + sexp_uint_t offset, length; + sexp bytes; +#endif + } string; + struct { + sexp_uint_t length; + char data[]; + } symbol; + struct { + FILE *stream; + char *buf; + char openp, bidirp, binaryp, shutdownp, no_closep, sourcep, + blockedp, fold_casep; + sexp_uint_t offset, line, flags; + size_t size; + sexp name; + sexp cookie; + sexp fd; + } port; + struct { + char openp, no_closep; + sexp_sint_t fd, count; + } fileno; + struct { + sexp kind, message, irritants, procedure, source; + } exception; + struct { + signed char sign; + sexp_uint_t length; + sexp_uint_t data[]; + } bignum; + struct { + sexp numerator, denominator; + } ratio; + struct { + sexp real, imag; + } complex; + struct { + sexp_uint_t length; + void *value; + sexp parent; + char body[]; + } cpointer; + /* runtime types */ + struct { + sexp parent, lambda, bindings; +#if SEXP_USE_RENAME_BINDINGS + sexp renames; +#endif + } env; + struct { + sexp_uint_t length, max_depth; + sexp name, literals, source; + unsigned char data[]; + } bytecode; + struct { + char flags; + sexp_proc_num_args_t num_args; + sexp bc, vars; + } procedure; + struct { + sexp proc, env, source; + } macro; + struct { + sexp env, free_vars, expr; + } synclo; + struct { + sexp file; + void* handle; + } dl; + struct sexp_opcode_struct opcode; + struct sexp_core_form_struct core; + /* ast types */ + struct { + sexp name, params, body, defs, locals, flags, fv, sv, ret, types, source; + } lambda; + struct { + sexp test, pass, fail, source; + } cnd; + struct { + sexp var, value, source; + } set; + struct { + sexp name, cell, source; + } ref; + struct { + sexp ls, source; + } seq; + struct { + sexp value, source; + } lit; + /* compiler state */ + struct { + sexp_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp_heap heap; + struct sexp_gc_var_t *saves; +#if SEXP_USE_GREEN_THREADS + sexp_sint_t refuel; + unsigned char* ip; + struct timeval tval; +#endif + char tailp, tracep, timeoutp, waitp, errorp; + sexp_uint_t last_fp; + sexp stack, env, parent, child, + globals, dk, params, proc, name, specific, event, result; +#if SEXP_USE_DL + sexp dl; +#endif + } context; +#if SEXP_USE_AUTO_FORCE + struct { + int donep; + sexp value; + } promise; +#endif + } value; +}; + +#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<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)) + +#if SEXP_USE_TRACK_ALLOC_SOURCE +#define sexp_with_current_source0(file, line) file ": " #line +#define sexp_with_current_source(file, line) , sexp_with_current_source0(file, line) +#else +#define sexp_with_current_source(file, line) +#endif + +#define sexp_alloc_tagged(ctx, size, tag) sexp_alloc_tagged_aux(ctx, size, tag sexp_with_current_source(__FILE__, __LINE__)) + +#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_markedp(x) ((x)->markedp) +#define sexp_flags(x) ((x)->flags) +#define sexp_immutablep(x) ((x)->immutablep) +#define sexp_freep(x) ((x)->freep) +#define sexp_brokenp(x) ((x)->brokenp) +#define sexp_pointer_magic(x) ((x)->magic) + +#if SEXP_USE_TRACK_ALLOC_SOURCE +#define sexp_pointer_source(x) ((x)->source) +#else +#define sexp_pointer_source(x) "" +#endif + +#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)) + +#define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b))) + +#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); +#define sexp_flonum_bits(f) ((char*)&f) +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) +#define sexp_flonum_bits(f) ((f)->value.flonum_bits) +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_bytesp(x) (sexp_check_tag(x, SEXP_BYTES)) +#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR)) +#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT)) +#if SEXP_USE_BIDIRECTIONAL_PORTS +#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT) || (sexp_check_tag(x, SEXP_IPORT) && sexp_port_bidirp(x))) +#else +#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) +#endif +#define sexp_filenop(x) (sexp_check_tag(x, SEXP_FILENO)) +#if SEXP_USE_BIGNUMS +#define sexp_bignump(x) (sexp_check_tag(x, SEXP_BIGNUM)) +#else +#define sexp_bignump(x) 0 +#endif +#if SEXP_USE_RATIOS +#define sexp_ratiop(x) (sexp_check_tag(x, SEXP_RATIO)) +#else +#define sexp_ratiop(x) 0 +#endif +#if SEXP_USE_COMPLEX +#define sexp_complexp(x) (sexp_check_tag(x, SEXP_COMPLEX)) +#else +#define sexp_complexp(x) 0 +#endif +#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_dlp(x) (sexp_check_tag(x, SEXP_DL)) +#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE)) +#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO)) +#define sexp_syntacticp(x) (sexp_corep(x) || sexp_macrop(x)) +#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)) +#define sexp_promisep(x) (sexp_check_tag(x, SEXP_PROMISE)) + +#define sexp_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x)) + +#if SEXP_USE_HUFF_SYMS +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +#else +#define sexp_symbolp(x) (sexp_lsymbolp(x)) +#endif + +SEXP_API int sexp_idp(sexp x); + +#define sexp_portp(x) (sexp_check_tag(x, SEXP_IPORT) || sexp_check_tag(x, SEXP_OPORT)) + +#if SEXP_USE_STRING_STREAMS +#define sexp_stream_portp(x) 1 +#else +#define sexp_stream_portp(x) (sexp_port_stream(x) != NULL) +#endif + +#define sexp_port_customp(x) (sexp_vectorp(sexp_port_cookie(x)) && sexp_vector_length(sexp_port_cookie(x)) == 6) + +/* only valid on custom ports */ +#define sexp_port_buffer(x) (sexp_vector_ref(sexp_port_cookie(x), SEXP_ONE)) +#define sexp_port_reader(x) (sexp_vector_ref(sexp_port_cookie(x), SEXP_TWO)) +#define sexp_port_writer(x) (sexp_vector_ref(sexp_port_cookie(x), SEXP_THREE)) +#define sexp_port_seeker(x) (sexp_vector_ref(sexp_port_cookie(x), SEXP_FOUR)) +#define sexp_port_closer(x) (sexp_vector_ref(sexp_port_cookie(x), SEXP_FIVE)) + +/***************************** 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) + +#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)) + +#define sexp_fixnum_to_double(x) ((double)sexp_unbox_fixnum(x)) + +#if SEXP_USE_PLACEHOLDER_DIGITS +#define sexp_placeholder_digit_p(c) ((c) == SEXP_PLACEHOLDER_DIGIT) +#else +#define sexp_placeholder_digit_p(c) 0 +#endif + +#define sexp_placeholder_digit_value(base) ((base)/2) + +#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_RATIOS +#define sexp_exactp(x) (sexp_exact_integerp(x) || sexp_ratiop(x)) +#else +#define sexp_exactp(x) sexp_exact_integerp(x) +#endif + +#if SEXP_USE_FLONUMS +#define sexp_fixnum_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_fixnum(x))) +#if SEXP_USE_RATIOS +#define sexp_realp(x) (sexp_exact_integerp(x) || sexp_flonump(x) || sexp_ratiop(x)) +#else +#define sexp_realp(x) (sexp_exact_integerp(x) || sexp_flonump(x)) +#endif +#else +#define sexp_fixnum_to_flonum(ctx, x) (x) +#define sexp_realp(x) sexp_exact_integerp(x) +#endif + +#if SEXP_USE_COMPLEX +#define sexp_numberp(x) (sexp_realp(x) || sexp_complexp(x)) +#else +#define sexp_numberp(x) (sexp_realp(x)) +#endif + +#define sexp_exact_negativep(x) (sexp_fixnump(x) ? (sexp_unbox_fixnum(x) < 0) \ + : ((SEXP_USE_BIGNUMS && sexp_bignump(x)) \ + && (sexp_bignum_sign(x) < 0))) +#define sexp_negativep(x) (sexp_exact_negativep(x) || \ + (sexp_flonump(x) && sexp_flonum_value(x) < 0)) +#define sexp_positivep(x) (!(sexp_negativep(x))) + +#if SEXP_USE_BIGNUMS +#define sexp_oddp(x) (sexp_fixnump(x) ? sexp_unbox_fixnum(x) & 1 : \ + sexp_bignump(x) && (sexp_bignum_data(x)[0] & 1)) +#else +#define sexp_oddp(x) (sexp_fixnump(x) && (sexp_unbox_fixnum(x) & 1)) +#endif +#define sexp_evenp(x) (!(sexp_oddp(x))) + +#define sexp_negate_exact(x) \ + if (sexp_bignump(x)) \ + sexp_bignum_sign(x) = -sexp_bignum_sign(x); \ + else if (sexp_fixnump(x)) \ + x = sexp_fx_neg(x); + +#if SEXP_USE_IMMEDIATE_FLONUMS +#define sexp_negate_flonum(x) (x) = sexp_make_flonum(NULL, -(sexp_flonum_value(x))) +#else +#define sexp_negate_flonum(x) sexp_flonum_value(x) = -(sexp_flonum_value(x)) +#endif + +#define sexp_negate(x) \ + if (sexp_flonump(x)) \ + sexp_negate_flonum(x); \ + else \ + sexp_negate_exact(x) + +#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) + +#define sexp_infp(x) (sexp_flonump(x) && isinf(sexp_flonum_value(x))) +#define sexp_nanp(x) (sexp_flonump(x) && isnan(sexp_flonum_value(x))) + +#if SEXP_USE_IEEE_EQV +#define sexp_flonum_eqv(x, y) (memcmp(sexp_flonum_bits(x), sexp_flonum_bits(y), sizeof(double)) == 0) +#else +#define sexp_flonum_eqv(x, y) (sexp_flonum_value(x) == sexp_flonum_value(y)) +#endif + +/*************************** field accessors **************************/ + +#if SEXP_USE_SAFE_ACCESSORS +#if 0 +#define sexp_field(x, type, id, field) (*(((x) && sexp_check_tag(x, id)) ? &((x)->value.type.field) : (fprintf(stderr, "invalid field access in %s line %d: %p (%d) isn't a "#type"\n", __FILE__, __LINE__, x, (int)(sexp_pointerp(x) ? sexp_pointer_tag(x) : -1)), &(((sexp)NULL)->value.type.field)))) +#define sexp_pred_field(x, type, pred, field) (*(((x) && pred(x)) ? &((x)->value.type.field) : (fprintf(stderr, "invalid field access in %s line %d: %p (%d) isn't a "#type"\n", __FILE__, __LINE__, x, (int)(sexp_pointerp(x) ? sexp_pointer_tag(x) : -1)), &(((sexp)NULL)->value.type.field)))) +#define sexp_cpointer_field(x, field) (*(((x) && sexp_pointerp(x) && sexp_pointer_tag(x) >= SEXP_CPOINTER) ? &((x)->value.cpointer.field) : (fprintf(stderr, "invalid field access in %s line %d: %p (%d) isn't a cpointer\n", __FILE__, __LINE__, x, (int)(sexp_pointerp(x) ? sexp_pointer_tag(x) : -1)), &(((sexp)NULL)->value.cpointer.field)))) +#else +#define sexp_field(x, type, id, field) (*({sexp _x=x; (((_x) && sexp_check_tag(_x, id)) ? &((_x)->value.type.field) : (fprintf(stderr, "invalid field access in %s line %d: %p (%d) isn't a "#type"\n", __FILE__, __LINE__, _x, (int)(sexp_pointerp(_x) ? sexp_pointer_tag(_x) : -1)), &(((sexp)NULL)->value.type.field)));})) +#define sexp_pred_field(x, type, pred, field) (*({sexp _x=x; (((_x) && pred(_x)) ? &((_x)->value.type.field) : (fprintf(stderr, "invalid field access in %s line %d: %p (%d) isn't a "#type"\n", __FILE__, __LINE__, _x, (int)(sexp_pointerp(_x) ? sexp_pointer_tag(_x) : -1)), &(((sexp)NULL)->value.type.field)));})) +#define sexp_cpointer_field(x, field) (*({sexp _x=x; (((_x) && sexp_pointerp(_x) && sexp_pointer_tag(_x) >= SEXP_CPOINTER) ? &((_x)->value.cpointer.field) : (fprintf(stderr, "invalid field access in %s line %d: %p (%d) isn't a cpointer\n", __FILE__, __LINE__, _x, (int)(sexp_pointerp(_x) ? sexp_pointer_tag(_x) : -1)), &(((sexp)NULL)->value.cpointer.field)));})) +#endif +#else +#define sexp_field(x, type, id, field) ((x)->value.type.field) +#define sexp_pred_field(x, type, pred, field) ((x)->value.type.field) +#define sexp_cpointer_field(x, field) ((x)->value.cpointer.field) +#endif + +#define sexp_vector_length(x) (sexp_field(x, vector, SEXP_VECTOR, length)) +#define sexp_vector_data(x) (sexp_field(x, vector, SEXP_VECTOR, data)) + +#if SEXP_USE_SAFE_VECTOR_ACCESSORS +#define sexp_vector_ref(x,i) (sexp_unbox_fixnum(i)>=0 && sexp_unbox_fixnum(i)=0 && sexp_unbox_fixnum(i)tag = SEXP_BYTES, x) +#else +#define sexp_string_to_bytes(ctx, x) sexp_string_bytes(x) +#endif + +#define sexp_bytes_ref(x, i) (sexp_make_fixnum((unsigned char)sexp_bytes_data(x)[sexp_unbox_fixnum(i)])) +#define sexp_bytes_set(x, i, v) (sexp_bytes_data(x)[sexp_unbox_fixnum(i)] = sexp_unbox_fixnum(v)) + +#define sexp_lsymbol_data(x) (sexp_field(x, symbol, SEXP_SYMBOL, data)) +#define sexp_lsymbol_length(x) (sexp_field(x, symbol, SEXP_SYMBOL, length)) + +#define sexp_port_stream(p) (sexp_pred_field(p, port, sexp_portp, stream)) +#define sexp_port_name(p) (sexp_pred_field(p, port, sexp_portp, name)) +#define sexp_port_line(p) (sexp_pred_field(p, port, sexp_portp, line)) +#define sexp_port_openp(p) (sexp_pred_field(p, port, sexp_portp, openp)) +#define sexp_port_bidirp(p) (sexp_pred_field(p, port, sexp_portp, bidirp)) +#define sexp_port_binaryp(p) (sexp_pred_field(p, port, sexp_portp, binaryp)) +#define sexp_port_shutdownp(p) (sexp_pred_field(p, port, sexp_portp, shutdownp)) +#define sexp_port_no_closep(p) (sexp_pred_field(p, port, sexp_portp, no_closep)) +#define sexp_port_sourcep(p) (sexp_pred_field(p, port, sexp_portp, sourcep)) +#define sexp_port_blockedp(p) (sexp_pred_field(p, port, sexp_portp, blockedp)) +#define sexp_port_fold_casep(p) (sexp_pred_field(p, port, sexp_portp, fold_casep)) +#define sexp_port_cookie(p) (sexp_pred_field(p, port, sexp_portp, cookie)) +#define sexp_port_buf(p) (sexp_pred_field(p, port, sexp_portp, buf)) +#define sexp_port_size(p) (sexp_pred_field(p, port, sexp_portp, size)) +#define sexp_port_offset(p) (sexp_pred_field(p, port, sexp_portp, offset)) +#define sexp_port_flags(p) (sexp_pred_field(p, port, sexp_portp, flags)) +#define sexp_port_fd(p) (sexp_pred_field(p, port, sexp_portp, fd)) + +#define sexp_fileno_fd(f) (sexp_pred_field(f, fileno, sexp_filenop, fd)) +#define sexp_fileno_count(f) (sexp_pred_field(f, fileno, sexp_filenop, count)) +#define sexp_fileno_openp(f) (sexp_pred_field(f, fileno, sexp_filenop, openp)) +#define sexp_fileno_socketp(f) (sexp_pred_field(f, fileno, sexp_filenop, socketp)) +#define sexp_fileno_no_closep(f) (sexp_pred_field(f, fileno, sexp_filenop, no_closep)) + +#define sexp_ratio_numerator(q) (sexp_pred_field(q, ratio, sexp_ratiop, numerator)) +#define sexp_ratio_denominator(q) (sexp_pred_field(q, ratio, sexp_ratiop, denominator)) + +#define sexp_complex_real(q) (sexp_pred_field(q, complex, sexp_complexp, real)) +#define sexp_complex_imag(q) (sexp_pred_field(q, complex, sexp_complexp, imag)) + +#define sexp_exception_kind(x) (sexp_field(x, exception, SEXP_EXCEPTION, kind)) +#define sexp_exception_message(x) (sexp_field(x, exception, SEXP_EXCEPTION, message)) +#define sexp_exception_irritants(x) (sexp_field(x, exception, SEXP_EXCEPTION, irritants)) +#define sexp_exception_procedure(x) (sexp_field(x, exception, SEXP_EXCEPTION, procedure)) +#define sexp_exception_source(x) (sexp_field(x, exception, SEXP_EXCEPTION, source)) + +#define sexp_trampolinep(x) (sexp_exceptionp(x) && sexp_exception_kind(x) == SEXP_TRAMPOLINE) +#define sexp_trampoline_procedure(x) sexp_exception_procedure(x) +#define sexp_trampoline_args(x) sexp_exception_irritants(x) + +#define sexp_cpointer_freep(x) (sexp_freep(x)) +#define sexp_cpointer_length(x) (sexp_cpointer_field(x, length)) +#define sexp_cpointer_body(x) (sexp_cpointer_field(x, body)) +#define sexp_cpointer_parent(x) (sexp_cpointer_field(x, parent)) +#define sexp_cpointer_value(x) (sexp_cpointer_field(x, value)) +#define sexp_cpointer_maybe_null_value(x) (sexp_not(x) ? NULL : sexp_cpointer_value(x)) + +#define sexp_bytecode_length(x) (sexp_field(x, bytecode, SEXP_BYTECODE, length)) +#define sexp_bytecode_max_depth(x) (sexp_field(x, bytecode, SEXP_BYTECODE, max_depth)) +#define sexp_bytecode_name(x) (sexp_field(x, bytecode, SEXP_BYTECODE, name)) +#define sexp_bytecode_literals(x) (sexp_field(x, bytecode, SEXP_BYTECODE, literals)) +#define sexp_bytecode_source(x) (sexp_field(x, bytecode, SEXP_BYTECODE, source)) +#define sexp_bytecode_data(x) (sexp_field(x, bytecode, SEXP_BYTECODE, data)) + +#define sexp_env_cell_syntactic_p(x) ((x)->syntacticp) + +#define sexp_env_syntactic_p(x) ((x)->syntacticp) +#define sexp_env_parent(x) (sexp_field(x, env, SEXP_ENV, parent)) +#define sexp_env_bindings(x) (sexp_field(x, env, SEXP_ENV, bindings)) +#define sexp_env_renames(x) (sexp_field(x, env, SEXP_ENV, renames)) +#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) (sexp_field(x, env, SEXP_ENV, lambda)) + +#define sexp_macro_proc(x) (sexp_field(x, macro, SEXP_MACRO, proc)) +#define sexp_macro_env(x) (sexp_field(x, macro, SEXP_MACRO, env)) +#define sexp_macro_source(x) (sexp_field(x, macro, SEXP_MACRO, source)) + +#define sexp_synclo_env(x) (sexp_field(x, synclo, SEXP_SYNCLO, env)) +#define sexp_synclo_free_vars(x) (sexp_field(x, synclo, SEXP_SYNCLO, free_vars)) +#define sexp_synclo_expr(x) (sexp_field(x, synclo, SEXP_SYNCLO, expr)) + +#define sexp_core_code(x) (sexp_field(x, core, SEXP_CORE, code)) +#define sexp_core_name(x) (sexp_field(x, core, SEXP_CORE, name)) + +#define sexp_dl_file(x) (sexp_field(x, dl, SEXP_DL, file)) +#define sexp_dl_handle(x) (sexp_field(x, dl, SEXP_DL, handle)) + +#define sexp_opcode_class(x) (sexp_field(x, opcode, SEXP_OPCODE, op_class)) +#define sexp_opcode_code(x) (sexp_field(x, opcode, SEXP_OPCODE, code)) +#define sexp_opcode_num_args(x) (sexp_field(x, opcode, SEXP_OPCODE, num_args)) +#define sexp_opcode_flags(x) (sexp_field(x, opcode, SEXP_OPCODE, flags)) +#define sexp_opcode_inverse(x) (sexp_field(x, opcode, SEXP_OPCODE, inverse)) +#define sexp_opcode_dl(x) (sexp_field(x, opcode, SEXP_OPCODE, dl)) +#define sexp_opcode_name(x) (sexp_field(x, opcode, SEXP_OPCODE, name)) +#define sexp_opcode_data(x) (sexp_field(x, opcode, SEXP_OPCODE, data)) +#define sexp_opcode_data2(x) (sexp_field(x, opcode, SEXP_OPCODE, data2)) +#define sexp_opcode_proc(x) (sexp_field(x, opcode, SEXP_OPCODE, proc)) +#define sexp_opcode_return_type(x) (sexp_field(x, opcode, SEXP_OPCODE, ret_type)) +#define sexp_opcode_arg1_type(x) (sexp_field(x, opcode, SEXP_OPCODE, arg1_type)) +#define sexp_opcode_arg2_type(x) (sexp_field(x, opcode, SEXP_OPCODE, arg2_type)) +#define sexp_opcode_arg3_type(x) (sexp_field(x, opcode, SEXP_OPCODE, arg3_type)) +#define sexp_opcode_argn_type(x) (sexp_field(x, opcode, SEXP_OPCODE, argn_type)) +#define sexp_opcode_methods(x) (sexp_field(x, opcode, SEXP_OPCODE, methods)) +#define sexp_opcode_func(x) (sexp_field(x, opcode, SEXP_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_opcode_static_param_p(x) (sexp_opcode_flags(x) & 8) +#define sexp_opcode_tail_call_p(x) (sexp_opcode_flags(x) & 16) + +#define sexp_lambda_name(x) (sexp_field(x, lambda, SEXP_LAMBDA, name)) +#define sexp_lambda_params(x) (sexp_field(x, lambda, SEXP_LAMBDA, params)) +#define sexp_lambda_locals(x) (sexp_field(x, lambda, SEXP_LAMBDA, locals)) +#define sexp_lambda_defs(x) (sexp_field(x, lambda, SEXP_LAMBDA, defs)) +#define sexp_lambda_flags(x) (sexp_field(x, lambda, SEXP_LAMBDA, flags)) +#define sexp_lambda_body(x) (sexp_field(x, lambda, SEXP_LAMBDA, body)) +#define sexp_lambda_fv(x) (sexp_field(x, lambda, SEXP_LAMBDA, fv)) +#define sexp_lambda_sv(x) (sexp_field(x, lambda, SEXP_LAMBDA, sv)) +#define sexp_lambda_return_type(x) (sexp_field(x, lambda, SEXP_LAMBDA, ret)) +#define sexp_lambda_param_types(x) (sexp_field(x, lambda, SEXP_LAMBDA, types)) +#define sexp_lambda_source(x) (sexp_field(x, lambda, SEXP_LAMBDA, source)) + +#define sexp_cnd_test(x) (sexp_field(x, cnd, SEXP_CND, test)) +#define sexp_cnd_pass(x) (sexp_field(x, cnd, SEXP_CND, pass)) +#define sexp_cnd_fail(x) (sexp_field(x, cnd, SEXP_CND, fail)) +#define sexp_cnd_source(x) (sexp_field(x, cnd, SEXP_CND, source)) + +#define sexp_set_var(x) (sexp_field(x, set, SEXP_SET, var)) +#define sexp_set_value(x) (sexp_field(x, set, SEXP_SET, value)) +#define sexp_set_source(x) (sexp_field(x, set, SEXP_SET, source)) + +#define sexp_ref_name(x) (sexp_field(x, ref, SEXP_REF, name)) +#define sexp_ref_cell(x) ((x)->value.ref.cell) +#define sexp_ref_loc(x) (sexp_cdr(sexp_ref_cell(x))) +#define sexp_ref_source(x) (sexp_field(x, ref, SEXP_REF, source)) + +#define sexp_seq_ls(x) (sexp_field(x, seq, SEXP_SEQ, ls)) +#define sexp_seq_source(x) (sexp_field(x, seq, SEXP_SEQ, source)) + +#define sexp_lit_value(x) (sexp_field(x, lit, SEXP_LIT, value)) +#define sexp_lit_source(x) (sexp_field(x, lit, SEXP_LIT, source)) + +#define sexp_stack_length(x) (sexp_field(x, stack, SEXP_STACK, length)) +#define sexp_stack_top(x) (sexp_field(x, stack, SEXP_STACK, top)) +#define sexp_stack_data(x) (sexp_field(x, stack, SEXP_STACK, data)) + +#define sexp_promise_donep(x) (sexp_field(x, promise, SEXP_PROMISE, donep)) +#define sexp_promise_value(x) (sexp_field(x, promise, SEXP_PROMISE, value)) + +#define sexp_context_env(x) (sexp_field(x, context, SEXP_CONTEXT, env)) +#define sexp_context_stack(x) (sexp_field(x, context, SEXP_CONTEXT, stack)) +#define sexp_context_parent(x) (sexp_field(x, context, SEXP_CONTEXT, parent)) +#define sexp_context_child(x) (sexp_field(x, context, SEXP_CONTEXT, child)) +#define sexp_context_saves(x) (sexp_field(x, context, SEXP_CONTEXT, saves)) +#define sexp_context_tailp(x) (sexp_field(x, context, SEXP_CONTEXT, tailp)) +#define sexp_context_tracep(x) (sexp_field(x, context, SEXP_CONTEXT, tracep)) +#define sexp_context_globals(x) (sexp_field(x, context, SEXP_CONTEXT, globals)) +#define sexp_context_dk(x) (sexp_field(x, context, SEXP_CONTEXT, dk)) +#define sexp_context_params(x) (sexp_field(x, context, SEXP_CONTEXT, params)) +#define sexp_context_last_fp(x) (sexp_field(x, context, SEXP_CONTEXT, last_fp)) +#define sexp_context_refuel(x) (sexp_field(x, context, SEXP_CONTEXT, refuel)) +#define sexp_context_ip(x) (sexp_field(x, context, SEXP_CONTEXT, ip)) +#define sexp_context_proc(x) (sexp_field(x, context, SEXP_CONTEXT, proc)) +#define sexp_context_timeval(x) (sexp_field(x, context, SEXP_CONTEXT, tval)) +#define sexp_context_name(x) (sexp_field(x, context, SEXP_CONTEXT, name)) +#define sexp_context_specific(x) (sexp_field(x, context, SEXP_CONTEXT, specific)) +#define sexp_context_event(x) (sexp_field(x, context, SEXP_CONTEXT, event)) +#define sexp_context_timeoutp(x) (sexp_field(x, context, SEXP_CONTEXT, timeoutp)) +#define sexp_context_waitp(x) (sexp_field(x, context, SEXP_CONTEXT, waitp)) +#define sexp_context_dl(x) (sexp_field(x, context, SEXP_CONTEXT, dl)) + +#define sexp_context_result(x) (sexp_field(x, context, SEXP_CONTEXT, result)) +#define sexp_context_errorp(x) (sexp_field(x, context, SEXP_CONTEXT, errorp)) + +/* during compilation, sexp_context_specific is set to a vector */ +/* containing the following elements: */ + +#define sexp_context_bc(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_ZERO)) +#define sexp_context_fv(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_ONE)) +#define sexp_context_lambda(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_TWO)) +#define sexp_context_pos(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_THREE)) +#define sexp_context_depth(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_FOUR)) +#define sexp_context_max_depth(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_FIVE)) +#define sexp_context_exception(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_SIX)) + +#if SEXP_USE_ALIGNED_BYTECODE +#define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = (sexp)sexp_word_align((sexp_uint_t)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 +#define sexp_context_max_size(ctx) 0 +#else +#define sexp_context_heap(ctx) ((ctx)->value.context.heap) +#define sexp_context_max_size(ctx) sexp_context_heap(ctx)->max_size +#endif + +#if SEXP_USE_GLOBAL_SYMBOLS +#define sexp_context_symbols(ctx) sexp_symbol_table +SEXP_API sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE]; +#else +#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) +#endif + +#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)) + +#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_type_num_weak_slots_of_object(t, x) \ + (((sexp_uint_t*)((char*)x + sexp_type_weak_len_off(t)))[0] \ + * sexp_type_weak_len_scale(t) \ + + sexp_type_weak_len_base(t)) + +#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) + +#define sexp_type_tag(x) (sexp_field(x, type, SEXP_TYPE, tag)) +#define sexp_type_field_base(x) (sexp_field(x, type, SEXP_TYPE, field_base)) +#define sexp_type_field_eq_len_base(x) (sexp_field(x, type, SEXP_TYPE, field_eq_len_base)) +#define sexp_type_field_len_base(x) (sexp_field(x, type, SEXP_TYPE, field_len_base)) +#define sexp_type_field_len_off(x) (sexp_field(x, type, SEXP_TYPE, field_len_off)) +#define sexp_type_field_len_scale(x) (sexp_field(x, type, SEXP_TYPE, field_len_scale)) +#define sexp_type_size_base(x) (sexp_field(x, type, SEXP_TYPE, size_base)) +#define sexp_type_size_off(x) (sexp_field(x, type, SEXP_TYPE, size_off)) +#define sexp_type_size_scale(x) (sexp_field(x, type, SEXP_TYPE, size_scale)) +#define sexp_type_weak_base(x) (sexp_field(x, type, SEXP_TYPE, weak_base)) +#define sexp_type_weak_len_base(x) (sexp_field(x, type, SEXP_TYPE, weak_len_base)) +#define sexp_type_weak_len_off(x) (sexp_field(x, type, SEXP_TYPE, weak_len_off)) +#define sexp_type_weak_len_scale(x) (sexp_field(x, type, SEXP_TYPE, weak_len_scale)) +#define sexp_type_weak_len_extra(x) (sexp_field(x, type, SEXP_TYPE, weak_len_extra)) +#define sexp_type_depth(x) (sexp_field(x, type, SEXP_TYPE, depth)) +#define sexp_type_name(x) (sexp_field(x, type, SEXP_TYPE, name)) +#define sexp_type_cpl(x) (sexp_field(x, type, SEXP_TYPE, cpl)) +#define sexp_type_slots(x) (sexp_field(x, type, SEXP_TYPE, slots)) +#define sexp_type_finalize(x) (sexp_field(x, type, SEXP_TYPE, finalize)) +#define sexp_type_print(x) (sexp_field(x, type, SEXP_TYPE, print)) +#define sexp_type_dl(x) (sexp_field(x, type, SEXP_TYPE, dl)) +#define sexp_type_id(x) (sexp_field(x, type, SEXP_TYPE, id)) + +#define sexp_bignum_sign(x) (sexp_field(x, bignum, SEXP_BIGNUM, sign)) +#define sexp_bignum_length(x) (sexp_field(x, bignum, SEXP_BIGNUM, length)) +#define sexp_bignum_data(x) (sexp_field(x, bignum, SEXP_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))) + +#if ! (SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS) +#define sexp_add(ctx, a, b) sexp_fx_add(a, b) +#define sexp_sub(ctx, a, b) sexp_fx_sub(a, b) +#define sexp_mul(ctx, a, b) sexp_fx_mul(a, b) +#define sexp_div(ctx, a, b) sexp_fx_div(a, b) +#endif + +/****************************** utilities *****************************/ + +enum sexp_context_globals { +#if ! SEXP_USE_GLOBAL_SYMBOLS + SEXP_G_SYMBOLS, +#endif + SEXP_G_TYPES, + SEXP_G_NUM_TYPES, + SEXP_G_OOM_ERROR, /* out of memory exception object */ + SEXP_G_OOS_ERROR, /* out of stack exception object */ + SEXP_G_ABI_ERROR, /* incompatible ABI loading library */ + SEXP_G_OPTIMIZATIONS, + SEXP_G_SIGNAL_HANDLERS, + SEXP_G_FILE_DESCRIPTORS, + SEXP_G_META_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_CONTINUABLE_SYMBOL, + SEXP_G_ERR_HANDLER, + SEXP_G_RESUMECC_BYTECODE, + SEXP_G_FINAL_RESUMER, + SEXP_G_STRICT_P, +#if SEXP_USE_FOLD_CASE_SYMS + SEXP_G_FOLD_CASE_P, +#endif +#if SEXP_USE_WEAK_REFERENCES + SEXP_G_WEAK_REFERENCE_CACHE, +#endif +#if ! SEXP_USE_BOEHM + SEXP_G_PRESERVATIVES, +#endif +#if SEXP_USE_GREEN_THREADS + SEXP_G_IO_BLOCK_ERROR, + SEXP_G_THREADS_SCHEDULER, + SEXP_G_THREADS_FRONT, + SEXP_G_THREADS_BACK, + SEXP_G_THREADS_PAUSED, + SEXP_G_THREADS_SIGNALS, + SEXP_G_THREADS_SIGNAL_RUNNER, + SEXP_G_THREADS_POLL_FDS, + SEXP_G_THREADS_FD_THREADS, + SEXP_G_THREADS_BLOCKER, + SEXP_G_THREADS_MUTEX_ID, + SEXP_G_THREADS_POLLFDS_ID, + SEXP_G_ATOMIC_P, +#endif + SEXP_G_NUM_GLOBALS +}; + +#define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL) + +SEXP_API sexp sexp_push_op(sexp ctx, sexp* loc, sexp x); + +#if SEXP_USE_UNSAFE_PUSH +#define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) +#else +#define sexp_push(ctx, ls, x) (sexp_push_op((ctx), &(ls), (x))) +#endif +#define sexp_insert(ctx, ls, x) ((sexp_memq(ctx, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x))) + +#define sexp_pair_source(x) (sexp_field(x, pair, SEXP_PAIR, source)) + +#define sexp_car(x) (sexp_field(x, pair, SEXP_PAIR, car)) +#define sexp_cdr(x) (sexp_field(x, pair, SEXP_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_write_string_n(x, s, n, p) (fwrite(s, 1, n, sexp_port_stream(p))) +#define sexp_flush(x, p) (fflush(sexp_port_stream(p))) +#define sexp_flush_forced sexp_flush + +#else + +#define sexp_read_char(x, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? ((unsigned char*)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) ((c!=EOF) && (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)), 0) : sexp_buffered_write_char(x, c, p)) : putc(c, sexp_port_stream(p))) +#define sexp_write_string(x, s, p) (sexp_port_buf(p) ? sexp_buffered_write_string(x, s, p) : fputs(s, sexp_port_stream(p))) +#define sexp_write_string_n(x, s, n, p) (sexp_port_buf(p) ? sexp_buffered_write_string_n(x, s, n, p) : fwrite(s, 1, n, sexp_port_stream(p))) +#define sexp_flush(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p, 0) : fflush(sexp_port_stream(p))) +#define sexp_flush_forced(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p, 1) : fflush(sexp_port_stream(p))) + +SEXP_API int sexp_buffered_read_char (sexp ctx, sexp p); +SEXP_API int sexp_buffered_write_char (sexp ctx, int c, sexp p); +SEXP_API int sexp_buffered_write_string_n (sexp ctx, const char *str, sexp_uint_t len, sexp p); +SEXP_API int sexp_buffered_write_string (sexp ctx, const char *str, sexp p); +SEXP_API int sexp_buffered_flush (sexp ctx, sexp p, int forcep); + +#endif + +#define sexp_newline(ctx, p) sexp_write_char((ctx), '\n', (p)) +#define sexp_at_eofp(p) (feof(sexp_port_stream(p))) +#define sexp_port_fileno(p) (sexp_port_stream(p) ? fileno(sexp_port_stream(p)) : sexp_filenop(sexp_port_fd(p)) ? sexp_fileno_fd(sexp_port_fd(p)) : -1) + +#if SEXP_USE_AUTOCLOSE_PORTS +#define SEXP_FINALIZE_PORT sexp_finalize_port +#define SEXP_FINALIZE_FILENO sexp_finalize_fileno +#else +#define SEXP_FINALIZE_PORT NULL +#define SEXP_FINALIZE_FILENO NULL +#endif + +#if SEXP_USE_DL +sexp sexp_finalize_dl (sexp ctx, sexp self, sexp_sint_t n, sexp dl); +#define SEXP_FINALIZE_DL sexp_finalize_dl +#else +#define SEXP_FINALIZE_DL NULL +#endif + +#if SEXP_USE_TRACK_ALLOC_SOURCE +#define sexp_current_source_param , const char* source +#else +#define sexp_current_source_param +#endif + +SEXP_API sexp sexp_alloc_tagged_aux(sexp ctx, size_t size, sexp_uint_t tag sexp_current_source_param); +SEXP_API sexp sexp_make_context(sexp ctx, size_t size, size_t max_size); +SEXP_API sexp sexp_cons_op(sexp ctx, sexp self, sexp_sint_t n, sexp head, sexp tail); +SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_equalp_bound (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b, sexp depth, sexp bound); +SEXP_API sexp sexp_equalp_op (sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b); +SEXP_API sexp sexp_listp_op(sexp ctx, sexp self, sexp_sint_t n, sexp obj); +SEXP_API sexp sexp_reverse_op(sexp ctx, sexp self, sexp_sint_t n, sexp ls); +SEXP_API sexp sexp_nreverse_op(sexp ctx, sexp self, sexp_sint_t n, sexp ls); +SEXP_API sexp sexp_copy_list_op(sexp ctx, sexp self, sexp_sint_t n, sexp ls); +SEXP_API sexp sexp_append2_op(sexp ctx, sexp self, sexp_sint_t n, sexp a, sexp b); +SEXP_API sexp sexp_memq_op(sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp ls); +SEXP_API sexp sexp_assq_op(sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp ls); +SEXP_API sexp sexp_length_op(sexp ctx, sexp self, sexp_sint_t n, sexp ls); +SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen); +SEXP_API sexp sexp_make_bytes_op(sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp i); +SEXP_API sexp sexp_make_string_op(sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp ch); +SEXP_API sexp sexp_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end); +SEXP_API sexp sexp_subbytes_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end); +SEXP_API sexp sexp_string_concatenate_op (sexp ctx, sexp self, sexp_sint_t 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 self, sexp_sint_t n, sexp str); +SEXP_API sexp sexp_symbol_to_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp sym); +SEXP_API sexp sexp_string_to_number_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp b); +SEXP_API sexp sexp_flonump_op (sexp ctx, sexp self, sexp_sint_t n, sexp x); +SEXP_API sexp sexp_make_vector_op (sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp dflt); +SEXP_API sexp sexp_list_to_vector_op (sexp ctx, sexp self, sexp_sint_t n, sexp ls); +SEXP_API sexp sexp_make_cpointer (sexp ctx, sexp_uint_t type_id, void* value, sexp parent, int freep); +SEXP_API int sexp_is_separator(int c); +SEXP_API sexp sexp_write_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp out); +SEXP_API sexp sexp_display_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp out); +SEXP_API sexp sexp_flush_output_op (sexp ctx, sexp self, sexp_sint_t n, sexp out); +SEXP_API sexp sexp_read_string (sexp ctx, sexp in, int sentinel); +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); +#if SEXP_USE_BIGNUMS +SEXP_API sexp sexp_read_bignum (sexp ctx, sexp in, sexp_uint_t init, + signed char sign, sexp_uint_t base); +SEXP_API sexp sexp_write_bignum (sexp ctx, sexp a, sexp out, sexp_uint_t base); +#endif +SEXP_API sexp sexp_read_float_tail(sexp ctx, sexp in, double whole, int negp); +#if SEXP_USE_COMPLEX +SEXP_API sexp sexp_read_complex_tail(sexp ctx, sexp in, sexp res); +#endif +SEXP_API sexp sexp_read_raw (sexp ctx, sexp in); +SEXP_API sexp sexp_read_op (sexp ctx, sexp self, sexp_sint_t n, sexp in); +SEXP_API sexp sexp_char_ready_p (sexp ctx, sexp self, sexp_sint_t n, sexp in); +SEXP_API sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len); +SEXP_API sexp sexp_read_error (sexp ctx, const char *msg, sexp ir, sexp port); +SEXP_API sexp sexp_write_to_string (sexp ctx, sexp obj); +SEXP_API sexp sexp_write_simple_object (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp writer, sexp out); +SEXP_API sexp sexp_finalize_port (sexp ctx, sexp self, sexp_sint_t n, sexp port); +SEXP_API sexp sexp_make_fileno_op (sexp ctx, sexp self, sexp_sint_t n, sexp fd, sexp no_closep); +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_open_input_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp socketp); +SEXP_API sexp sexp_open_output_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp fileno, sexp socketp); +SEXP_API sexp sexp_make_non_null_input_port (sexp ctx, FILE* in, sexp name); +SEXP_API sexp sexp_make_non_null_output_port (sexp ctx, FILE* out, sexp name); +SEXP_API sexp sexp_make_non_null_input_output_port (sexp ctx, FILE* io, sexp name); +SEXP_API sexp sexp_port_outputp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port); +SEXP_API sexp sexp_port_binaryp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port); +SEXP_API sexp sexp_port_openp_op (sexp ctx, sexp self, sexp_sint_t n, sexp port); +#if SEXP_USE_FOLD_CASE_SYMS +SEXP_API sexp sexp_get_port_fold_case (sexp ctx, sexp self, sexp_sint_t n, sexp in); +SEXP_API sexp sexp_set_port_fold_case (sexp ctx, sexp self, sexp_sint_t n, sexp in, sexp x); +#endif +#if SEXP_USE_OBJECT_BRACE_LITERALS +SEXP_API sexp sexp_lookup_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp id); +#endif +SEXP_API sexp sexp_open_input_string_op (sexp ctx, sexp self, sexp_sint_t n, sexp str); +SEXP_API sexp sexp_open_output_string_op (sexp ctx, sexp self, sexp_sint_t n); +SEXP_API sexp sexp_get_output_string_op (sexp ctx, sexp self, sexp_sint_t 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_file_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 self, sexp_sint_t n, sexp exn, sexp out); +SEXP_API sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out); +SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); +SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x); +SEXP_API sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args); +SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); +SEXP_API void sexp_init(void); + +#if SEXP_USE_UTF8_STRINGS +SEXP_API int sexp_utf8_initial_byte_count (int c); +SEXP_API int sexp_utf8_char_byte_count (int c); +SEXP_API sexp_uint_t sexp_string_utf8_length (unsigned char *p, long len); +SEXP_API char* sexp_string_utf8_prev (unsigned char *p); +SEXP_API sexp sexp_string_utf8_ref (sexp ctx, sexp str, sexp i); +SEXP_API sexp sexp_string_utf8_index_ref (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp i); +SEXP_API sexp sexp_string_index_to_offset (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp index); +SEXP_API sexp sexp_utf8_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end); +SEXP_API void sexp_utf8_encode_char (unsigned char* p, int len, int c); +SEXP_API int sexp_write_utf8_char (sexp ctx, int c, sexp out); +#define sexp_string_ref(ctx, s, i) (sexp_string_utf8_index_ref(ctx, NULL, 2, s, i)) +#define sexp_string_set(ctx, s, i, ch) (sexp_string_utf8_index_set(ctx, NULL, 3, s, i, ch)) +#define sexp_string_cursor_ref(ctx, s, i) (sexp_string_utf8_ref(ctx, s, i)) +#define sexp_string_cursor_set(ctx, s, i) (sexp_string_utf8_set(ctx, s, i)) +#define sexp_string_cursor_next(s, i) sexp_make_fixnum(sexp_unbox_fixnum(i) + sexp_utf8_initial_byte_count(((unsigned char*)sexp_string_data(s))[sexp_unbox_fixnum(i)])) +#define sexp_string_cursor_prev(s, i) sexp_make_fixnum(sexp_string_utf8_prev((unsigned char*)sexp_string_data(s)+sexp_unbox_fixnum(i)) - sexp_string_data(s)) +#define sexp_string_length(s) sexp_string_utf8_length((unsigned char*)sexp_string_data(s), sexp_string_size(s)) +#define sexp_substring(ctx, s, i, j) sexp_utf8_substring_op(ctx, NULL, 3, s, i, j) +#define sexp_substring_cursor(ctx, s, i, j) sexp_substring_op(ctx, NULL, 3, s, i, j) +#else /* ASCII strings */ +#define sexp_string_ref(ctx, s, i) (sexp_make_character((unsigned char)sexp_string_data(s)[sexp_unbox_fixnum(i)])) +#define sexp_string_set(ctx, s, i, ch) (sexp_string_data(s)[sexp_unbox_fixnum(i)] = sexp_unbox_character(ch)) +#define sexp_string_cursor_ref(ctx, s, i) sexp_string_ref(ctx, s, i) +#define sexp_string_cursor_set(ctx, s, i, ch) sexp_string_set(ctx, s, i, ch) +#define sexp_string_cursor_next(s, i) sexp_make_fixnum(sexp_unbox_fixnum(i) + 1) +#define sexp_string_cursor_prev(s, i) sexp_make_fixnum(sexp_unbox_fixnum(i) - 1) +#define sexp_string_length(s) sexp_string_size(s) +#define sexp_substring(ctx, s, i, j) sexp_substring_op(ctx, NULL, 3, s, i, j) +#define sexp_substring_cursor(ctx, s, i, j) sexp_substring_op(ctx, NULL, 3, s, i, j) +#endif + +#if SEXP_USE_GREEN_THREADS +SEXP_API int sexp_maybe_block_port (sexp ctx, sexp in, int forcep); +SEXP_API void sexp_maybe_unblock_port (sexp ctx, sexp in); +#define sexp_check_block_port(ctx, in, forcep) \ + if (sexp_maybe_block_port(ctx, in, forcep)) \ + return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR) +#else +#define sexp_maybe_block_port(ctx, in, forcep) +#define sexp_maybe_unblock_port(ctx, in) +#define sexp_check_block_port(ctx, in, forcep) +#endif + +#define SEXP_PORT_UNKNOWN_FLAGS -1uL + +#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 +#define SEXP_COPY_LOADP SEXP_TWO + +#if ! SEXP_USE_BOEHM && ! SEXP_USE_MALLOC +SEXP_API void sexp_gc_init (void); +SEXP_API sexp_heap sexp_make_heap (size_t size, size_t max_size); +SEXP_API void sexp_mark (sexp ctx, sexp x); +SEXP_API sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr); +SEXP_API sexp sexp_finalize (sexp ctx); +#endif + +#if SEXP_USE_GLOBAL_HEAP +#define sexp_free_heap(heap) +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_free_heap (sexp_heap heap); +SEXP_API void sexp_destroy_context (sexp ctx); +SEXP_API sexp sexp_copy_context (sexp ctx, sexp dst, sexp flags); +#endif + +#if SEXP_USE_SAFE_GC_MARK +SEXP_API int sexp_in_heap_p(sexp ctx, sexp x); +#else +#define sexp_in_heap_p(ctx, x) 1 +#endif + +#if SEXP_DEBUG_GC > 1 || SEXP_USE_SAFE_GC_MARK || SEXP_USE_HEADER_MAGIC +SEXP_API int sexp_valid_object_p(sexp ctx, sexp x); +#else +#define sexp_valid_object_p(ctx, x) 1 +#endif + +#if SEXP_USE_TYPE_DEFS +SEXP_API sexp sexp_register_type_op (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc2); +SEXP_API sexp sexp_register_simple_type_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp parent, sexp slots); +SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp self, sexp_sint_t n, sexp obj); +#define sexp_register_c_type(ctx, name, finalizer) \ + sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + sexp_make_fixnum(sexp_sizeof(cpointer)), \ + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, \ + SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, NULL, \ + (sexp_proc2)finalizer) +#endif + +#define sexp_current_error_port(ctx) sexp_parameter_ref(ctx, sexp_env_ref(ctx, sexp_context_env(ctx), sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE)) +#define sexp_debug(ctx, msg, obj) (sexp_portp(sexp_current_error_port(ctx)) ? (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))) : 0) + +/* simplify primitive API interface */ + +#define sexp_read(ctx, in) sexp_read_op(ctx, NULL, 1, in) +#define sexp_write(ctx, obj, out) sexp_write_op(ctx, NULL, 2, obj, out) +#define sexp_display(ctx, obj, out) sexp_display_op(ctx, NULL, 2, obj, out) +#define sexp_print_exception(ctx, e, out) sexp_print_exception_op(ctx, NULL, 2, e, out) +#define sexp_flush_output(ctx, out) sexp_flush_output_op(ctx, NULL, 1, out) +#define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx, NULL, 2, a, b) +#define sexp_listp(ctx, x) sexp_listp_op(ctx, NULL, 1, x) +#define sexp_length(ctx, x) sexp_length_op(ctx, NULL, 1, x) +#define sexp_reverse(ctx, x) sexp_reverse_op(ctx, NULL, 1, x) +#define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx, NULL, 1, x) +#define sexp_copy_list(ctx, x) sexp_copy_list_op(ctx, NULL, 1, x) +#define sexp_cons(ctx, a, b) sexp_cons_op(ctx, NULL, 2, a, b) +#define sexp_append2(ctx, a, b) sexp_append2_op(ctx, NULL, 2, a, b) +#define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx, NULL, 2, a, b); +#define sexp_list_to_vector(ctx, x) sexp_list_to_vector_op(ctx, NULL, 1, x) +#define sexp_exception_type(ctx, x) sexp_exception_type_op(ctx, NULL, 1, x) +#define sexp_string_to_symbol(ctx, s) sexp_string_to_symbol_op(ctx, NULL, 1, s) +#define sexp_string_to_number(ctx, s, b) sexp_string_to_number_op(ctx, NULL, 2, s, b) +#define sexp_symbol_to_string(ctx, s) sexp_symbol_to_string_op(ctx, NULL, 1, s) +#define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx, NULL, 2, l, i) +#define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx, NULL, 2, l, c) +#define sexp_subbytes(ctx, a, b, c) sexp_subbytes_op(ctx, NULL, 3, a, b, c) +#define sexp_string_concatenate(ctx, ls, s) sexp_string_concatenate_op(ctx, NULL, 2, ls, s) +#define sexp_memq(ctx, a, b) sexp_memq_op(ctx, NULL, 2, a, b) +#define sexp_assq(ctx, a, b) sexp_assq_op(ctx, NULL, 2, a, b) +#define sexp_open_output_string(ctx) sexp_open_output_string_op(ctx, NULL, 0) +#define sexp_open_input_string(ctx, s) sexp_open_input_string_op(ctx, NULL, 1, s) +#define sexp_get_output_string(ctx, out) sexp_get_output_string_op(ctx, NULL, 1, out) +#define sexp_expt(ctx, a, b) sexp_expt_op(ctx, NULL, 2, a, b) +#define sexp_register_simple_type(ctx, a, b, c) sexp_register_simple_type_op(ctx, NULL, 3, a, b, c) +#define sexp_register_type(ctx, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r, s) sexp_register_type_op(ctx, NULL, 18, a, b, c, d, e, f, g, h, i, j, k, l, m, o, p, q, r, s) +#define sexp_make_type_predicate(ctx, a, b) sexp_make_type_predicate_op(ctx, NULL, 2, a, b) +#define sexp_make_constructor(ctx, a, b) sexp_make_constructor_op(ctx, NULL, 2, a, b) +#define sexp_make_getter(ctx, a, b, c) sexp_make_getter_op(ctx, NULL, 3, a, b, c) +#define sexp_make_setter(ctx, a, b, c) sexp_make_setter_op(ctx, NULL, 3, a, b, c) +#define sexp_lookup_type(ctx, name, id) sexp_lookup_type_op(ctx, NULL, 2, name, id) +#define sexp_make_fileno(ctx, fd, no_closep) sexp_make_fileno_op(ctx, NULL, 2, fd, no_closep) + +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_FCALLN, + SEXP_OP_JUMP_UNLESS, + SEXP_OP_JUMP, + SEXP_OP_PUSH, + SEXP_OP_RESERVE, + SEXP_OP_DROP, + SEXP_OP_GLOBAL_REF, + SEXP_OP_GLOBAL_KNOWN_REF, + SEXP_OP_PARAMETER_REF, + SEXP_OP_STACK_REF, + SEXP_OP_LOCAL_REF, + SEXP_OP_LOCAL_SET, + SEXP_OP_CLOSURE_REF, + SEXP_OP_CLOSURE_VARS, + SEXP_OP_VECTOR_REF, + SEXP_OP_VECTOR_SET, + SEXP_OP_VECTOR_LENGTH, + SEXP_OP_BYTES_REF, + SEXP_OP_BYTES_SET, + SEXP_OP_BYTES_LENGTH, + SEXP_OP_STRING_REF, + SEXP_OP_STRING_SET, + SEXP_OP_STRING_LENGTH, + SEXP_OP_STRING_CURSOR_NEXT, + SEXP_OP_STRING_CURSOR_PREV, + SEXP_OP_STRING_SIZE, + 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_ISA, + SEXP_OP_SLOTN_REF, + SEXP_OP_SLOTN_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_CHAR2INT, + SEXP_OP_INT2CHAR, + SEXP_OP_CHAR_UPCASE, + SEXP_OP_CHAR_DOWNCASE, + SEXP_OP_WRITE_CHAR, + SEXP_OP_WRITE_STRING, + SEXP_OP_READ_CHAR, + SEXP_OP_PEEK_CHAR, + SEXP_OP_YIELD, + SEXP_OP_FORCE, + SEXP_OP_RET, + SEXP_OP_DONE, + SEXP_OP_NUM_OPCODES +}; + +#ifdef __cplusplus +} /* extern "C" */ +#endif + +#endif /* ! SEXP_H */ diff --git a/lib/chibi/accept.c b/lib/chibi/accept.c new file mode 100644 index 00000000..b9ec5d0d --- /dev/null +++ b/lib/chibi/accept.c @@ -0,0 +1,56 @@ + +/* chibi-ffi should probably be able to detect these patterns automatically, */ +/* but for now we manually check two special cases - accept should check for */ +/* EWOULDBLOCK and block on the socket, and listen should automatically make */ +/* sockets non-blocking. */ + +sexp sexp_accept (sexp ctx, sexp self, int sock, struct sockaddr* addr, socklen_t len) { +#if SEXP_USE_GREEN_THREADS + sexp f; +#endif + int res; + res = accept(sock, addr, &len); +#if SEXP_USE_GREEN_THREADS + if (res < 0 && errno == EWOULDBLOCK) { + f = sexp_global(ctx, SEXP_G_THREADS_BLOCKER); + if (sexp_opcodep(f)) { + ((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, sexp_make_fixnum(sock)); + return sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR); + } + } + if (res >= 0) + fcntl(res, F_SETFL, fcntl(res, F_GETFL) | O_NONBLOCK); +#endif + return sexp_make_fileno(ctx, sexp_make_fixnum(res), SEXP_FALSE); +} + +/* If we're listening on a socket from Scheme, we most likely want it */ +/* to be non-blocking. */ + +sexp sexp_listen (sexp ctx, sexp self, sexp fileno, sexp backlog) { + int fd, res; + sexp_assert_type(ctx, sexp_filenop, SEXP_FILENO, fileno); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, backlog); + fd = sexp_fileno_fd(fileno); + res = listen(fd, sexp_unbox_fixnum(backlog)); +#if SEXP_USE_GREEN_THREADS + if (res >= 0) + fcntl(fd, F_SETFL, fcntl(fd, F_GETFL) | O_NONBLOCK); +#endif + return (res == 0) ? SEXP_TRUE : SEXP_FALSE; +} + +/* Additional utilities. */ + +sexp sexp_sockaddr_name (sexp ctx, sexp self, struct sockaddr* addr) { + char buf[20]; + struct sockaddr_in *sa = (struct sockaddr_in *)addr; + unsigned char *ptr = (unsigned char *)&(sa->sin_addr); + sprintf(buf, "%d.%d.%d.%d", ptr[0], ptr[1], ptr[2], ptr[3]); + return sexp_c_string(ctx, buf, -1); +} + +int sexp_sockaddr_port (sexp ctx, sexp self, struct sockaddr* addr) { + struct sockaddr_in *sa = (struct sockaddr_in *)addr; + return sa->sin_port; +} diff --git a/lib/chibi/app.scm b/lib/chibi/app.scm new file mode 100644 index 00000000..3fbb7afa --- /dev/null +++ b/lib/chibi/app.scm @@ -0,0 +1,261 @@ +;; app.scm -- unified option parsing and config +;; Copyright (c) 2012-2013 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;> Parses command-line options into a config object. + +(define (parse-option prefix conf-spec args fail) + (define (lookup-conf-spec conf-spec syms strs) + (let ((sym (car syms)) + (str (car strs))) + (cond + ((= 1 (length syms)) + (let lp ((ls conf-spec)) + (and (pair? ls) + (let ((x (car ls))) + (cond + ((eq? sym (car x)) x) + ((and (pair? (cddr x)) (member str (car (cddr x)))) x) + ((and (pair? (cddr x)) (member `(not ,str) (car (cddr x)))) + `(not ,x)) + (else (lp (cdr ls)))))))) + (else + (let lp ((ls conf-spec)) + (and (pair? ls) + (let ((x (car ls))) + (cond + ((or (eq? sym (car x)) + (and (pair? (cddr x)) (member str (car (cddr x))))) + (let ((type (cadr x))) + (if (not (and (pair? type) (eq? 'conf (car type)))) + (error "option prefix not a subconf" sym) + (lookup-conf-spec (cdr type) (cdr syms) (cdr strs))))) + (else (lp (cdr ls))))))))))) + (define (lookup-short-option ch spec) + (let lp ((ls spec)) + (and (pair? ls) + (let ((x (car ls))) + (cond + ((and (pair? (cddr x)) (memv ch (car (cddr x)))) + x) + ((and (pair? (cddr x)) (member `(not ,ch) (car (cddr x)))) + `(not ,x)) + (else (lp (cdr ls)))))))) + (define (parse-conf-spec str args) + (let* ((strs (string-split str #\.)) + (syms (map string->symbol strs)) + (spec (lookup-conf-spec conf-spec syms strs))) + (cond + ((not spec) + #f) + ((and (pair? spec) (eq? 'not (car spec))) + (cons (cons (append prefix (list (car spec))) #f) args)) + ((eq? 'boolean (cadr spec)) + (cons (cons (append prefix (list (car spec))) #t) args)) + ((null? args) + (error "missing argument to option " str)) + (else + (cons (cons (append prefix syms) (car args)) (cdr args)))))) + (define (parse-long-option str args) + (let* ((str+val (string-split str #\= 2)) + (str (car str+val)) + (args (if (pair? (cdr str+val)) (cons (cadr str+val) args) args))) + (or (parse-conf-spec str args) + (and (string-prefix? "no-" str) + (let ((res (parse-long-option (substring str 3) args))) + (cond + ((not res) + #f) + ((not (boolean? (cdar res))) + (error "'no-' prefix only valid on boolean options")) + (else + `(((,@prefix ,(caar res)) . ,(not (cdar res))) + ,@(cdr res))))))))) + (define (parse-short-option str args) + (let* ((ch (string-ref str 0)) + (x (lookup-short-option ch conf-spec))) + (cond + ((not x) + #f) + ((and (pair? x) (eq? 'not (car x))) + (cons (cons (append prefix (list (car (cadr x)))) #f) + (if (= 1 (string-length str)) + args + (cons (string-append "-" (substring str 1)) args)))) + ((eq? 'boolean (cadr x)) + (cons (cons (append prefix (list (car x))) #t) + (if (= 1 (string-length str)) + args + (cons (string-append "-" (substring str 1)) args)))) + ((> (string-length str) 1) + (cons (cons (append prefix (list (car x))) (substring str 1)) args)) + ((null? args) + (error "missing argument to option " x)) + (else + (cons (cons (append prefix (list (car x))) (car args)) (cdr args)))))) + (or (if (eqv? #\- (string-ref (car args) 1)) + (parse-long-option (substring (car args) 2) (cdr args)) + (parse-short-option (substring (car args) 1) (cdr args))) + (fail prefix conf-spec (car args) args))) + +(define (parse-options prefix conf-spec orig-args fail) + (let lp ((args orig-args) + (opts (make-conf '() #f (cons 'options orig-args) #f))) + (cond + ((null? args) + (cons opts args)) + ((or (member (car args) '("" "-" "--")) + (not (eqv? #\- (string-ref (car args) 0)))) + (cons opts (if (equal? (car args) "--") (cdr args) args))) + (else + (let ((val+args (parse-option prefix conf-spec args fail))) + (lp (cdr val+args) + (conf-set opts (caar val+args) (cdar val+args)))))))) + +(define (parse-app prefix spec opt-spec args config init end . o) + (define (next-prefix prefix name) + (append (if (null? prefix) '(command) prefix) (list name))) + (define (prev-prefix prefix) + (cond ((and (= 2 (length prefix)))) + ((null? prefix) '()) + (else (reverse (cdr (reverse prefix)))))) + (let ((fail (if (pair? o) + (car o) + (lambda (prefix spec opt args) + ;; TODO: search for closest option + (error "unknown option: " opt))))) + (cond + ((null? spec) + (error "no procedure in application spec")) + ((pair? (car spec)) + (case (caar spec) + ((@) + (let* ((new-opt-spec (cadr (car spec))) + (new-fail + (lambda (new-prefix new-spec opt args) + (parse-option (prev-prefix prefix) opt-spec args fail))) + (cfg+args (parse-options prefix new-opt-spec args new-fail)) + (config (conf-append (car cfg+args) config)) + (args (cdr cfg+args))) + (parse-app prefix (cdr spec) new-opt-spec args config init end new-fail))) + ((or) + (any (lambda (x) (parse-app prefix x opt-spec args config init end)) + (cdar spec))) + ((begin:) + (parse-app prefix (cdr spec) opt-spec args config (cadr (car spec)) end fail)) + ((end:) + (parse-app prefix (cdr spec) opt-spec args config init (cadr (car spec)) fail)) + (else + (if (procedure? (caar spec)) + (vector (caar spec) config args init end) ; TODO: verify + (parse-app prefix (car spec) opt-spec args config init end fail))))) + ((symbol? (car spec)) + (and (pair? args) + (eq? (car spec) (string->symbol (car args))) + (let ((prefix (next-prefix prefix (car spec)))) + (parse-app prefix (cdr spec) opt-spec (cdr args) config init end fail)))) + ((procedure? (car spec)) + (vector (car spec) config args init end)) + (else + (if (not (string? (car spec))) + (error "unknown application spec" (car spec))) + (parse-app prefix (cdr spec) opt-spec args config init end fail))))) + +(define (print-command-help command out) + (cond + ((and (pair? command) (symbol? (car command))) + (display " " out) + (display (car command) out) + (cond + ((find (lambda (x) (and (pair? x) (procedure? (car x)))) command) + => (lambda (x) + (let lp ((args (cdr x)) (opt-depth 0)) + (cond + ((null? args) + (display (make-string opt-depth #\]) out)) + ((pair? (car args)) + (display " [" out) + (display (caar args) out) + (lp (cdr args) (+ opt-depth 1))) + (else + (display " " out) + (display (car args) out) + (lp (cdr args) opt-depth))))))) + (cond + ((find string? command) + => (lambda (doc-string) (display " - " out) (display doc-string out)))) + (newline out)))) + +(define (print-option-help option out) + (let* ((str (symbol->string (car option))) + (names (if (and (pair? (cdr option)) (pair? (cddr option))) + (car (cddr option)) + '())) + (pref-str (cond ((find string? names) => values) (else str))) + (pref-ch (find char? names)) + (doc (find string? (cdr option)))) + ;; TODO: consider aligning these + (cond + (pref-ch (display " -" out) (write-char pref-ch out)) + (else (display " " out))) + (cond + (pref-str + (display (if pref-ch ", " " ") out) + (display "--" out) (display pref-str out))) + (cond (doc (display " - " out) (display doc out))) + (newline out))) + +(define (print-help name docs commands options . o) + (let ((out (if (pair? o) (car o) (current-output-port)))) + (display "Usage: " out) (display name out) + (if (pair? options) (display " [options]" out)) + (case (length commands) + ((0) (newline out)) + (else + (display " \nCommands:\n" out) + (for-each (lambda (c) (print-command-help c out)) commands)) + ((1) (print-command-help (car commands) out))) + (if (pair? options) (display "Options:\n" out)) + (for-each (lambda (o) (print-option-help o out)) options))) + +(define (app-help spec args . o) + (let ((out (if (pair? o) (car o) (current-output-port)))) + (let lp ((ls (cdr spec)) + (docs #f) + (commands '()) + (options '())) + (cond + ((null? ls) + (print-help (car spec) docs commands options out)) + ((string? (car ls)) + (lp (cdr ls) (car ls) commands options)) + ((and (pair? (car ls)) (eq? '@ (caar ls))) + (lp (cdr ls) docs commands (append options (cadr (car ls))))) + ((and (pair? (car ls)) (symbol? (caar ls))) + ;; don't print nested commands + (if (pair? commands) + (print-help (car spec) docs commands options out) + (if (eq? 'or (caar ls)) + (lp (cdr ls) docs (cdar ls) options) + (lp (cdr ls) docs (list (car ls)) options)))) + (else + (lp (cdr ls) docs commands options)))))) + +(define (app-help-command config spec . args) + (app-help spec args (current-output-port))) + +(define (run-application spec . o) + (let ((args (if (pair? o) (car o) (command-line)))) + (cond + ((parse-app '() (cdr spec) '() (cdr args) #f #f #f) + => (lambda (v) + (let ((proc (vector-ref v 0)) + (cfg (vector-ref v 1)) + (args (vector-ref v 2)) + (init (vector-ref v 3)) + (end (vector-ref v 4))) + (if init (init cfg)) + (apply proc cfg spec args) + (if end (end cfg))))) + (else + (error "Unknown command: " args))))) diff --git a/lib/chibi/app.sld b/lib/chibi/app.sld new file mode 100644 index 00000000..585cfc95 --- /dev/null +++ b/lib/chibi/app.sld @@ -0,0 +1,11 @@ + +(define-library (chibi app) + (export parse-option parse-options parse-app run-application + app-help app-help-command) + (import (scheme base) + (scheme write) + (scheme process-context) + (srfi 1) + (chibi config) + (chibi string)) + (include "app.scm")) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c new file mode 100644 index 00000000..d82c487e --- /dev/null +++ b/lib/chibi/ast.c @@ -0,0 +1,629 @@ +/* ast.c -- interface to the Abstract Syntax Tree */ +/* Copyright (c) 2009-2012 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#ifndef PLAN9 +#include +#endif + +#if ! SEXP_USE_BOEHM +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +#endif + +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); + if (get) { + 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); + } + if (set) { + 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 self, sexp_sint_t n, sexp env, sexp id, sexp createp) { + sexp cell; + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + cell = sexp_env_cell(ctx, env, id, 0); + if (! cell) { + if (sexp_synclop(id)) { + env = sexp_synclo_env(id); + id = sexp_synclo_expr(id); + } + cell = sexp_env_cell(ctx, env, id, 0); + if (!cell && createp) + cell = sexp_env_cell_define(ctx, env, id, SEXP_UNDEF, NULL); + } + return cell ? cell : SEXP_FALSE; +} + +static sexp sexp_get_procedure_code (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc); + return sexp_procedure_code(proc); +} + +static sexp sexp_get_procedure_vars (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc); + return sexp_procedure_vars(proc); +} + +static sexp sexp_get_procedure_arity (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc); + return sexp_make_fixnum(sexp_procedure_num_args(proc)); +} + +static sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc); + return sexp_make_boolean(sexp_procedure_variadic_p(proc)); +} + +static sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t 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_opcode_name(op); +} + +static sexp sexp_translate_opcode_type (sexp ctx, sexp type) { + sexp_gc_var2(res, tmp); + res = type; + if (! res) { + res = sexp_type_by_index(ctx, SEXP_OBJECT); + } if (sexp_fixnump(res)) { + res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); + } else if (sexp_nullp(res)) { /* opcode list types */ + sexp_gc_preserve2(ctx, res, tmp); + tmp = sexp_intern(ctx, "or", -1); + res = sexp_cons(ctx, SEXP_NULL, SEXP_NULL); + res = sexp_cons(ctx, sexp_type_by_index(ctx, SEXP_PAIR), res); + res = sexp_cons(ctx, tmp, res); + sexp_gc_release2(ctx); + } + return res; +} + +static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) { + sexp res; + if (!op) + return sexp_type_by_index(ctx, SEXP_OBJECT); + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + if (sexp_opcode_code(op) == SEXP_OP_RAISE) + return sexp_list1(ctx, sexp_intern(ctx, "error", -1)); + res = sexp_opcode_return_type(op); + if (sexp_fixnump(res)) + res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res)); + return sexp_translate_opcode_type(ctx, res); +} + +static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp op, sexp k) { + sexp res; + int p = sexp_unbox_fixnum(k); + if (! sexp_opcodep(op)) + return sexp_type_exception(ctx, self, SEXP_OPCODE, op); + else if (! sexp_fixnump(k)) + return sexp_type_exception(ctx, self, SEXP_FIXNUM, k); + if (p > sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op)) + p = sexp_opcode_num_args(op); + switch (p) { + case 0: + res = sexp_opcode_arg1_type(op); + break; + case 1: + res = sexp_opcode_arg2_type(op); + break; + default: + res = sexp_opcode_arg3_type(op); + if (res && sexp_vectorp(res)) { + if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2)) + res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO)); + else + res = sexp_type_by_index(ctx, SEXP_OBJECT); + } + break; + } + return sexp_translate_opcode_type(ctx, res); +} + +static sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) { + sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op); + return sexp_make_fixnum(sexp_opcode_class(op)); +} + +static sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) { + sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op); + return sexp_make_fixnum(sexp_opcode_code(op)); +} + +static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) { + sexp data; + sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op); + data = sexp_opcode_data(op); + if (!data) return SEXP_VOID; + return sexp_opcode_class(op) == SEXP_OPC_TYPE_PREDICATE + && 0 <= sexp_unbox_fixnum(data) + && sexp_unbox_fixnum(data) <= sexp_context_num_types(ctx) ? + sexp_type_by_index(ctx, sexp_unbox_fixnum(data)) : data; +} + +static sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) { + sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op); + return sexp_make_fixnum(sexp_opcode_num_args(op)); +} + +static sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) { + sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op); + return sexp_make_boolean(sexp_opcode_variadic_p(op)); +} + +static sexp sexp_get_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p) { + sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p); + return sexp_make_fixnum(sexp_port_line(p)); +} + +static sexp sexp_set_port_line (sexp ctx, sexp self, sexp_sint_t n, sexp p, sexp i) { + sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, p); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + sexp_port_line(p) = sexp_unbox_fixnum(i); + return SEXP_VOID; +} + +static sexp sexp_type_of (sexp ctx, sexp self, sexp_sint_t n, sexp x) { + if (!x) + return sexp_type_by_index(ctx, SEXP_OBJECT); + if (sexp_pointerp(x)) + return sexp_object_type(ctx, x); + else if (sexp_fixnump(x)) + return sexp_type_by_index(ctx, SEXP_FIXNUM); + else if (sexp_booleanp(x)) + return sexp_type_by_index(ctx, SEXP_BOOLEAN); + else if (sexp_charp(x)) + return sexp_type_by_index(ctx, SEXP_CHAR); +#if SEXP_USE_HUFF_SYMS + else if (sexp_symbolp(x)) + return sexp_type_by_index(ctx, SEXP_SYMBOL); +#endif +#if SEXP_USE_IMMEDIATE_FLONUMS + else if (sexp_flonump(x)) + return sexp_type_by_index(ctx, SEXP_FLONUM); +#endif + else + return sexp_type_by_index(ctx, SEXP_OBJECT); +} + +static sexp sexp_env_parent_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); + return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE; +} + +static sexp sexp_env_parent_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); + return sexp_env_parent(e) ? sexp_env_parent(e) : SEXP_FALSE; +} + +static sexp sexp_env_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); + return sexp_env_lambda(e) ? sexp_env_lambda(e) : SEXP_FALSE; +} + +static sexp sexp_env_lambda_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp lam) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); + sexp_assert_type(ctx, sexp_lambdap, SEXP_LAMBDA, lam); + sexp_env_lambda(e) = lam; + return SEXP_VOID; +} + +static sexp sexp_env_syntactic_op (sexp ctx, sexp self, sexp_sint_t n, sexp e) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); + return sexp_make_boolean(sexp_env_syntactic_p(e)); +} + +static sexp sexp_env_syntactic_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp e, sexp synp) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, e); + sexp_env_syntactic_p(e) = sexp_truep(synp); + return SEXP_VOID; +} + +static sexp sexp_env_define_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name); + return sexp_env_cell_define(ctx, env, name, value, NULL); +} + +static sexp sexp_env_push_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp name, sexp value) { + sexp_gc_var1(tmp); + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + sexp_assert_type(ctx, sexp_idp, SEXP_SYMBOL, name); + sexp_gc_preserve1(ctx, tmp); + sexp_env_push(ctx, env, tmp, name, value); + sexp_gc_release1(ctx); + return SEXP_VOID; +} + +static sexp sexp_core_code_op (sexp ctx, sexp self, sexp_sint_t n, sexp c) { + sexp_assert_type(ctx, sexp_corep, SEXP_CORE, c); + return sexp_make_fixnum(sexp_core_code(c)); +} + +static sexp sexp_type_name_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { + sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t); + return sexp_type_name(t); +} + +static sexp sexp_type_cpl_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { + sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t); + return sexp_type_cpl(t); +} + +static sexp sexp_type_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { + sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t); + return sexp_type_slots(t); +} + +static sexp sexp_type_num_slots_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { + sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t); + return sexp_truep(sexp_type_slots(t)) ? sexp_length(ctx, sexp_type_slots(t)) + : sexp_make_fixnum(sexp_type_field_eq_len_base(t)); +} + +static sexp sexp_type_printer_op (sexp ctx, sexp self, sexp_sint_t n, sexp t) { + sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, t); + return sexp_type_print(t) ? sexp_type_print(t) : SEXP_FALSE; +} + +static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) { + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx))) + return SEXP_ZERO; + t = sexp_object_type(ctx, x); + return sexp_make_fixnum(sexp_type_size_of_object(t, x)); +} + +static sexp sexp_integer_to_immediate (sexp ctx, sexp self, sexp_sint_t n, sexp i, sexp dflt) { + sexp x = (sexp)sexp_unbox_fixnum(i); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, i); + if (sexp_pointerp(x)) + return dflt; + return x; +} + +static sexp sexp_make_lambda_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp params, sexp body, sexp locals) { + sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA); + sexp_lambda_name(res) = name; + sexp_lambda_params(res) = params; + sexp_lambda_body(res) = body; + sexp_lambda_locals(res) = locals; + sexp_lambda_fv(res) = SEXP_NULL; + sexp_lambda_sv(res) = SEXP_NULL; + sexp_lambda_defs(res) = SEXP_NULL; + sexp_lambda_return_type(res) = SEXP_FALSE; + sexp_lambda_param_types(res) = SEXP_NULL; + return res; +} + +static sexp sexp_copy_lambda (sexp ctx, sexp self, sexp_sint_t n, sexp lambda) { + sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA); + sexp_lambda_name(res) = sexp_lambda_name(lambda); + sexp_lambda_params(res) = sexp_lambda_params(lambda); + sexp_lambda_body(res) = sexp_lambda_body(lambda); + sexp_lambda_locals(res) = sexp_lambda_locals(lambda); + sexp_lambda_fv(res) = sexp_lambda_fv(lambda); + sexp_lambda_sv(res) = sexp_lambda_sv(lambda); + sexp_lambda_defs(res) = sexp_lambda_defs(lambda); + sexp_lambda_return_type(res) = sexp_lambda_return_type(lambda); + sexp_lambda_param_types(res) = sexp_lambda_param_types(lambda); + return res; +} + +static sexp sexp_make_set_op (sexp ctx, sexp self, sexp_sint_t n, sexp var, sexp value) { + sexp res = sexp_alloc_type(ctx, set, SEXP_SET); + sexp_set_var(res) = var; + sexp_set_value(res) = value; + return res; +} + +static sexp sexp_make_ref_op (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp cell) { + sexp res = sexp_alloc_type(ctx, ref, SEXP_REF); + sexp_ref_name(res) = name; + sexp_ref_cell(res) = cell; + return res; +} + +static sexp sexp_make_cnd_op (sexp ctx, sexp self, sexp_sint_t n, sexp test, sexp pass, sexp fail) { + sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND); + sexp_cnd_test(res) = test; + sexp_cnd_pass(res) = pass; + sexp_cnd_fail(res) = fail; + return res; +} + +static sexp sexp_make_seq (sexp ctx, sexp self, sexp_sint_t n, sexp ls) { + sexp res = sexp_alloc_type(ctx, seq, SEXP_SEQ); + sexp_seq_ls(res) = ls; + return res; +} + +static sexp sexp_make_lit_op (sexp ctx, sexp self, sexp_sint_t n, sexp value) { + sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT); + sexp_lit_value(res) = value; + return res; +} + +static sexp sexp_make_macro_op (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp env) { + sexp res = sexp_alloc_type(ctx, macro, SEXP_MACRO); + sexp_macro_proc(res) = proc; + sexp_macro_env(res) = env; + return res; +} + +static sexp sexp_analyze_op (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp e) { + sexp ctx2 = ctx; + if (sexp_envp(e)) { + ctx2 = sexp_make_child_context(ctx, NULL); + sexp_context_env(ctx2) = e; + } + return sexp_analyze(ctx2, x); +} + +static sexp sexp_extend_env_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp vars, sexp value) { + sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); + return sexp_extend_env(ctx, env, vars, value); +} + +static sexp sexp_optimize (sexp ctx, sexp self, sexp_sint_t n, sexp x) { + sexp_gc_var2(ls, res); + sexp_gc_preserve2(ctx, ls, res); + res = x; + ls = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_apply1(ctx, sexp_cdar(ls), res); + sexp_free_vars(ctx, res, SEXP_NULL); + sexp_gc_release2(ctx); + return res; +} + +static sexp sexp_gc_op (sexp ctx, sexp self, sexp_sint_t n) { + size_t sum_freed=0; +#if SEXP_USE_BOEHM + GC_gcollect(); +#else + sexp_gc(ctx, &sum_freed); +#endif + return sexp_make_unsigned_integer(ctx, sum_freed); +} + +#if SEXP_USE_GREEN_THREADS +static sexp sexp_set_atomic (sexp ctx, sexp self, sexp_sint_t n, sexp new) { + sexp res = sexp_global(ctx, SEXP_G_ATOMIC_P); + sexp_global(ctx, SEXP_G_ATOMIC_P) = new; + return res; +} +#endif + +sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) { + sexp ls; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; +#if SEXP_USE_GREEN_THREADS + for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(ctx, res, sexp_car(ls)); + for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(ctx, res, sexp_car(ls)); +#endif + if (sexp_not(sexp_memq(ctx, ctx, res))) sexp_push(ctx, res, ctx); + sexp_gc_release1(ctx); + return res; +} + +static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp y) { + const char *res; + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, x); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, y); + res = strstr(sexp_string_data(x), sexp_string_data(y)); + return res ? sexp_make_fixnum(res-sexp_string_data(x)) : SEXP_FALSE; +} + +static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) { +#ifdef PLAN9 + return SEXP_FALSE; +#else + return sexp_make_fixnum(errno); +#endif +} + +static sexp sexp_error_string (sexp ctx, sexp self, sexp_sint_t n, sexp x) { +#ifdef PLAN9 + return SEXP_FALSE; +#else + int err; + if (x == SEXP_FALSE) { + err = errno; + } else { + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, x); + err = sexp_unbox_fixnum(x); + } + return sexp_c_string(ctx, strerror(err), -1); +#endif +} + +static sexp sexp_update_free_vars (sexp ctx, sexp self, sexp_sint_t n, sexp x) { + return sexp_free_vars(ctx, x, SEXP_NULL); +} + +static sexp sexp_setenv (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp value) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, value); + return sexp_make_boolean(setenv(sexp_string_data(name), sexp_string_data(value), 1)); +} + +static sexp sexp_unsetenv (sexp ctx, sexp self, sexp_sint_t n, sexp name) { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, name); + return sexp_make_boolean(unsetenv(sexp_string_data(name))); +} + +#define sexp_define_type(ctx, name, tag) \ + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), sexp_type_by_index(ctx, tag)); + +sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) { + if (!(sexp_version_compatible(ctx, version, sexp_version) + && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) + return SEXP_ABI_ERROR; + sexp_define_type(ctx, "Object", SEXP_OBJECT); + sexp_define_type(ctx, "Number", SEXP_NUMBER); + sexp_define_type(ctx, "Bignum", SEXP_BIGNUM); + sexp_define_type(ctx, "Flonum", SEXP_FLONUM); + sexp_define_type(ctx, "Integer", SEXP_FIXNUM); +#if SEXP_USE_RATIOS + sexp_define_type(ctx, "Ratio", SEXP_RATIO); +#endif +#if SEXP_USE_COMPLEX + sexp_define_type(ctx, "Complex", SEXP_COMPLEX); +#endif + sexp_define_type(ctx, "Symbol", SEXP_SYMBOL); + sexp_define_type(ctx, "Char", SEXP_CHAR); + sexp_define_type(ctx, "Boolean", SEXP_BOOLEAN); + sexp_define_type(ctx, "String", SEXP_STRING); + sexp_define_type(ctx, "Byte-Vector", SEXP_BYTES); + sexp_define_type(ctx, "Pair", SEXP_PAIR); + sexp_define_type(ctx, "Vector", SEXP_VECTOR); + sexp_define_type(ctx, "Input-Port", SEXP_IPORT); + sexp_define_type(ctx, "Output-Port", SEXP_OPORT); + sexp_define_type(ctx, "File-Descriptor", SEXP_FILENO); + sexp_define_type(ctx, "Opcode", SEXP_OPCODE); + sexp_define_type(ctx, "Procedure", SEXP_PROCEDURE); + sexp_define_type(ctx, "Bytecode", SEXP_BYTECODE); + sexp_define_type(ctx, "Env", SEXP_ENV); + sexp_define_type(ctx, "Macro", SEXP_MACRO); + sexp_define_type(ctx, "Lam", SEXP_LAMBDA); + sexp_define_type(ctx, "Cnd", SEXP_CND); + sexp_define_type(ctx, "Set", SEXP_SET); + sexp_define_type(ctx, "Ref", SEXP_REF); + sexp_define_type(ctx, "Seq", SEXP_SEQ); + sexp_define_type(ctx, "Lit", SEXP_LIT); + sexp_define_type(ctx, "Sc", SEXP_SYNCLO); + sexp_define_type(ctx, "Context", SEXP_CONTEXT); + sexp_define_type(ctx, "Exception", SEXP_EXCEPTION); + sexp_define_type(ctx, "Core", SEXP_CORE); + sexp_define_type_predicate(ctx, env, "environment?", SEXP_ENV); + sexp_define_type_predicate(ctx, env, "bytecode?", SEXP_BYTECODE); + sexp_define_type_predicate(ctx, env, "macro?", SEXP_MACRO); + 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_type_predicate(ctx, env, "type?", SEXP_TYPE); + sexp_define_type_predicate(ctx, env, "core?", SEXP_CORE); + sexp_define_type_predicate(ctx, env, "context?", SEXP_CONTEXT); + sexp_define_type_predicate(ctx, env, "file-descriptor?", SEXP_FILENO); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", NULL); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", NULL); + sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", NULL); + 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_LAMBDA, 4, "lambda-locals", "lambda-locals-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 5, "lambda-flags", "lambda-flags-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 6, "lambda-free-vars", "lambda-free-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-set-vars", "lambda-set-vars-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 8, "lambda-return-type", "lambda-return-type-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 9, "lambda-param-types", "lambda-param-types-set!"); + sexp_define_accessors(ctx, env, SEXP_LAMBDA, 10, "lambda-source", "lambda-source-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_accessors(ctx, env, SEXP_BYTECODE, 2, "bytecode-name", "bytecode-name-set!"); + sexp_define_accessors(ctx, env, SEXP_BYTECODE, 3, "bytecode-literals", NULL); + sexp_define_accessors(ctx, env, SEXP_BYTECODE, 4, "bytecode-source", NULL); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 1, "exception-message", NULL); + sexp_define_accessors(ctx, env, SEXP_EXCEPTION, 4, "exception-source", NULL); + sexp_define_accessors(ctx, env, SEXP_MACRO, 0, "macro-procedure", NULL); + sexp_define_accessors(ctx, env, SEXP_MACRO, 1, "macro-env", NULL); + sexp_define_accessors(ctx, env, SEXP_MACRO, 2, "macro-source", NULL); + sexp_define_foreign(ctx, env, "procedure-code", 1, sexp_get_procedure_code); + sexp_define_foreign(ctx, env, "procedure-vars", 1, sexp_get_procedure_vars); + sexp_define_foreign(ctx, env, "procedure-arity", 1, sexp_get_procedure_arity); + sexp_define_foreign(ctx, env, "procedure-variadic?", 1, sexp_get_procedure_variadic_p); + sexp_define_foreign(ctx, env, "copy-lambda", 1, sexp_copy_lambda); + sexp_define_foreign_opt(ctx, env, "make-lambda", 4, sexp_make_lambda_op, SEXP_NULL); + sexp_define_foreign_opt(ctx, env, "make-cnd", 3, sexp_make_cnd_op, SEXP_VOID); + sexp_define_foreign(ctx, env, "make-ref", 2, sexp_make_ref_op); + sexp_define_foreign(ctx, env, "make-set", 2, sexp_make_set_op); + sexp_define_foreign(ctx, env, "make-lit", 1, sexp_make_lit_op); + sexp_define_foreign(ctx, env, "make-seq", 1, sexp_make_seq); + sexp_define_foreign(ctx, env, "make-macro", 2, sexp_make_macro_op); + sexp_define_foreign_opt(ctx, env, "analyze", 2, sexp_analyze_op, SEXP_FALSE); + sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize); + sexp_define_foreign(ctx, env, "extend-env", 3, sexp_extend_env_op); + sexp_define_foreign_opt(ctx, env, "env-cell", 3, sexp_get_env_cell, SEXP_FALSE); + sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name); + sexp_define_foreign(ctx, env, "opcode-class", 1, sexp_get_opcode_class); + sexp_define_foreign(ctx, env, "opcode-code", 1, sexp_get_opcode_code); + sexp_define_foreign(ctx, env, "opcode-data", 1, sexp_get_opcode_data); + sexp_define_foreign(ctx, env, "opcode-variadic?", 1, sexp_get_opcode_variadic_p); + sexp_define_foreign(ctx, env, "opcode-num-params", 1, sexp_get_opcode_num_params); + sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type); + sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type); + sexp_define_foreign(ctx, env, "port-line", 1, sexp_get_port_line); + sexp_define_foreign(ctx, env, "port-line-set!", 2, sexp_set_port_line); + sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of); + sexp_define_foreign(ctx, env, "type-name", 1, sexp_type_name_op); + sexp_define_foreign(ctx, env, "type-cpl", 1, sexp_type_cpl_op); + sexp_define_foreign(ctx, env, "type-slots", 1, sexp_type_slots_op); + sexp_define_foreign(ctx, env, "type-num-slots", 1, sexp_type_num_slots_op); + sexp_define_foreign(ctx, env, "type-printer", 1, sexp_type_printer_op); + sexp_define_foreign(ctx, env, "env-parent", 1, sexp_env_parent_op); + sexp_define_foreign(ctx, env, "env-parent-set!", 2, sexp_env_parent_set_op); + sexp_define_foreign(ctx, env, "env-lambda", 1, sexp_env_lambda_op); + sexp_define_foreign(ctx, env, "env-lambda-set!", 2, sexp_env_lambda_set_op); + sexp_define_foreign(ctx, env, "env-syntactic?", 1, sexp_env_syntactic_op); + sexp_define_foreign(ctx, env, "env-syntactic?-set!", 2, sexp_env_syntactic_set_op); + sexp_define_foreign(ctx, env, "env-define!", 3, sexp_env_define_op); + sexp_define_foreign(ctx, env, "env-push!", 3, sexp_env_push_op); + sexp_define_foreign(ctx, env, "core-code", 1, sexp_core_code_op); + sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size); + sexp_define_foreign_opt(ctx, env, "integer->immediate", 2, sexp_integer_to_immediate, SEXP_FALSE); + sexp_define_foreign(ctx, env, "gc", 0, sexp_gc_op); +#if SEXP_USE_GREEN_THREADS + sexp_define_foreign(ctx, env, "%set-atomic!", 1, sexp_set_atomic); +#endif + sexp_define_foreign(ctx, env, "thread-list", 0, sexp_thread_list); + sexp_define_foreign(ctx, env, "string-contains", 2, sexp_string_contains); + sexp_define_foreign(ctx, env, "errno", 0, sexp_errno); + sexp_define_foreign_opt(ctx, env, "integer->error-string", 1, sexp_error_string, SEXP_FALSE); + sexp_define_foreign(ctx, env, "update-free-vars!", 1, sexp_update_free_vars); + sexp_define_foreign(ctx, env, "setenv", 2, sexp_setenv); + sexp_define_foreign(ctx, env, "unsetenv", 1, sexp_unsetenv); + return SEXP_VOID; +} diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm new file mode 100644 index 00000000..32a049ff --- /dev/null +++ b/lib/chibi/ast.scm @@ -0,0 +1,377 @@ +;; ast.scm -- ast utilities +;; Copyright (c) 2010-2012 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;> Abstract Syntax Tree. Interface to the types used by +;;> the compiler, and other core types less commonly +;;> needed in user code, plus related utilities. + +;;> \section{Analysis and Expansion} + +;;> \procedure{(analyze x [env])} + +;;> Expands and analyzes the expression \var{x} and returns the +;;> resulting AST. + +;;> \procedure{(optimize ast)} + +;;> Runs an optimization pass on \var{ast} and returns the +;;> resulting simplified expression. + +(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 (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 (flatten-dot x) + (cond ((pair? x) (cons (car x) (flatten-dot (cdr x)))) + ((null? x) x) + (else (list x)))) + +(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 (map* f ls) + (cond ((pair? ls) (cons (f (car ls)) (map* f (cdr ls)))) + ((null? ls) '()) + (else (f ls)))) + +;;> Performs a full syntax expansion of the form \var{x} and +;;> returns the resulting s-expression. + +(define (macroexpand x) + (ast->sexp (analyze x))) + +;;> Convert \var{ast} to a s-expression, renaming variables if +;;> necessary. + +(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 (caar 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) (cond ((opcode-name x) => string->symbol) (else x))) + (else x))))) + +;;> \section{Types} + +;;> All objects have an associated type, and types may have parent +;;> types. When using +;;> \hyperlink["http://srfi.schemers.org/srfi-9/srfi-9/html"]{SRFI-9} +;;> \scheme{define-record-type}, the name is bound to a first class +;;> type object. + +;;> The following core types are also available by name, and may be +;;> used in the \scheme{match} \scheme{($ ...)} syntax. + +;;> \itemlist[ +;;> \item{\scheme{} - the parent of all types} +;;> \item{\scheme{} - abstract numeric type} +;;> \item{\scheme{} - arbitrary precision exact integers} +;;> \item{\scheme{} - inexact real numbers} +;;> \item{\scheme{} - abstract integer type} +;;> \item{\scheme{} - symbols} +;;> \item{\scheme{} - character} +;;> \item{\scheme{} - \scheme{#t} or \scheme{#f}} +;;> \item{\scheme{} - strings of characters} +;;> \item{\scheme{} - uniform vector of octets} +;;> \item{\scheme{} - a \var{car} and \var{cdr}, the basis for lists} +;;> \item{\scheme{} - vectors} +;;> \item{\scheme{} - a primitive opcode or C function} +;;> \item{\scheme{} - a closure} +;;> \item{\scheme{} - the compiled code for a closure} +;;> \item{\scheme{} - an environment structure} +;;> \item{\scheme{} - a macro object, usually not first-class} +;;> \item{\scheme{} - a lambda AST type} +;;> \item{\scheme{} - an conditional AST type (i.e. \scheme{if})} +;;> \item{\scheme{} - a reference AST type} +;;> \item{\scheme{} - a mutation AST type (i.e. \scheme{set!})} +;;> \item{\scheme{} - a sequence AST type} +;;> \item{\scheme{} - a literal AST type} +;;> \item{\scheme{} - a syntactic closure} +;;> \item{\scheme{} - a context object (including threads)} +;;> \item{\scheme{} - an exception object} +;;> ] + +;;> The following extended type predicates may also be used to test +;;> individual objects for their type: + +;;> \itemlist[ +;;> \item{\scheme{environment?}} +;;> \item{\scheme{bytecode?}} +;;> \item{\scheme{macro?}} +;;> \item{\scheme{syntactic-closure?}} +;;> \item{\scheme{lambda?}} +;;> \item{\scheme{cnd?}} +;;> \item{\scheme{ref?}} +;;> \item{\scheme{set?}} +;;> \item{\scheme{seq?}} +;;> \item{\scheme{lit?}} +;;> \item{\scheme{opcode?}} +;;> \item{\scheme{type?}} +;;> \item{\scheme{context?}} +;;> \item{\scheme{exception?}} +;;> ] + +;;> \procedure{(type-of x)} + +;;> Returns the type of any object \var{x}. + +;;> \procedure{(type-name type)} + +;;> Returns the name of type \var{type}. + +;;> \procedure{(type-parent type)} + +;;> Returns the immediate parent of type \var{type}, +;;> or \scheme{#f} for a type with no parent. + +(define (type-parent type) + (let ((v (type-cpl type))) + (and (vector? v) + (> (vector-length v) 1) + (vector-ref v (- (vector-length v) 2))))) + +;;> \procedure{(type-cpl type)} + +;;> Returns the class precedence list of type \var{type} as a +;;> vector, or \scheme{#f} for a type with no parent. + +;;> \procedure{(type-slots type)} + +;;> Returns the slot list of type \var{type}. + +;;> \section{Accessors} + +;;> This section describes additional accessors on AST and other core +;;> types. + +;;> \subsection{Procedures} + +;;> \itemlist[ +;;> \item{\scheme{(procedure-code f)} - the compiled bytecode object} +;;> \item{\scheme{(procedure-vars f)} - the variables closed over by \var{f}} +;;> \item{\scheme{(procedure-name f)} - the name of \var{f} if known, else \scheme{#f}} +;;> ] + +(define (procedure-name x) + (bytecode-name (procedure-code x))) + +(define (procedure-name-set! x name) + (bytecode-name-set! (procedure-code x) name)) + +;;> \subsection{Macros} + +;;> \itemlist[ +;;> \item{\scheme{(macro-procedure f)} - the macro procedure} +;;> \item{\scheme{(macro-env f)} - the environment the macro was defined in} +;;> \item{\scheme{(macro-source f)} - the source location the macro was defined in} +;;> ] + +;;> \subsection{Bytecode Objects} + +;;> \itemlist[ +;;> \item{\scheme{(bytecode-name bc)} - the macro procedure} +;;> \item{\scheme{(bytecode-literals bc)} - literals the bytecode references} +;;> \item{\scheme{(bytecode-source bc)} - the source location the procedure was defined in} +;;> ] + +;;> \subsection{Syntactic Closures} + +;;> \itemlist[ +;;> \item{\scheme{(syntactic-closure-env sc)}} +;;> \item{\scheme{(syntactic-closure-vars sc)}} +;;> \item{\scheme{(syntactic-closure-expr sc)}} +;;> ] + +;;> Return the environment, free variables, and expression +;;> associated with \var{sc} respectively. + +;;> \subsection{Exceptions} + +;;> \itemlist[ +;;> \item{\scheme{(exception-kind exn)}} +;;> \item{\scheme{(exception-message exn)}} +;;> \item{\scheme{(exception-irritants exn)}} +;;> ] + +;;> Return the kind, message, and irritants +;;> associated with \var{exn} respectively. + +;;> \subsection{Lambdas} + +;;> \itemlist[ +;;> \item{\scheme{(lambda-name lam)} - the name of the lambda, if known} +;;> \item{\scheme{(lambda-name-set! lam x)}} +;;> \item{\scheme{(lambda-params lam)} - the lambda parameter list} +;;> \item{\scheme{(lambda-params-set! lam x)}} +;;> \item{\scheme{(lambda-body lam)} - the body of the lambda} +;;> \item{\scheme{(lambda-body-set! lam x)}} +;;> \item{\scheme{(lambda-defs lam)} - internal definitions of the lambda} +;;> \item{\scheme{(lambda-defs-set! lam x)}} +;;> \item{\scheme{(lambda-locals lam)} - local variables as a list of identifiers} +;;> \item{\scheme{(lambda-locals-set! lam x)}} +;;> \item{\scheme{(lambda-flags lam)} - various flags describing the lambda} +;;> \item{\scheme{(lambda-flags-set! lam x)}} +;;> \item{\scheme{(lambda-free-vars lam)} - free variables the lambda will need to close over} +;;> \item{\scheme{(lambda-free-vars-set! lam x)}} +;;> \item{\scheme{(lambda-set-vars lam)} - variables the lambda mutates} +;;> \item{\scheme{(lambda-set-vars-set! lam x)}} +;;> \item{\scheme{(lambda-return-type lam)} - the return type of the lambda} +;;> \item{\scheme{(lambda-return-type-set! lam x)}} +;;> \item{\scheme{(lambda-param-types lam)} - the types of the input parameters} +;;> \item{\scheme{(lambda-param-types-set! lam x)}} +;;> \item{\scheme{(lambda-source lam)} - the source code of the lambda} +;;> \item{\scheme{(lambda-source-set! lam x)}} +;;> ] + +;;> \subsection{Conditionals} + +;;> \itemlist[ +;;> \item{\scheme{(cnd-test cnd)} - the test for the conditional} +;;> \item{\scheme{(cnd-test-set! cnd x)}} +;;> \item{\scheme{(cnd-pass cnd)} - the success branch} +;;> \item{\scheme{(cnd-pass-set! cnd x)}} +;;> \item{\scheme{(cnd-fail cnd)} - the failure branch} +;;> \item{\scheme{(cnd-fail-set! cnd x)}} +;;> ] + +;;> \subsection{Sequences} + +;;> \itemlist[ +;;> \item{\scheme{(seq-ls seq)} - the list of sequence expressions} +;;> \item{\scheme{(seq-ls-set! seq x)}} +;;> ] + +;;> \subsection{References} + +;;> \itemlist[ +;;> \item{\scheme{(ref-name ref)} - the name of the referenced variable} +;;> \item{\scheme{(ref-name-set! ref x)}} +;;> \item{\scheme{(ref-cell ref)} - the environment cell the reference resolves to} +;;> \item{\scheme{(ref-cell-set! ref x)}} +;;> ] + +;;> \subsection{Mutations} + +;;> \itemlist[ +;;> \item{\scheme{(set-var set)} - a reference to the mutated variable} +;;> \item{\scheme{(set-var-set! set x)}} +;;> \item{\scheme{(set-value set)} - the value to set the variable to} +;;> \item{\scheme{(set-value-set! set x)}} +;;> ] + +;;> \subsection{Literals} + +;;> \itemlist[ +;;> \item{\scheme{(lit-value lit)} - the literal value} +;;> \item{\scheme{(lit-value-set! lit x)}} +;;> ] + +;;> \subsection{Pairs} + +;;> \itemlist[ +;;> \item{\scheme{(pair-source x)}} +;;> \item{\scheme{(pair-source-set! x source)}} +;;> ] + +;;> Set or return the source code info associated with a pair x. +;;> Source info is represented as another pair whose \var{car} is +;;> the source file name and whose \var{cdr} is the line number. + +;;> \section{Miscellaneous Utilities} + +;;> \procedure{(gc)} + +;;> Force a garbage collection. + +;;> \procedure{(object-size x)} + +;;> Returns the heap space directly used by \var{x}, not +;;> counting any elements of \var{x}. + +;;> \procedure{(integer->immediate n)} + +;;> Returns the interpretation of the integer \var{n} as +;;> an immediate object, useful for debugging. + +;;> \procedure{(string-contains str pat)} + +;;> Returns the first string cursor of \var{pat} in \var{str}, +;;> of \scheme{#f} if it's not found. + +;;> \procedure{(atomically expr)} + +;;> Run \var{expr} atomically, disabling yields. Ideally should only be +;;> used for brief, deterministic expressions. If used incorrectly (e.g. +;;> running an infinite loop) can render the system unusable. +;;> Never expose to a sandbox. + +(cond-expand + (threads + (define-syntax atomically + (syntax-rules () + ((atomically . body) + (let* ((atomic? (%set-atomic! #t)) + (res (begin . body))) + (%set-atomic! atomic?) + res))))) + (else + (define-syntax atomically + (syntax-rules () ((atomically . body) (begin . body)))))) diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld new file mode 100644 index 00000000..c9356be1 --- /dev/null +++ b/lib/chibi/ast.sld @@ -0,0 +1,42 @@ + +(define-library (chibi ast) + (export + analyze optimize env-cell ast->sexp macroexpand type-of + Object Input-Port Output-Port Opcode Procedure Bytecode Macro Env + Number Bignum Flonum Integer Complex Char Boolean + Symbol String Byte-Vector Vector Pair File-Descriptor + Context Lam Cnd Set Ref Seq Lit Sc Exception Core + syntactic-closure? lambda? cnd? set? ref? seq? lit? type? core? + environment? bytecode? exception? macro? context? file-descriptor? + syntactic-closure-expr syntactic-closure-env syntactic-closure-vars + copy-lambda make-lambda make-cnd make-ref make-set make-seq make-lit + make-macro + lambda-name lambda-params lambda-body lambda-defs lambda-locals + lambda-flags lambda-free-vars lambda-set-vars lambda-return-type + lambda-param-types lambda-source + lambda-name-set! lambda-params-set! lambda-body-set! lambda-defs-set! + lambda-locals-set! lambda-flags-set! lambda-free-vars-set! + lambda-set-vars-set! lambda-return-type-set! lambda-param-types-set! + lambda-source-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! + exception-kind exception-message exception-irritants exception-source + opcode-name opcode-num-params opcode-return-type opcode-param-type + opcode-class opcode-code opcode-data opcode-variadic? + macro-procedure macro-env macro-source + procedure-code procedure-vars procedure-name procedure-name-set! + procedure-arity procedure-variadic? + bytecode-name bytecode-literals bytecode-source + port-line port-line-set! + extend-env env-parent env-parent-set! env-lambda env-lambda-set! + env-define! env-push! env-syntactic? env-syntactic?-set! core-code + type-name type-cpl type-parent type-slots type-num-slots type-printer + object-size integer->immediate gc atomically thread-list + string-contains errno integer->error-string + flatten-dot update-free-vars! setenv unsetenv) + (import (chibi)) + (include-shared "ast") + (include "ast.scm")) diff --git a/lib/chibi/base64.scm b/lib/chibi/base64.scm new file mode 100644 index 00000000..142bb653 --- /dev/null +++ b/lib/chibi/base64.scm @@ -0,0 +1,347 @@ +;; Copyright (c) 2005-2014 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;> RFC 3548 base64 encoding and decoding utilities. +;;> 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 + +;;> 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. + +;; 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)))))) + +;;> Variation of the above to read and write to ports. + +(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 out 0 dst-len))) + ((eqv? b1 *outside-char*) + (write-string dst out 0 dst-len) + (lp 0)) + (else + (write-string dst out 0 dst-len) + ;; 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 out 0 dst-len))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; encoding + +;;> Return a base64 encoded representation of string according to the +;;> official base64 standard as described in RFC3548. + +(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))))))) + +;;> Variation of the above to read and write to ports. + +(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 out 0 (* 3 (quotient (+ n 3) 4))) + (if (= n 2048) + (lp))))))) + +;;> Return a base64 encoded representation of the string \var{str} as +;;> above, wrapped in =?ENC?B?...?= as per RFC1522, split across +;;> multiple MIME-header lines as needed to keep each lines length +;;> less than \var{max-col}. The string is encoded as is, and the +;;> encoding \var{enc} is just used for the prefix, i.e. you are +;;> responsible for ensuring \var{str} is already encoded according to +;;> \var{enc}. The optional argument \var{nl} is the newline +;;> separator, defaulting to \var{crlf}. + +(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)) + "?="))))) + diff --git a/lib/chibi/base64.sld b/lib/chibi/base64.sld new file mode 100644 index 00000000..fe43b202 --- /dev/null +++ b/lib/chibi/base64.sld @@ -0,0 +1,7 @@ + +(define-library (chibi base64) + (export base64-encode base64-encode-string + base64-decode base64-decode-string + base64-encode-header) + (import (chibi) (srfi 33) (chibi io)) + (include "base64.scm")) diff --git a/lib/chibi/bytevector.scm b/lib/chibi/bytevector.scm new file mode 100644 index 00000000..4b6041a1 --- /dev/null +++ b/lib/chibi/bytevector.scm @@ -0,0 +1,70 @@ + +;;> \section{Additional accessors} + +(define (bytevector-u16-ref-le str i) + (+ (bytevector-u8-ref str i) + (arithmetic-shift (bytevector-u8-ref str (+ i 1)) 8))) + +(define (bytevector-u16-ref-be str i) + (+ (arithmetic-shift (bytevector-u8-ref str i) 8) + (bytevector-u8-ref str (+ i 1)))) + +(define (bytevector-u32-ref-le str i) + (+ (bytevector-u8-ref str i) + (arithmetic-shift (bytevector-u8-ref str (+ i 1)) 8) + (arithmetic-shift (bytevector-u8-ref str (+ i 2)) 16) + (arithmetic-shift (bytevector-u8-ref str (+ i 3)) 24))) + +(define (bytevector-u32-ref-be str i) + (+ (arithmetic-shift (bytevector-u8-ref str i) 24) + (arithmetic-shift (bytevector-u8-ref str (+ i 1)) 16) + (arithmetic-shift (bytevector-u8-ref str (+ i 2)) 8) + (bytevector-u8-ref str (+ i 3)))) + +;;> \section{Integer conversion} + +(define (integer->bytevector n) + (cond + ((zero? n) + (make-bytevector 1 0)) + ((negative? n) + (error "can't convert a negative integer to bytevector" n)) + (else + (let lp ((n n) (res '())) + (if (zero? n) + (let* ((len (length res)) + (bv (make-bytevector len 0))) + (do ((i 0 (+ i 1)) + (ls res (cdr ls))) + ((= i len) bv) + (bytevector-u8-set! bv i (car ls)))) + (lp (quotient n 256) (cons (remainder n 256) res))))))) + +(define (bytevector->integer bv) + (let ((len (bytevector-length bv))) + (let lp ((i 0) (n 0)) + (if (>= i len) + n + (lp (+ i 1) + (+ (arithmetic-shift n 8) + (bytevector-u8-ref bv i))))))) + +;;> \section{Hex string conversion} + +;;> Big-endian conversion, guaranteed padded to even length. + +(define (integer->hex-string n) + (let* ((res (number->string n 16)) + (len (string-length res))) + (if (even? len) + res + (string-append "0" res)))) + +(define (hex-string->integer str) + (string->number str 16)) + +(define (bytevector->hex-string bv) + (integer->hex-string (bytevector->integer bv))) + +(define (hex-string->bytevector str) + (integer->bytevector (hex-string->integer str))) diff --git a/lib/chibi/bytevector.sld b/lib/chibi/bytevector.sld new file mode 100644 index 00000000..42b83a86 --- /dev/null +++ b/lib/chibi/bytevector.sld @@ -0,0 +1,10 @@ + +(define-library (chibi bytevector) + (export + bytevector-u16-ref-le bytevector-u16-ref-be + bytevector-u32-ref-le bytevector-u32-ref-be + integer->bytevector bytevector->integer + integer->hex-string hex-string->integer + bytevector->hex-string hex-string->bytevector) + (import (chibi) (srfi 33)) + (include "bytevector.scm")) diff --git a/lib/chibi/channel.scm b/lib/chibi/channel.scm new file mode 100644 index 00000000..c12d226f --- /dev/null +++ b/lib/chibi/channel.scm @@ -0,0 +1,44 @@ +;; channel.scm -- thread-safe channel (FIFO) library +;; Copyright (c) 2012 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-record-type Channel + (%make-channel mutex condvar front rear) + channel? + (mutex channel-mutex channel-mutex-set!) + (condvar channel-condvar channel-condvar-set!) + (front channel-front channel-front-set!) + (rear channel-rear channel-rear-set!)) + +(define (make-channel) + (%make-channel (make-mutex) (make-condition-variable) '() '())) + +(define (channel-empty? chan) + (null? (channel-front chan))) + +(define (channel-send! chan obj) + (mutex-lock! (channel-mutex chan)) + (let ((new (list obj)) + (rear (channel-rear chan))) + (channel-rear-set! chan new) + (cond + ((pair? rear) + (set-cdr! rear new)) + (else ; sending to empty channel + (channel-front-set! chan new) + (condition-variable-signal! (channel-condvar chan))))) + (mutex-unlock! (channel-mutex chan))) + +(define (channel-receive! chan) + (mutex-lock! (channel-mutex chan)) + (let ((front (channel-front chan))) + (cond + ((null? front) ; receiving from empty channel + (mutex-unlock! (channel-mutex chan) (channel-condvar chan)) + (channel-receive! chan)) + (else + (channel-front-set! chan (cdr front)) + (if (null? (cdr front)) + (channel-rear-set! chan '())) + (mutex-unlock! (channel-mutex chan)) + (car front))))) diff --git a/lib/chibi/channel.sld b/lib/chibi/channel.sld new file mode 100644 index 00000000..435aca1b --- /dev/null +++ b/lib/chibi/channel.sld @@ -0,0 +1,6 @@ + +(define-library (chibi channel) + (import (chibi) (srfi 9) (srfi 18)) + (export Channel make-channel channel? channel-empty? + channel-send! channel-receive!) + (include "channel.scm")) diff --git a/lib/chibi/char-set.sld b/lib/chibi/char-set.sld new file mode 100644 index 00000000..85183d74 --- /dev/null +++ b/lib/chibi/char-set.sld @@ -0,0 +1,12 @@ + +(define-library (chibi char-set) + (import (chibi) (chibi char-set base) (chibi char-set extras)) + (export + Char-Set char-set? char-set-contains? + char-set ucs-range->char-set char-set-copy char-set-size + list->char-set char-set->list string->char-set char-set->string + char-set-adjoin! char-set-adjoin char-set-union char-set-union! + char-set-intersection char-set-intersection! + char-set-difference char-set-difference! + immutable-char-set char-set-complement + char-set:empty char-set:ascii char-set:full)) diff --git a/lib/chibi/char-set/ascii.scm b/lib/chibi/char-set/ascii.scm new file mode 100644 index 00000000..8096ea07 --- /dev/null +++ b/lib/chibi/char-set/ascii.scm @@ -0,0 +1,42 @@ +;; char-set:lower-case +(define char-set:lower-case (immutable-char-set (%make-iset 97 122 #f #f #f))) + +;; char-set:upper-case +(define char-set:upper-case (immutable-char-set (%make-iset 65 90 #f #f #f))) + +;; char-set:title-case +(define char-set:title-case (immutable-char-set (%make-iset 0 0 0 #f #f))) + +;; char-set:letter +(define char-set:letter (immutable-char-set (%make-iset 97 122 #f (%make-iset 65 90 #f #f #f) #f))) + +;; char-set:punctuation +(define char-set:punctuation (immutable-char-set (%make-iset 63 64 #f (%make-iset 44 47 #f (%make-iset 37 42 #f (%make-iset 33 35 #f #f #f) #f) (%make-iset 58 59 #f #f #f)) (%make-iset 123 123 #f (%make-iset 95 95 #f (%make-iset 91 93 #f #f #f) #f) (%make-iset 125 125 #f #f #f))))) + +;; char-set:symbol +(define char-set:symbol (immutable-char-set (%make-iset 94 94 #f (%make-iset 43 43 #f (%make-iset 36 36 #f #f #f) (%make-iset 60 62 #f #f #f)) (%make-iset 124 124 #f (%make-iset 96 96 #f #f #f) (%make-iset 126 126 #f #f #f))))) + +;; char-set:blank +(define char-set:blank (immutable-char-set (%make-iset 32 32 #f (%make-iset 9 9 #f #f #f) #f))) + +;; char-set:whitespace +(define char-set:whitespace (immutable-char-set (%make-iset 32 32 #f (%make-iset 9 13 #f #f #f) #f))) + +;; char-set:digit +(define char-set:digit (immutable-char-set (%make-iset 48 57 #f #f #f))) + +;; char-set:letter+digit +(define char-set:letter+digit (immutable-char-set (%make-iset 65 90 #f (%make-iset 48 57 #f #f #f) (%make-iset 97 122 #f #f #f)))) + +;; char-set:hex-digit +(define char-set:hex-digit (immutable-char-set (%make-iset 65 70 #f (%make-iset 48 57 #f #f #f) (%make-iset 97 102 #f #f #f)))) + +;; char-set:iso-control +(define char-set:iso-control (immutable-char-set (%make-iset 127 127 #f (%make-iset 0 31 #f #f #f) #f))) + +;; char-set:graphic +(define char-set:graphic (immutable-char-set (%make-iset 33 126 #f #f #f))) + +;; char-set:printing +(define char-set:printing (immutable-char-set (%make-iset 32 126 #f (%make-iset 9 13 #f #f #f) #f))) + diff --git a/lib/chibi/char-set/ascii.sld b/lib/chibi/char-set/ascii.sld new file mode 100644 index 00000000..cd2e5433 --- /dev/null +++ b/lib/chibi/char-set/ascii.sld @@ -0,0 +1,9 @@ + +(define-library (chibi char-set ascii) + (import (chibi) (chibi iset base) (chibi char-set base)) + (export char-set:lower-case char-set:upper-case char-set:title-case + char-set:letter char-set:digit char-set:letter+digit + char-set:graphic char-set:printing char-set:whitespace + char-set:iso-control char-set:punctuation char-set:symbol + char-set:hex-digit char-set:blank) + (include "ascii.scm")) diff --git a/lib/chibi/char-set/base.sld b/lib/chibi/char-set/base.sld new file mode 100644 index 00000000..62cde5a4 --- /dev/null +++ b/lib/chibi/char-set/base.sld @@ -0,0 +1,14 @@ + +(define-library (chibi char-set base) + (import (chibi) (chibi iset base)) + (export (rename Integer-Set Char-Set) + (rename iset? char-set?) + immutable-char-set + char-set-contains?) + (begin + (define-syntax immutable-char-set + (sc-macro-transformer + (lambda (expr use-env) + (eval (cadr expr) use-env)))) + (define (char-set-contains? cset ch) + (iset-contains? cset (char->integer ch))))) diff --git a/lib/chibi/char-set/boundary.scm b/lib/chibi/char-set/boundary.scm new file mode 100644 index 00000000..c7b9f04f --- /dev/null +++ b/lib/chibi/char-set/boundary.scm @@ -0,0 +1,24 @@ +;; Control +(define char-set:control (immutable-char-set (char-set-union (ucs-range->char-set 0 10) (ucs-range->char-set 11 13) (ucs-range->char-set 14 32) (ucs-range->char-set 127 160) (ucs-range->char-set 1536 1541) (ucs-range->char-set 8206 8208) (ucs-range->char-set 8234 8239) (ucs-range->char-set 8288 8293) (ucs-range->char-set 8294 8304) (ucs-range->char-set 55296 57344) (ucs-range->char-set 65520 65529) (ucs-range->char-set 65529 65532) (ucs-range->char-set 119155 119163) (ucs-range->char-set 917506 917536) (ucs-range->char-set 917536 917632) (ucs-range->char-set 917632 917760) (ucs-range->char-set 918000 921600)))) + +;; Extend,SpacingMark +(define char-set:extend-or-spacing-mark (immutable-char-set (char-set-union (char-set-union (ucs-range->char-set 768 880) (ucs-range->char-set 1155 1160) (ucs-range->char-set 1160 1162) (ucs-range->char-set 1425 1470) (ucs-range->char-set 1473 1475) (ucs-range->char-set 1476 1478) (ucs-range->char-set 1552 1563) (ucs-range->char-set 1611 1632) (ucs-range->char-set 1750 1757) (ucs-range->char-set 1759 1765) (ucs-range->char-set 1767 1769) (ucs-range->char-set 1770 1774) (ucs-range->char-set 1840 1867) (ucs-range->char-set 1958 1969) (ucs-range->char-set 2027 2036) (ucs-range->char-set 2070 2074) (ucs-range->char-set 2075 2084) (ucs-range->char-set 2085 2088) (ucs-range->char-set 2089 2094) (ucs-range->char-set 2137 2140) (ucs-range->char-set 2276 2303) (ucs-range->char-set 2304 2307) (ucs-range->char-set 2369 2377) (ucs-range->char-set 2385 2392) (ucs-range->char-set 2402 2404) (ucs-range->char-set 2497 2501) (ucs-range->char-set 2530 2532) (ucs-range->char-set 2561 2563) (ucs-range->char-set 2625 2627) (ucs-range->char-set 2631 2633) (ucs-range->char-set 2635 2638) (ucs-range->char-set 2672 2674) (ucs-range->char-set 2689 2691) (ucs-range->char-set 2753 2758) (ucs-range->char-set 2759 2761) (ucs-range->char-set 2786 2788) (ucs-range->char-set 2881 2885) (ucs-range->char-set 2914 2916) (ucs-range->char-set 3134 3137) (ucs-range->char-set 3142 3145) (ucs-range->char-set 3146 3150) (ucs-range->char-set 3157 3159) (ucs-range->char-set 3170 3172) (ucs-range->char-set 3276 3278) (ucs-range->char-set 3285 3287) (ucs-range->char-set 3298 3300) (ucs-range->char-set 3393 3397) (ucs-range->char-set 3426 3428) (ucs-range->char-set 3538 3541) (ucs-range->char-set 3636 3643) (ucs-range->char-set 3655 3663) (ucs-range->char-set 3764 3770) (ucs-range->char-set 3771 3773) (ucs-range->char-set 3784 3790) (ucs-range->char-set 3864 3866) (ucs-range->char-set 3953 3967) (ucs-range->char-set 3968 3973) (ucs-range->char-set 3974 3976) (ucs-range->char-set 3981 3992) (ucs-range->char-set 3993 4029) (ucs-range->char-set 4141 4145) (ucs-range->char-set 4146 4152) (ucs-range->char-set 4153 4155) (ucs-range->char-set 4157 4159) (ucs-range->char-set 4184 4186) (ucs-range->char-set 4190 4193) (ucs-range->char-set 4209 4213) (ucs-range->char-set 4229 4231) (ucs-range->char-set 4957 4960) (ucs-range->char-set 5906 5909) (ucs-range->char-set 5938 5941) (ucs-range->char-set 5970 5972) (ucs-range->char-set 6002 6004) (ucs-range->char-set 6068 6070) (ucs-range->char-set 6071 6078) (ucs-range->char-set 6089 6100) (ucs-range->char-set 6155 6158) (ucs-range->char-set 6432 6435) (ucs-range->char-set 6439 6441) (ucs-range->char-set 6457 6460) (ucs-range->char-set 6679 6681) (ucs-range->char-set 6744 6751) (ucs-range->char-set 6757 6765) (ucs-range->char-set 6771 6781) (ucs-range->char-set 6912 6916) (ucs-range->char-set 6966 6971) (ucs-range->char-set 7019 7028) (ucs-range->char-set 7040 7042) (ucs-range->char-set 7074 7078) (ucs-range->char-set 7080 7082) (ucs-range->char-set 7144 7146) (ucs-range->char-set 7151 7154) (ucs-range->char-set 7212 7220) (ucs-range->char-set 7222 7224) (ucs-range->char-set 7376 7379) (ucs-range->char-set 7380 7393) (ucs-range->char-set 7394 7401) (ucs-range->char-set 7616 7655) (ucs-range->char-set 7676 7680) (ucs-range->char-set 8204 8206) (ucs-range->char-set 8400 8413) (ucs-range->char-set 8413 8417) (ucs-range->char-set 8418 8421) (ucs-range->char-set 8421 8433) (ucs-range->char-set 11503 11506) (ucs-range->char-set 11744 11776) (ucs-range->char-set 12330 12334) (ucs-range->char-set 12334 12336) (ucs-range->char-set 12441 12443) (ucs-range->char-set 42608 42611) (ucs-range->char-set 42612 42622) (ucs-range->char-set 42736 42738) (ucs-range->char-set 43045 43047) (ucs-range->char-set 43232 43250) (ucs-range->char-set 43302 43310) (ucs-range->char-set 43335 43346) (ucs-range->char-set 43392 43395) (ucs-range->char-set 43446 43450) (ucs-range->char-set 43561 43567) (ucs-range->char-set 43569 43571) (ucs-range->char-set 43573 43575) (ucs-range->char-set 43698 43701) (ucs-range->char-set 43703 43705) (ucs-range->char-set 43710 43712) (ucs-range->char-set 43756 43758) (ucs-range->char-set 65024 65040) (ucs-range->char-set 65056 65063) (ucs-range->char-set 65438 65440) (ucs-range->char-set 68097 68100) (ucs-range->char-set 68101 68103) (ucs-range->char-set 68108 68112) (ucs-range->char-set 68152 68155) (ucs-range->char-set 69688 69703) (ucs-range->char-set 69760 69762) (ucs-range->char-set 69811 69815) (ucs-range->char-set 69817 69819) (ucs-range->char-set 69888 69891) (ucs-range->char-set 69927 69932) (ucs-range->char-set 69933 69941) (ucs-range->char-set 70016 70018) (ucs-range->char-set 70070 70079) (ucs-range->char-set 71344 71350) (ucs-range->char-set 94095 94099) (ucs-range->char-set 119143 119146) (ucs-range->char-set 119150 119155) (ucs-range->char-set 119163 119171) (ucs-range->char-set 119173 119180) (ucs-range->char-set 119210 119214) (ucs-range->char-set 119362 119365) (ucs-range->char-set 917760 918000)) (char-set-union (ucs-range->char-set 2366 2369) (ucs-range->char-set 2377 2381) (ucs-range->char-set 2382 2384) (ucs-range->char-set 2434 2436) (ucs-range->char-set 2495 2497) (ucs-range->char-set 2503 2505) (ucs-range->char-set 2507 2509) (ucs-range->char-set 2622 2625) (ucs-range->char-set 2750 2753) (ucs-range->char-set 2763 2765) (ucs-range->char-set 2818 2820) (ucs-range->char-set 2887 2889) (ucs-range->char-set 2891 2893) (ucs-range->char-set 3009 3011) (ucs-range->char-set 3014 3017) (ucs-range->char-set 3018 3021) (ucs-range->char-set 3073 3076) (ucs-range->char-set 3137 3141) (ucs-range->char-set 3202 3204) (ucs-range->char-set 3264 3266) (ucs-range->char-set 3267 3269) (ucs-range->char-set 3271 3273) (ucs-range->char-set 3274 3276) (ucs-range->char-set 3330 3332) (ucs-range->char-set 3391 3393) (ucs-range->char-set 3398 3401) (ucs-range->char-set 3402 3405) (ucs-range->char-set 3458 3460) (ucs-range->char-set 3536 3538) (ucs-range->char-set 3544 3551) (ucs-range->char-set 3570 3572) (ucs-range->char-set 3902 3904) (ucs-range->char-set 4155 4157) (ucs-range->char-set 4182 4184) (ucs-range->char-set 6078 6086) (ucs-range->char-set 6087 6089) (ucs-range->char-set 6435 6439) (ucs-range->char-set 6441 6444) (ucs-range->char-set 6448 6450) (ucs-range->char-set 6451 6457) (ucs-range->char-set 6581 6584) (ucs-range->char-set 6681 6683) (ucs-range->char-set 6765 6771) (ucs-range->char-set 6973 6978) (ucs-range->char-set 6979 6981) (ucs-range->char-set 7078 7080) (ucs-range->char-set 7084 7086) (ucs-range->char-set 7146 7149) (ucs-range->char-set 7154 7156) (ucs-range->char-set 7204 7212) (ucs-range->char-set 7220 7222) (ucs-range->char-set 7410 7412) (ucs-range->char-set 43043 43045) (ucs-range->char-set 43136 43138) (ucs-range->char-set 43188 43204) (ucs-range->char-set 43346 43348) (ucs-range->char-set 43444 43446) (ucs-range->char-set 43450 43452) (ucs-range->char-set 43453 43457) (ucs-range->char-set 43567 43569) (ucs-range->char-set 43571 43573) (ucs-range->char-set 43758 43760) (ucs-range->char-set 44003 44005) (ucs-range->char-set 44006 44008) (ucs-range->char-set 44009 44011) (ucs-range->char-set 69808 69811) (ucs-range->char-set 69815 69817) (ucs-range->char-set 70067 70070) (ucs-range->char-set 70079 70081) (ucs-range->char-set 71342 71344) (ucs-range->char-set 94033 94079))))) + +;; Regional_Indicator +(define char-set:regional-indicator (immutable-char-set (char-set-union (ucs-range->char-set 127462 127488)))) + +;; :L +(define char-set:hangul-l (immutable-char-set (char-set-union (ucs-range->char-set 4352 4448) (ucs-range->char-set 43360 43389)))) + +;; :V +(define char-set:hangul-v (immutable-char-set (char-set-union (ucs-range->char-set 4448 4520) (ucs-range->char-set 55216 55239)))) + +;; :T +(define char-set:hangul-t (immutable-char-set (char-set-union (ucs-range->char-set 4520 4608) (ucs-range->char-set 55243 55292)))) + +;; :LV +(define char-set:hangul-lv (immutable-char-set (char-set-union))) + +;; :LVT +(define char-set:hangul-lvt (immutable-char-set (char-set-union (ucs-range->char-set 44033 44060) (ucs-range->char-set 44061 44088) (ucs-range->char-set 44089 44116) (ucs-range->char-set 44117 44144) (ucs-range->char-set 44145 44172) (ucs-range->char-set 44173 44200) (ucs-range->char-set 44201 44228) (ucs-range->char-set 44229 44256) (ucs-range->char-set 44257 44284) (ucs-range->char-set 44285 44312) (ucs-range->char-set 44313 44340) (ucs-range->char-set 44341 44368) (ucs-range->char-set 44369 44396) (ucs-range->char-set 44397 44424) (ucs-range->char-set 44425 44452) (ucs-range->char-set 44453 44480) (ucs-range->char-set 44481 44508) (ucs-range->char-set 44509 44536) (ucs-range->char-set 44537 44564) (ucs-range->char-set 44565 44592) (ucs-range->char-set 44593 44620) (ucs-range->char-set 44621 44648) (ucs-range->char-set 44649 44676) (ucs-range->char-set 44677 44704) (ucs-range->char-set 44705 44732) (ucs-range->char-set 44733 44760) (ucs-range->char-set 44761 44788) (ucs-range->char-set 44789 44816) (ucs-range->char-set 44817 44844) (ucs-range->char-set 44845 44872) (ucs-range->char-set 44873 44900) (ucs-range->char-set 44901 44928) (ucs-range->char-set 44929 44956) (ucs-range->char-set 44957 44984) (ucs-range->char-set 44985 45012) (ucs-range->char-set 45013 45040) (ucs-range->char-set 45041 45068) (ucs-range->char-set 45069 45096) (ucs-range->char-set 45097 45124) (ucs-range->char-set 45125 45152) (ucs-range->char-set 45153 45180) (ucs-range->char-set 45181 45208) (ucs-range->char-set 45209 45236) (ucs-range->char-set 45237 45264) (ucs-range->char-set 45265 45292) (ucs-range->char-set 45293 45320) (ucs-range->char-set 45321 45348) (ucs-range->char-set 45349 45376) (ucs-range->char-set 45377 45404) (ucs-range->char-set 45405 45432) (ucs-range->char-set 45433 45460) (ucs-range->char-set 45461 45488) (ucs-range->char-set 45489 45516) (ucs-range->char-set 45517 45544) (ucs-range->char-set 45545 45572) (ucs-range->char-set 45573 45600) (ucs-range->char-set 45601 45628) (ucs-range->char-set 45629 45656) (ucs-range->char-set 45657 45684) (ucs-range->char-set 45685 45712) (ucs-range->char-set 45713 45740) (ucs-range->char-set 45741 45768) (ucs-range->char-set 45769 45796) (ucs-range->char-set 45797 45824) (ucs-range->char-set 45825 45852) (ucs-range->char-set 45853 45880) (ucs-range->char-set 45881 45908) (ucs-range->char-set 45909 45936) (ucs-range->char-set 45937 45964) (ucs-range->char-set 45965 45992) (ucs-range->char-set 45993 46020) (ucs-range->char-set 46021 46048) (ucs-range->char-set 46049 46076) (ucs-range->char-set 46077 46104) (ucs-range->char-set 46105 46132) (ucs-range->char-set 46133 46160) (ucs-range->char-set 46161 46188) (ucs-range->char-set 46189 46216) (ucs-range->char-set 46217 46244) (ucs-range->char-set 46245 46272) (ucs-range->char-set 46273 46300) (ucs-range->char-set 46301 46328) (ucs-range->char-set 46329 46356) (ucs-range->char-set 46357 46384) (ucs-range->char-set 46385 46412) (ucs-range->char-set 46413 46440) (ucs-range->char-set 46441 46468) (ucs-range->char-set 46469 46496) (ucs-range->char-set 46497 46524) (ucs-range->char-set 46525 46552) (ucs-range->char-set 46553 46580) (ucs-range->char-set 46581 46608) (ucs-range->char-set 46609 46636) (ucs-range->char-set 46637 46664) (ucs-range->char-set 46665 46692) (ucs-range->char-set 46693 46720) (ucs-range->char-set 46721 46748) (ucs-range->char-set 46749 46776) (ucs-range->char-set 46777 46804) (ucs-range->char-set 46805 46832) (ucs-range->char-set 46833 46860) (ucs-range->char-set 46861 46888) (ucs-range->char-set 46889 46916) (ucs-range->char-set 46917 46944) (ucs-range->char-set 46945 46972) (ucs-range->char-set 46973 47000) (ucs-range->char-set 47001 47028) (ucs-range->char-set 47029 47056) (ucs-range->char-set 47057 47084) (ucs-range->char-set 47085 47112) (ucs-range->char-set 47113 47140) (ucs-range->char-set 47141 47168) (ucs-range->char-set 47169 47196) (ucs-range->char-set 47197 47224) (ucs-range->char-set 47225 47252) (ucs-range->char-set 47253 47280) (ucs-range->char-set 47281 47308) (ucs-range->char-set 47309 47336) (ucs-range->char-set 47337 47364) (ucs-range->char-set 47365 47392) (ucs-range->char-set 47393 47420) (ucs-range->char-set 47421 47448) (ucs-range->char-set 47449 47476) (ucs-range->char-set 47477 47504) (ucs-range->char-set 47505 47532) (ucs-range->char-set 47533 47560) (ucs-range->char-set 47561 47588) (ucs-range->char-set 47589 47616) (ucs-range->char-set 47617 47644) (ucs-range->char-set 47645 47672) (ucs-range->char-set 47673 47700) (ucs-range->char-set 47701 47728) (ucs-range->char-set 47729 47756) (ucs-range->char-set 47757 47784) (ucs-range->char-set 47785 47812) (ucs-range->char-set 47813 47840) (ucs-range->char-set 47841 47868) (ucs-range->char-set 47869 47896) (ucs-range->char-set 47897 47924) (ucs-range->char-set 47925 47952) (ucs-range->char-set 47953 47980) (ucs-range->char-set 47981 48008) (ucs-range->char-set 48009 48036) (ucs-range->char-set 48037 48064) (ucs-range->char-set 48065 48092) (ucs-range->char-set 48093 48120) (ucs-range->char-set 48121 48148) (ucs-range->char-set 48149 48176) (ucs-range->char-set 48177 48204) (ucs-range->char-set 48205 48232) (ucs-range->char-set 48233 48260) (ucs-range->char-set 48261 48288) (ucs-range->char-set 48289 48316) (ucs-range->char-set 48317 48344) (ucs-range->char-set 48345 48372) (ucs-range->char-set 48373 48400) (ucs-range->char-set 48401 48428) (ucs-range->char-set 48429 48456) (ucs-range->char-set 48457 48484) (ucs-range->char-set 48485 48512) (ucs-range->char-set 48513 48540) (ucs-range->char-set 48541 48568) (ucs-range->char-set 48569 48596) (ucs-range->char-set 48597 48624) (ucs-range->char-set 48625 48652) (ucs-range->char-set 48653 48680) (ucs-range->char-set 48681 48708) (ucs-range->char-set 48709 48736) (ucs-range->char-set 48737 48764) (ucs-range->char-set 48765 48792) (ucs-range->char-set 48793 48820) (ucs-range->char-set 48821 48848) (ucs-range->char-set 48849 48876) (ucs-range->char-set 48877 48904) (ucs-range->char-set 48905 48932) (ucs-range->char-set 48933 48960) (ucs-range->char-set 48961 48988) (ucs-range->char-set 48989 49016) (ucs-range->char-set 49017 49044) (ucs-range->char-set 49045 49072) (ucs-range->char-set 49073 49100) (ucs-range->char-set 49101 49128) (ucs-range->char-set 49129 49156) (ucs-range->char-set 49157 49184) (ucs-range->char-set 49185 49212) (ucs-range->char-set 49213 49240) (ucs-range->char-set 49241 49268) (ucs-range->char-set 49269 49296) (ucs-range->char-set 49297 49324) (ucs-range->char-set 49325 49352) (ucs-range->char-set 49353 49380) (ucs-range->char-set 49381 49408) (ucs-range->char-set 49409 49436) (ucs-range->char-set 49437 49464) (ucs-range->char-set 49465 49492) (ucs-range->char-set 49493 49520) (ucs-range->char-set 49521 49548) (ucs-range->char-set 49549 49576) (ucs-range->char-set 49577 49604) (ucs-range->char-set 49605 49632) (ucs-range->char-set 49633 49660) (ucs-range->char-set 49661 49688) (ucs-range->char-set 49689 49716) (ucs-range->char-set 49717 49744) (ucs-range->char-set 49745 49772) (ucs-range->char-set 49773 49800) (ucs-range->char-set 49801 49828) (ucs-range->char-set 49829 49856) (ucs-range->char-set 49857 49884) (ucs-range->char-set 49885 49912) (ucs-range->char-set 49913 49940) (ucs-range->char-set 49941 49968) (ucs-range->char-set 49969 49996) (ucs-range->char-set 49997 50024) (ucs-range->char-set 50025 50052) (ucs-range->char-set 50053 50080) (ucs-range->char-set 50081 50108) (ucs-range->char-set 50109 50136) (ucs-range->char-set 50137 50164) (ucs-range->char-set 50165 50192) (ucs-range->char-set 50193 50220) (ucs-range->char-set 50221 50248) (ucs-range->char-set 50249 50276) (ucs-range->char-set 50277 50304) (ucs-range->char-set 50305 50332) (ucs-range->char-set 50333 50360) (ucs-range->char-set 50361 50388) (ucs-range->char-set 50389 50416) (ucs-range->char-set 50417 50444) (ucs-range->char-set 50445 50472) (ucs-range->char-set 50473 50500) (ucs-range->char-set 50501 50528) (ucs-range->char-set 50529 50556) (ucs-range->char-set 50557 50584) (ucs-range->char-set 50585 50612) (ucs-range->char-set 50613 50640) (ucs-range->char-set 50641 50668) (ucs-range->char-set 50669 50696) (ucs-range->char-set 50697 50724) (ucs-range->char-set 50725 50752) (ucs-range->char-set 50753 50780) (ucs-range->char-set 50781 50808) (ucs-range->char-set 50809 50836) (ucs-range->char-set 50837 50864) (ucs-range->char-set 50865 50892) (ucs-range->char-set 50893 50920) (ucs-range->char-set 50921 50948) (ucs-range->char-set 50949 50976) (ucs-range->char-set 50977 51004) (ucs-range->char-set 51005 51032) (ucs-range->char-set 51033 51060) (ucs-range->char-set 51061 51088) (ucs-range->char-set 51089 51116) (ucs-range->char-set 51117 51144) (ucs-range->char-set 51145 51172) (ucs-range->char-set 51173 51200) (ucs-range->char-set 51201 51228) (ucs-range->char-set 51229 51256) (ucs-range->char-set 51257 51284) (ucs-range->char-set 51285 51312) (ucs-range->char-set 51313 51340) (ucs-range->char-set 51341 51368) (ucs-range->char-set 51369 51396) (ucs-range->char-set 51397 51424) (ucs-range->char-set 51425 51452) (ucs-range->char-set 51453 51480) (ucs-range->char-set 51481 51508) (ucs-range->char-set 51509 51536) (ucs-range->char-set 51537 51564) (ucs-range->char-set 51565 51592) (ucs-range->char-set 51593 51620) (ucs-range->char-set 51621 51648) (ucs-range->char-set 51649 51676) (ucs-range->char-set 51677 51704) (ucs-range->char-set 51705 51732) (ucs-range->char-set 51733 51760) (ucs-range->char-set 51761 51788) (ucs-range->char-set 51789 51816) (ucs-range->char-set 51817 51844) (ucs-range->char-set 51845 51872) (ucs-range->char-set 51873 51900) (ucs-range->char-set 51901 51928) (ucs-range->char-set 51929 51956) (ucs-range->char-set 51957 51984) (ucs-range->char-set 51985 52012) (ucs-range->char-set 52013 52040) (ucs-range->char-set 52041 52068) (ucs-range->char-set 52069 52096) (ucs-range->char-set 52097 52124) (ucs-range->char-set 52125 52152) (ucs-range->char-set 52153 52180) (ucs-range->char-set 52181 52208) (ucs-range->char-set 52209 52236) (ucs-range->char-set 52237 52264) (ucs-range->char-set 52265 52292) (ucs-range->char-set 52293 52320) (ucs-range->char-set 52321 52348) (ucs-range->char-set 52349 52376) (ucs-range->char-set 52377 52404) (ucs-range->char-set 52405 52432) (ucs-range->char-set 52433 52460) (ucs-range->char-set 52461 52488) (ucs-range->char-set 52489 52516) (ucs-range->char-set 52517 52544) (ucs-range->char-set 52545 52572) (ucs-range->char-set 52573 52600) (ucs-range->char-set 52601 52628) (ucs-range->char-set 52629 52656) (ucs-range->char-set 52657 52684) (ucs-range->char-set 52685 52712) (ucs-range->char-set 52713 52740) (ucs-range->char-set 52741 52768) (ucs-range->char-set 52769 52796) (ucs-range->char-set 52797 52824) (ucs-range->char-set 52825 52852) (ucs-range->char-set 52853 52880) (ucs-range->char-set 52881 52908) (ucs-range->char-set 52909 52936) (ucs-range->char-set 52937 52964) (ucs-range->char-set 52965 52992) (ucs-range->char-set 52993 53020) (ucs-range->char-set 53021 53048) (ucs-range->char-set 53049 53076) (ucs-range->char-set 53077 53104) (ucs-range->char-set 53105 53132) (ucs-range->char-set 53133 53160) (ucs-range->char-set 53161 53188) (ucs-range->char-set 53189 53216) (ucs-range->char-set 53217 53244) (ucs-range->char-set 53245 53272) (ucs-range->char-set 53273 53300) (ucs-range->char-set 53301 53328) (ucs-range->char-set 53329 53356) (ucs-range->char-set 53357 53384) (ucs-range->char-set 53385 53412) (ucs-range->char-set 53413 53440) (ucs-range->char-set 53441 53468) (ucs-range->char-set 53469 53496) (ucs-range->char-set 53497 53524) (ucs-range->char-set 53525 53552) (ucs-range->char-set 53553 53580) (ucs-range->char-set 53581 53608) (ucs-range->char-set 53609 53636) (ucs-range->char-set 53637 53664) (ucs-range->char-set 53665 53692) (ucs-range->char-set 53693 53720) (ucs-range->char-set 53721 53748) (ucs-range->char-set 53749 53776) (ucs-range->char-set 53777 53804) (ucs-range->char-set 53805 53832) (ucs-range->char-set 53833 53860) (ucs-range->char-set 53861 53888) (ucs-range->char-set 53889 53916) (ucs-range->char-set 53917 53944) (ucs-range->char-set 53945 53972) (ucs-range->char-set 53973 54000) (ucs-range->char-set 54001 54028) (ucs-range->char-set 54029 54056) (ucs-range->char-set 54057 54084) (ucs-range->char-set 54085 54112) (ucs-range->char-set 54113 54140) (ucs-range->char-set 54141 54168) (ucs-range->char-set 54169 54196) (ucs-range->char-set 54197 54224) (ucs-range->char-set 54225 54252) (ucs-range->char-set 54253 54280) (ucs-range->char-set 54281 54308) (ucs-range->char-set 54309 54336) (ucs-range->char-set 54337 54364) (ucs-range->char-set 54365 54392) (ucs-range->char-set 54393 54420) (ucs-range->char-set 54421 54448) (ucs-range->char-set 54449 54476) (ucs-range->char-set 54477 54504) (ucs-range->char-set 54505 54532) (ucs-range->char-set 54533 54560) (ucs-range->char-set 54561 54588) (ucs-range->char-set 54589 54616) (ucs-range->char-set 54617 54644) (ucs-range->char-set 54645 54672) (ucs-range->char-set 54673 54700) (ucs-range->char-set 54701 54728) (ucs-range->char-set 54729 54756) (ucs-range->char-set 54757 54784) (ucs-range->char-set 54785 54812) (ucs-range->char-set 54813 54840) (ucs-range->char-set 54841 54868) (ucs-range->char-set 54869 54896) (ucs-range->char-set 54897 54924) (ucs-range->char-set 54925 54952) (ucs-range->char-set 54953 54980) (ucs-range->char-set 54981 55008) (ucs-range->char-set 55009 55036) (ucs-range->char-set 55037 55064) (ucs-range->char-set 55065 55092) (ucs-range->char-set 55093 55120) (ucs-range->char-set 55121 55148) (ucs-range->char-set 55149 55176) (ucs-range->char-set 55177 55204)))) + diff --git a/lib/chibi/char-set/boundary.sld b/lib/chibi/char-set/boundary.sld new file mode 100644 index 00000000..f4037786 --- /dev/null +++ b/lib/chibi/char-set/boundary.sld @@ -0,0 +1,21 @@ +;; Character sets for Unicode boundaries, TR29. + +(define-library (chibi char-set boundary) + (cond-expand + (chibi + (import (chibi) (chibi char-set))) + (else + (import (scheme base) (srfi 14)) + (begin (define (immutable-char-set cs) cs)))) + (export char-set:regional-indicator + char-set:extend-or-spacing-mark + char-set:hangul-l + char-set:hangul-v + char-set:hangul-t + char-set:hangul-lv + char-set:hangul-lvt) + ;; generated with: + ;; tools/extract-unicode-props.scm --derived GraphemeBreakProperty.txt + ;; Control extend-or-spacing-mark=Extend,SpacingMark Regional_Indicator + ;; hangul-l=:L hangul-v=:V hangul-t=:T hangul-lv=:LV hangul-lvt=:LVT + (include "boundary.scm")) diff --git a/lib/chibi/char-set/extras.scm b/lib/chibi/char-set/extras.scm new file mode 100644 index 00000000..41d81121 --- /dev/null +++ b/lib/chibi/char-set/extras.scm @@ -0,0 +1,47 @@ + +(define (char-set . args) + (list->char-set args)) + +;; This is a mistake in the SRFI-14 design - end should be inclusive. +(define (ucs-range->char-set start end) + (make-iset start (- end 1))) + +(define char-set-copy iset-copy) + +(define char-set-size iset-size) + +(define (list->char-set ls) + (list->iset (map char->integer ls))) +(define (char-set->list cset) + (map integer->char (iset->list cset))) + +(define (string->char-set str) + (list->char-set (string->list str))) +(define (char-set->string cset) + (list->string (char-set->list cset))) + +(define (char-set-adjoin! cset ch) + (iset-adjoin! cset (char->integer ch))) +(define (char-set-adjoin cset ch) + (iset-adjoin cset (char->integer ch))) + +(define char-set-union iset-union) +(define char-set-union! iset-union!) +(define char-set-intersection iset-intersection) +(define char-set-intersection! iset-intersection!) +(define char-set-difference iset-difference) +(define char-set-difference! iset-difference!) + +(define char-set:empty (immutable-char-set (%make-iset 0 0 0 #f #f))) +(define char-set:ascii (immutable-char-set (%make-iset 0 #x7F #f #f #f))) + +(cond-expand + (full-unicode + (define char-set:full + (immutable-char-set + (%make-iset 0 #xD7FF #f #f (%make-iset #xE000 #x10FFFD #f #f #f))))) + (else + (define char-set:full (immutable-char-set (%make-iset 0 #xFF #f #f #f))))) + +(define (char-set-complement cset) + (char-set-difference char-set:full cset)) diff --git a/lib/chibi/char-set/extras.sld b/lib/chibi/char-set/extras.sld new file mode 100644 index 00000000..632dbf27 --- /dev/null +++ b/lib/chibi/char-set/extras.sld @@ -0,0 +1,11 @@ + +(define-library (chibi char-set extras) + (import (chibi) (chibi iset) (chibi char-set base)) + (include "extras.scm") + (export + char-set ucs-range->char-set char-set-copy char-set-size + list->char-set char-set->list string->char-set char-set->string + char-set-adjoin! char-set-adjoin char-set-union char-set-union! + char-set-intersection char-set-intersection! + char-set-difference char-set-difference! + char-set-complement char-set:empty char-set:ascii char-set:full)) diff --git a/lib/chibi/char-set/full.scm b/lib/chibi/char-set/full.scm new file mode 100644 index 00000000..0240cf56 --- /dev/null +++ b/lib/chibi/char-set/full.scm @@ -0,0 +1,42 @@ +;; char-set:lower-case +(define char-set:lower-case (immutable-char-set (%make-iset 11312 11557 113078212145405220956299481848306876004857152314519694622414813644330106879 (%make-iset 7424 7615 6277101735386680763834460195211881500229451637403754168319 (%make-iset 891 1231 3359617113266706315836163420852667279900761594669382740612734659380575149118011965863067042895076786183 (%make-iset 591 740 1382646202340133545564837515061266821645598719 (%make-iset 97 576 2365509536875796115271152425453441351280931286999514252096600828646551318540912334052744481790519950100366591329056407886414129454316222836375551 #f #f) #f) (%make-iset 1377 1415 #f #f #f)) (%make-iset 8336 8575 1766820104831717270911194217800685387968293958678012717949960101612756991 (%make-iset 7829 8183 63072327451413996121415570261819623312617164997438933550707549860292318813601613991411837156872431794651647 #f #f) (%make-iset 9424 9449 #f #f #f))) (%make-iset 65345 65370 #f (%make-iset 43000 43001 #f (%make-iset 42799 42872 18815678955183742648327 #f #f) (%make-iset 64256 64279 16253055 #f #f)) (%make-iset 119834 120327 51146727486231585908820696036815651831314948480676177501992199236163085036512359821035265912047941451080432971005274950492488384578638513597382131711 (%make-iset 66600 66639 #f #f #f) (%make-iset 120354 120777 42984503304530211461104808282321868720026385944674536297193504244060802094551012793517930744128497289034962077133152853331804159 #f #f)))))) + +;; char-set:upper-case +(define char-set:upper-case (immutable-char-set (%make-iset 9398 9423 #f (%make-iset 1216 1366 2854495385401535168399502283641929280107053059 (%make-iset 376 582 193510492298500594587530311832788051917914503280678853822825987 (%make-iset 65 222 363948161469878586209393690477933956061783392255 #f #f) (%make-iset 904 1071 374144419156711012060424995402076372759432889630407 #f #f)) (%make-iset 7944 8187 1736907842101479124536426275495535083658609664624882011531376654293716462141695 (%make-iset 4256 4293 #f #f #f) (%make-iset 8459 8559 2535262514830237892353053933799 #f #f))) (%make-iset 66560 66599 #f (%make-iset 42877 42878 #f (%make-iset 11264 11392 595503879886640614262110651042930622463 #f #f) (%make-iset 65313 65338 #f #f #f)) (%make-iset 120328 120744 338460645933693697560665215760249528245999403264098033404085806319476851798827321172475719366475085497933670543086984716353535 (%make-iset 119808 120301 51146727486231585908820696036815651831314948480394089408712024707913450654934185184668161964607423236491353583631673266179433585099917637254106841087 #f #f) #f))))) + +;; char-set:title-case +(define char-set:title-case (immutable-char-set (%make-iset 8072 8188 83076749736557537208897815481090303 (%make-iset 453 498 35184372088905 #f #f) #f))) + +;; char-set:letter +(define char-set:letter (immutable-char-set (%make-iset 44032 55203 #f (%make-iset 6912 7414 22886562555891042693710382455505074355841760073166317418421820388451117221729500954464088123708152923721508489525154758089698131078348046953168412606447 (%make-iset 3913 4346 44362715105927999221712262984342111652617098472873236058512408135598431308732685725527979136265102154321118707789398691204023975935 (%make-iset 1869 2380 13407424329480734270447878660048428920496373804417168083627602288254107168259292949124979141882146787383731347613928737074953757721179033264662499184082943 (%make-iset 880 1366 399583814438996167382020011346842847816169115710121343500162631807336209279770003226660543306154439487482399564906606488253101298916621286954252495 (%make-iset 452 740 963565667247331348724662781356953235953225866953231882562121816871620562685859362504703 (%make-iset 65 451 314600393224337169960540460799584166474933543237622550739399649019542269878494744694979332000092312996040451282698239 #f #f) #f) (%make-iset 1377 1855 1560874275157973934342501410334434064559112153595576892194119830209925249809262307688780388207250242577643819833026382406056630315346898446188543 #f #f)) (%make-iset 2908 3404 381991200485141231019756222367537226053710584749387702525493540482928266985181611648107653982490012918979831010671369935541658005339438249753284968699 (%make-iset 2382 2892 5366736463464336406706714106425487149575078127243771493347988908203826370682080174911419639786360015702762728603625228669492029470702181043482460663316355 #f #f) (%make-iset 3424 3911 796045880330578019002307293597294347346987043146984104137316595631780707567417231169995506839382805294177527833722740156565765733950441790015275023 #f #f))) (%make-iset 5121 5740 #f (%make-iset 4682 4822 2787528182814337039150675927861957382578127 (%make-iset 4349 4680 #f #f #f) (%make-iset 4824 5108 62165404551223330269422779455378792455782943721961461362086716517957521327837304324095 #f #f)) (%make-iset 6212 6683 12194330229244424385358936041275179229938106075909171049697737889247539090636773541118657721546749280855637804188578406358228684801308538961919 (%make-iset 5743 6210 762145642144808933311681242303344929266684400897434715282060471834151313118761625963263953770881497968694418657905208578955948716669007691775 #f #f) (%make-iset 6688 6772 38685487814037185985773567 #f #f)))) (%make-iset 19968 40908 #f (%make-iset 9398 9449 #f (%make-iset 7680 8188 1669429210027032353070387959902572074068251569912541634239543664469254840701605815586298160569854604812755249439701457169906905863833481177213265564925951 (%make-iset 7424 7615 6277101735386680763834460195211881500229451637403754168319 #f #f) (%make-iset 8336 8584 904625697166121400702423284964750605108746128179460890055734500600385118207 #f #f)) (%make-iset 12321 12799 1560850458106678397246853318509506420346053090363696722427379182288726125506853871807416126725592575693831523564009034418563951096328109074350591 (%make-iset 11264 11775 1716199415031085457304815023196129625190876140284840059163076939411632061379695825768761320243048559913035261692194332965927453391792248614786550156348096511 #f #f) (%make-iset 13312 19893 #f #f #f))) (%make-iset 42656 43137 9366007796590143684266426014173832021882860391206691228341429856634888413055477646498624449482500722743196759142345085250473767233032902320062463 (%make-iset 40982 42124 #f (%make-iset 40960 40980 #f #f #f) (%make-iset 42192 42647 186070703019498633361408888448075376716851403313694244648522839560594426772554545643464113891391655073968019319443321956603475346266783743 #f #f)) (%make-iset 43648 43822 47701954761756259097387504798417463778755529815359487 (%make-iset 43138 43638 6495633707107511592130816216430842683164567658071841769919061558009539875610149675919448576995054309973657727503245554791947025664158092800029345447935 #f #f) (%make-iset 43968 44010 7559142440959 #f #f))))) (%make-iset 71296 71349 17952825858326527 (%make-iset 65536 65908 354901720847464262643270080013918741494457029505007323037992842993478140487429303646626346434630199938330987804055257434518162763775 (%make-iset 64256 64433 383123885216472214589586756787576615644966064332734591 (%make-iset 63744 64109 #f (%make-iset 55216 55291 75557863725914197590015 #f #f) (%make-iset 64112 64217 #f #f #f)) (%make-iset 64848 64967 341611594916723379280938182270919901183 (%make-iset 64467 64829 #f #f #f) (%make-iset 65008 65500 23166459242184795109519745412560813317707843523172326996034783221158488630072272676325665038195628414381257440134258275967737233656228847161199038463 #f #f))) (%make-iset 67840 68220 4925250765375315437575115447282545225619899143486530057386523691675827454339457238250572167562730571287653355880447 (%make-iset 66640 66717 #f (%make-iset 66176 66639 878680692688788100968217104054132723536510135400456683066998889497980605885632024127229627367624962058724496859707859793938161524087860595782141042536975695871 #f #f) (%make-iset 67584 67669 77371243358065019892792383 #f #f)) (%make-iset 68608 68680 #f (%make-iset 68352 68466 1427247352465131255837309846865400673685471231 #f #f) (%make-iset 69635 70084 204586912993508730593563550625432944389072422914203271589172564161864958211730995356562955949992950450193086469961732181890394864571677076213876129791 #f #f)))) (%make-iset 120146 120485 #f (%make-iset 92160 92728 #f (%make-iset 74752 74850 #f (%make-iset 73728 74606 #f #f #f) (%make-iset 77824 78894 #f #f #f)) (%make-iset 110592 110593 #f (%make-iset 93952 94111 1461323231539455856679019361440445717580125044735 #f #f) (%make-iset 119808 120144 1221462192088229133428742507380976417683660481320862010013722843488511299179635651402650638514783282651558855669972991 #f #f))) (%make-iset 131072 173782 #f (%make-iset 120656 120779 21226109557071405325645863666178850815 (%make-iset 120488 120654 187072206790762423064706648907459429699768891211775 #f #f) (%make-iset 126464 126651 6421867392636242726356536395708148792154285362342779204665327 #f #f)) (%make-iset 177984 178205 #f (%make-iset 173824 177972 #f #f #f) (%make-iset 194560 195101 #f #f #f)))))))) + +;; char-set:punctuation +(define char-set:punctuation (immutable-char-set (%make-iset 10627 10749 7975367975289779630837864365545226239 (%make-iset 5120 5120 #f (%make-iset 2800 2800 #f (%make-iset 1370 1805 177440029682739492195629626423414285791075425806584367987188710887245779556727828964224741026149370230681856791701409903272452423743 (%make-iset 894 903 513 (%make-iset 33 191 6277101735777033378358367027585284040564796057489604901879 #f #f) #f) (%make-iset 2404 2416 4099 (%make-iset 2039 2142 10141204806548057579655195000839 #f #f) #f)) (%make-iset 4347 4347 #f (%make-iset 3844 4175 8612299728833109452216727519275634166367255279803428156814546022481552546661143084834195942383124479 (%make-iset 3572 3675 15214283082817323578510236712961 #f #f) #f) (%make-iset 4960 4968 #f #f #f))) (%make-iset 7002 7008 #f (%make-iset 6468 6469 #f (%make-iset 6100 6154 36011204832919671 (%make-iset 5741 5942 4820814132776970826626481771165599449877669887122490332807171 #f #f) #f) (%make-iset 6816 6829 16255 (%make-iset 6686 6687 #f #f #f) #f)) (%make-iset 9001 9002 #f (%make-iset 8208 8334 127607834706674478748244504138880122879 (%make-iset 7164 7379 52681756409358971006475467946070306489686807156907791211684691983 #f #f) #f) (%make-iset 10088 10223 87027215340059722591700904977272299077631 #f #f)))) (%make-iset 65281 65381 2521683860030948918624327334903 (%make-iset 43124 43615 11987514433213410168505333362405758614102799522152940711615041872404225459959956214682136066587259816913167135759024198010248565942507088814987542543 (%make-iset 12289 12539 1809251394333065553493296641491499378872794969502476229475819322195851214727 (%make-iset 11776 11835 1152780767118491647 (%make-iset 11513 11632 664613997892457936451903530140172399 #f #f) #f) (%make-iset 42509 42743 54351252480975689826048702415431575448442147475312362296571857733681159 (%make-iset 42238 42239 #f #f #f) #f)) (%make-iset 64830 64831 #f (%make-iset 44011 44011 #f (%make-iset 43742 43761 786435 #f #f) #f) (%make-iset 65040 65131 4037812089938908849547248639 #f #f))) (%make-iset 68176 68223 140737488355839 (%make-iset 67671 67671 #f (%make-iset 66463 66512 562949953421313 (%make-iset 65792 65794 #f #f #f) #f) (%make-iset 67871 67903 4294967297 #f #f)) (%make-iset 70085 70088 #f (%make-iset 69703 69955 13569385457497991651199724805705614201565294768222350139146883642703225028735 (%make-iset 68409 68415 #f #f #f) #f) (%make-iset 74864 74867 #f #f #f))))))) + +;; char-set:symbol +(define char-set:symbol (immutable-char-set (%make-iset 10750 11084 #f (%make-iset 4254 4255 #f (%make-iset 2801 2928 170141183460469231731687303715884105729 (%make-iset 1423 1551 536343496299213554716686148823119036417 (%make-iset 706 1014 521481209941628438084722096232800884555162981189081790621504207040293760564100563907364454415 (%make-iset 36 247 3291009115408659855127328282852688335858940725263447471358476417 #f #f) (%make-iset 1154 1154 #f #f #f)) (%make-iset 2038 2038 #f (%make-iset 1758 1790 6442452993 #f #f) (%make-iset 2546 2555 771 #f #f))) (%make-iset 3647 3647 #f (%make-iset 3199 3199 #f (%make-iset 3059 3066 #f #f #f) (%make-iset 3449 3449 #f #f #f)) (%make-iset 4030 4056 126058239 (%make-iset 3841 3896 47287798208921607 #f #f) #f))) (%make-iset 8592 9000 #f (%make-iset 6622 6655 #f (%make-iset 6107 6107 #f (%make-iset 5008 5017 #f #f #f) (%make-iset 6464 6464 #f #f #f)) (%make-iset 8125 8527 15180504508302547082559792549452134039979727921597050291198905168453617261872958515620728168035045459212134851764818477085 (%make-iset 7009 7036 267912191 #f #f) #f)) (%make-iset 10224 10626 #f (%make-iset 9472 9983 #f (%make-iset 9003 9449 363419362147803445274660701490199886974208000930090554402992578672453439413725018135787913021374683400778402767997805117095404640403455 #f #f) (%make-iset 9985 10213 862718293047519590130783627714548701007576706064464912086123449155583 #f #f)) (%make-iset 10716 10749 4294967295 (%make-iset 10649 10711 #f #f #f) #f)))) (%make-iset 65020 65129 796084576943328064139929612976131 (%make-iset 19904 19967 #f (%make-iset 12443 12444 #f (%make-iset 11493 11498 #f (%make-iset 11088 11097 #f #f #f) (%make-iset 11904 12351 547258453716185545689710299454841531346882567525409776024515836385994490529377606833512566938465691840048809561654146263061905633443839 #f #f)) (%make-iset 13056 13311 #f (%make-iset 12688 13054 300613450595050653137261935414156179889591998741512647513967970216935158771592840931503642564904187380807827395 #f #f) #f)) (%make-iset 43639 43641 #f (%make-iset 42752 42890 522673715590561479879743397015208866086911 (%make-iset 42128 42182 #f #f #f) (%make-iset 43048 43065 245775 #f #f)) (%make-iset 64434 64449 #f (%make-iset 64297 64297 #f #f #f) #f))) (%make-iset 120513 120771 463168363851011130091785795673740600836767278013411671357985905734243019915265 (%make-iset 118784 119261 780437137578995458467560908739391556888996158179266522929460546508236933653296437157060350808521225678016835714111230592247297551268494937423871 (%make-iset 65504 65533 805339007 (%make-iset 65284 65374 1547425050547877224499904641 #f #f) (%make-iset 65847 66044 401734511064736150903948875408776876244564738538201663144447 #f #f)) (%make-iset 119552 119638 #f (%make-iset 119296 119365 664082786653543858175 #f #f) #f)) (%make-iset 127744 128252 1623601741516486367526542089626489179499454454837360135582644525057721907975405279813447049733043276512275822980244041212191896116171460908759068350349311 (%make-iset 126976 127386 5288447750321425141395456744287458546996189758388629186172721346534510152156602991240248150625623449590204448175840041107455 (%make-iset 126704 126705 #f #f #f) (%make-iset 127462 127569 244021541289521102071576548868095 #f #f)) (%make-iset 128507 128883 307828173409331868845930000782371979146838607456393061394578876014578854359990151589006733868359031372480153387007 (%make-iset 128256 128359 5104235524096485346957782767918670413823 #f #f) #f))))))) + +;; char-set:blank +(define char-set:blank (immutable-char-set (%make-iset 6158 6158 #f (%make-iset 160 160 #f (%make-iset 9 32 8388609 #f #f) (%make-iset 5760 5760 #f #f #f)) (%make-iset 12288 12288 #f (%make-iset 8192 8287 39614081257132309534260332543 #f #f) #f)))) + +;; char-set:whitespace +(define char-set:whitespace (immutable-char-set (%make-iset 6158 6158 #f (%make-iset 160 160 #f (%make-iset 9 32 8388639 #f #f) (%make-iset 5760 5760 #f #f #f)) (%make-iset 12288 12288 #f (%make-iset 8192 8287 39614081257132312832795215871 #f #f) #f)))) + +;; char-set:digit +(define char-set:digit (immutable-char-set (%make-iset 6992 7097 81050410252092417358195461194751 (%make-iset 3430 3439 #f (%make-iset 1984 1993 #f (%make-iset 1632 1641 #f (%make-iset 48 57 #f #f #f) (%make-iset 1776 1785 #f #f #f)) (%make-iset 2918 3311 743556014954405849072266507808340190880121684743320383604969609548181369962480481034346862340233244904693236621235324859507752652901450751 (%make-iset 2406 2799 743556014954405849072266507808340190880121684743320383604969609548181369962480481034346862340233244904693236621235324859507752652901450751 #f #f) #f)) (%make-iset 6470 6479 #f (%make-iset 4160 4249 1236731113465765645724419071 (%make-iset 3664 3881 420844212009973745855555120560483693212126493377631139457593771007 #f #f) (%make-iset 6112 6169 287948901175002111 #f #f)) (%make-iset 6784 6809 67044351 (%make-iset 6608 6617 #f #f #f) #f))) (%make-iset 66720 66729 #f (%make-iset 43472 43609 6421475075300574421752121441301562791795741843089406187013119 (%make-iset 42528 42537 #f (%make-iset 7232 7257 67044351 #f #f) (%make-iset 43216 43273 287948901175002111 #f #f)) (%make-iset 65296 65305 #f (%make-iset 44016 44025 #f #f #f) #f)) (%make-iset 70096 70105 #f (%make-iset 69872 69951 1207745227993911763403775 (%make-iset 69734 69743 #f #f #f) #f) (%make-iset 120782 120831 #f (%make-iset 71360 71369 #f #f #f) #f)))))) + +;; char-set:letter+digit +(define char-set:letter+digit (immutable-char-set (%make-iset 44032 55203 #f (%make-iset 6912 7414 22886562555891042693710382458146756289377006471936556892838923982807328844367070294241793956553485968351753386046618718102707539530518625959993520685039 (%make-iset 3913 4346 44362715105927999221712262984621806339048726122702370012163096018033725502663463203116646689073826286574787756247207860776650932223 (%make-iset 1869 2380 13407424329480734270447878660048428920496373804417168083627602288254107168259292949124979141882146787383731347613928779568711247970208345158244457521348607 (%make-iset 880 1366 399583814438996167382020011346842847816169115710121343500162631807336209279770003226660543306154439487482399564906606488253101298916621286954252495 (%make-iset 452 740 963565667247331348724662781356953235953225866953231882562121816871620562685859362504703 (%make-iset 48 451 41235302740700321541067959277923095868202489379241662970514590796289444397514063176660331003916099649017014030525823583231 #f #f) #f) (%make-iset 1377 1855 1560874275157973934343822231147075518302721156252056432767839474782185051280962423908807488297855721715644480587704321413018649007858524599877631 #f #f)) (%make-iset 2908 3404 381991200485141231019756222408812876448756014237186533546277447507183436269917901262081454044646810274583365631168335787645676728618713947476107197691 (%make-iset 2382 2892 5366736463561891048904088864332422319078538891026511232750792789353571719231492410784884055633496549297705163924592108787908229198392583314950938978942851 #f #f) (%make-iset 3424 3911 796045881074145379721101485003658612742377112762910063541249941107066206101891013710754591976857025636790244447628442609572802972081506968078974927 #f #f))) (%make-iset 5121 5740 #f (%make-iset 4682 4822 2787528182814337039150675927861957382578127 (%make-iset 4349 4680 #f #f #f) (%make-iset 4824 5108 62165404551223330269422779455378792455782943721961461362086716517957521327837304324095 #f #f)) (%make-iset 6212 6683 12194330229244424385524038642855360947889231407969113621412693927197786728086255496979946034430370000318048005765115268416095504239842568437759 (%make-iset 5743 6210 762145642145155178562790324783619807494011846352632466837216562044788852063159421730556579887606746611010843054583947091606179550442951671807 #f #f) (%make-iset 6688 6809 5311800736730066244218093126239125503 #f #f)))) (%make-iset 19968 40908 #f (%make-iset 9398 9449 #f (%make-iset 7680 8188 1669429210027032353070387959902572074068251569912541634239543664469254840701605815586298160569854604812755249439701457169906905863833481177213265564925951 (%make-iset 7424 7615 6277101735386680763834460195211881500229451637403754168319 #f #f) (%make-iset 8336 8584 904625697166121400702423284964750605108746128179460890055734500600385118207 #f #f)) (%make-iset 12321 12799 1560850458106678397246853318509506420346053090363696722427379182288726125506853871807416126725592575693831523564009034418563951096328109074350591 (%make-iset 11264 11775 1716199415031085457304815023196129625190876140284840059163076939411632061379695825768761320243048559913035261692194332965927453391792248614786550156348096511 #f #f) (%make-iset 13312 19893 #f #f #f))) (%make-iset 42656 43137 9366007796590143684266426014173832021882860391206691228341429856634888413055477646498624449482500722743196759142345085250473767233032902320062463 (%make-iset 40982 42124 #f (%make-iset 40960 40980 #f #f #f) (%make-iset 42192 42647 186070703019498633361408888448075519920530856307050957164988653405500459175263525083868751559444797946410782900983767246458201399646748671 #f #f)) (%make-iset 43648 43822 47701954761756259097387504798417463778755529815359487 (%make-iset 43138 43638 224726016208531273348937437899872290007502680726266932355584409924411794087837267452460956059789185107995855861761463319664142696520594339463520992995707994505215 #f #f) (%make-iset 43968 44025 287956460317442047 #f #f))))) (%make-iset 71296 71369 348108861360120048141903260542929609949183 (%make-iset 65536 65908 354901720847464262643270080013918741494457029505007323037992842993478140487429303646626346434630199938330987804055257434518162763775 (%make-iset 64256 64433 383123885216472214589586756787576615644966064332734591 (%make-iset 63744 64109 #f (%make-iset 55216 55291 75557863725914197590015 #f #f) (%make-iset 64112 64217 #f #f #f)) (%make-iset 64848 64967 341611594916723379280938182270919901183 (%make-iset 64467 64829 #f #f #f) (%make-iset 65008 65500 23166459242184795109519745412560813317707843523172326996035291982829335841807197632365519235915051181023523126849199870616098935821672668804369354751 #f #f))) (%make-iset 67840 68220 4925250765375315437575115447282545225619899143486530057386523691675827454339457238250572167562730571287653355880447 (%make-iset 66640 66729 1237033344920669303018094591 (%make-iset 66176 66639 878680692688788100968217104054132723536510135400456683066998889497980605885632024127229627367624962058724496859707859793938161524087860595782141042536975695871 #f #f) (%make-iset 67584 67669 77371243358065019892792383 #f #f)) (%make-iset 68608 68680 #f (%make-iset 68352 68466 1427247352465131255837309846865400673685471231 #f #f) (%make-iset 69635 70105 204586912993508730593563550625432944389072422914203271855910203047007904292292283148049105766861891958292943578471947333866751571791177989246645436415 #f #f)))) (%make-iset 120146 120485 #f (%make-iset 92160 92728 #f (%make-iset 74752 74850 #f (%make-iset 73728 74606 #f #f #f) (%make-iset 77824 78894 #f #f #f)) (%make-iset 110592 110593 #f (%make-iset 93952 94111 1461323231539455856679019361440445717580125044735 #f #f) (%make-iset 119808 120144 1221462192088229133428742507380976417683660481320862010013722843488511299179635651402650638514783282651558855669972991 #f #f))) (%make-iset 131072 173782 #f (%make-iset 120656 120831 95780971304117989802914516033683783778383003373273087 (%make-iset 120488 120654 187072206790762423064706648907459429699768891211775 #f #f) (%make-iset 126464 126651 6421867392636242726356536395708148792154285362342779204665327 #f #f)) (%make-iset 177984 178205 #f (%make-iset 173824 177972 #f #f #f) (%make-iset 194560 195101 #f #f #f)))))))) + +;; char-set:hex-digit +(define char-set:hex-digit (immutable-char-set (%make-iset 48 102 35465847073801215 #f #f))) + +;; char-set:iso-control +(define char-set:iso-control (immutable-char-set (%make-iset 0 159 1461501637160761734743215600984595715944343404543 #f #f))) + +;; char-set:graphic +(define char-set:graphic (immutable-char-set (%make-iset 4960 4968 #f (%make-iset 64848 64967 341611594916723379280938182270919901183 (%make-iset 8336 8584 904625697166121400702423284964750605108746128179460890055734500600385118207 (%make-iset 4349 4680 #f (%make-iset 1869 2380 13407424329480734270447878660048428920496373804417168083627602288254107168259292949124979141882146787383731347613928779568711247970208345158244457521348607 (%make-iset 880 1366 399583814438996167382020011346842847816169115710121343500162631837690410720797019959777135600271922403770006425096286507812670201087000743294040271 (%make-iset 452 1014 15095849699286165408966218323953077744206039126039399880352876178469244380253667520073008553405383346474973778635124736918461513833545106799961749425123263291782871384063 (%make-iset 33 451 1351198400207268136257714889618984005409259171978990812217822137540885437287020053544046511735433817788139780300462983613513727 #f #f) #f) (%make-iset 1377 1855 1560874275157973934343822231147075518302721156252056432767839474782185051280962423908807488297855721715644480587704321413018649007858524599877631 #f #f)) (%make-iset 3424 3911 796045881074145379721101485003658612742377112762910063541249941107066206101891013710754591976857025636790244447628442609572802972081506968078974927 (%make-iset 2908 3404 381991200485141231019756222408812876448756014237186533546277447507183436269917901262081454044646810274583365631168335787645676728618713947476107197691 (%make-iset 2382 2892 5366736463561891048904088864332422319078538891026511232750792789353571719231492410784884055633496549297705163924592108787908229198392583314950938978942851 #f #f) #f) (%make-iset 3913 4346 44362715105927999221712262984621806339048726122702370012163096018033725502663463203116646689073826286574787756247207860776650932223 #f #f))) (%make-iset 6212 6683 12194330229244424385524038642855360947889231407969113621412693927197786728086255496979946034430370000318048005765115268416095504239842568437759 (%make-iset 5121 5740 #f (%make-iset 4824 5108 62165404551223330269422779455378792455782943721961461362086716517957521327837304324095 (%make-iset 4682 4822 2787528182814337039150675927861957382578127 #f #f) #f) (%make-iset 5743 6210 762145642145155178562790324783619807494011846352632466837216562044788852063159421730556579887606746611010843054583947091606179550442951671807 #f #f)) (%make-iset 7424 7615 6277101735386680763834460195211881500229451637403754168319 (%make-iset 6912 7414 22886562555891042693710382458146756289377006471936556892838923982807328844367070294241793956553485968351753386046618718102707539530518625959993520685039 (%make-iset 6688 6809 5311800736730066244218093126239125503 #f #f) #f) (%make-iset 7680 8188 1669429210027032353070387959902572074068251569912541634239543664469254840701605815586298160569854604812755249439701457169906905863833481177213265564925951 #f #f)))) (%make-iset 43138 43638 224726016208531273348937437899872290007502680726266932355584409924411794087837267452460956059789185107995855861761463319664142696520594339463520992995707994505215 (%make-iset 19968 40908 #f (%make-iset 12321 12799 1560850458106678397246853318509506420346053090363696722427379182288726125506853871807416126725592575693831523564009034418563951096328109074350591 (%make-iset 11264 11775 1716199415031085457304815023196129625190876140284840059163076939411632061379695825768761320243048559913035261692194332965927453391792248614786550156348096511 (%make-iset 9398 9449 #f #f #f) #f) (%make-iset 13312 19893 #f #f #f)) (%make-iset 42192 42647 186070703019498633361408888448075519920530856307050957164988653405500459175263525083868751559444797946410782900983767246458201399646748671 (%make-iset 40982 42124 #f (%make-iset 40960 40980 #f #f #f) #f) (%make-iset 42656 43137 9366007796590143684266426014173832021882860391206691228341429856634888413055477646498624449482500722743196759142345085250473767233032902320062463 #f #f))) (%make-iset 63744 64109 #f (%make-iset 44032 55203 #f (%make-iset 43968 44025 287956460317442047 (%make-iset 43648 43822 47701954761756259097387504798417463778755529815359487 #f #f) #f) (%make-iset 55216 55291 75557863725914197590015 #f #f)) (%make-iset 64256 64433 383123885216472214589586756787576615644966064332734591 (%make-iset 64112 64217 #f #f #f) (%make-iset 64467 64829 #f #f #f))))) (%make-iset 120488 120654 187072206790762423064706648907459429699768891211775 (%make-iset 71296 71369 348108861360120048141903260542929609949183 (%make-iset 67584 67669 77371243358065019892792383 (%make-iset 66176 66639 878680692688788100968217104054132723536510135400456683066998889497980605885632024127229627367624962058724496859707859793938161524087860595782141042536975695871 (%make-iset 65536 65908 354901720847464262643270080013918741494457029505007323037992842993478140487429303646626346434630199938330987804055257434518162763775 (%make-iset 65008 65500 23166459242184795109519745412560813317707843523172326996035291982829335841807197632365519235915051181023523126849199870616098935821672668804369354751 #f #f) #f) (%make-iset 66640 66729 1237033344920669303018094591 #f #f)) (%make-iset 68608 68680 #f (%make-iset 68352 68466 1427247352465131255837309846865400673685471231 (%make-iset 67840 68220 4925250765375315437575115447282545225619899143486530057386523691675827454339457238250572167562730571287653355880447 #f #f) #f) (%make-iset 69635 70105 204586912993508730593563550625432944389072422914203271855910203047007904292292283148049105766861891958292943578471947333866751571791177989246645436415 #f #f))) (%make-iset 93952 94111 1461323231539455856679019361440445717580125044735 (%make-iset 77824 78894 #f (%make-iset 74752 74850 #f (%make-iset 73728 74606 #f #f #f) #f) (%make-iset 92160 92728 #f #f #f)) (%make-iset 119808 120144 1221462192088229133428742507380976417683660481320862010013722843488511299179635651402650638514783282651558855669972991 (%make-iset 110592 110593 #f #f #f) (%make-iset 120146 120485 #f #f #f)))) (%make-iset 2404 2416 4099 (%make-iset 177984 178205 #f (%make-iset 131072 173782 #f (%make-iset 126464 126651 6421867392636242726356536395708148792154285362342779204665327 (%make-iset 120656 120831 95780971304117989802914516033683783778383003373273087 #f #f) #f) (%make-iset 173824 177972 #f #f #f)) (%make-iset 2038 2038 #f (%make-iset 1370 1805 177444091211903494854164183597562195186987239759942234703242934973005962356878807556430406995673757716803475823941853280674043134015 (%make-iset 194560 195101 #f #f #f) #f) (%make-iset 2039 2142 10141204806548057579655195000839 #f #f))) (%make-iset 3449 3449 #f (%make-iset 3059 3066 #f (%make-iset 2800 2928 340282366920938463463374607431768211459 (%make-iset 2546 2555 771 #f #f) #f) (%make-iset 3199 3199 #f #f #f)) (%make-iset 3844 4175 8612299728833109452216727519275634166367255279803428156814546022481552546661143084834195942383124479 (%make-iset 3572 3675 15214283120596255441467398422529 #f #f) (%make-iset 4347 4347 #f #f #f)))))) (%make-iset 6622 6655 #f (%make-iset 44011 44011 #f (%make-iset 9001 9002 #f (%make-iset 6686 6687 #f (%make-iset 6100 6154 36011204832919671 (%make-iset 5741 5942 4820814132776970826626481771165599449877669887122490332807171 (%make-iset 5120 5120 #f #f #f) #f) (%make-iset 6468 6469 #f #f #f)) (%make-iset 7164 7379 52681756409358971006475467946070306489686807156907791211684691983 (%make-iset 7002 7008 #f (%make-iset 6816 6829 16255 #f #f) #f) (%make-iset 8208 8334 127607834706674478748244504138880122879 #f #f))) (%make-iset 12289 12539 1809251394333065553493296641491499378872794969502476229475819322195851214727 (%make-iset 11513 11632 664613997892457936451903530140172399 (%make-iset 10627 10749 7975367975289779630837864365545226239 (%make-iset 10088 10223 87027215340059722591700904977272299077631 #f #f) #f) (%make-iset 11776 11835 1152780767118491647 #f #f)) (%make-iset 43124 43615 11987514433213410168505333362405758614102799522152940711615041872404225459959956214682136066587259816913167135759024198010248565942507088814987542543 (%make-iset 42509 42743 54351252480975689826048702415431575448442147475312362296571857733681159 (%make-iset 42238 42239 #f #f #f) #f) (%make-iset 43742 43761 786435 #f #f)))) (%make-iset 69703 69955 13569385457497991651199724805705614201565294768222350139146883642703225028735 (%make-iset 66463 66512 562949953421313 (%make-iset 65281 65381 2521683860030948918624327334903 (%make-iset 65040 65131 4037812089938908849547248639 (%make-iset 64830 64831 #f #f #f) #f) (%make-iset 65792 65794 #f #f #f)) (%make-iset 68176 68223 140737488355839 (%make-iset 67871 67903 4294967297 (%make-iset 67671 67671 #f #f #f) #f) (%make-iset 68409 68415 #f #f #f))) (%make-iset 4254 4255 #f (%make-iset 3841 3896 47287798208921607 (%make-iset 74864 74867 #f (%make-iset 70085 70088 #f #f #f) #f) (%make-iset 4030 4056 126058239 #f #f)) (%make-iset 6107 6107 #f (%make-iset 5008 5017 #f #f #f) (%make-iset 6464 6464 #f #f #f))))) (%make-iset 42752 42890 522673715590561479879743397015208866086911 (%make-iset 10750 11084 #f (%make-iset 9472 9983 #f (%make-iset 8592 9000 #f (%make-iset 8125 8527 15180504508302547082559792549452134039979727921597050291198905168453617261872958515620728168035045459212134851764818477085 (%make-iset 7009 7036 267912191 #f #f) #f) (%make-iset 9003 9449 363419362147803445274660701490199886974208000930090554402992578672453439413725018135787913021374683400778402767997805117095404640403455 #f #f)) (%make-iset 10649 10711 #f (%make-iset 10224 10626 #f (%make-iset 9985 10213 862718293047519590130783627714548701007576706064464912086123449155583 #f #f) #f) (%make-iset 10716 10749 4294967295 #f #f))) (%make-iset 12688 13054 300613450595050653137261935414156179889591998741512647513967970216935158771592840931503642564904187380807827395 (%make-iset 11904 12351 547258453716185545689710299454841531346882567525409776024515836385994490529377606833512566938465691840048809561654146263061905633443839 (%make-iset 11493 11498 #f (%make-iset 11088 11097 #f #f #f) #f) (%make-iset 12443 12444 #f #f #f)) (%make-iset 19904 19967 #f (%make-iset 13056 13311 #f #f #f) (%make-iset 42128 42182 #f #f #f)))) (%make-iset 119296 119365 664082786653543858175 (%make-iset 65020 65129 796084576943328064139929612976131 (%make-iset 64297 64297 #f (%make-iset 43639 43641 #f (%make-iset 43048 43065 245775 #f #f) #f) (%make-iset 64434 64449 #f #f #f)) (%make-iset 65847 66044 401734511064736150903948875408776876244564738538201663144447 (%make-iset 65504 65533 805339007 (%make-iset 65284 65374 1547425050547877224499904641 #f #f) #f) (%make-iset 118784 119261 780437137578995458467560908739391556888996158179266522929460546508236933653296437157060350808521225678016835714111230592247297551268494937423871 #f #f))) (%make-iset 127462 127569 244021541289521102071576548868095 (%make-iset 126704 126705 #f (%make-iset 120513 120771 463168363851011130091785795673740600836767278013411671357985905734243019915265 (%make-iset 119552 119638 #f #f #f) #f) (%make-iset 126976 127386 5288447750321425141395456744287458546996189758388629186172721346534510152156602991240248150625623449590204448175840041107455 #f #f)) (%make-iset 128256 128359 5104235524096485346957782767918670413823 (%make-iset 127744 128252 1623601741516486367526542089626489179499454454837360135582644525057721907975405279813447049733043276512275822980244041212191896116171460908759068350349311 #f #f) (%make-iset 128507 128883 307828173409331868845930000782371979146838607456393061394578876014578854359990151589006733868359031372480153387007 #f #f))))))))) + +;; char-set:printing +(define char-set:printing (immutable-char-set (%make-iset 4347 4347 #f (%make-iset 63744 64109 #f (%make-iset 6688 6809 5311800736730066244218093126239125503 (%make-iset 4349 4680 #f (%make-iset 1869 2380 13407424329480734270447878660048428920496373804417168083627602288254107168259292949124979141882146787383731347613928779568711247970208345158244457521348607 (%make-iset 452 1366 276978483139049986878383159513059937866295390192563056831002732490712977617729827250930061495547874753339425272845057761345036295330752004396560217460615349388256052740008771052267223259379816261947173385923045218076729795326919802994234467957919553429350144124989345512816639 (%make-iset 160 160 #f (%make-iset 9 451 22669347419131782291913114369553852359296309528272676318593841051105143812618789434640033841431908014736263332293412376088380325232671 #f #f) #f) (%make-iset 1377 1855 1560874275157973934343822231147075518302721156252056432767839474782185051280962423908807488297855721715644480587704321413018649007858524599877631 #f #f)) (%make-iset 3424 3911 796045881074145379721101485003658612742377112762910063541249941107066206101891013710754591976857025636790244447628442609572802972081506968078974927 (%make-iset 2908 3404 381991200485141231019756222408812876448756014237186533546277447507183436269917901262081454044646810274583365631168335787645676728618713947476107197691 (%make-iset 2382 2892 5366736463561891048904088864332422319078538891026511232750792789353571719231492410784884055633496549297705163924592108787908229198392583314950938978942851 #f #f) #f) (%make-iset 3913 4346 44362715105927999221712262984621806339048726122702370012163096018033725502663463203116646689073826286574787756247207860776650932223 #f #f))) (%make-iset 6158 6158 #f (%make-iset 5121 5740 #f (%make-iset 4824 5108 62165404551223330269422779455378792455782943721961461362086716517957521327837304324095 (%make-iset 4682 4822 2787528182814337039150675927861957382578127 #f #f) #f) (%make-iset 5760 5760 #f #f #f)) (%make-iset 5743 6210 762145642145155178562790324783619807494011846352632466837216562044788852063159421730556579887606746611010843054583947091606179550442951671807 (%make-iset 12288 12288 #f (%make-iset 8192 8287 39614081257132312832795215871 #f #f) #f) (%make-iset 6212 6683 12194330229244424385524038642855360947889231407969113621412693927197786728086255496979946034430370000318048005765115268416095504239842568437759 #f #f)))) (%make-iset 40960 40980 #f (%make-iset 9398 9449 #f (%make-iset 7680 8188 1669429210027032353070387959902572074068251569912541634239543664469254840701605815586298160569854604812755249439701457169906905863833481177213265564925951 (%make-iset 7424 7615 6277101735386680763834460195211881500229451637403754168319 (%make-iset 6912 7414 22886562555891042693710382458146756289377006471936556892838923982807328844367070294241793956553485968351753386046618718102707539530518625959993520685039 #f #f) #f) (%make-iset 8336 8584 904625697166121400702423284964750605108746128179460890055734500600385118207 #f #f)) (%make-iset 13312 19893 #f (%make-iset 12321 12799 1560850458106678397246853318509506420346053090363696722427379182288726125506853871807416126725592575693831523564009034418563951096328109074350591 (%make-iset 11264 11775 1716199415031085457304815023196129625190876140284840059163076939411632061379695825768761320243048559913035261692194332965927453391792248614786550156348096511 #f #f) #f) (%make-iset 19968 40908 #f #f #f))) (%make-iset 43648 43822 47701954761756259097387504798417463778755529815359487 (%make-iset 42656 43137 9366007796590143684266426014173832021882860391206691228341429856634888413055477646498624449482500722743196759142345085250473767233032902320062463 (%make-iset 42192 42647 186070703019498633361408888448075519920530856307050957164988653405500459175263525083868751559444797946410782900983767246458201399646748671 (%make-iset 40982 42124 #f #f #f) #f) (%make-iset 43138 43638 224726016208531273348937437899872290007502680726266932355584409924411794087837267452460956059789185107995855861761463319664142696520594339463520992995707994505215 #f #f)) (%make-iset 44032 55203 #f (%make-iset 43968 44025 287956460317442047 #f #f) (%make-iset 55216 55291 75557863725914197590015 #f #f))))) (%make-iset 110592 110593 #f (%make-iset 67840 68220 4925250765375315437575115447282545225619899143486530057386523691675827454339457238250572167562730571287653355880447 (%make-iset 65008 65500 23166459242184795109519745412560813317707843523172326996035291982829335841807197632365519235915051181023523126849199870616098935821672668804369354751 (%make-iset 64467 64829 #f (%make-iset 64256 64433 383123885216472214589586756787576615644966064332734591 (%make-iset 64112 64217 #f #f #f) #f) (%make-iset 64848 64967 341611594916723379280938182270919901183 #f #f)) (%make-iset 66640 66729 1237033344920669303018094591 (%make-iset 66176 66639 878680692688788100968217104054132723536510135400456683066998889497980605885632024127229627367624962058724496859707859793938161524087860595782141042536975695871 (%make-iset 65536 65908 354901720847464262643270080013918741494457029505007323037992842993478140487429303646626346434630199938330987804055257434518162763775 #f #f) #f) (%make-iset 67584 67669 77371243358065019892792383 #f #f))) (%make-iset 73728 74606 #f (%make-iset 69635 70105 204586912993508730593563550625432944389072422914203271855910203047007904292292283148049105766861891958292943578471947333866751571791177989246645436415 (%make-iset 68608 68680 #f (%make-iset 68352 68466 1427247352465131255837309846865400673685471231 #f #f) #f) (%make-iset 71296 71369 348108861360120048141903260542929609949183 #f #f)) (%make-iset 92160 92728 #f (%make-iset 77824 78894 #f (%make-iset 74752 74850 #f #f #f) #f) (%make-iset 93952 94111 1461323231539455856679019361440445717580125044735 #f #f)))) (%make-iset 1370 1805 177444091211903494854164183597562195186987239759942234703242934973005962356878807556430406995673757716803475823941853280674043134015 (%make-iset 126464 126651 6421867392636242726356536395708148792154285362342779204665327 (%make-iset 120488 120654 187072206790762423064706648907459429699768891211775 (%make-iset 120146 120485 #f (%make-iset 119808 120144 1221462192088229133428742507380976417683660481320862010013722843488511299179635651402650638514783282651558855669972991 #f #f) #f) (%make-iset 120656 120831 95780971304117989802914516033683783778383003373273087 #f #f)) (%make-iset 177984 178205 #f (%make-iset 173824 177972 #f (%make-iset 131072 173782 #f #f #f) #f) (%make-iset 194560 195101 #f #f #f))) (%make-iset 3059 3066 #f (%make-iset 2546 2555 771 (%make-iset 2404 2416 4099 (%make-iset 2038 2142 20282409613096115159310390001679 #f #f) #f) (%make-iset 2800 2928 340282366920938463463374607431768211459 #f #f)) (%make-iset 3449 3675 161786008477555489129424138914539858559159520266627551066615690821633 (%make-iset 3199 3199 #f #f #f) (%make-iset 3844 4175 8612299728833109452216727519275634166367255279803428156814546022481552546661143084834195942383124479 #f #f)))))) (%make-iset 6464 6464 #f (%make-iset 43742 43761 786435 (%make-iset 8208 8334 127607834706674478748244504138880122879 (%make-iset 6468 6469 #f (%make-iset 5741 5942 4820814132776970826626481771165599449877669887122490332807171 (%make-iset 5120 5120 #f (%make-iset 4960 4968 #f #f #f) #f) (%make-iset 6100 6154 36011204832919671 #f #f)) (%make-iset 7002 7008 #f (%make-iset 6816 6829 16255 (%make-iset 6686 6687 #f #f #f) #f) (%make-iset 7164 7379 52681756409358971006475467946070306489686807156907791211684691983 #f #f))) (%make-iset 11776 11835 1152780767118491647 (%make-iset 10627 10749 7975367975289779630837864365545226239 (%make-iset 10088 10223 87027215340059722591700904977272299077631 (%make-iset 9001 9002 #f #f #f) #f) (%make-iset 11513 11632 664613997892457936451903530140172399 #f #f)) (%make-iset 42509 42743 54351252480975689826048702415431575448442147475312362296571857733681159 (%make-iset 42238 42239 #f (%make-iset 12289 12539 1809251394333065553493296641491499378872794969502476229475819322195851214727 #f #f) #f) (%make-iset 43124 43615 11987514433213410168505333362405758614102799522152940711615041872404225459959956214682136066587259816913167135759024198010248565942507088814987542543 #f #f)))) (%make-iset 68409 68415 #f (%make-iset 65792 65794 #f (%make-iset 65040 65131 4037812089938908849547248639 (%make-iset 64830 64831 #f (%make-iset 44011 44011 #f #f #f) #f) (%make-iset 65281 65381 2521683860030948918624327334903 #f #f)) (%make-iset 67871 67903 4294967297 (%make-iset 67671 67671 #f (%make-iset 66463 66512 562949953421313 #f #f) #f) (%make-iset 68176 68223 140737488355839 #f #f))) (%make-iset 4030 4056 126058239 (%make-iset 74864 74867 #f (%make-iset 70085 70088 #f (%make-iset 69703 69955 13569385457497991651199724805705614201565294768222350139146883642703225028735 #f #f) #f) (%make-iset 3841 3896 47287798208921607 #f #f)) (%make-iset 5008 5017 #f (%make-iset 4254 4255 #f #f #f) (%make-iset 6107 6107 #f #f #f))))) (%make-iset 42752 42890 522673715590561479879743397015208866086911 (%make-iset 10716 10749 4294967295 (%make-iset 9003 9449 363419362147803445274660701490199886974208000930090554402992578672453439413725018135787913021374683400778402767997805117095404640403455 (%make-iset 8125 8527 15180504508302547082559792549452134039979727921597050291198905168453617261872958515620728168035045459212134851764818477085 (%make-iset 7009 7036 267912191 (%make-iset 6622 6655 #f #f #f) #f) (%make-iset 8592 9000 #f #f #f)) (%make-iset 10224 10626 #f (%make-iset 9985 10213 862718293047519590130783627714548701007576706064464912086123449155583 (%make-iset 9472 9983 #f #f #f) #f) (%make-iset 10649 10711 #f #f #f))) (%make-iset 12443 12444 #f (%make-iset 11493 11498 #f (%make-iset 11088 11097 #f (%make-iset 10750 11084 #f #f #f) #f) (%make-iset 11904 12351 547258453716185545689710299454841531346882567525409776024515836385994490529377606833512566938465691840048809561654146263061905633443839 #f #f)) (%make-iset 19904 19967 #f (%make-iset 13056 13311 #f (%make-iset 12688 13054 300613450595050653137261935414156179889591998741512647513967970216935158771592840931503642564904187380807827395 #f #f) #f) (%make-iset 42128 42182 #f #f #f)))) (%make-iset 119296 119365 664082786653543858175 (%make-iset 65020 65129 796084576943328064139929612976131 (%make-iset 64297 64297 #f (%make-iset 43639 43641 #f (%make-iset 43048 43065 245775 #f #f) #f) (%make-iset 64434 64449 #f #f #f)) (%make-iset 65847 66044 401734511064736150903948875408776876244564738538201663144447 (%make-iset 65504 65533 805339007 (%make-iset 65284 65374 1547425050547877224499904641 #f #f) #f) (%make-iset 118784 119261 780437137578995458467560908739391556888996158179266522929460546508236933653296437157060350808521225678016835714111230592247297551268494937423871 #f #f))) (%make-iset 127462 127569 244021541289521102071576548868095 (%make-iset 126704 126705 #f (%make-iset 120513 120771 463168363851011130091785795673740600836767278013411671357985905734243019915265 (%make-iset 119552 119638 #f #f #f) #f) (%make-iset 126976 127386 5288447750321425141395456744287458546996189758388629186172721346534510152156602991240248150625623449590204448175840041107455 #f #f)) (%make-iset 128256 128359 5104235524096485346957782767918670413823 (%make-iset 127744 128252 1623601741516486367526542089626489179499454454837360135582644525057721907975405279813447049733043276512275822980244041212191896116171460908759068350349311 #f #f) (%make-iset 128507 128883 307828173409331868845930000782371979146838607456393061394578876014578854359990151589006733868359031372480153387007 #f #f))))))))) + diff --git a/lib/chibi/char-set/full.sld b/lib/chibi/char-set/full.sld new file mode 100644 index 00000000..99aa740d --- /dev/null +++ b/lib/chibi/char-set/full.sld @@ -0,0 +1,9 @@ + +(define-library (chibi char-set full) + (import (chibi) (chibi iset base) (chibi char-set base)) + (export char-set:lower-case char-set:upper-case char-set:title-case + char-set:letter char-set:digit char-set:letter+digit + char-set:graphic char-set:printing char-set:whitespace + char-set:iso-control char-set:punctuation char-set:symbol + char-set:hex-digit char-set:blank) + (include "full.scm")) diff --git a/lib/chibi/config.scm b/lib/chibi/config.scm new file mode 100644 index 00000000..b8eac1e7 --- /dev/null +++ b/lib/chibi/config.scm @@ -0,0 +1,488 @@ +;; config.scm -- general configuration management +;; Copyright (c) 2012 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;> This is a library for unified configuration management. +;;> Essentially it provides an abstract collection data type for +;;> looking up named values, two or more of which can be chained +;;> together. Values from more recent collections can be preferred as +;;> with an environment, or the values at multiple levels can be +;;> flattened together. Convenience routines are provided from +;;> loading these collections from files while allowing extensions +;;> such as configurations from command-line options. + +;;> \section{Background} +;;> +;;> As any application grows to sufficient complexity, it acquires +;;> options and behaviors that one may want to modify at startup or +;;> runtime. The traditional approach is a combination of +;;> command-line options, config files, environment variables, and/or +;;> other specialized settings. These all have various pros and cons: +;;> +;;> \table[(@ (border 1) (style border-collapse:collapse) (width "100%"))]{ +;;> \tr{\th{name} \th{pros} \th{cons}} +;;> \tr{\td{environment variables} +;;> \td{implicit - no need to retype; can share between applications} +;;> \td{unclear when set; unexpected differences between users; limited size}} +;;> \tr{\td{command-line options} +;;> \td{explicit - visible each time a command is run; } +;;> \td{verbose; limited size}} +;;> \tr{\td{config files} +;;> \td{implicit; preserved - can be shared and version controlled} +;;> \td{requires a parser}} +;;> } +;;> +;;> Environment variables are convenient for broad preferences, used +;;> by many different applications, and unlikely to change per user. +;;> Command-line options are best for settings that are likely to +;;> change between invocations of a program. Anything else is best +;;> stored in a config file. If there are settings that multiple +;;> users of a group or whole system are likely to want to share, then +;;> it makes sense to cascade multiple config files. + +;;> \section{Syntax} +;;> +;;> With any other language there is a question of config file syntax, +;;> and a few popular choices exist such as .ini syntax. With Scheme +;;> the obvious choice is sexps, generally as an alist. We use a +;;> single alist for the whole file, with symbols for keys and +;;> arbitrary sexps for values. The alists are intended primarily for +;;> editing by hand and need not be dotted, but the interface allows +;;> dotted values. Disambiguation is handled as with two separate +;;> functions, \scheme{(conf-get config key)} and +;;> \scheme{(conf-get-list config key)}, which both retrieve the value +;;> associated with \var{key} from \var{config}, in the latter case +;;> coercing to a list. The result is determined according to the +;;> structure of the alist cell as follows: +;;> +;;> \table[(@ (border 1) (style border-collapse:collapse) (width "100%"))]{ +;;> \tr{\th{Cell} \th{\scheme{conf-get} result} \th{\scheme{conf-get-list} result}} +;;> \tr{\td{\scheme{(key)}} \td{\scheme{()}} \td{\scheme{()}}} +;;> \tr{\td{\scheme{(key . non-list-value)}} \td{\scheme{non-list-value}} \td{\scheme{(non-list-value)}}} +;;> \tr{\td{\scheme{(key non-list-value)}} \td{\scheme{non-list-value}} \td{\scheme{(non-list-value)}}} +;;> \tr{\td{\scheme{(key (value1 value2 ...))}} \td{\scheme{(value1 value2 ...)}} \td{\scheme{(value1 value2 ...)}}} +;;> \tr{\td{\scheme{(key value1 value2 ...)}} \td{\scheme{(value1 value2 ...)}} \td{\scheme{(value1 value2 ...)}}} +;;> } +;;> +;;> Thus writing the non-dotted value will always do what you want. +;;> Specifically, the only thing to be careful of is if you want a +;;> single-element list value, even with \scheme{conf-get}, you should +;;> write \scheme{(key (value))}. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;> \section{Interface} + +;;> Returns true iff \var{x} is a config object. + +(define-record-type Config + (make-conf alist parent source timestamp) + conf? + (alist conf-alist conf-alist-set!) + (parent conf-parent conf-parent-set!) + (source conf-source conf-source-set!) + (timestamp conf-timestamp conf-timestamp-set!)) + +(define (assq-tail key alist) + (let lp ((ls alist)) + (and (pair? ls) + (if (and (pair? (car ls)) (eq? key (caar ls))) + ls + (lp (cdr ls)))))) + +(define (assq-chain key alist) + (let ((x (assq-tail (car key) alist))) + (and x + (if (null? (cdr key)) + (car x) + (or (assq-chain (cdr key) (cdar x)) + (assq-chain key (cdr x))))))) + +(define (assq-split key alist) + (let lp ((ls alist) (rev '())) + (cond + ((null? ls) #f) + ((and (pair? (car ls)) (eq? key (caar ls))) (cons (reverse rev) ls)) + (else (lp (cdr ls) (cons (car ls) rev)))))) + +(define (read-from-file file . opt) + (guard (exn (else (and (pair? opt) (car opt)))) + (call-with-input-file file read))) + +(define (alist? x) + (and (list? x) (every pair? x))) + +;;> \procedure{(assoc-get alist key [equal? [default]])} + +;;> Utility analogous to \scheme{conf-get} on a pure alist. Returns +;;> the value of the cell in \var{alist} whose car is \var{equal?} to +;;> \var{key}, where the value is determined as the \var{cadr} if the +;;> cell is a proper list of two elements and the \var{cdr} otherwise. +;;> If no cell is found, returns \var{default}, or \scheme{#f} if +;;> unspecified. + +(define (assoc-get alist key . o) + (cond + ((assoc key alist (or (and (pair? o) (car o)) equal?)) + => (lambda (x) + (if (and (pair? (cdr x)) (null? (cddr x))) (cadr x) (cdr x)))) + (else + (and (pair? o) (pair? (cdr o)) (cadr o))))) + +;;> Returns just the base of \var{config} without any parent. + +(define (conf-head config) + (make-conf + (conf-alist config) #f (conf-source config) (conf-timestamp config))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Loading from files. + +;;> \procedure{(conf-load file [conf])} + +;;> Loads the config file \var{file}, prepending to \var{conf} if +;;> provided. + +(define (conf-load file . o) + (make-conf + (read-from-file file '()) + (and (pair? o) (car o)) + file + (current-second))) + +;;> Search for and load any files named \var{file} in the +;;> \var{config-path}, which should be a list of strings. + +(define (conf-load-in-path config-path file) + (cond + ((equal? file "") + (error "can't load from empty filename" file)) + ((eqv? #\/ (string-ref file 0)) + (conf-load file)) + (else + (let lp ((ls (reverse config-path)) (res #f)) + (if (null? ls) + (or res (make-conf '() #f #f (current-second))) + (let ((path (string-append (car ls) "/" file))) + (if (file-exists? path) + (lp (cdr ls) (conf-load path res)) + (lp (cdr ls) res)))))))) + +;;> \procedure{(conf-load-cascaded config-path file [include-keyword])} + +;;> Similar to conf-load-in-path, but also recursively loads any +;;> "include" config files, indicated by a top-level +;;> \var{include-keyword} with either a string or symbol value. +;;> Includes are loaded relative to the current file, and cycles +;;> automatically ignored. + +(define (conf-load-cascaded config-path file . o) + (define (path-directory file) + (let lp ((i (string-length file))) + (cond ((zero? i) "./") + ((eqv? #\/ (string-ref file (- i 1))) (substring file 0 i)) + (else (lp (- i 1)))))) + (define (path-relative file from) + (if (eqv? #\/ (string-ref file 0)) + file + (string-append (path-directory from) file))) + (let ((include-keyword (if (pair? o) (car o) 'include))) + (let load ((ls (list (cons file (and (pair? o) (pair? (cdr o)) (cadr o))))) + (seen '()) + (res '())) + (cond + ((null? ls) + res) + (else + (let ((file (if (symbol? (caar ls)) + (symbol->string (caar ls)) + (caar ls))) + (depth (cdar ls))) + (cond + ((member file seen) + (load (cdr ls) seen res)) + ((and (number? depth) (<= depth 0)) + (load (cdr ls) seen res)) + (else + (let* ((config (conf-load-in-path config-path file)) + (includes (conf-get-list config include-keyword))) + (load (append (cdr ls) + (map (lambda (x) + (cons (path-relative x file) + (and (number? depth) (- depth 1)))) + includes)) + (cons file seen) + (append res config))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (conf-get-cell config key) + (cond + ((pair? key) + (cond + ((null? (cdr key)) (conf-get-cell config (car key))) + ((assq-chain key (conf-alist config))) + ((conf-parent config) => (lambda (p) (conf-get-cell p key))) + (else #f))) + (else + (let search ((config config)) + (and config + (or (assq key (conf-alist config)) + (search (conf-parent config)))))))) + +;;> \procedure{(conf-get config key [default])} + +;;> Basic config lookup - retrieves the value from \var{config} +;;> associated with \var{key}. If not present, return \var{default}. +;;> In \scheme{conf-get} and related accessors \var{key} can be either +;;> a symbol, or a list of symbols. In the latter case, each symbol +;;> is used as a key in turn, with the value taken as an alist to +;;> further lookup values in. + +(define (conf-get config key . opt) + (let ((cell (conf-get-cell config key))) + (if (not cell) + (and (pair? opt) (car opt)) + (if (and (pair? (cdr cell)) (null? (cddr cell))) + (cadr cell) + (cdr cell))))) + +;;> \procedure{(conf-get-list config key [default])} + +;;> Equivalent to \scheme{conf-get} but coerces its result to a list +;;> as described in the syntax section. + +(define (conf-get-list config key . opt) + (let ((res (conf-get config key))) + (if res + (if (or (pair? res) (null? res)) res (list res)) + (if (pair? opt) (car opt) '())))) + +;;> Equivalent to \scheme{conf-get} but always returns the +;;> \scheme{cdr} as-is without possibly taking its \scheme{car}. + +(define (conf-get-cdr config key . opt) + (let ((cell (conf-get-cell config key))) + (if (not cell) + (and (pair? opt) (car opt)) + (cdr cell)))) + +;;> Equivalent to \scheme{conf-get-list} but returns a list of all +;;> cascaded configs appended together. + +(define (conf-get-multi config key) + (if (not config) + '() + (append (conf-get-list (conf-head config)) + (conf-get-multi (conf-parent config) key)))) + +;;> Extends the config with anadditional alist. + +(define (conf-extend config alist . o) + (let ((source (and (pair? o) (car o)))) + (if (pair? alist) + (make-conf alist config source (current-second)) + config))) + +;;> Joins two configs. + +(define (conf-append a b) + (let ((parent (if (conf-parent a) (conf-append (conf-parent a) b) b))) + (make-conf (conf-alist a) parent (conf-source a) (conf-timestamp a)))) + +;;> Utility to create an alist cell representing the chained key +;;> \var{key} mapped to \var{value}. + +(define (conf-unfold-key key value) + (if (null? (cdr key)) + (cons (car key) value) + (list (car key) (conf-unfold-key (cdr key) value)))) + +;;> Replace a new definition into the first config alist. + +(define (conf-set config key value) + (make-conf + (let lp ((key (if (not (list? key)) (list key) key)) + (alist (conf-alist config))) + (cond + ((null? (cdr key)) + (cons (cons (car key) value) + (remove (lambda (x) (and (pair? x) (eq? (car key) (car x)))) + alist))) + ((assq-split (car key) alist) + => (lambda (x) + (let ((left (car x)) + (right (cdr x))) + (append left + (cons (cons (car key) (lp (cdr key) (cdar right))) + (cdr right)))))) + (else + (cons (conf-unfold-key key value) alist)))) + (conf-parent config) + (conf-source config) + (conf-timestamp config))) + +;;> Lift specialized sections to the top-level of a config. + +(define (conf-specialize config key name) + (let lp ((ls config) (res '())) + (cond + ((null? ls) (reverse res)) + ((assq key (car ls)) + => (lambda (specialized) + (let ((named (assq name (cdr specialized)))) + (if named + (lp (cdr ls) (cons (car ls) (cons (cdr named) res))) + (lp (cdr ls) (cons (car ls) res)))))) + (else (lp (cdr ls) (cons (car ls) res)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;> \section{Config Verification} + +(define (conf-default-warn . args) + (for-each + (lambda (a) ((if (string? a) display write) a (current-error-port))) + args) + (newline (current-error-port)) + #f) + +(define (conf-verify-symbol->predicate sym) + (case sym + ((integer) integer?) + ((number) number?) + ((list) list?) + ((alist) alist?) + ((boolean) boolean?) + ((char) char?) + ((string) string?) + ((symbol) symbol?) + ((pair) pair?) + ((filename dirname) string?) + (else (error "no known conf predicate for" sym)))) + +;; non-short-circuit versions to report all warnings + +(define (and* . args) + (every (lambda (x) x) args)) + +(define (every* pred ls) + (apply and* (map pred ls))) + +(define (conf-verify-match def cell warn) + (define (cell-value) + (if (and (pair? (cdr cell)) (null? (cddr cell))) (cadr cell) (cdr cell))) + (define (cell-list) + (if (and (pair? (cdr cell)) (null? (cddr cell)) (not (pair? (cadr cell)))) + (list (cadr cell)) + (cdr cell))) + (cond + ((procedure? def) + (or (def (cell-value)) + (warn "bad conf value for " (car cell) ": " (cell-value)))) + ((symbol? def) + (case def + ((existing-filename) + (cond + ((not (string? (cell-value))) + (warn "bad conf value for " (car cell) + ": expected a filename but got " (cell-value))) + ((not (file-exists? (cell-value))) + (warn "conf setting ~S references a non-existent file: ~S" + (car cell) (cell-value))) + (else + #t))) + ((existing-dirname) + (cond + ((not (string? (cell-value))) + (warn "bad conf value for " (car cell) + ": expected a dirname but got " (cell-value))) + ((not (file-directory? (cell-value))) + (cond + ((file-exists? (cell-value)) + (warn "conf setting " (car cell) + " expected a directory but found a file: " (cell-value))) + (else + (warn "conf setting " (car cell) + " references a non-existent directory: " (cell-value))))) + (else + #t))) + ((integer number char string symbol filename dirname boolean pair) + (or ((conf-verify-symbol->predicate def) (cell-value)) + (warn "bad conf value for " (car cell) + ": expected " def " but got " (cell-value)))) + ((list alist) + (or ((conf-verify-symbol->predicate def) (cell-list)) + (warn "bad conf value for " (car cell) + ": expected " def " but got " (cell-list)))) + (else + (warn "bad conf spec list: " def)))) + ((pair? def) + (case (car def) + ((cons) + (and* + (conf-verify-match + (cadr def) (cons `(car ,(car cell)) (car (cell-list))) warn) + (conf-verify-match + (car (cddr def)) (cons `(car ,(car cell)) (cdr (cell-list))) warn))) + ((list) + (and (list? (cell-list)) + (every* (lambda (x) + ;; (cons `(list ,(car cell)) x) + (conf-verify-match (cadr def) x warn)) + (cell-list)))) + ((alist) + (let ((key-def (cadr def)) + (val-def (if (pair? (cddr def)) (car (cddr def)) (lambda (x) #t)))) + (and (alist? (cell-list)) + (every* (lambda (x) + (and (pair? x) + (conf-verify-match key-def (car x) warn) + (conf-verify-match val-def (cell-value x) warn))) + (cell-list))))) + ((conf) + (and (alist? (cell-list)) + (conf-verify (cdr def) (list (cell-list)) warn))) + ((or) + (or (any (lambda (x) (conf-verify-match x cell (lambda (x) x))) + (cdr def)) + (warn "bad spec value for " (car cell) + ": expected " def " but got " (cell-value)))) + ((member) + (or (member (cell-value) (cdr def)) + (warn "bad spec value " (cell-value) + " for " (car cell) ", expected one of " (cdr def)))) + ((quote) + (or (equal? (cadr def) (cell-value)) + (warn "bad conf value for " (car cell) + ": expected '" (cadr def) " but got " (cell-value)))) + (else + (warn "bad conf list spec name: " (car def))))) + (else + (or (equal? def (cell-value)) + (warn "bad conf value for " (car cell) + ": expected " def " but got " (cell-value)))))) + +(define (conf-verify-one spec cell warn) + (cond + ((not (pair? cell)) + (warn "bad config entry: " cell)) + ((not (symbol? (car cell))) + (warn "non-symbol config entry name: " (car cell))) + (else + (let ((def (assq (car cell) spec))) + (cond + ((not def) + (warn "unknown config entry: " (car cell))) + ((null? (cdr def))) + (else (conf-verify-match (cadr def) cell warn))))))) + +(define (conf-verify spec config . o) + (let ((warn (if (pair? o) (car o) conf-default-warn))) + (let lp ((config config)) + (cond + (config + (for-each + (lambda (cell) (conf-verify-one spec cell warn)) + (conf-alist config)) + (lp (conf-parent config))))))) diff --git a/lib/chibi/config.sld b/lib/chibi/config.sld new file mode 100644 index 00000000..6786a54a --- /dev/null +++ b/lib/chibi/config.sld @@ -0,0 +1,15 @@ + +(define-library (chibi config) + (export make-conf conf? conf-load conf-load-in-path conf-load-cascaded + conf-verify conf-extend conf-append conf-set conf-unfold-key + conf-get conf-get-list conf-get-cdr conf-get-multi + conf-specialize read-from-file conf-source conf-head conf-parent + assoc-get) + (import (scheme base) (scheme read) (scheme write) (scheme file) + (scheme time) (srfi 1)) + ;; This is only used for config verification, it's acceptable to + ;; substitute file existence for the stronger directory check. + (cond-expand + (chibi (import (only (chibi filesystem) file-directory?))) + (else (begin (define file-directory? file-exists?)))) + (include "config.scm")) diff --git a/lib/chibi/crypto/md5.scm b/lib/chibi/crypto/md5.scm new file mode 100644 index 00000000..36e969b8 --- /dev/null +++ b/lib/chibi/crypto/md5.scm @@ -0,0 +1,362 @@ +;; md5.scm -- pure R7RS md5 implementation (originally from hato) +;; Copyright (c) 2009-2014 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; Break computations down into 16-bit words to keep everything in +;; fixnum even on 32-bit machines. + +;; All values are in little-endian. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities. + +(define (extract-byte n i) + (bitwise-and #xFF (arithmetic-shift n (* i -8)))) + +;; integer->hex-string is big-endian, so we adjust here +(define (hex-byte n) + (if (< n 16) + (string-append "0" (number->string n 16)) + (number->string n 16))) + +(define (hex n) + (string-append (hex-byte (remainder n 256)) + (hex-byte (quotient n 256)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; 3. MD5 Algorithm Description + +;; We begin by supposing that we have a b-bit message as input, and that +;; we wish to find its message digest. Here b is an arbitrary +;; nonnegative integer; b may be zero, it need not be a multiple of +;; eight, and it may be arbitrarily large. We imagine the bits of the +;; message written down as follows: + +;; m_0 m_1 ... m_{b-1} + +;; The following five steps are performed to compute the message digest +;; of the message. + +;; 3.1 Step 1. Append Padding Bits + +;; The message is "padded" (extended) so that its length (in bits) is +;; congruent to 448, modulo 512. That is, the message is extended so +;; that it is just 64 bits shy of being a multiple of 512 bits long. +;; Padding is always performed, even if the length of the message is +;; already congruent to 448, modulo 512. + +;; Padding is performed as follows: a single "1" bit is appended to the +;; message, and then "0" bits are appended so that the length in bits of +;; the padded message becomes congruent to 448, modulo 512. In all, at +;; least one bit and at most 512 bits are appended. + +;; 3.2 Step 2. Append Length + +;; A 64-bit representation of b (the length of the message before the +;; padding bits were added) is appended to the result of the previous +;; step. In the unlikely event that b is greater than 2^64, then only +;; the low-order 64 bits of b are used. (These bits are appended as two +;; 32-bit words and appended low-order word first in accordance with the +;; previous conventions.) + +;; At this point the resulting message (after padding with bits and with +;; b) has a length that is an exact multiple of 512 bits. Equivalently, +;; this message has a length that is an exact multiple of 16 (32-bit) +;; words. Let M[0 ... N-1] denote the words of the resulting message, +;; where N is a multiple of 16. + +;; 3.3 Step 3. Initialize MD Buffer + +;; A four-word buffer (A,B,C,D) is used to compute the message digest. +;; Here each of A, B, C, D is a 32-bit register. These registers are +;; initialized to the following values in hexadecimal, low-order bytes +;; first): + +;; word A: 01 23 45 67 +;; word B: 89 ab cd ef +;; word C: fe dc ba 98 +;; word D: 76 54 32 10 + +;; 3.4 Step 4. Process Message in 16-Word Blocks + +;; We first define four auxiliary functions that each take as input +;; three 32-bit words and produce as output one 32-bit word. + +;; F(X,Y,Z) = XY v not(X) Z +;; G(X,Y,Z) = XZ v Y not(Z) +;; H(X,Y,Z) = X xor Y xor Z +;; I(X,Y,Z) = Y xor (X v not(Z)) + +;; In each bit position F acts as a conditional: if X then Y else Z. +;; The function F could have been defined using + instead of v since XY +;; and not(X)Z will never have 1's in the same bit position.) It is +;; interesting to note that if the bits of X, Y, and Z are independent +;; and unbiased, the each bit of F(X,Y,Z) will be independent and +;; unbiased. + +;; The functions G, H, and I are similar to the function F, in that they +;; act in "bitwise parallel" to produce their output from the bits of X, +;; Y, and Z, in such a manner that if the corresponding bits of X, Y, +;; and Z are independent and unbiased, then each bit of G(X,Y,Z), +;; H(X,Y,Z), and I(X,Y,Z) will be independent and unbiased. Note that +;; the function H is the bit-wise "xor" or "parity" function of its +;; inputs. + +;; This step uses a 64-element table T[1 ... 64] constructed from the +;; sine function. Let T[i] denote the i-th element of the table, which +;; is equal to the integer part of 4294967296 times abs(sin(i)), where i +;; is in radians. The elements of the table are given in the appendix. + +;; (define T +;; (do ((i 64 (- i 1)) +;; (ls '() +;; (cons (u32 (exact (truncate (* 4294967296 (abs (sin i)))))) +;; ls))) +;; ((< i 0) (list->vector ls)))) + +(define T + '#(0 0 #xd76a #xa478 #xe8c7 #xb756 #x2420 #x70db #xc1bd #xceee + #xf57c #x0faf #x4787 #xc62a #xa830 #x4613 #xfd46 #x9501 #x6980 #x98d8 + #x8b44 #xf7af #xffff #x5bb1 #x895c #xd7be #x6b90 #x1122 #xfd98 #x7193 + #xa679 #x438e #x49b4 #x0821 #xf61e #x2562 #xc040 #xb340 #x265e #x5a51 + #xe9b6 #xc7aa #xd62f #x105d #x0244 #x1453 #xd8a1 #xe681 #xe7d3 #xfbc8 + #x21e1 #xcde6 #xc337 #x07d6 #xf4d5 #x0d87 #x455a #x14ed #xa9e3 #xe905 + #xfcef #xa3f8 #x676f #x02d9 #x8d2a #x4c8a #xfffa #x3942 #x8771 #xf681 + #x6d9d #x6122 #xfde5 #x380c #xa4be #xea44 #x4bde #xcfa9 #xf6bb #x4b60 + #xbebf #xbc70 #x289b #x7ec6 #xeaa1 #x27fa #xd4ef #x3085 #x0488 #x1d05 + #xd9d4 #xd039 #xe6db #x99e5 #x1fa2 #x7cf8 #xc4ac #x5665 #xf429 #x2244 + #x432a #xff97 #xab94 #x23a7 #xfc93 #xa039 #x655b #x59c3 #x8f0c #xcc92 + #xffef #xf47d #x8584 #x5dd1 #x6fa8 #x7e4f #xfe2c #xe6e0 #xa301 #x4314 + #x4e08 #x11a1 #xf753 #x7e82 #xbd3a #xf235 #x2ad7 #xd2bb #xeb86 #xd391)) + +(define (md5 src) + (let ((in (cond ((string? src) (open-input-bytevector (string->utf8 src))) + ((bytevector? src) (open-input-bytevector src)) + ((input-port? src) src) + (else (error "unknown digest source: " src)))) + ;; 3.3 Step 3. Initialize MD Buffer + (buf (make-bytevector 64 0)) + (vec (make-vector 32)) + (A1 #x6745) (A0 #x2301) + (B1 #xefcd) (B0 #xab89) + (C1 #x98ba) (C0 #xdcfe) + (D1 #x1032) (D0 #x5476)) + ;; Process each 16-word block. + (let lp ((i 0) + (pad #x80)) + (let* ((n (read-bytevector! buf in)) + (n (if (eof-object? n) 0 n))) + (cond + ((< n 64) + (let ((len (* 8 (+ i n)))) + ;; 3.1 Step 1. Append Padding Bits + (bytevector-u8-set! buf n pad) + (do ((j (+ n 1) (+ j 1))) ((>= j 64)) + (bytevector-u8-set! buf j 0)) + ;; 3.2 Step 2. Append Length + (cond + ((< n 56) + (bytevector-u8-set! buf 56 (extract-byte len 0)) + (bytevector-u8-set! buf 57 (extract-byte len 1)) + (bytevector-u8-set! buf 58 (extract-byte len 2)) + (bytevector-u8-set! buf 59 (extract-byte len 3)) + (bytevector-u8-set! buf 60 (extract-byte len 4)) + (bytevector-u8-set! buf 61 (extract-byte len 5)) + (bytevector-u8-set! buf 62 (extract-byte len 6)) + (bytevector-u8-set! buf 63 (extract-byte len 7))))))) + ;; 3.4 Step 4. Process Message in 16-Word Blocks + ;; + ;; Copy block i into X. + (do ((j 0 (+ j 1))) + ((= j 16)) + (vector-set! vec (* j 2) (bytevector-u16-ref-le buf (* j 4))) + (vector-set! vec + (+ (* j 2) 1) + (bytevector-u16-ref-le buf (+ (* j 4) 2)))) + ;; Save A as AA, B as BB, C as CC, and D as DD. + (let ((AA0 A0) (AA1 A1) + (BB0 B0) (BB1 B1) + (CC0 C0) (CC1 C1) + (DD0 D0) (DD1 D1) + (T1 0) (T0 0)) + (letrec-syntax + ((add + (syntax-rules () + ((add d1 d0 a1 a0 b1 b0) + (begin + (set! d0 (+ a0 b0)) + (set! d1 (bitwise-and + (+ a1 b1 (arithmetic-shift d0 -16)) + #xFFFF)) + (set! d0 (bitwise-and d0 #xFFFF)))))) + (rot + (syntax-rules () + ((rot d1 d0 a1 a0 s) + (let ((tmp a1)) + (set! d1 (bitwise-and + (bitwise-ior (arithmetic-shift a1 s) + (arithmetic-shift a1 (- s 32)) + (arithmetic-shift a0 (- s 16))) + #xFFFF)) + (set! d0 (bitwise-and + (bitwise-ior (arithmetic-shift a0 s) + (arithmetic-shift a0 (- s 32)) + (arithmetic-shift tmp (- s 16))) + #xFFFF)))))) + (bit-not + (syntax-rules () + ((bit-not a) (- (expt 2 16) a 1)))) + (FF + (syntax-rules () + ((FF d1 d0 x1 x0 y1 y0 z1 z0) + (begin + (set! d1 (bitwise-ior (bitwise-and x1 y1) + (bitwise-and (bit-not x1) z1))) + (set! d0 (bitwise-ior (bitwise-and x0 y0) + (bitwise-and (bit-not x0) z0))) + )))) + (GG + (syntax-rules () + ((GG d1 d0 x1 x0 y1 y0 z1 z0) + (begin + (set! d1 (bitwise-ior (bitwise-and x1 z1) + (bitwise-and y1 (bit-not z1)))) + (set! d0 (bitwise-ior (bitwise-and x0 z0) + (bitwise-and y0 (bit-not z0)))) + )))) + (HH + (syntax-rules () + ((HH d1 d0 x1 x0 y1 y0 z1 z0) + (begin (set! d1 (bitwise-xor x1 y1 z1)) + (set! d0 (bitwise-xor x0 y0 z0)))))) + (II + (syntax-rules () + ((II d1 d0 x1 x0 y1 y0 z1 z0) + (begin + (set! d1 (bitwise-xor y1 (bitwise-ior x1 (bit-not z1)))) + (set! d0 (bitwise-xor y0 (bitwise-ior x0 (bit-not z0)))) + )))) + (R + (syntax-rules () + ((R op T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i) + (begin + (op T1 T0 b1 b0 c1 c0 d1 d0) + (add T1 T0 T1 T0 + (vector-ref vec (+ (* k 2) 1)) + (vector-ref vec (* k 2))) + (add T1 T0 T1 T0 + (vector-ref T (* i 2)) + (vector-ref T (+ (* i 2) 1))) + (add a1 a0 a1 a0 T1 T0) + (rot a1 a0 a1 a0 s) + (add a1 a0 a1 a0 b1 b0))))) + (R1 (syntax-rules () + ((R1 T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i) + (R FF T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)))) + (R2 (syntax-rules () + ((R2 T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i) + (R GG T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)))) + (R3 (syntax-rules () + ((R3 T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i) + (R HH T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i)))) + (R4 (syntax-rules () + ((R4 T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i) + (R II T1 T0 a1 a0 b1 b0 c1 c0 d1 d0 vec k s i))))) + ;; Round 1: Let [abcd k s i] denote the operation + ;; a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) + (R1 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 0 7 1) + (R1 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 1 12 2) + (R1 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 2 17 3) + (R1 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 3 22 4) + (R1 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 4 7 5) + (R1 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 5 12 6) + (R1 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 6 17 7) + (R1 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 7 22 8) + (R1 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 8 7 9) + (R1 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 9 12 10) + (R1 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 10 17 11) + (R1 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 11 22 12) + (R1 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 12 7 13) + (R1 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 13 12 14) + (R1 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 14 17 15) + (R1 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 15 22 16) + ;; Round 2: Let [abcd k s i] denote the operation + ;; a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s) + (R2 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 1 5 17) + (R2 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 6 9 18) + (R2 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 11 14 19) + (R2 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 0 20 20) + (R2 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 5 5 21) + (R2 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 10 9 22) + (R2 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 15 14 23) + (R2 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 4 20 24) + (R2 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 9 5 25) + (R2 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 14 9 26) + (R2 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 3 14 27) + (R2 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 8 20 28) + (R2 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 13 5 29) + (R2 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 2 9 30) + (R2 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 7 14 31) + (R2 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 12 20 32) + ;; Round 3: Let [abcd k s i] denote the operation + ;; a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s) + (R3 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 5 4 33) + (R3 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 8 11 34) + (R3 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 11 16 35) + (R3 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 14 23 36) + (R3 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 1 4 37) + (R3 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 4 11 38) + (R3 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 7 16 39) + (R3 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 10 23 40) + (R3 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 13 4 41) + (R3 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 0 11 42) + (R3 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 3 16 43) + (R3 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 6 23 44) + (R3 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 9 4 45) + (R3 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 12 11 46) + (R3 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 15 16 47) + (R3 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 2 23 48) + ;; Round 4: Let [abcd k s i] denote the operation + ;; a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s) + (R4 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 0 6 49) + (R4 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 7 10 50) + (R4 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 14 15 51) + (R4 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 5 21 52) + (R4 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 12 6 53) + (R4 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 3 10 54) + (R4 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 10 15 55) + (R4 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 1 21 56) + (R4 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 8 6 57) + (R4 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 15 10 58) + (R4 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 6 15 59) + (R4 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 13 21 60) + (R4 T1 T0 A1 A0 B1 B0 C1 C0 D1 D0 vec 4 6 61) + (R4 T1 T0 D1 D0 A1 A0 B1 B0 C1 C0 vec 11 10 62) + (R4 T1 T0 C1 C0 D1 D0 A1 A0 B1 B0 vec 2 15 63) + (R4 T1 T0 B1 B0 C1 C0 D1 D0 A1 A0 vec 9 21 64) + ;; Then in increment each of the four registers by the + ;; value it had before this block was started. + (add A1 A0 A1 A0 AA1 AA0) + (add B1 B0 B1 B0 BB1 BB0) + (add C1 C0 C1 C0 CC1 CC0) + (add D1 D0 D1 D0 DD1 DD0) + (cond + ((< n 64) + ;; 3.5 Step 5. Output + ;; + ;; The message digest produced as output is A, B, C, + ;; D. That is, we begin with the low-order byte of A, + ;; and end with the high-order byte of D. + (if (>= n 56) + (lp (+ i n) 0) + (string-append + (hex A0) (hex A1) + (hex B0) (hex B1) + (hex C0) (hex C1) + (hex D0) (hex D1)))) + (else + (lp (+ i 64) pad))))))))) + +;; This completes the description of MD5. A reference implementation in +;; C is given in the appendix. diff --git a/lib/chibi/crypto/md5.sld b/lib/chibi/crypto/md5.sld new file mode 100644 index 00000000..08851ef3 --- /dev/null +++ b/lib/chibi/crypto/md5.sld @@ -0,0 +1,5 @@ + +(define-library (chibi crypto md5) + (import (scheme base) (srfi 33) (chibi bytevector)) + (export md5) + (include "md5.scm")) diff --git a/lib/chibi/crypto/rsa.scm b/lib/chibi/crypto/rsa.scm new file mode 100644 index 00000000..0f923b75 --- /dev/null +++ b/lib/chibi/crypto/rsa.scm @@ -0,0 +1,124 @@ +;; rsa.scm -- RSA public key cryptography library +;; Copyright (c) 2014 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; The RSA key type. The public fields are always present, but the +;; private key d may be #f. +(define-record-type Rsa-Key + (make-rsa-key bits n e d) + rsa-key? + (bits rsa-key-bits) + (n rsa-key-n) ; public modulus, the product of two primes + (e rsa-key-e) ; public exponent, coptime to (totient n) + (d rsa-key-d)) ; private exponent, the inverse of e mod (totient n) + +(define (rsa-key-gen-from-primes bit-length p q . o) + (define (choose-exponent phi e) + (cond ((>= e phi) (error "couldn't find an exponent for " p q)) + ((= 1 (gcd e phi)) e) + (else (choose-exponent phi (+ e 2))))) + (let* ((n (* p q)) + (phi (* (- p 1) (- q 1))) + ;; Default to Fermat's number F4, or if too large the number + ;; 3, as suggested by RFC 1423. Ensure it's coprime to phi. + (e (choose-exponent phi (cond ((pair? o) (car o)) + ((< 65537 phi) 65537) + (else 3)))) + (d (modular-inverse e phi))) + (make-rsa-key bit-length n e d))) + +(define (rsa-key-gen . o) + (let* ((bit-length (if (pair? o) (car o) 128)) + (lo (max 3 (expt 2 (- bit-length 1)))) + (hi (expt 2 bit-length)) + (p (random-prime lo hi)) + (q (random-prime-distinct-from lo hi p))) + (rsa-key-gen-from-primes bit-length p q))) + +;;> Returns a copy of the given key with the private key, if any, +;;> removed. +(define (rsa-pub-key priv-key) + (make-rsa-key (rsa-key-bits priv-key) (rsa-key-n priv-key) + (rsa-key-e priv-key) #f)) + +;; From RFC-1423 +(define (pkcs1-pad bv) + (let ((pad (- 8 (modulo (bytevector-length bv) 8)))) + (bytevector-append bv (make-bytevector pad pad)))) + +(define (pkcs1-unpad bv) + (let* ((len (bytevector-length bv)) + (pad (bytevector-u8-ref bv (- len 1)))) + (if (not (<= 1 pad 8)) + (error "not pkcs1 padded" bv) + (bytevector-copy bv 0 (- len pad))))) + +;; Actual encryption and decryption are trivially defined as modular +;; exponentiation. + +(define (rsa-encrypt-integer pub-key msg) + (if (>= msg (rsa-key-n pub-key)) + (error "message larger than modulus")) + (modular-expt msg (rsa-key-e pub-key) (rsa-key-n pub-key))) + +(define (rsa-decrypt-integer priv-key cipher) + (if (>= cipher (rsa-key-n priv-key)) + (error "cipher larger than modulus")) + (modular-expt cipher (rsa-key-d priv-key) (rsa-key-n priv-key))) + +;; Arbitrary messages are encrypted by converting padded bytevectors +;; to and from integers. +;; TODO: user better padding + +(define (convert-plain f key msg) + (cond + ((bytevector? msg) + (integer->bytevector (f key (bytevector->integer (pkcs1-pad msg))))) + ((string? msg) + (convert-plain f key (string->utf8 msg))) + (else + (f key msg)))) + +(define (convert-cipher f key cipher) + (cond + ((bytevector? cipher) + (pkcs1-unpad (integer->bytevector (f key (bytevector->integer cipher))))) + ((string? cipher) + (convert-cipher f key (string->utf8 cipher))) + (else + (f key cipher)))) + +;; General API can handle integers, bytevectors, or strings which are +;; converted to utf8 bytevectors. + +;;> Encrypts \var{msg} for the given public key \var{pub-key}. +;;> \var{msg} may be an integer or bytevector, in which case the +;;> result is of the same type, or a string, in which case the string +;;> is first coerced to a utf8 encoded bytevector. +(define (rsa-encrypt pub-key msg) + (if (not (rsa-key-e pub-key)) + (error "can't encrypt without a public key" pub-key) + (convert-plain rsa-encrypt-integer pub-key msg))) + +;;> Decrypts \var{cipher} using the given private key \var{priv-key}. +;;> \var{cipher} may be an integer or bytevector, in which case the +;;> result is of the same type, or a string, in which case the string +;;> is first coerced to a utf8 encoded bytevector. +(define (rsa-decrypt priv-key cipher) + (if (not (rsa-key-d priv-key)) + (error "can't decrypt without a private key" priv-key) + (convert-cipher rsa-decrypt-integer priv-key cipher))) + +;;> Signs \var{msg} using the given private key \var{priv-key}. +(define (rsa-sign priv-key msg) + (if (not (rsa-key-d priv-key)) + (error "can't sign without a private key" priv-key) + (convert-plain rsa-decrypt-integer priv-key msg))) + +;;> Returns true iff \var{sig} is a valid signature of \var{msg} for +;;> the given public key \var{pub-key}. +(define (rsa-verify? pub-key msg sig) + (if (not (rsa-key-e pub-key)) + (error "can't verify without a public key" pub-key) + (equal? (if (string? msg) (string->utf8 msg) msg) + (convert-cipher rsa-encrypt-integer pub-key sig)))) diff --git a/lib/chibi/crypto/rsa.sld b/lib/chibi/crypto/rsa.sld new file mode 100644 index 00000000..95382796 --- /dev/null +++ b/lib/chibi/crypto/rsa.sld @@ -0,0 +1,7 @@ + +(define-library (chibi crypto rsa) + (import (scheme base) (srfi 33) (chibi bytevector) (chibi math prime)) + (export make-rsa-key rsa-key-gen rsa-key-gen-from-primes rsa-pub-key + rsa-encrypt rsa-decrypt rsa-sign rsa-verify? + rsa-key? rsa-key-bits rsa-key-n rsa-key-e rsa-key-d) + (include "rsa.scm")) diff --git a/lib/chibi/crypto/sha2.scm b/lib/chibi/crypto/sha2.scm new file mode 100644 index 00000000..e5b2faa9 --- /dev/null +++ b/lib/chibi/crypto/sha2.scm @@ -0,0 +1,196 @@ +;; sha2.scm -- SHA2 digest algorithms +;; Copyright (c) 2014 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; http://csrc.nist.gov/groups/STM/cavp/documents/shs/sha256-384-512.pdf +;; http://tools.ietf.org/html/rfc6234 + +;; Note 1: All variables are 32 bit unsigned integers and addition is +;; calculated modulo 32 +;; Note 2: For each round, there is one round constant k[i] and one entry +;; in the message schedule array w[i], 0 ≤ i ≤ 63 +;; Note 3: The compression function uses 8 working variables, a through h +;; Note 4: Big-endian convention is used when expressing the constants in +;; this pseudocode, and when parsing message block data from bytes to +;; words, for example, the first word of the input message "abc" after +;; padding is #x61626380 + +;; On a 32-bit machine, these will involve bignum computations +;; resulting in poor performance. Breaking this down into separate +;; 16-bit computations may help. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities. + +;; We fake 32-bit arithmetic by ANDing out the low 32 bits. +(define (u32 n) + (bitwise-and n #xFFFFFFFF)) + +;; 32-bit addition. +(define (u32+ a b) + (u32 (+ a b))) + +;; Extract bytes 0..3 of a big-endian 32-bit value. +(define (extract-byte n i) + (bitwise-and #xFF (arithmetic-shift n (* i -8)))) + +;; Rotate right in 32 bits. +(define (bitwise-rot-u32 n k) + (bitwise-ior + (u32 (arithmetic-shift n (- 32 k))) + (arithmetic-shift n (- k)))) + +(define hex integer->hex-string) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The first 32 bits of the fractional parts of the square roots of +;; the first 8 primes 2..19: + +(define sha-224-inits + '#(#xc1059ed8 #x367cd507 #x3070dd17 #xf70e5939 + #xffc00b31 #x68581511 #x64f98fa7 #xbefa4fa4)) + +;; The second 32 bits of the fractional parts of the square roots of +;; the 9th through 16th primes 23..53. + +(define sha-256-inits + '#(#x6a09e667 #xbb67ae85 #x3c6ef372 #xa54ff53a + #x510e527f #x9b05688c #x1f83d9ab #x5be0cd19)) + +;; First 32 bits of the fractional parts of the cube roots of the +;; first 64 primes 2..311: + +(define k + '#(#x428a2f98 #x71374491 #xb5c0fbcf #xe9b5dba5 + #x3956c25b #x59f111f1 #x923f82a4 #xab1c5ed5 + #xd807aa98 #x12835b01 #x243185be #x550c7dc3 + #x72be5d74 #x80deb1fe #x9bdc06a7 #xc19bf174 + #xe49b69c1 #xefbe4786 #x0fc19dc6 #x240ca1cc + #x2de92c6f #x4a7484aa #x5cb0a9dc #x76f988da + #x983e5152 #xa831c66d #xb00327c8 #xbf597fc7 + #xc6e00bf3 #xd5a79147 #x06ca6351 #x14292967 + #x27b70a85 #x2e1b2138 #x4d2c6dfc #x53380d13 + #x650a7354 #x766a0abb #x81c2c92e #x92722c85 + #xa2bfe8a1 #xa81a664b #xc24b8b70 #xc76c51a3 + #xd192e819 #xd6990624 #xf40e3585 #x106aa070 + #x19a4c116 #x1e376c08 #x2748774c #x34b0bcb5 + #x391c0cb3 #x4ed8aa4a #x5b9cca4f #x682e6ff3 + #x748f82ee #x78a5636f #x84c87814 #x8cc70208 + #x90befffa #xa4506ceb #xbef9a3f7 #xc67178f2)) + +(define (sha-224-256 src inits full?) + (let ((in (cond ((string? src) (open-input-bytevector (string->utf8 src))) + ((bytevector? src) (open-input-bytevector src)) + ((input-port? src) src) + (else (error "unknown digest source: " src)))) + (buf (make-bytevector 64 0)) + (w (make-vector 64 0))) + (let chunk ((i 0) + (pad #x80) + (h0 (vector-ref inits 0)) + (h1 (vector-ref inits 1)) + (h2 (vector-ref inits 2)) + (h3 (vector-ref inits 3)) + (h4 (vector-ref inits 4)) + (h5 (vector-ref inits 5)) + (h6 (vector-ref inits 6)) + (h7 (vector-ref inits 7))) + (let* ((n (read-bytevector! buf in)) + (n (if (eof-object? n) 0 n))) + ;; Maybe pad. + (cond + ((< n 64) + (let ((len (* 8 (+ i n)))) + (bytevector-u8-set! buf n pad) + (do ((j (+ n 1) (+ j 1))) ((>= j 64)) + (bytevector-u8-set! buf j 0)) + (cond + ((< n 56) + (bytevector-u8-set! buf 63 (extract-byte len 0)) + (bytevector-u8-set! buf 62 (extract-byte len 1)) + (bytevector-u8-set! buf 61 (extract-byte len 2)) + (bytevector-u8-set! buf 60 (extract-byte len 3)) + (bytevector-u8-set! buf 59 (extract-byte len 4)) + (bytevector-u8-set! buf 58 (extract-byte len 5)) + (bytevector-u8-set! buf 57 (extract-byte len 6)) + (bytevector-u8-set! buf 56 (extract-byte len 7))))))) + ;; Copy block i into the buffer. + (do ((j 0 (+ j 1))) + ((= j 16)) + (vector-set! w j (bytevector-u32-ref-be buf (* j 4)))) + ;; Extend the first 16 words into the remaining 48 words + ;; w[16..63] of the message schedule array: + (do ((j 16 (+ j 1))) + ((= j 64)) + (let* ((w15 (vector-ref w (- j 15))) + (w2 (vector-ref w (- j 2))) + (s0 (bitwise-xor (bitwise-rot-u32 w15 7) + (bitwise-rot-u32 w15 18) + (arithmetic-shift w15 -3))) + (s1 (bitwise-xor (bitwise-rot-u32 w2 17) + (bitwise-rot-u32 w2 19) + (arithmetic-shift w2 -10)))) + (vector-set! w j (u32 (+ (vector-ref w (- j 16)) + s0 + (vector-ref w (- j 7)) + s1))))) + ;; Compression function main loop: + (let lp ((j 0) + (a h0) + (b h1) + (c h2) + (d h3) + (e h4) + (f h5) + (g h6) + (h h7)) + (cond + ((= j 64) + ;; Repeat on next block. + (cond + ((< n 64) + (if (>= n 56) + (chunk (+ i n) 0 + (u32+ h0 a) (u32+ h1 b) (u32+ h2 c) (u32+ h3 d) + (u32+ h4 e) (u32+ h5 f) (u32+ h6 g) (u32+ h7 h)) + ;; Done - add back in the has inits and serialize. + (string-append + (hex (u32+ a (vector-ref inits 0))) + (hex (u32+ b (vector-ref inits 1))) + (hex (u32+ c (vector-ref inits 2))) + (hex (u32+ d (vector-ref inits 3))) + (hex (u32+ e (vector-ref inits 4))) + (hex (u32+ f (vector-ref inits 5))) + (hex (u32+ g (vector-ref inits 6))) + (if full? + (hex (u32+ h #x5be0cd19)) + "")))) + (else + (chunk (+ i 64) pad + (u32+ h0 a) (u32+ h1 b) (u32+ h2 c) (u32+ h3 d) + (u32+ h4 e) (u32+ h5 f) (u32+ h6 g) (u32+ h7 h))))) + (else + ;; Step - compute the two sigmas and recurse on the new a-h. + (let* ((s1 (bitwise-xor (bitwise-rot-u32 e 6) + (bitwise-rot-u32 e 11) + (bitwise-rot-u32 e 25))) + (ch (bitwise-xor (bitwise-and e f) + (bitwise-and (bitwise-not e) g))) + (temp1 (u32 (+ h s1 ch (vector-ref k j) (vector-ref w j)))) + (s0 (bitwise-xor (bitwise-rot-u32 a 2) + (bitwise-rot-u32 a 13) + (bitwise-rot-u32 a 22))) + (maj (bitwise-xor (bitwise-and a b) + (bitwise-and a c) + (bitwise-and b c))) + (temp2 (u32+ s0 maj))) + (lp (+ j 1) + (u32+ temp1 temp2) a b c + (u32+ d temp1) e f g))))))))) + +(define (sha-224 src) + (sha-224-256 src sha-224-inits #f)) + +(define (sha-256 src) + (sha-224-256 src sha-256-inits #t)) diff --git a/lib/chibi/crypto/sha2.sld b/lib/chibi/crypto/sha2.sld new file mode 100644 index 00000000..412f5881 --- /dev/null +++ b/lib/chibi/crypto/sha2.sld @@ -0,0 +1,5 @@ + +(define-library (chibi crypto sha2) + (import (scheme base) (srfi 33) (chibi bytevector)) + (export sha-224 sha-256) + (include "sha2.scm")) diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c new file mode 100644 index 00000000..1f2e8110 --- /dev/null +++ b/lib/chibi/disasm.c @@ -0,0 +1,240 @@ +/* disasm.c -- optional debugging utilities */ +/* Copyright (c) 2009-2012 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "chibi/eval.h" +#if ! SEXP_USE_STATIC_LIBS +#include "../../opt/opcode_names.h" +#endif + +#define SEXP_DISASM_MAX_DEPTH 16 +#define SEXP_DISASM_PAD_WIDTH 4 + +#if SEXP_64_BIT +#define SEXP_PRId "%ld" +#else +#define SEXP_PRId "%d" +#endif + +static void sexp_write_pointer (sexp ctx, void *p, sexp out) { + char buf[32]; + sprintf(buf, "%p", p); + sexp_write_string(ctx, buf, out); +} + +static void sexp_write_integer (sexp ctx, sexp_sint_t n, sexp out) { + char buf[32]; + sprintf(buf, SEXP_PRId, n); + sexp_write_string(ctx, buf, out); +} + +static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { + unsigned char *ip, opcode, i; + sexp tmp=NULL, src; + sexp_sint_t *labels, label=1, off; +#if SEXP_USE_FULL_SOURCE_INFO + sexp src_here=NULL; + sexp_sint_t src_off=0; +#endif + + if (sexp_procedurep(bc)) { + bc = sexp_procedure_code(bc); + } else if (sexp_opcodep(bc)) { + sexp_write(ctx, sexp_opcode_name(bc), out); + sexp_write_string(ctx, " is a primitive\n", out); + 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); + } + + src = sexp_bytecode_source(bc); + + 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_write_pointer(ctx, bc, out); +#if SEXP_USE_FULL_SOURCE_INFO + if (!(src && sexp_vectorp(src))) + src_off = -1; + /* if (src) sexp_write(ctx, src, out); */ +#else + if (src && sexp_pairp(src)) { + sexp_write(ctx, sexp_car(src), out); + sexp_write_string(ctx, ":", out); + sexp_write(ctx, sexp_cdr(src), out); + } +#endif + sexp_newline(ctx, out); + + /* build a table of labels that are jumped to */ + labels = calloc(sexp_bytecode_length(bc), sizeof(sexp_sint_t)); + ip = sexp_bytecode_data(bc); + while (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) { + switch (*ip++) { + case SEXP_OP_JUMP: + case SEXP_OP_JUMP_UNLESS: + off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0]; + if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] == 0) + labels[off] = label++; + case SEXP_OP_CALL: + case SEXP_OP_CLOSURE_REF: + case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_GLOBAL_REF: + case SEXP_OP_LOCAL_REF: + case SEXP_OP_LOCAL_SET: + case SEXP_OP_PARAMETER_REF: + case SEXP_OP_PUSH: + case SEXP_OP_RESERVE: + case SEXP_OP_STACK_REF: + case SEXP_OP_TAIL_CALL: + case SEXP_OP_TYPEP: + 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_MAKE_PROCEDURE: + ip += sizeof(sexp)*3; + break; + default: + /* opcode takes no additional instruction args */ + break; + } + } + + ip = sexp_bytecode_data(bc); + loop: + for (i=0; i<(depth*SEXP_DISASM_PAD_WIDTH); i++) + sexp_write_char(ctx, ' ', out); + if (labels[ip - sexp_bytecode_data(bc)] == 0) { + sexp_write_string(ctx, " ", out); + } else { + sexp_write_char(ctx, 'L', out); + sexp_write_integer(ctx, labels[ip - sexp_bytecode_data(bc)], out); + sexp_write_string(ctx, ": ", out); + if (labels[ip - sexp_bytecode_data(bc)] < 10) + sexp_write_char(ctx, ' ', out); + } +#if SEXP_USE_FULL_SOURCE_INFO + if ((src_off >= 0) + && ((ip-sexp_bytecode_data(bc)) + == sexp_unbox_fixnum( + sexp_car(sexp_vector_ref(src, sexp_make_fixnum(src_off)))))) { + src_here = sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(src_off))); + src_off = src_off < sexp_vector_length(src)-1 ? src_off + 1 : -1; + } else { + src_here = NULL; + } +#endif + opcode = *ip++; + if (opcode < SEXP_OP_NUM_OPCODES) { + sexp_write_char(ctx, ' ', out); + sexp_write_string(ctx, sexp_opcode_names[opcode], out); + sexp_write_char(ctx, ' ', out); + } else { + sexp_write_string(ctx, " ", out); + sexp_write(ctx, sexp_make_fixnum(opcode), out); + sexp_write_char(ctx, ' ', out); + } + 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_TYPEP: + case SEXP_OP_RESERVE: + sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out); + ip += sizeof(sexp); + break; + case SEXP_OP_JUMP: + case SEXP_OP_JUMP_UNLESS: + sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out); + off = ip - sexp_bytecode_data(bc) + ((sexp_sint_t*)ip)[0]; + if (off >= 0 && off < sexp_bytecode_length(bc) && labels[off] > 0) { + sexp_write_string(ctx, " L", out); + sexp_write_integer(ctx, labels[off], out); + } + ip += sizeof(sexp); + break; + case SEXP_OP_FCALL0: + case SEXP_OP_FCALL1: + case SEXP_OP_FCALL2: + case SEXP_OP_FCALL3: + case SEXP_OP_FCALL4: + sexp_write_pointer(ctx, ((sexp*)ip)[0], out); + sexp_write_char(ctx, ' ', out); + sexp_write(ctx, sexp_opcode_name(((sexp*)ip)[0]), out); + 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_MAKE_PROCEDURE: + sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out); + sexp_write_char(ctx, ' ', out); + sexp_write_integer(ctx, ((sexp_sint_t*)ip)[1], out); + tmp = ((sexp*)ip)[2]; + ip += sizeof(sexp)*3; + break; + case SEXP_OP_GLOBAL_REF: + case SEXP_OP_GLOBAL_KNOWN_REF: + case SEXP_OP_PARAMETER_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_PARAMETER_REF) + && sexp_opcodep(tmp) && sexp_opcode_data(tmp) + && sexp_pairp(sexp_opcode_data(tmp))) + tmp = sexp_car(sexp_opcode_data(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; + } +#if SEXP_USE_FULL_SOURCE_INFO + if (src_here && sexp_pairp(src_here)) { + sexp_write_string(ctx, " ; ", out); + sexp_write(ctx, sexp_car(src_here), out); + sexp_write_string(ctx, ":", out); + sexp_write(ctx, sexp_cdr(src_here), out); + } +#endif + sexp_write_char(ctx, '\n', out); + if ((opcode == SEXP_OP_PUSH || opcode == SEXP_OP_MAKE_PROCEDURE) + && (depth < SEXP_DISASM_MAX_DEPTH) + && tmp && (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; + + free(labels); + return SEXP_VOID; +} + +static sexp sexp_disasm (sexp ctx, sexp self, sexp_sint_t n, sexp bc, sexp out) { + return disasm(ctx, self, bc, out, 0); +} + +sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) { + if (!(sexp_version_compatible(ctx, version, sexp_version) + && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) + return SEXP_ABI_ERROR; + sexp_define_foreign_param(ctx, env, "disasm", 2, (sexp_proc1)sexp_disasm, "current-output-port"); + return SEXP_VOID; +} diff --git a/lib/chibi/disasm.sld b/lib/chibi/disasm.sld new file mode 100644 index 00000000..ad8a9a5b --- /dev/null +++ b/lib/chibi/disasm.sld @@ -0,0 +1,10 @@ + +;;> \subsubsubsection{\scheme{(disasm f [out])}} + +;;> Write a human-readable disassembly for the procedure \var{f} to +;;> the port \var{out}, defaulting to \scheme{(current-output-port)}. + +(define-library (chibi disasm) + (export disasm) + (import (chibi)) + (include-shared "disasm")) diff --git a/lib/chibi/doc.scm b/lib/chibi/doc.scm new file mode 100644 index 00000000..c7a1d9f0 --- /dev/null +++ b/lib/chibi/doc.scm @@ -0,0 +1,752 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utils + +(define (write-to-string x) + (call-with-output-string (lambda (out) (write x out)))) + +(define (string-concatenate-reverse ls) + (string-concatenate (reverse ls))) + +(define (string-strip str . o) + (let ((bad (if (pair? o) (car o) " \t\n"))) + (call-with-output-string + (lambda (out) + (call-with-input-string str + (lambda (in) + (let lp () + (let ((ch (read-char in))) + (cond + ((not (eof-object? ch)) + (if (not (string-find? bad ch)) + (write-char ch out)) + (lp))))))))))) + +(define (string-first-token str sep) + (let ((len (string-length str))) + (let lp ((i 0)) + (cond ((= i len) str) + ((not (string-find? sep (string-ref str i))) (lp (+ i 1))) + (else + (let lp ((j (+ i 1))) + (cond ((= j len) "") + ((string-find? sep (string-ref str j)) (lp (+ j 1))) + (else + (let lp ((k (+ j 1))) + (cond + ((or (= k len) (string-find? sep (string-ref str k))) + (substring str j k)) + (else + (lp (+ k 1))))))))))))) + +(define (intersperse ls x) + (if (or (null? ls) (null? (cdr ls))) + ls + (let lp ((ls (cdr ls)) (res (list (car ls)))) + (let ((res (cons (car ls) (cons x res)))) + (if (null? (cdr ls)) + (reverse res) + (lp (cdr ls) res)))))) + +(define (normalize-sxml x) + (cond + ((pair? x) + (let lp ((ls x) (res '())) + (cond ((null? ls) + (string-concatenate-reverse res)) + ((string? (car ls)) + (lp (cdr ls) (cons (car ls) res))) + ((pair? res) + (cons (string-concatenate-reverse res) + (cons (car ls) (normalize-sxml (cdr ls))))) + (else + (cons (car ls) (normalize-sxml (cdr ls))))))) + (else x))) + +(define (map-sxml proc x) + (if (pair? x) + (cons (map-sxml proc (car x)) (map-sxml proc (cdr x))) + (proc x))) + +(define (sxml-body x) + (cond ((not (and (pair? x) (pair? (cdr x)))) '()) + ((and (pair? (cadr x)) (eq? '@ (car (cadr x)))) (cddr x)) + (else (cdr x)))) + +(define (sxml->sexp-list x) + (call-with-input-string (sxml-strip x) port->sexp-list)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; doc environments + +(define (env-ref env name . o) + (cond ((assq name (car env)) => cdr) + ((pair? o) (car o)) + (else #f))) + +(define (env-set! env name value) + (cond ((assq name (car env)) => (lambda (cell) (set-cdr! cell value))) + (else (set-car! env (cons (cons name value) (car env)))))) + +(define (env-extend env vars vals) + (list (append (map cons vars vals) (car env)))) + +(define (make-default-doc-env) + `(((title . ,(expand-section 'h1)) + (section . ,(expand-section 'h2)) + (subsection . ,(expand-section 'h3)) + (subsubsection . ,(expand-section 'h4)) + (subsubsubsection . ,(expand-section 'h5)) + (procedure . ,expand-procedure) + (macro . ,expand-macro) + (centered . center) + (smaller . small) + (larger . large) + (bold . b) + (italic . i) + (emph . em) + (subscript . sub) + (superscript . sup) + (itemlist . ul) + (item . li) + (var . code) + (cfun . code) + (cmacro . code) + (ctype . code) + (url . ,expand-url) + (hyperlink . ,expand-hyperlink) + (rawcode . code) + (code . ,expand-code) + (codeblock . ,expand-codeblock) + (ccode + . ,(lambda (x env) + (expand-code `(,(car x) language: c ,@(cdr x)) env))) + (ccodeblock + . ,(lambda (x env) + (expand-codeblock `(,(car x) language: c ,@(cdr x)) env))) + (scheme + . ,(lambda (x env) + (expand-code `(,(car x) language: scheme ,@(cdr x)) env))) + (schemeblock + . ,(lambda (x env) + (expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env))) + (command . ,expand-command) + (author . ,expand-author) + (margin-note . ,expand-note) + (example . ,expand-example) + (example-import . ,expand-example-import) + ))) + +(define (make-module-doc-env mod-name) + (env-extend (make-default-doc-env) + '(example-env) + (list (environment '(scheme base) + '(only (chibi) import) + mod-name)))) + +(define (section-name tag name) + (string-strip + (call-with-output-string + (lambda (out) + (display tag out) + (write-char #\_ out) + (display name out))))) + +(define (expand-section tag) + (lambda (sxml env) + (if (null? (cdr sxml)) + (error "section must not be empty" sxml) + (let* ((name (and (eq? 'tag: (cadr sxml)) + (pair? (cddr sxml)) + (sxml-strip (car (cddr sxml))))) + (body (map (lambda (x) (expand-docs x env)) + (if name (cdr (cddr sxml)) (cdr sxml)))) + (name (or name (sxml-strip (cons tag body))))) + `(div (a (@ (name . ,(section-name tag name)))) (,tag ,@body)))))) + +(define (expand-url sxml env) + (if (not (= 2 (length sxml))) + (error "url expects one argument" sxml) + (let ((url (expand-docs (cadr sxml) env))) + `(a (@ (href . ,url)) ,url)))) + +(define (expand-hyperlink sxml env) + (if (not (>= (length sxml) 3)) + (error "hyperlink expects at least two arguments" sxml) + (let ((url (expand-docs (cadr sxml) env))) + `(a (@ (href . ,url)) + ,(map (lambda (x) (expand-docs x env)) (cddr sxml)))))) + +(define (expand-note sxml env) + `(div (@ (id . "notes")) + ,@(map (lambda (x) (expand-docs x env)) (cdr sxml)))) + +(define (expand-author sxml env) + `(div (@ (id . "notes")) + ,@(map (lambda (x) (expand-docs x env)) (cdr sxml)) + (br) + ,(seconds->string (current-seconds)))) + +(define (expand-code sxml env) + (let* ((hl (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml))) + (highlighter-for (car (cddr sxml))) + highlight)) + (body (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml))) + (cdr (cddr sxml)) + (cdr sxml)))) + `(code ,@(map-sxml (lambda (x) (if (string? x) (hl x) x)) + (normalize-sxml + (map (lambda (x) (expand-docs x env)) body)))))) + +(define (expand-codeblock sxml env) + `(pre ,(expand-code sxml env))) + +(define (expand-example x env) + (let ((expr `(begin ,@(sxml->sexp-list x))) + (example-env (or (env-ref env 'example-env) (current-environment)))) + `(div + ,(expand-codeblock `(,(car x) language: scheme ,@(cdr x)) env) + (code + (div (@ (class . "result")) + ,(call-with-output-string + (lambda (out) + (protect (exn (#t (print-exception exn out))) + (let ((res (eval expr example-env))) + (display "=> " out) + (write res out)))))))))) + +(define (expand-example-import x env) + (eval `(import ,@(cdr x)) + (or (env-ref env 'example-env) (current-environment))) + "") + +(define (expand-command sxml env) + `(pre (@ (class . "command")) + (code ,@(map (lambda (x) (expand-docs x env)) (cdr sxml))))) + +(define (expand-tagged tag ls env) + (cons tag (map (lambda (x) (expand-docs x env)) ls))) + +(define (expand-docs sxml env) + (cond + ((pair? sxml) + (cond + ((symbol? (car sxml)) + (let ((op (env-ref env (car sxml)))) + (cond + ((procedure? op) + (op sxml env)) + ((symbol? op) + (expand-tagged op (cdr sxml) env)) + (else + (expand-tagged (car sxml) (cdr sxml) env))))) + (else + (map (lambda (x) (expand-docs x env)) sxml)))) + (else + sxml))) + +(define (expand-procedure sxml env) + ((expand-section 'h3) `(,(car sxml) (rawcode ,@(cdr sxml))) env)) + +(define (expand-macro sxml env) + (expand-procedure sxml env)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; adjustments for html + +(define header-index + (let* ((headers '(h1 h2 h3 h4 h5 h6)) + (len (length headers))) + (lambda (h) (- len (length (memq h headers)))))) + +(define (extract-contents x) + (match x + (('div ('a ('@ ('name . name)) . _) + ((and h (or 'h1 'h2 'h3 'h4 'h5 'h6)) . section)) + (let* ((raw-text (sxml-strip (cons h section))) + (text (if (string-prefix? "(" raw-text) + (let ((end (string-find + raw-text + (lambda (ch) + (or (char-whitespace? ch) + (eqv? ch #\))))))) + (substring raw-text 1 end)) + raw-text))) + `((,(header-index h) + (a (@ (href . ,(string-append "#" name))) + ,text))))) + ((a . b) + (append (extract-contents a) (extract-contents b))) + (else + '()))) + +(define (get-contents x) + (if (null? x) + '() + (let ((d (caar x))) + (let lp ((ls (cdr x)) (parent (car (cdar x))) (kids '()) (res '())) + (define (collect) + (cons `(li ,parent ,(get-contents (reverse kids))) res)) + (cond + ((null? ls) + `(ol ,@(reverse (collect)))) + ((> (caar ls) d) + (lp (cdr ls) parent (cons (car ls) kids) res)) + (else + (lp (cdr ls) (car (cdar ls)) '() (collect)))))))) + +(define (fix-header x) + `(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x))) + (else '())) + "\n" + (style (@ (type . "text/css")) + " +body {color: #000; background-color: #FFF} +div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 190px; height: 100%} +div#main {position: absolute; top: 0; left: 200px; width: 540px; height: 100%} +div#notes {position: relative; top: 2em; left: 570px; max-width: 200px; height: 0px; font-size: smaller;} +div#footer {padding-bottom: 50px} +.result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px} +.command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px} +" + ,(highlight-style)) + "\n") + (body + (div (@ (id . "menu")) + ,(let ((contents (get-contents (extract-contents x)))) + (match contents + (('ol (li y sections ...)) + sections) + (else contents)))) + (div (@ (id . "main")) + ,@(map (lambda (x) + (if (and (pair? x) (eq? 'title (car x))) + (cons 'h1 (cdr x)) + x)) + x) + (div (@ (id . "footer"))))))) + +(define (fix-paragraphs x) + (let lp ((ls x) (p '()) (res '())) + (define (collect) + (if (pair? p) (cons `(p ,@(reverse p)) res) res)) + (define (inline? x) + (or (string? x) + (and (pair? x) (symbol? (car x)) + (memq (car x) '(a b i u span code small large sub sup em))))) + (define (enclosing? x) + (and (pair? x) (symbol? (car x)) + (memq (car x) '(div body)))) + (cond + ((null? ls) + (reverse (collect))) + ((equal? "\n" (car ls)) + (if (and (pair? p) (equal? "\n" (car p))) + (let lp2 ((ls (cdr ls))) + (if (and (pair? ls) (equal? "\n" (car ls))) + (lp2 (cdr ls)) + (lp ls '() (collect)))) + (lp (cdr ls) (cons (car ls) p) res))) + ((inline? (car ls)) + (lp (cdr ls) (cons (car ls) p) res)) + ((enclosing? (car ls)) + (lp (cdr ls) '() (cons (car ls) (collect)))) + (else + (lp (cdr ls) '() (cons (car ls) (collect))))))) + +(define (fix-begins x) + x) + +(define (fixup-docs sxml) + (fix-header (fix-paragraphs (fix-begins sxml)))) + +(define (generate-docs sxml . o) + (fixup-docs + (expand-docs sxml (if (pair? o) (car o) (make-default-doc-env))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; extraction + +(define (skip-horizontal-whitespace in) + (cond ((memv (peek-char in) '(#\space #\tab)) + (read-char in) + (skip-horizontal-whitespace in)))) + +(define (external-clause? x) + (not (and (pair? (cdr x)) (pair? (cadr x)) (string? (car (cadr x)))))) + +(define (contains? tree x) + (or (eq? tree x) + (and (pair? tree) + (or (contains? (car tree) x) + (contains? (cdr tree) x))))) + +;; Try to determine the names of optional parameters checking common +;; patterns. +(define (get-optionals ls body) + (let lp ((ls ls) (pre '())) + (cond + ((pair? ls) (lp (cdr ls) (cons (car ls) pre))) + ((null? ls) (reverse pre)) + (else + (let* ((o ls) + (o? (lambda (x) (eq? x o)))) + (let extract ((x body) + (vars '()) + (i 0)) + (match x + ((('define x val) . rest) + (if (contains? val o) + (extract #f vars i) + (extract rest vars i))) + ((((or 'let 'let* 'letrec 'letrec*) (y ...) . body)) + (let ((ordered? (memq (car x) '(let* letrec*)))) + (let lp ((ls y) (vars vars) (j i)) + (cond + ((pair? ls) + (match (car ls) + (((? o?) ('if ('pair? (? o?)) ('cdr (? o?)) default)) + (lp (cdr ls) vars (+ j 1))) + (((? o?) expr) + (extract #f vars i)) + ((v ('if ('pair? (? o?)) ('car (? o?)) default)) + (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j)) + ((v ('and ('pair? (? o?)) ('car (? o?)))) + (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j)) + ((v ('if ('and ('pair? (? o?)) ('pair? ('cdr (? o?)))) + ('cadr (? o?)) + default)) + (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j)) + (else + (lp (cdr ls) vars j)))) + (else + (extract body vars j)))))) + ((((or 'let-optionals 'let-optionals*) ls ((var default) ...) + . body)) + (let lp ((ls var) (vars vars) (i i)) + (cond + ((pair? ls) + (lp (cdr ls) (cons (cons (caar ls) i) vars) (+ i 1))) + (else + (extract body vars i))))) + (else + (let ((opts (map car (sort vars < cdr))) + (dotted? (contains? x o))) + (append (reverse pre) + (cond + ((and (pair? opts) dotted?) + (list (append opts o))) + (dotted? + o) + (else + (list opts))))))))))))) + +(define (get-signature proc source form) + (match form + (('define (name args ...) . body) + (list (cons name args))) + (('define (name . args) . body) + (list (cons name (get-optionals args body)))) + (('define-syntax name ('syntax-rules () (clause . body) ...)) + ;; TODO: smarter summary + (map (lambda (x) (cons name (cdr x))) + (filter external-clause? clause))) + ((procedure? proc) + (cond ((procedure-signature proc) => list) (else '()))) + (else + '()))) + +(define (get-ffi-signatures form) + (match form + (('define-c ret-type (or (name _) name) (args ...)) + (list (cons name + (map (lambda (x) (if (pair? x) (last x) x)) + (remove (lambda (x) + (and (pair? x) + (memq (car x) '(value result)))) + args))))) + (('define-c-const type (or (name _) name)) + (list (list 'const: type name))) + (((or 'define-c-struct 'define-c-class 'define-c-type) name . rest) + (let lp ((ls rest) (res '())) + (cond + ((null? ls) + (reverse res)) + ((eq? 'predicate: (car ls)) + (lp (cddr ls) (cons (list (cadr ls) 'obj) res))) + ((eq? 'constructor: (car ls)) + (lp (cddr ls) + (cons (if (pair? (cadr ls)) (cadr ls) (list (cadr ls))) res))) + ((pair? (car ls)) + (lp (cdr ls) + (append (if (pair? (cddr (cdar ls))) + (list (list (car (cddr (cdar ls))) name (caar ls))) + '()) + (list (list (cadr (cdar ls)) name)) + res))) + ((symbol? (car ls)) + (lp (cddr ls) res)) + (else + (lp (cdr ls) res))))) + (else + '()))) + +(define section-number + (let ((sections '(section subsection subsubsection subsubsubsection))) + (lambda (x) + (cond ((memq x sections) => length) + ((memq x '(procedure macro)) (section-number 'subsection)) + (else 0))))) + +(define (section>=? x n) + (and (pair? x) + (if (memq (car x) '(div)) + (find (lambda (y) (section>=? y n)) (sxml-body x)) + (>= (section-number (car x)) n)))) + +(define (extract-sxml tag x) + (and (pair? x) + (cond ((if (pair? tag) (memq (car x) tag) (eq? tag (car x))) x) + ((memq (car x) '(div)) + (any (lambda (y) (extract-sxml tag y)) (sxml-body x))) + (else #f)))) + +(define (section-describes? x name) + (let ((name (symbol->string name))) + (and (pair? x) (pair? (cdr x)) + (let* ((str (sxml-strip (cadr x))) + (op (string-first-token str " \t\r\n()#"))) + (or (string=? op name) + ;; FIXME: hack for loop iterators + (and (string=? op "for") + (string-contains str (string-append "(" name " ")))))))) + +;; write a signature handling a trailing list as [optional] parameters +(define (write-signature sig) + (if (and (list? sig) + (> (length sig) 1) + (pair? (last sig)) + (not (any pair? (drop-right sig 1)))) + (call-with-output-string + (lambda (out) + (display "(" out) + (write (car sig) out) + (let lp ((ls sig)) + (cond + ((pair? (car ls)) + (display " [" out) + (write (caar ls) out) + (let lp ((ls (cdar ls))) + (cond + ((pair? ls) + (display " " out) + (write (car ls) out) + (lp (cdr ls))) + ((not (null? ls)) + (display " . " out) + (write ls out)))) + (display "])" out)) + (else + (display " " out) + (write (car ls) out) + (lp (cdr ls))))))) + (write-to-string sig))) + +(define (insert-signature orig-ls name sig) + (cond + ((not (pair? sig)) + orig-ls) + (else + (let ((name + (or name + (if (eq? 'const: (caar sig)) (cadr (cdar sig)) (caar sig))))) + (let lp ((ls orig-ls) (rev-pre '())) + (cond + ((or (null? ls) + (section>=? (car ls) (section-number 'subsection))) + `(,@(reverse rev-pre) + ,@(if (and (pair? ls) + (section-describes? + (extract-sxml '(subsection procedure macro) + (car ls)) + name)) + '() + `((subsection + tag: ,(write-to-string name) + (rawcode + ,@(if (eq? 'const: (caar sig)) + `((i ,(write-to-string (car (cdar sig))) ": ") + ,(write-to-string (cadr (cdar sig)))) + (intersperse (map write-signature sig) '(br))))))) + ,@ls)) + (else + (lp (cdr ls) (cons (car ls) rev-pre))))))))) + +;; Extract inline scribble documentation (with the ;;> prefix) from a +;; source file, associating any signatures from the provided defs when +;; available and not overridden in the docs. +(define (extract-file-docs file all-defs strict? . o) + ;; extract ( . ) macro source or + ;; ( >) procedure source + (define (source-line source) + (and (pair? source) + (if (string? (car source)) + (and (equal? file (car source)) + (number? (cdr source)) + (cdr source)) + (and (number? (car source)) + (pair? (cdr source)) + (equal? file (cadr source)) + (cddr source))))) + (call-with-input-file file + (lambda (in) + (let* ((lang (or (and (pair? o) (car o)) 'scheme)) + ;; filter to only defs found in this file + (defs (filter-map + (lambda (x) + (let ((line (source-line (third x)))) + (and line + ;; (name value line) + `(,(car x) ,(cadr x) ,line)))) + all-defs))) + (let lp ((lines '()) (cur '()) (res '()) (last-line 0)) + (define (collect) + (if (pair? lines) + (append + (reverse + (call-with-input-string + (string-concatenate (reverse lines) "\n") + scribble-parse)) + cur) + cur)) + (skip-horizontal-whitespace in) + (cond + ((eof-object? (peek-char in)) + (append (collect) res)) + ((eqv? #\newline (peek-char in)) + (read-char in) + (lp lines cur res last-line)) + ((eqv? #\; (peek-char in)) + (read-char in) + (cond + ((and (eqv? #\; (peek-char in)) + (begin (read-char in) (eqv? #\> (peek-char in)))) + (read-char in) + (if (eqv? #\space (peek-char in)) (read-char in)) + (lp (cons (read-line in) lines) cur res last-line)) + (else + (let lp () + (cond ((eqv? #\; (peek-char in)) + (read-char in) + (lp)))) + (let ((line (read-line in)) + (cur (collect))) + ;; ";;/" attaches the docs to the preceding form + (if (equal? line "/") + (lp '() '() (append cur res) last-line) + (lp '() cur res last-line)))))) + (else ;; found a top-level expression + (let* ((cur (collect)) + (form (read in)) + (line (port-line in)) + ;; find all procedures defined by form + (procs (filter (lambda (x) (<= last-line (third x) line)) + (filter third defs))) + ;; the the signature for the form + (sigs + (cond + ((eq? lang 'ffi) + (filter + (lambda (x) + (assq (if (eq? 'const: (car x)) (third x) (car x)) + defs)) + (get-ffi-signatures form))) + ((= 1 (length procs)) + (get-signature (caar procs) (cdar procs) form)) + (else + (get-signature #f #f form))))) + (cond + ((and strict? + (or (not (pair? sigs)) (not (assq (caar sigs) defs)))) + ;; drop unrelated docs in strict mode + (lp '() '() res line)) + ((and (eq? lang 'ffi) (pair? sigs)) + (lp '() '() (append (insert-signature cur #f sigs) res) line)) + ((and (eq? lang 'scheme) (= 1 (length procs))) + (lp '() '() (append (insert-signature cur (caar procs) sigs) + res) + line)) + (else + (lp '() '() (append cur res) line))))))))))) + +;; utility to get the source position of an object +(define (object-source x) + (cond ((opcode? x) #f) + ((bytecode? x) + (let ((src (bytecode-source x))) + (if (and (vector? src) (positive? (vector-length src))) + (vector-ref src 0) + src))) + ((procedure? x) (object-source (procedure-code x))) + ((macro? x) (macro-source x)) + (else #f))) + +;; extract documentation from a module +(define (extract-module-docs mod-name strict? . o) + (let ((mod (load-module mod-name))) + (if (not mod) + (error "couldn't find module" mod-name) + (let* ((exports (if (pair? o) (car o) (module-exports mod))) + (defs + (map (lambda (x) + (let ((val (module-ref mod x))) + `(,x ,val ,(object-source val)))) + exports))) + (append + (cond + ((find-module-file (module-name->file mod-name)) + => (lambda (f) (reverse (extract-file-docs f defs strict? 'module)))) + (else '())) + (reverse (append-map (lambda (x) (extract-file-docs x defs strict?)) + (module-includes mod))) + (reverse (append-map (lambda (x) (extract-file-docs x defs strict? 'ffi)) + (module-shared-includes mod)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (print-module-docs mod-name . o) + (let ((out (if (pair? o) (car o) (current-output-port))) + (render (or (and (pair? o) (pair? (cdr o)) (cadr o)) + sxml-display-as-text))) + (render + (generate-docs + `((title ,(write-to-string mod-name)) + ,@(extract-module-docs mod-name #f)) + (make-module-doc-env mod-name)) + out))) + +(define (print-module-binding-docs mod-name var . o) + (let ((out (if (pair? o) (car o) (current-output-port))) + (render (or (and (pair? o) (pair? (cdr o)) (cadr o)) + sxml-display-as-text))) + (render + (generate-docs + (extract-module-docs mod-name #t (list var)) + (make-module-doc-env mod-name)) + out))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (procedure-docs proc) + (let ((mod (and (procedure? proc) (containing-module proc)))) + (and mod + (generate-docs + (extract-module-docs (car mod) #t (list (procedure-name proc))) + (make-module-doc-env (car mod)))))) + +(define (print-procedure-docs proc . o) + (let ((out (if (pair? o) (car o) (current-output-port))) + (render (or (and (pair? o) (pair? (cdr o)) (cadr o)) + sxml-display-as-text)) + (docs (procedure-docs proc))) + (if docs (render docs out)))) diff --git a/lib/chibi/doc.sld b/lib/chibi/doc.sld new file mode 100644 index 00000000..634cd706 --- /dev/null +++ b/lib/chibi/doc.sld @@ -0,0 +1,14 @@ + +(define-library (chibi doc) + (import + (except (chibi) eval) (scheme eval) (srfi 1) (srfi 95) + (chibi modules) (chibi ast) (chibi io) (chibi match) + (chibi time) (chibi filesystem) (chibi process) + (chibi string) (chibi scribble) (chibi sxml) (chibi highlight) + (chibi type-inference)) + (export procedure-docs print-procedure-docs + print-module-docs print-module-binding-docs + generate-docs expand-docs fixup-docs + extract-module-docs extract-file-docs + make-default-doc-env make-module-doc-env) + (include "doc.scm")) diff --git a/lib/chibi/equiv.scm b/lib/chibi/equiv.scm new file mode 100644 index 00000000..6d88acce --- /dev/null +++ b/lib/chibi/equiv.scm @@ -0,0 +1,49 @@ + +;;> Cycle-aware equality. Returns \scheme{#t} iff \scheme{a} and +;;> \scheme{b} are \scheme{equal?}, including cycles. Another way +;;> to think of it is they are \scheme{equiv} if they print the +;;> same, assuming all elements can be printed. + +(define (equiv? a b) + (let ((equivs (make-hash-table eq?))) + (define (get-equivs x) + (or (hash-table-ref/default equivs x #f) + (let ((tmp (make-hash-table eq?))) + (hash-table-set! equivs x tmp) + tmp))) + (define (merge! tab x) + (hash-table-set! tab x tab) + (cond ((hash-table-ref/default equivs x #f) + => (lambda (tab2) + (hash-table-walk tab2 (lambda (key value) + (hash-table-set! tab key tab))))))) + (define (equiv? a b) + (cond + ((eq? a b)) + ((pair? a) + (and (pair? b) + (let ((a-tab (get-equivs a))) + (hash-table-ref + a-tab + b + (lambda () + (merge! a-tab b) + (and (equiv? (car a) (car b)) + (equiv? (cdr a) (cdr b)))))))) + ((vector? a) + (and (vector? b) + (= (vector-length a) (vector-length b)) + (let ((a-tab (get-equivs a))) + (hash-table-ref + a-tab + b + (lambda () + (merge! a-tab b) + (let lp ((i (- (vector-length a) 1))) + (or (< i 0) + (and (equiv? (vector-ref a i) (vector-ref b i)) + (lp (- i 1)))))))))) + (else + (equal? a b)))) + (let ((res (equal?/bounded a b 100000 100000))) + (and res (or (> res 0) (equiv? a b)) #t)))) diff --git a/lib/chibi/equiv.sld b/lib/chibi/equiv.sld new file mode 100644 index 00000000..463eec57 --- /dev/null +++ b/lib/chibi/equiv.sld @@ -0,0 +1,6 @@ + +(define-library (chibi equiv) + (export equiv?) + (import (chibi)) + (import (srfi 69)) + (include "equiv.scm")) diff --git a/lib/chibi/filesystem.scm b/lib/chibi/filesystem.scm new file mode 100644 index 00000000..aabb1742 --- /dev/null +++ b/lib/chibi/filesystem.scm @@ -0,0 +1,164 @@ +;; filesystem.scm -- additional filesystem utilities +;; Copyright (c) 2009-2013 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;> Creates the directory \var{dir}, including any parent directories +;;> as needed. Returns \scheme{#t} on success and \scheme{#f} on +;;> failure. + +(define (create-directory* dir . o) + (let ((mode (if (pair? o) (car o) #o755))) + (or (create-directory dir mode) + (let ((slash + (string-find-right dir #\/ 0 (string-skip-right dir #\/)))) + (and (> slash 0) + (let ((parent (substring-cursor dir 0 slash))) + (and (not (equal? parent dir)) + (not (file-exists? parent)) + (create-directory* parent mode) + (create-directory dir mode)))))))) + +;;> The fundamental directory iterator. Applies \var{kons} to +;;> each filename in directory \var{dir} and the result of the +;;> previous application, beginning with \var{knil}. With +;;> \var{kons} as \scheme{cons} and \var{knil} as \scheme{'()}, +;;> equivalent to \scheme{directory-files}. + +(define (directory-fold dir kons knil) + (let ((dir (opendir dir))) + (if (not dir) + knil + (let lp ((res knil)) + (let ((file (readdir dir))) + (if file + (lp (kons (dirent-name file) res)) + (begin (closedir dir) res))))))) + +;;> Returns a list of the files in \var{dir} in an unspecified +;;> order. + +(define (directory-files dir) + (directory-fold dir cons '())) + +;;> The fundamental directory traverser. + +(define (directory-fold-tree file down up here . o) + ;; TODO: Use link count to reduce stats. + ;; TODO: Provide higher-level wrapper for filtering and avoids links. + (let ((knil (and (pair? o) (car o))) + (down (or down (lambda (f acc) acc))) + (up (or up (lambda (f acc) acc))) + (here (or here (lambda (f acc) acc)))) + (let fold ((file file) (acc knil)) + (cond + ((file-directory? file) + (let ((d (opendir file))) + (if (not d) + acc + (let lp ((acc acc)) + (let ((e (readdir d))) + (cond + (e + (let ((f (dirent-name e))) + (if (member f '("." "..")) + (lp acc) + (let ((path (string-append file "/" f))) + (lp (fold path (down path acc))))))) + (else + (closedir d) + (up file acc)))))))) + (else + (here file acc)))))) + +;;> Unlinks the file named \var{string} from the filesystem. +;;> Returns \scheme{#t} on success and \scheme{#f} on failure. + +(define (delete-file file) + (if (not (%delete-file file)) + (raise-continuable + (make-exception 'file "couldn't delete file" file delete-file #f)))) + +;;> Recursively delete all files and directories under \var{dir}. +;;> Unless optional arg \var{ignore-errors?} is true, raises an error +;;> if any file can't be deleted. + +(define (delete-file-hierarchy dir . o) + (let ((ignore-errors? (and (pair? o) (car o)))) + (if (member dir '("" "/")) + (error "won't delete unsafe directory" dir)) + (directory-fold-tree + dir + #f + (lambda (d acc) + (if (and (not (delete-directory d)) (not ignore-errors?)) + (error "couldn't delete directory" d))) + (lambda (f acc) + (if (and (not (delete-file f)) (not ignore-errors?)) + (error "couldn't delete file" f)))))) + +;;> Runs \var{thunk} with the current directory of the process temporarily +;;> set to \var{dir}. + +(define (with-directory dir thunk) + (let ((pwd (current-directory))) + (dynamic-wind + (lambda () (change-directory dir)) + thunk + (lambda () (change-directory pwd))))) + +;;> Returns the \scheme{status} object for the given \var{file}, +;;> which should be a string indicating the path or a file +;;> descriptor. + +(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)))) + +;;> File status accessors. \var{x} should be a string indicating +;;> the file to lookup the status for, or an existing status object. +;;> Raises an error in the string case for non-existing files. +;;/ + +(define-syntax file-test-mode + (syntax-rules () + ((file-test-mode op x) + (let* ((tmp x) + (st (if (stat? tmp) tmp (file-status tmp)))) + (and st (op (stat-mode st))))))) + +(define (file-regular? x) (file-test-mode S_ISREG x)) +(define (file-directory? x) (file-test-mode S_ISDIR x)) +(define (file-character? x) (file-test-mode S_ISCHR x)) +(define (file-block? x) (file-test-mode S_ISBLK x)) +(define (file-fifo? x) (file-test-mode S_ISFIFO x)) +(define (file-link? x) + (let ((st (if (stat? x) x (file-link-status x)))) + (and st (S_ISLNK (stat-mode st))))) +(define (file-socket? x) (file-test-mode S_ISSOCK x)) +(define (file-exists? x) (and (if (stat? x) #t (file-status x)) #t)) + +;;> File type tests. \var{x} should be a string indicating the +;;> file to lookup the status for, or an existing status object. +;;> Returns \scheme{#t} if the file exists and the given type +;;> is satisfied, and \scheme{#f} otherwise. +;;/ + +;;> Equivalent to duplicating the file descriptor \var{old} to +;;> \var{new} and closing \var{old}. + +(define (renumber-file-descriptor old new) + (and (duplicate-file-descriptor-to old new) + (close-file-descriptor old))) diff --git a/lib/chibi/filesystem.sld b/lib/chibi/filesystem.sld new file mode 100644 index 00000000..c93642d5 --- /dev/null +++ b/lib/chibi/filesystem.sld @@ -0,0 +1,38 @@ + +;;> Interface to the filesystem and file descriptor objects. +;;> Note that file descriptors are currently represented as +;;> integers, but may be replaced with opaque (and gc-managed) +;;> objects in a future release. + +(define-library (chibi filesystem) + (export duplicate-file-descriptor duplicate-file-descriptor-to + close-file-descriptor renumber-file-descriptor + open-input-file-descriptor open-output-file-descriptor + delete-file link-file symbolic-link-file rename-file + directory-files directory-fold directory-fold-tree + delete-file-hierarchy delete-directory + create-directory create-directory* + current-directory change-directory with-directory + open open-pipe make-fifo + 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 + file-lock + lock/shared lock/exclusive lock/non-blocking lock/unlock + is-a-tty?) + (import (chibi) (chibi string)) + (include-shared "filesystem") + (include "filesystem.scm")) + diff --git a/lib/chibi/filesystem.stub b/lib/chibi/filesystem.stub new file mode 100644 index 00000000..2a4c8ddd --- /dev/null +++ b/lib/chibi/filesystem.stub @@ -0,0 +1,205 @@ +;; filesystem.stub -- filesystem bindings +;; Copyright (c) 2009-2013 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(c-system-include "sys/file.h") +(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))) + +;; Creates a new input-port from the file descriptor \var{int}. + +;; (define-c input-port (open-input-file-descriptor "fdopen") +;; (fileno (value "r" string))) + +;; Creates a new output-port from the file descriptor \var{int}. + +;; (define-c output-port (open-output-file-descriptor "fdopen") +;; (fileno (value "w" string))) + +;; Creates a new bidirectional port from the file descriptor \var{int}. + +;; (define-c input-output-port (open-input-output-file-descriptor "fdopen") +;; (fileno (value "r+" string))) + +(define-c errno (%delete-file "unlink") (string)) + +;;> Creates a hard link to the first arg from the second. +;;> Returns \scheme{#t} on success and \scheme{#f} on failure. + +(define-c errno (link-file "link") (string string)) + +;;> Creates a symbolic link to the first arg from the second. +;;> Returns \scheme{#t} on success and \scheme{#f} on failure. + +(define-c errno (symbolic-link-file "symlink") (string string)) + +;;> Renames the first arg to the second. +;;> Returns \scheme{#t} on success and \scheme{#f} on failure. + +(define-c errno (rename-file "rename") (string string)) + +;;> Returns the current working directory of the process as a string. + +(define-c non-null-string (current-directory "getcwd") + ((result (array char (auto-expand arg1))) (value 256 int))) + +;;> Change the current working directory of the process. + +(define-c errno (change-directory "chdir") (string)) + +;;> Creates a new directory with the given mode. +;;> Returns \scheme{#t} on success and \scheme{#f} on failure. + +(define-c errno (create-directory "mkdir") (string (default #o775 int))) + +;;> Deletes the directory named \var{string} from the filesystem. +;;> Does not attempt to delete recursively. +;;> Returns \scheme{#t} on success and \scheme{#f} on failure. + +(define-c errno (delete-directory "rmdir") (string)) + +(define-c (free DIR) opendir (string)) +(define-c dirent readdir ((link (pointer DIR)))) + +;;> Duplicates the given file descriptor, returning he new value, +;; or -1 on failure. + +(define-c fileno (duplicate-file-descriptor "dup") (fileno)) + +;;> Copies the first file descriptor to the second, closing +;;> it if needed. +;;> Returns \scheme{#t} on success and \scheme{#f} on failure. + +(define-c errno (duplicate-file-descriptor-to "dup2") (fileno fileno)) + +;;> Closes the given file descriptor. +;;> Returns \scheme{#t} on success and \scheme{#f} on failure. + +(define-c errno (close-file-descriptor "close") (fileno)) + +;;> Opens the given file and returns a file descriptor. + +(define-c fileno open (string int (default #o644 int))) + +;;> Returns a list of 2 new file descriptors, the input and +;;> output end of a new pipe, respectively. + +(define-c errno (open-pipe "pipe") ((result (array fileno 2)))) + +;;> Creates a new named pipe in the given path. +;;> Returns \scheme{#t} on success and \scheme{#f} on failure. + +(define-c errno (make-fifo "mkfifo") (string (default #o664 int))) + +(define-c int (get-file-descriptor-flags "fcntl") + (port-or-fileno (value F_GETFD int))) +(define-c errno (set-file-descriptor-flags! "fcntl") + (port-or-fileno (value F_SETFD int) long)) + +;;> Get and set the flags for the given file descriptor. +;;/ + +(define-c int (get-file-descriptor-status "fcntl") + (port-or-fileno (value F_GETFL int))) +(define-c errno (set-file-descriptor-status! "fcntl") + (port-or-fileno (value F_SETFL int) long)) + +;;> Get and set the status for the given file descriptor. +;;/ + +;; (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")) + +;;> File opening modes. +;;/ + +;;> Applies the specified locking operation using flock(2) to the port +;;> or file-descriptor. + +(define-c errno (file-lock "flock") (port-or-fileno int)) + +(define-c-const int (lock/shared "LOCK_SH")) +(define-c-const int (lock/exclusive "LOCK_EX")) +(define-c-const int (lock/non-blocking "LOCK_NB")) +(define-c-const int (lock/unlock "LOCK_UN")) + +;;> Locking operations. +;;/ + +;;> Returns \scheme{#t} if the given port of file descriptor +;;> if backed by a TTY object, and \scheme{#f} otherwise. + +(define-c boolean (is-a-tty? "isatty") (port-or-fileno)) diff --git a/lib/chibi/generic.scm b/lib/chibi/generic.scm new file mode 100644 index 00000000..512b45da --- /dev/null +++ b/lib/chibi/generic.scm @@ -0,0 +1,104 @@ + +;;> Define a new generic function named \var{name}. + +(define-syntax define-generic + (syntax-rules () + ((define-generic name) + (define name (make-generic 'name))))) + +;; call-next-method needs to be unhygienic +'(define-syntax define-method + (syntax-rules () + ((define-method (name (param type) ...) . body) + (generic-add! name + (list type ...) + (lambda (next param ...) + (let-syntax ((call)) + . body)))))) + +;;> \macro{(define-method (name params ...) body ...)} + +;;> Each parameter should be either a single identifier or a list of the form +;;> \scheme{(param type)} where \var{param} is the parameter name and +;;> \var{type} is a predicate which returns true if it's argument is of the +;;> correct type. +;;> Parameters without a predicate will always match. + +;;> If multiple methods satisfy the arguments, the most recent method +;;> will be used. The special form \scheme{(call-next-method)} can be +;;> invoked to call the next most recent method with the same arguments. + +(define-syntax define-method + (er-macro-transformer + (lambda (e r c) + (let ((name (car (cadr e))) + (params (map (lambda (param) + (if (identifier? param) + `(,param (lambda _ #t)) + param)) + (cdr (cadr e)))) + (body (cddr e))) + `(,(r 'generic-add!) ,name + (,(r 'list) ,@(map cadr params)) + (,(r 'lambda) (,(r 'next) ,@(map car params)) + (,(r 'let-syntax) ((call-next-method + (,(r 'syntax-rules) () + ((_) (,(r 'next)))))) + ,@body))))))) + +(define (no-applicable-method-error name args) + (error "no applicable method" name args)) + +(define (satisfied? preds args) + (cond ((null? preds) (null? args)) + ((null? args) #f) + (((car preds) (car args)) (satisfied? (cdr preds) (cdr args))) + (else #f))) + +(define add-method-tag (list 'add-method-tag)) + +;;> Create a new first-class generic function named \var{name}. + +(define (make-generic name) + (let ((name name) + (methods (make-vector 6 '()))) + (vector-set! methods + 3 + (list (cons (list (lambda (x) (eq? x add-method-tag)) + (lambda (x) (list? x)) + procedure?) + (lambda (next t p f) + (set! methods (insert-method! methods p f)))))) + (lambda args + (let ((len (length args))) + (cond + ((>= len (vector-length methods)) + (no-applicable-method-error name args)) + (else + (let lp ((ls (vector-ref methods len))) + (cond + ((null? ls) + (no-applicable-method-error name args)) + ((satisfied? (car (car ls)) args) + (apply (cdr (car ls)) (lambda () (lp (cdr ls))) args)) + (else + (lp (cdr ls))))))))))) + +(define (insert-method! vec preds f) + (let ((vlen (vector-length vec)) + (plen (length preds))) + (let ((res (if (>= plen vlen) + (let ((r (make-vector (+ vlen 1) '()))) + (do ((i 0 (+ i 1))) + ((>= i vlen) r) + (vector-set! r i (vector-ref vec i)))) + vec))) + (vector-set! res plen (cons (cons preds f) (vector-ref res plen))) + res))) + +;;> Extend the generic \var{g} with a new method \var{f} +;;> that applies when all parameters match the given list +;;> of predicates \var{preds}. + +(define (generic-add! g preds f) + (g add-method-tag preds f)) diff --git a/lib/chibi/generic.sld b/lib/chibi/generic.sld new file mode 100644 index 00000000..ce0a9a89 --- /dev/null +++ b/lib/chibi/generic.sld @@ -0,0 +1,7 @@ + +;;> Simple generic function interface. + +(define-library (chibi generic) + (export define-generic define-method make-generic generic-add!) + (import (chibi)) + (include "generic.scm")) diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c new file mode 100644 index 00000000..2f61bc6a --- /dev/null +++ b/lib/chibi/heap-stats.c @@ -0,0 +1,138 @@ +/* heap-stats.c -- count or dump heap objects */ +/* Copyright (c) 2009-2011 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define SEXP_HEAP_VECTOR_DEPTH 1 + +#if ! SEXP_USE_BOEHM + +extern sexp sexp_gc (sexp ctx, size_t *sum_freed); +extern sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x); + +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, "#", 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; i0) + sexp_write_char(ctx, ' ', out); + sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1); + } + if (i", 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_parameter_ref(ctx, + sexp_env_ref(ctx, + 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_string_to_symbol(ctx, sexp_type_name_by_index(ctx, i)); + tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); + res = sexp_cons(ctx, tmp, res); + } + sexp_gc_release3(ctx); + return res; +} + +static sexp sexp_heap_stats (sexp ctx, sexp self, sexp_sint_t n) { + return sexp_heap_walk(ctx, 0, 0); +} + +static sexp sexp_heap_dump (sexp ctx, sexp self, sexp_sint_t 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); +} + +#else + +static sexp sexp_heap_stats (sexp ctx, sexp self, sexp_sint_t n) { + return SEXP_NULL; +} + +static sexp sexp_heap_dump (sexp ctx, sexp self, sexp_sint_t n, sexp depth) { + return SEXP_NULL; +} + +#endif + +sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) { + if (!(sexp_version_compatible(ctx, version, sexp_version) + && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) + return SEXP_ABI_ERROR; + 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; +} diff --git a/lib/chibi/heap-stats.sld b/lib/chibi/heap-stats.sld new file mode 100644 index 00000000..5b8a2420 --- /dev/null +++ b/lib/chibi/heap-stats.sld @@ -0,0 +1,24 @@ + +;;> Utilities for gathering statistics on the heap. Just measuring +;;> runtime memory usage doesn't give a good idea of how to optimize +;;> that usage, so this module is provided for profiling. + +;;> \procedure{(heap-stats)} + +;;> Returns an alist summarizing all heap allocated objects. The +;;> \var{car} of each cell is the type-name, and the \var{cdr} is the +;;> count of objects of that type in the heap. Garbage is collected +;;> before the counts are taken. + +;;> \procedure{(heap-dump [depth])} + +;;> Returns the same value as \scheme{(heap-stats)}, but also prints +;;> all objects on the heap as it runs. \var{depth} indicates the +;;> printing depth for compound objects and defaults to 1. + +;;> These functions just return \scheme{'()} when using the Boehm GC. + +(define-library (chibi heap-stats) + (export heap-stats heap-dump) + (import (chibi)) + (include-shared "heap-stats")) diff --git a/lib/chibi/highlight.scm b/lib/chibi/highlight.scm new file mode 100644 index 00000000..27878291 --- /dev/null +++ b/lib/chibi/highlight.scm @@ -0,0 +1,453 @@ +;; highlight.scm -- source code highlighting library +;; Copyright (c) 2011 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;> Library for highlighting source code in different +;;> languages. Currently supports Scheme, C and Assembly. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (string-concatenate-reverse ls) + (string-concatenate (reverse ls))) + +(define (reverse-list->string ls) + (list->string (reverse ls))) + +;;> Returns an sxml structure representing the code from source +;;> with various language constructs wrapped in highlighting +;;> forms. \var{source} should be a string or port. The +;;> language to highlight for is auto-detected. + +(define (highlight source) + (let ((str (if (string? source) source (port->string source)))) + ((highlighter-for (highlight-detect-language str)) str))) + +;;> Attempst to auto-detect which language \var{str} is code +;;> for, and returns a symbol representing that language. + +(define (highlight-detect-language str) + (cond + ((protect (exn (else #f)) + (call-with-input-string str + (lambda (in) (do ((x #f (read in))) ((eof-object? x))))) + #t) + 'scheme) + (else + 'c))) + +;;> Return a procedure for highlighting the given language. + +(define (highlighter-for language) + (case language + ((scheme) highlight-scheme) + ((asm) highlight-assembly) + ((none) (lambda (x) x)) + (else highlight-c))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define highlight-themes + '((light + (keyword . "#800080") + (type . "#008000") + (function . "#0000FF") + (variable . "#B8860B") + (comment . "#FF0000") + (string . "#BC8F8F") + (attribute . "#FF5000") + (preprocessor . "#FF00FF") + (builtin . "#FF00FF") + (character . "#0055AA") + (syntaxerror . "#FF0000") + (diff-deleted . "#5F2121") + (diff-added . "#215F21") + ))) + +(define highlight-paren-styles + ;;'("#BAFFFF" "#FFCACA" "#FFFFBA" "#CACAFF" "#CAFFCA" "FFBAFF") + '("#AAAAAA" "#888888" "#666666" "#444444" "#222222" "#000000")) + +;;> Returns a string representing the CSS needed for the output +;;> of \var{highlight}. This should be included in a referenced +;;> CSS file, or in a \var{